From 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
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 "<anonymous>";
+ 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 ("<anonymous>");
+ 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 ("<anonymous>");
+ 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 ("<integer base type>");
+ when Iir_Kind_Floating_Type_Definition =>
+ Put ("<floating base type>");
+ when Iir_Kind_Physical_Type_Definition =>
+ Put ("<physical base type>");
+ 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 ("<unknown> ");
+ 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;
+
+ -- <SDFSimpleConditionAndOrEdge> ::=
+ -- <ConditionName>
+ -- | <Edge>
+ -- | <ConditionName>_<Edge>
+ 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;
+
+ -- <SDFFullConditionAndOrEdge> ::=
+ -- <ConditionNameEdge>[_<SDFSimpleConditionAndOrEdge>]
+ --
+ -- <ConditionNameEdge> ::=
+ -- [<ConditionName>_]<Edge>
+ -- | [<ConditionName>_]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
+ -- <VITALPropagationDelayName> ::=
+ -- TPD_<InputPort>_<OutputPort>[_<SDFSimpleConditionAndOrEdge>]
+ 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 '_<ClockPort>'.
+ 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<dir> Add <dir> to the end of the vhdl library path
+
+-elab
+vhdl Separate
+--elab <name> Used internally during elaboration of <name>
+
+-anaelab
+vhdl Separate
+--anaelab <name> Used internally during elaboration of <name>
+
+; -c is a driver option for gcc. --ghdl-source is used instead.
+;c
+;vhdl Separate
+;-c <filename> Analyze <filename> for --anaelab
+
+;v
+;vhdl
+;Verbose
+
+-warn-
+vhdl Joined
+--warn-<name> Warn about <name>
+
+-ghdl
+vhdl Joined
+--ghdl-<option> Pass <option> to vhdl front-end
+
+-expect-failure
+vhdl
+Expect a compiler error (used for testsuite)
+
+-no-vital-checks
+vhdl
+Disable VITAL checks
+
+-vital-checks
+vhdl
+Enable VITAL checks
+
+fexplicit
+vhdl
+Explicit function declarations override implicit one in use
+
+frelaxed-rules
+vhdl
+Relax some LRM rules to compile vendor libraries
+
+fpsl
+vhdl
+Allow PSL asserts in comments
+
+-no-direct-drivers
+vhdl
+Disable direct drivers optimization
+
+-syn-binding
+vhdl
+Use synthetizer rules for default bindings
+
+l
+vhdl Joined Separate
+-l<filename> Put list of files for link in <filename>
+
+; -C was commented out, as it is already defined for C/C++.
+;C
+;vhdl
+;Allow any character in comments
+
+-mb-comments
+vhdl
+Allow any character in comments
diff --git a/src/ortho/gcc/ortho-lang.c b/src/ortho/gcc/ortho-lang.c
new file mode 100644
index 000000000..c19012e6e
--- /dev/null
+++ b/src/ortho/gcc/ortho-lang.c
@@ -0,0 +1,2191 @@
+/* GCC back-end for ortho
+ Copyright (C) 2002-1014 Tristan Gingold and al.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA. */
+
+#include <stddef.h>
+#include <math.h>
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "tm_p.h"
+#include "defaults.h"
+#include "ggc.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "langhooks-def.h"
+#include "toplev.h"
+#include "opts.h"
+#include "options.h"
+#include "real.h"
+#include "tree-iterator.h"
+#include "function.h"
+#include "cgraph.h"
+#include "target.h"
+#include "convert.h"
+#include "tree-pass.h"
+#include "tree-dump.h"
+
+/* Undefine for gcc-4.8 */
+#define GCC49
+
+#ifdef GCC49
+
+#include "print-tree.h"
+#include "stringpool.h"
+#include "stor-layout.h"
+#include "varasm.h"
+
+/* Returns the number of FIELD_DECLs in TYPE.
+ Copied here from expr.c in gcc4.9 as it is no longer exported by tree.h. */
+
+static int
+fields_length (const_tree type)
+{
+ tree t = TYPE_FIELDS (type);
+ int count = 0;
+
+ for (; t; t = DECL_CHAIN (t))
+ if (TREE_CODE (t) == FIELD_DECL)
+ ++count;
+
+ return count;
+}
+
+#else
+
+// adapt gcc4.9 practice to gcc4.8 functions
+bool
+tree_fits_uhwi_p (const_tree t)
+{
+ return host_integerp (t, 1);
+}
+
+unsigned HOST_WIDE_INT
+tree_to_uhwi (const_tree t)
+{
+ return tree_low_cst (t, 1);
+}
+
+#endif
+
+/* TODO:
+ * remove stmt_list_stack, save in if/case/loop block
+ * Re-add -v (if necessary)
+ */
+
+static tree type_for_size (unsigned int precision, int unsignedp);
+
+const int tree_identifier_size = sizeof (struct tree_identifier);
+
+struct GTY(()) binding_level
+{
+ /* The BIND_EXPR node for this binding. */
+ tree bind;
+
+ /* The BLOCK node for this binding. */
+ tree block;
+
+ /* If true, stack must be saved (alloca is used). */
+ int save_stack;
+
+ /* Parent binding level. */
+ struct binding_level *prev;
+
+ /* Decls in this binding. */
+ tree first_decl;
+ tree last_decl;
+
+ /* Blocks in this binding. */
+ tree first_block;
+ tree last_block;
+};
+
+/* The current binding level. */
+static GTY(()) struct binding_level *cur_binding_level = NULL;
+
+/* Chain of unused binding levels. */
+static GTY(()) struct binding_level *old_binding_levels = NULL;
+
+/* Chain of statements currently generated. */
+static GTY(()) tree cur_stmts = NULL_TREE;
+
+static void
+push_binding (void)
+{
+ struct binding_level *res;
+
+ if (old_binding_levels == NULL)
+ res = ggc_alloc_binding_level ();
+ else
+ {
+ res = old_binding_levels;
+ old_binding_levels = res->prev;
+ }
+
+ /* Init. */
+ res->first_decl = NULL_TREE;
+ res->last_decl = NULL_TREE;
+
+ res->first_block = NULL_TREE;
+ res->last_block = NULL_TREE;
+
+ res->save_stack = 0;
+
+ res->bind = make_node (BIND_EXPR);
+ res->block = make_node (BLOCK);
+ BIND_EXPR_BLOCK (res->bind) = res->block;
+ TREE_SIDE_EFFECTS (res->bind) = true;
+ TREE_TYPE (res->bind) = void_type_node;
+ TREE_USED (res->block) = true;
+
+ if (cur_binding_level != NULL)
+ {
+ /* Append the block created. */
+ if (cur_binding_level->first_block == NULL)
+ cur_binding_level->first_block = res->block;
+ else
+ BLOCK_CHAIN (cur_binding_level->last_block) = res->block;
+ cur_binding_level->last_block = res->block;
+
+ BLOCK_SUPERCONTEXT (res->block) = cur_binding_level->block;
+ }
+
+ res->prev = cur_binding_level;
+ cur_binding_level = res;
+}
+
+static void
+push_decl (tree decl)
+{
+ DECL_CONTEXT (decl) = current_function_decl;
+
+ if (cur_binding_level->first_decl == NULL)
+ cur_binding_level->first_decl = decl;
+ else
+ TREE_CHAIN (cur_binding_level->last_decl) = decl;
+ cur_binding_level->last_decl = decl;
+}
+
+static tree
+pop_binding (void)
+{
+ tree res;
+ struct binding_level *cur;
+
+ cur = cur_binding_level;
+ res = cur->bind;
+
+ if (cur->save_stack)
+ {
+ tree tmp_var;
+ tree save;
+ tree save_call;
+ tree restore;
+ tree t;
+
+ /* Create an artificial var to save the stack pointer. */
+ tmp_var = build_decl (input_location, VAR_DECL, NULL, ptr_type_node);
+ DECL_ARTIFICIAL (tmp_var) = true;
+ DECL_IGNORED_P (tmp_var) = true;
+ TREE_USED (tmp_var) = true;
+ push_decl (tmp_var);
+
+ /* Create the save stmt. */
+ save_call = build_call_expr
+ (builtin_decl_implicit (BUILT_IN_STACK_SAVE), 0);
+ save = build2 (MODIFY_EXPR, ptr_type_node, tmp_var, save_call);
+ TREE_SIDE_EFFECTS (save) = true;
+
+ /* Create the restore stmt. */
+ restore = build_call_expr
+ (builtin_decl_implicit (BUILT_IN_STACK_RESTORE), 1, tmp_var);
+
+ /* Build a try-finally block.
+ The statement list is the block of current statements. */
+ t = build2 (TRY_FINALLY_EXPR, void_type_node, cur_stmts, NULL_TREE);
+ TREE_SIDE_EFFECTS (t) = true;
+
+ /* The finally block is the restore stmt. */
+ append_to_statement_list (restore, &TREE_OPERAND (t, 1));
+
+ /* The body of the BIND_BLOCK is the save stmt, followed by the
+ try block. */
+ BIND_EXPR_BODY (res) = NULL_TREE;
+ append_to_statement_list (save, &BIND_EXPR_BODY (res));
+ append_to_statement_list (t, &BIND_EXPR_BODY (res));
+ }
+ else
+ {
+ /* The body of the BIND_BLOCK is the statement block. */
+ BIND_EXPR_BODY (res) = cur_stmts;
+ }
+ BIND_EXPR_VARS (res) = cur->first_decl;
+
+ BLOCK_SUBBLOCKS (cur->block) = cur->first_block;
+ BLOCK_VARS (cur->block) = cur->first_decl;
+
+ cur_binding_level = cur->prev;
+ cur->prev = old_binding_levels;
+ old_binding_levels = cur;
+
+ return res;
+}
+
+// naive conversion to new vec API following the wiki at
+// http://gcc.gnu.org/wiki/cxx-conversion/cxx-vec
+// see also push_stmts, pop_stmts
+static vec <tree> stmt_list_stack = vec<tree>();
+
+static void
+push_stmts (tree stmts)
+{
+ stmt_list_stack.safe_push(cur_stmts);
+ cur_stmts = stmts;
+}
+
+static void
+pop_stmts (void)
+{
+ cur_stmts = stmt_list_stack.pop();
+}
+
+static void
+append_stmt (tree stmt)
+{
+ if (!EXPR_HAS_LOCATION (stmt))
+ SET_EXPR_LOCATION (stmt, input_location);
+ TREE_SIDE_EFFECTS (stmt) = true;
+ append_to_statement_list (stmt, &cur_stmts);
+}
+
+static GTY(()) tree top;
+
+static GTY(()) tree stack_alloc_function_ptr;
+
+static bool
+global_bindings_p (void)
+{
+ return cur_binding_level->prev == NULL;
+}
+
+static tree
+pushdecl (tree t)
+{
+ //gcc_unreachable ();
+ // gcc4.8.2 we get here from build_common_builtin_nodes () call in ortho_init
+ return t;
+}
+
+static tree
+builtin_function (const char *name,
+ tree type,
+ int function_code,
+ enum built_in_class decl_class,
+ const char *library_name,
+ tree attrs ATTRIBUTE_UNUSED);
+
+REAL_VALUE_TYPE fp_const_p5; /* 0.5 */
+REAL_VALUE_TYPE fp_const_m_p5; /* -0.5 */
+REAL_VALUE_TYPE fp_const_zero; /* 0.0 */
+
+static bool
+ortho_init (void)
+{
+ tree n;
+
+ input_location = BUILTINS_LOCATION;
+
+ /* Create a global binding. */
+ push_binding ();
+
+ build_common_tree_nodes (0, 0);
+
+ n = build_decl (input_location,
+ TYPE_DECL, get_identifier ("int"), integer_type_node);
+ push_decl (n);
+ n = build_decl (input_location,
+ TYPE_DECL, get_identifier ("char"), char_type_node);
+ push_decl (n);
+
+ /* Create alloca builtin. */
+ {
+ tree args_type = tree_cons (NULL_TREE, size_type_node, void_list_node);
+ tree func_type = build_function_type (ptr_type_node, args_type);
+
+ set_builtin_decl
+ (BUILT_IN_ALLOCA,
+ builtin_function
+ ("__builtin_alloca", func_type,
+ BUILT_IN_ALLOCA, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
+
+ stack_alloc_function_ptr = build1
+ (ADDR_EXPR,
+ build_pointer_type (func_type),
+ builtin_decl_implicit (BUILT_IN_ALLOCA));
+ }
+
+ {
+ tree ptr_ftype = build_function_type (ptr_type_node, NULL_TREE);
+
+ set_builtin_decl
+ (BUILT_IN_STACK_SAVE,
+ builtin_function
+ ("__builtin_stack_save", ptr_ftype,
+ BUILT_IN_STACK_SAVE, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
+ }
+
+ {
+ tree ftype_ptr;
+
+ ftype_ptr = build_function_type
+ (void_type_node,
+ tree_cons (NULL_TREE, ptr_type_node, NULL_TREE));
+
+ set_builtin_decl
+ (BUILT_IN_STACK_RESTORE,
+ builtin_function
+ ("__builtin_stack_restore", ftype_ptr,
+ BUILT_IN_STACK_RESTORE, BUILT_IN_NORMAL, NULL, NULL_TREE), true);
+ }
+ {
+ REAL_VALUE_TYPE v;
+
+ REAL_VALUE_FROM_INT (v, 1, 0, DFmode);
+ real_ldexp (&fp_const_p5, &v, -1);
+
+ REAL_VALUE_FROM_INT (v, -1, -1, DFmode);
+ real_ldexp (&fp_const_m_p5, &v, -1);
+
+ REAL_VALUE_FROM_INT (fp_const_zero, 0, 0, DFmode);
+ }
+
+ build_common_builtin_nodes ();
+ // FIXME: this MAY remove the need for creating the builtins above...
+ // Evaluate tree.c / build_common_builtin_nodes (); for each in turn.
+
+ return true;
+}
+
+static void
+ortho_finish (void)
+{
+}
+
+static unsigned int
+ortho_option_lang_mask (void)
+{
+ return CL_vhdl;
+}
+
+static bool
+ortho_post_options (const char **pfilename)
+{
+ if (*pfilename == NULL || strcmp (*pfilename, "-") == 0)
+ *pfilename = "*stdin*";
+
+ /* Default hook. */
+ lhd_post_options (pfilename);
+
+ // This stops compile failures writing debug information when both -g and -O2
+ // (or -O1, -O3 or -Os) options are present.
+ // Should really make it conditional on specific options
+ // FIXME : re-evaluate if this is still necessary with newer gccrevisions
+ dwarf_strict = 1;
+
+ /* Run the back-end. */
+ return false;
+}
+
+extern "C" int lang_handle_option (const char *opt, const char *arg);
+
+static bool
+ortho_handle_option (size_t code, const char *arg,
+ int value ATTRIBUTE_UNUSED,
+ int kind ATTRIBUTE_UNUSED,
+ location_t loc ATTRIBUTE_UNUSED,
+ const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
+{
+ const char *opt;
+
+ opt = cl_options[code].opt_text;
+
+ switch (code)
+ {
+ case OPT__elab:
+ case OPT_l:
+ case OPT_c:
+ case OPT__anaelab:
+ /* Only a few options have a real arguments. */
+ return lang_handle_option (opt, arg) != 0;
+ default:
+ /* The other options must have a joint argument. */
+ if (arg != NULL)
+ {
+ size_t len1;
+ size_t len2;
+ char *nopt;
+
+ len1 = strlen (opt);
+ len2 = strlen (arg);
+ nopt = (char *) alloca (len1 + len2 + 1);
+ memcpy (nopt, opt, len1);
+ memcpy (nopt + len1, arg, len2);
+ nopt[len1 + len2] = 0;
+ opt = nopt;
+ }
+ return lang_handle_option (opt, NULL) != 0;
+ }
+}
+
+extern "C" int lang_parse_file (const char *filename);
+
+static void
+ortho_parse_file (void)
+{
+ const char *filename;
+
+ if (num_in_fnames == 0)
+ filename = NULL;
+ else
+ filename = in_fnames[0];
+
+ linemap_add (line_table, LC_ENTER, 0, filename ? filename :"*no-file*", 1);
+ input_location = linemap_line_start (line_table, 1, 252);
+
+ if (!lang_parse_file (filename))
+ errorcount++;
+ linemap_add (line_table, LC_LEAVE, 0, NULL, 1);
+}
+
+/* Called by the back-end or by the front-end when the address of EXP
+ must be taken.
+ This function should found the base object (if any), and mark it as
+ addressable (via TREE_ADDRESSABLE). It may emit a warning if this
+ object cannot be addressable (front-end restriction).
+ Returns TRUE in case of success, FALSE in case of failure.
+ Note that the status is never checked by the back-end. */
+static bool
+ortho_mark_addressable (tree exp)
+{
+ tree n;
+
+ n = exp;
+
+ while (1)
+ switch (TREE_CODE (n))
+ {
+ case VAR_DECL:
+ case CONST_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ TREE_ADDRESSABLE (n) = true;
+ return true;
+
+ case COMPONENT_REF:
+ case ARRAY_REF:
+ case ARRAY_RANGE_REF:
+ n = TREE_OPERAND (n, 0);
+ break;
+
+ case FUNCTION_DECL:
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (n) = true;
+ return true;
+
+ case INDIRECT_REF:
+ return true;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+static tree
+ortho_truthvalue_conversion (tree expr)
+{
+ tree expr_type;
+ tree t;
+ tree f;
+
+ expr_type = TREE_TYPE (expr);
+ if (TREE_CODE (expr_type) != BOOLEAN_TYPE)
+ {
+ t = integer_one_node;
+ f = integer_zero_node;
+ }
+ else
+ {
+ f = TYPE_MIN_VALUE (expr_type);
+ t = TYPE_MAX_VALUE (expr_type);
+ }
+
+
+ switch (TREE_CODE (expr))
+ {
+ case EQ_EXPR:
+ case NE_EXPR:
+ case LE_EXPR:
+ case GE_EXPR:
+ case LT_EXPR:
+ case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case ERROR_MARK:
+ return expr;
+
+ case INTEGER_CST:
+ /* Not 0 is true. */
+ return integer_zerop (expr) ? f : t;
+
+ case REAL_CST:
+ return real_zerop (expr) ? f : t;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+/* The following function has been copied and modified from c-convert.c. */
+
+/* Change of width--truncation and extension of integers or reals--
+ is represented with NOP_EXPR. Proper functioning of many things
+ assumes that no other conversions can be NOP_EXPRs.
+
+ Conversion between integer and pointer is represented with CONVERT_EXPR.
+ Converting integer to real uses FLOAT_EXPR
+ and real to integer uses FIX_TRUNC_EXPR.
+
+ Here is a list of all the functions that assume that widening and
+ narrowing is always done with a NOP_EXPR:
+ In convert.c, convert_to_integer.
+ In c-typeck.c, build_binary_op (boolean ops), and
+ c_common_truthvalue_conversion.
+ In expr.c: expand_expr, for operands of a MULT_EXPR.
+ In fold-const.c: fold.
+ In tree.c: get_narrower and get_unwidened. */
+
+/* Subroutines of `convert'. */
+
+
+
+/* Create an expression whose value is that of EXPR,
+ converted to type TYPE. The TREE_TYPE of the value
+ is always TYPE. This function implements all reasonable
+ conversions; callers should filter out those that are
+ not permitted by the language being compiled. */
+
+tree
+convert (tree type, tree expr)
+{
+ tree e = expr;
+ enum tree_code code = TREE_CODE (type);
+ const char *invalid_conv_diag;
+
+ if (type == error_mark_node
+ || expr == error_mark_node
+ || TREE_TYPE (expr) == error_mark_node)
+ return error_mark_node;
+
+ if ((invalid_conv_diag
+ = targetm.invalid_conversion (TREE_TYPE (expr), type)))
+ {
+ error (invalid_conv_diag);
+ return error_mark_node;
+ }
+
+ if (type == TREE_TYPE (expr))
+ return expr;
+
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
+ return fold_build1 (NOP_EXPR, type, expr);
+ if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK)
+ return error_mark_node;
+ if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE || code == VOID_TYPE)
+ {
+ gcc_unreachable ();
+ }
+ if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
+ return fold (convert_to_integer (type, e));
+ if (code == BOOLEAN_TYPE)
+ {
+ tree t = ortho_truthvalue_conversion (expr);
+ if (TREE_CODE (t) == ERROR_MARK)
+ return t;
+
+ /* If it returns a NOP_EXPR, we must fold it here to avoid
+ infinite recursion between fold () and convert (). */
+ if (TREE_CODE (t) == NOP_EXPR)
+ return fold_build1 (NOP_EXPR, type, TREE_OPERAND (t, 0));
+ else
+ return fold_build1 (NOP_EXPR, type, t);
+ }
+ if (code == POINTER_TYPE || code == REFERENCE_TYPE)
+ return fold (convert_to_pointer (type, e));
+ if (code == REAL_TYPE)
+ return fold (convert_to_real (type, e));
+
+ gcc_unreachable ();
+}
+
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
+
+ If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function. If
+ ATTRS is nonzero, use that for the function's attribute list. */
+static tree
+builtin_function (const char *name,
+ tree type,
+ int function_code,
+ enum built_in_class decl_class,
+ const char *library_name,
+ tree attrs ATTRIBUTE_UNUSED)
+{
+ tree decl = build_decl (input_location,
+ FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ if (library_name)
+ SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
+ make_decl_rtl (decl);
+ DECL_BUILT_IN_CLASS (decl) = decl_class;
+ DECL_FUNCTION_CODE (decl) = (built_in_function) function_code;
+ DECL_SOURCE_LOCATION (decl) = input_location;
+ return decl;
+}
+
+#ifndef MAX_BITS_PER_WORD
+#define MAX_BITS_PER_WORD BITS_PER_WORD
+#endif
+
+/* This variable keeps a table for types for each precision so that we only
+ allocate each of them once. Signed and unsigned types are kept separate.
+ */
+static GTY(()) tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2];
+
+/* Return an integer type with the number of bits of precision given by
+ PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
+ it is a signed type. */
+static tree
+type_for_size (unsigned int precision, int unsignedp)
+{
+ tree t;
+
+ if (precision <= MAX_BITS_PER_WORD
+ && signed_and_unsigned_types[precision][unsignedp] != NULL_TREE)
+ return signed_and_unsigned_types[precision][unsignedp];
+
+ if (unsignedp)
+ t = make_unsigned_type (precision);
+ else
+ t = make_signed_type (precision);
+
+ if (precision <= MAX_BITS_PER_WORD)
+ signed_and_unsigned_types[precision][unsignedp] = t;
+
+ return t;
+}
+
+/* Return a data type that has machine mode MODE. UNSIGNEDP selects
+ an unsigned type; otherwise a signed type is returned. */
+static tree
+type_for_mode (enum machine_mode mode, int unsignedp)
+{
+ if (SCALAR_INT_MODE_P (mode))
+ return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
+
+ if (mode == TYPE_MODE (void_type_node))
+ return void_type_node;
+
+ if (mode == TYPE_MODE (float_type_node))
+ return float_type_node;
+
+ if (mode == TYPE_MODE (double_type_node))
+ return double_type_node;
+
+ if (mode == TYPE_MODE (long_double_type_node))
+ return long_double_type_node;
+
+ return NULL_TREE;
+}
+
+#undef LANG_HOOKS_NAME
+#define LANG_HOOKS_NAME "vhdl"
+#undef LANG_HOOKS_IDENTIFIER_SIZE
+#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
+#undef LANG_HOOKS_INIT
+#define LANG_HOOKS_INIT ortho_init
+#undef LANG_HOOKS_FINISH
+#define LANG_HOOKS_FINISH ortho_finish
+#undef LANG_HOOKS_OPTION_LANG_MASK
+#define LANG_HOOKS_OPTION_LANG_MASK ortho_option_lang_mask
+#undef LANG_HOOKS_HANDLE_OPTION
+#define LANG_HOOKS_HANDLE_OPTION ortho_handle_option
+#undef LANG_HOOKS_POST_OPTIONS
+#define LANG_HOOKS_POST_OPTIONS ortho_post_options
+#undef LANG_HOOKS_HONOR_READONLY
+#define LANG_HOOKS_HONOR_READONLY true
+#undef LANG_HOOKS_MARK_ADDRESSABLE
+#define LANG_HOOKS_MARK_ADDRESSABLE ortho_mark_addressable
+#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
+#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION ortho_expand_function
+
+#undef LANG_HOOKS_TYPE_FOR_MODE
+#define LANG_HOOKS_TYPE_FOR_MODE type_for_mode
+#undef LANG_HOOKS_TYPE_FOR_SIZE
+#define LANG_HOOKS_TYPE_FOR_SIZE type_for_size
+#undef LANG_HOOKS_SIGNED_TYPE
+#define LANG_HOOKS_SIGNED_TYPE signed_type
+#undef LANG_HOOKS_UNSIGNED_TYPE
+#define LANG_HOOKS_UNSIGNED_TYPE unsigned_type
+#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
+#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE signed_or_unsigned_type
+#undef LANG_HOOKS_PARSE_FILE
+#define LANG_HOOKS_PARSE_FILE ortho_parse_file
+
+#define pushlevel lhd_do_nothing_i
+#define poplevel lhd_do_nothing_iii_return_null_tree
+#define set_block lhd_do_nothing_t
+#undef LANG_HOOKS_GETDECLS
+#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
+
+struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
+
+union GTY((desc ("0"),
+ chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL")))
+ lang_tree_node
+{
+ union tree_node GTY((tag ("0"),
+ desc ("tree_node_structure (&%h)"))) generic;
+};
+
+/* GHDL does not use the lang_decl and lang_type.
+
+ FIXME: the variable_size annotation here is needed because these types are
+ variable-sized in some other front-ends. Due to gengtype deficiency, the
+ GTY options of such types have to agree across all front-ends. */
+
+struct GTY((variable_size)) lang_type { char dummy; };
+struct GTY((variable_size)) lang_decl { char dummy; };
+
+struct GTY(()) language_function
+{
+ char dummy;
+};
+
+
+extern "C" {
+
+struct GTY(()) chain_constr_type
+{
+ tree first;
+ tree last;
+};
+
+static void
+chain_init (struct chain_constr_type *constr)
+{
+ constr->first = NULL_TREE;
+ constr->last = NULL_TREE;
+}
+
+static void
+chain_append (struct chain_constr_type *constr, tree el)
+{
+ if (constr->first == NULL_TREE)
+ {
+ gcc_assert (constr->last == NULL_TREE);
+ constr->first = el;
+ }
+ else
+ TREE_CHAIN (constr->last) = el;
+ constr->last = el;
+}
+
+struct GTY(()) list_constr_type
+{
+ tree first;
+ tree last;
+};
+
+static void
+list_init (struct list_constr_type *constr)
+{
+ constr->first = NULL_TREE;
+ constr->last = NULL_TREE;
+}
+
+static void
+ortho_list_append (struct list_constr_type *constr, tree el)
+{
+ tree res;
+
+ res = tree_cons (NULL_TREE, el, NULL_TREE);
+ if (constr->first == NULL_TREE)
+ constr->first = res;
+ else
+ TREE_CHAIN (constr->last) = res;
+ constr->last = res;
+}
+
+enum ON_op_kind {
+ /* Not an operation; invalid. */
+ ON_Nil,
+
+ /* Dyadic operations. */
+ ON_Add_Ov,
+ ON_Sub_Ov,
+ ON_Mul_Ov,
+ ON_Div_Ov,
+ ON_Rem_Ov,
+ ON_Mod_Ov,
+
+ /* Binary operations. */
+ ON_And,
+ ON_Or,
+ ON_Xor,
+
+ /* Monadic operations. */
+ ON_Not,
+ ON_Neg_Ov,
+ ON_Abs_Ov,
+
+ /* Comparaisons */
+ ON_Eq,
+ ON_Neq,
+ ON_Le,
+ ON_Lt,
+ ON_Ge,
+ ON_Gt,
+
+ ON_LAST
+};
+
+static enum tree_code ON_op_to_TREE_CODE[ON_LAST] = {
+ ERROR_MARK,
+
+ PLUS_EXPR,
+ MINUS_EXPR,
+ MULT_EXPR,
+ ERROR_MARK,
+ TRUNC_MOD_EXPR,
+ FLOOR_MOD_EXPR,
+
+ BIT_AND_EXPR,
+ BIT_IOR_EXPR,
+ BIT_XOR_EXPR,
+
+ BIT_NOT_EXPR,
+ NEGATE_EXPR,
+ ABS_EXPR,
+
+ EQ_EXPR,
+ NE_EXPR,
+ LE_EXPR,
+ LT_EXPR,
+ GE_EXPR,
+ GT_EXPR,
+};
+
+tree
+new_dyadic_op (enum ON_op_kind kind, tree left, tree right)
+{
+ tree left_type;
+ enum tree_code code;
+
+ /* Truncate to avoid representations issue. */
+ kind = (enum ON_op_kind)((unsigned)kind & 0xff);
+
+ left_type = TREE_TYPE (left);
+ gcc_assert (left_type == TREE_TYPE (right));
+
+ switch (kind)
+ {
+ case ON_Div_Ov:
+ if (TREE_CODE (left_type) == REAL_TYPE)
+ code = RDIV_EXPR;
+ else
+ code = TRUNC_DIV_EXPR;
+ break;
+ default:
+ code = ON_op_to_TREE_CODE[kind];
+ break;
+ }
+ return build2 (code, left_type, left, right);
+}
+
+tree
+new_monadic_op (enum ON_op_kind kind, tree operand)
+{
+ /* Truncate to avoid representations issue. */
+ kind = (enum ON_op_kind)((unsigned)kind & 0xff);
+
+ return build1 (ON_op_to_TREE_CODE[kind], TREE_TYPE (operand), operand);
+}
+
+tree
+new_compare_op (enum ON_op_kind kind, tree left, tree right, tree ntype)
+{
+ gcc_assert (TREE_CODE (ntype) == BOOLEAN_TYPE);
+ gcc_assert (TREE_TYPE (left) == TREE_TYPE (right));
+
+ /* Truncate to avoid representations issue. */
+ kind = (enum ON_op_kind)((unsigned)kind & 0xff);
+
+ return build2 (ON_op_to_TREE_CODE[kind], ntype, left, right);
+}
+
+tree
+new_convert_ov (tree val, tree rtype)
+{
+ tree val_type;
+ enum tree_code val_code;
+ enum tree_code rtype_code;
+ enum tree_code code;
+
+ val_type = TREE_TYPE (val);
+ if (val_type == rtype)
+ return val;
+
+ /* FIXME: check conversions. */
+ val_code = TREE_CODE (val_type);
+ rtype_code = TREE_CODE (rtype);
+ if (val_code == POINTER_TYPE && rtype_code == POINTER_TYPE)
+ code = NOP_EXPR;
+ else if (val_code == INTEGER_TYPE && rtype_code == INTEGER_TYPE)
+ code = CONVERT_EXPR;
+ else if (val_code == REAL_TYPE && rtype_code == INTEGER_TYPE)
+ {
+ /* REAL to INTEGER
+ Gcc only handles FIX_TRUNC_EXPR, but we need rounding. */
+ tree m_p5;
+ tree p5;
+ tree zero;
+ tree saved;
+ tree comp;
+ tree adj;
+ tree res;
+
+ m_p5 = build_real (val_type, fp_const_m_p5);
+ p5 = build_real (val_type, fp_const_p5);
+ zero = build_real (val_type, fp_const_zero);
+ saved = save_expr (val);
+ comp = build2 (GE_EXPR, integer_type_node, saved, zero);
+ /* FIXME: instead of res = res + (comp ? .5 : -.5)
+ do: res = res (comp ? + : -) .5 */
+ adj = build3 (COND_EXPR, val_type, comp, p5, m_p5);
+ res = build2 (PLUS_EXPR, val_type, saved, adj);
+ res = build1 (FIX_TRUNC_EXPR, rtype, res);
+ return res;
+ }
+ else if (val_code == INTEGER_TYPE && rtype_code == ENUMERAL_TYPE)
+ code = CONVERT_EXPR;
+ else if (val_code == ENUMERAL_TYPE && rtype_code == INTEGER_TYPE)
+ code = CONVERT_EXPR;
+ else if (val_code == INTEGER_TYPE && rtype_code == REAL_TYPE)
+ code = FLOAT_EXPR;
+ else if (val_code == BOOLEAN_TYPE && rtype_code == BOOLEAN_TYPE)
+ code = NOP_EXPR;
+ else if (val_code == BOOLEAN_TYPE && rtype_code == INTEGER_TYPE)
+ code = CONVERT_EXPR;
+ else if (val_code == INTEGER_TYPE && rtype_code == BOOLEAN_TYPE)
+ code = NOP_EXPR;
+ else if (val_code == REAL_TYPE && rtype_code == REAL_TYPE)
+ code = NOP_EXPR;
+ else
+ gcc_unreachable ();
+
+ return build1 (code, rtype, val);
+}
+
+tree
+new_alloca (tree rtype, tree size)
+{
+ tree res;
+
+ /* Must save stack except when at function level. */
+ if (cur_binding_level->prev != NULL
+ && cur_binding_level->prev->prev != NULL)
+ cur_binding_level->save_stack = 1;
+
+ res = build_call_nary (ptr_type_node, stack_alloc_function_ptr,
+ 1, fold_convert (size_type_node, size));
+ return fold_convert (rtype, res);
+}
+
+tree
+new_signed_literal (tree ltype, long long value)
+{
+ tree res;
+ HOST_WIDE_INT lo;
+ HOST_WIDE_INT hi;
+
+ lo = value;
+ hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
+ res = build_int_cst_wide (ltype, lo, hi);
+ return res;
+}
+
+tree
+new_unsigned_literal (tree ltype, unsigned long long value)
+{
+ tree res;
+ unsigned HOST_WIDE_INT lo;
+ unsigned HOST_WIDE_INT hi;
+
+ lo = value;
+ hi = (value >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
+ res = build_int_cst_wide (ltype, lo, hi);
+ return res;
+}
+
+tree
+new_null_access (tree ltype)
+{
+ tree res;
+
+ res = build_int_cst_wide (ltype, 0, 0);
+ return res;
+}
+
+tree
+new_float_literal (tree ltype, double value)
+{
+ signed long long s;
+ double frac;
+ int ex;
+ REAL_VALUE_TYPE r_sign;
+ REAL_VALUE_TYPE r_exp;
+ REAL_VALUE_TYPE r;
+ tree res;
+ HOST_WIDE_INT lo;
+ HOST_WIDE_INT hi;
+
+ frac = frexp (value, &ex);
+
+ s = ldexp (frac, 60);
+ lo = s;
+ hi = (s >> 1) >> (8 * sizeof (HOST_WIDE_INT) - 1);
+ res = build_int_cst_wide (long_integer_type_node, lo, hi);
+ REAL_VALUE_FROM_INT (r_sign, lo, hi, DFmode);
+ real_2expN (&r_exp, ex - 60, DFmode);
+ real_arithmetic (&r, MULT_EXPR, &r_sign, &r_exp);
+ res = build_real (ltype, r);
+ return res;
+}
+
+struct GTY(()) o_element_list
+{
+ tree res;
+ struct chain_constr_type chain;
+};
+
+void
+new_uncomplete_record_type (tree *res)
+{
+ *res = make_node (RECORD_TYPE);
+}
+
+void
+start_record_type (struct o_element_list *elements)
+{
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+start_uncomplete_record_type (tree res, struct o_element_list *elements)
+{
+ elements->res = res;
+ chain_init (&elements->chain);
+}
+
+static void
+new_record_union_field (struct o_element_list *list,
+ tree *el,
+ tree ident,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location,
+ FIELD_DECL, ident, etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ *el = res;
+}
+
+void
+new_record_field (struct o_element_list *list,
+ tree *el,
+ tree ident,
+ tree etype)
+{
+ return new_record_union_field (list, el, ident, etype);
+}
+
+void
+finish_record_type (struct o_element_list *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+
+ if (TYPE_NAME (elements->res) != NULL_TREE)
+ {
+ /* The type was completed. */
+ rest_of_type_compilation (elements->res, 1);
+ }
+}
+
+void
+start_union_type (struct o_element_list *elements)
+{
+ elements->res = make_node (UNION_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_union_field (struct o_element_list *elements,
+ tree *el,
+ tree ident,
+ tree etype)
+{
+ return new_record_union_field (elements, el, ident, etype);
+}
+
+void
+finish_union_type (struct o_element_list *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
+tree
+new_unsigned_type (int size)
+{
+ return make_unsigned_type (size);
+}
+
+tree
+new_signed_type (int size)
+{
+ return make_signed_type (size);
+}
+
+tree
+new_float_type (void)
+{
+ tree res;
+
+ res = make_node (REAL_TYPE);
+ TYPE_PRECISION (res) = DOUBLE_TYPE_SIZE;
+ layout_type (res);
+ return res;
+}
+
+tree
+new_access_type (tree dtype)
+{
+ tree res;
+
+ if (dtype == NULL_TREE)
+ {
+ res = make_node (POINTER_TYPE);
+ TREE_TYPE (res) = NULL_TREE;
+ /* Seems necessary. */
+ SET_TYPE_MODE (res, Pmode);
+ layout_type (res);
+ return res;
+ }
+ else
+ return build_pointer_type (dtype);
+}
+
+void
+finish_access_type (tree atype, tree dtype)
+{
+ gcc_assert (TREE_CODE (atype) == POINTER_TYPE
+ && TREE_TYPE (atype) == NULL_TREE);
+
+ TREE_TYPE (atype) = dtype;
+}
+
+tree
+new_array_type (tree el_type, tree index_type)
+{
+ return build_array_type (el_type, index_type);
+}
+
+
+tree
+new_constrained_array_type (tree atype, tree length)
+{
+ tree range_type;
+ tree index_type;
+ tree len;
+ tree one;
+ tree res;
+
+ index_type = TYPE_DOMAIN (atype);
+ if (integer_zerop (length))
+ {
+ /* Handle null array, by creating a one-length array... */
+ len = size_zero_node;
+ }
+ else
+ {
+ one = build_int_cstu (index_type, 1);
+ len = build2 (MINUS_EXPR, index_type, length, one);
+ len = fold (len);
+ }
+
+ range_type = build_range_type (index_type, size_zero_node, len);
+ res = build_array_type (TREE_TYPE (atype), range_type);
+
+ /* Constrained arrays are *always* a subtype of its array type.
+ Just copy alias set. */
+ TYPE_ALIAS_SET (res) = get_alias_set (atype);
+ return res;
+}
+
+void
+new_boolean_type (tree *res,
+ tree false_id ATTRIBUTE_UNUSED, tree *false_e,
+ tree true_id ATTRIBUTE_UNUSED, tree *true_e)
+{
+ *res = make_node (BOOLEAN_TYPE);
+ TYPE_PRECISION (*res) = 1;
+ fixup_unsigned_type (*res);
+ *false_e = TYPE_MIN_VALUE (*res);
+ *true_e = TYPE_MAX_VALUE (*res);
+}
+
+struct o_enum_list
+{
+ tree res;
+ struct chain_constr_type chain;
+ int num;
+ int size;
+};
+
+void
+start_enum_type (struct o_enum_list *list, int size)
+{
+ list->res = make_node (ENUMERAL_TYPE);
+ // as of gcc4.8, TYPE_PRECISION of 0 is rigorously enforced!
+ TYPE_PRECISION(list->res) = size;
+ chain_init (&list->chain);
+ list->num = 0;
+ list->size = size;
+}
+
+void
+new_enum_literal (struct o_enum_list *list, tree ident, tree *res)
+{
+ *res = build_int_cstu (list->res, (HOST_WIDE_INT)(list->num));
+ chain_append (&list->chain, tree_cons (ident, *res, NULL_TREE));
+ list->num++;
+}
+
+void
+finish_enum_type (struct o_enum_list *list, tree *res)
+{
+ *res = list->res;
+ TYPE_VALUES (*res) = list->chain.first;
+ TYPE_UNSIGNED (*res) = 1;
+ TYPE_PRECISION (*res) = list->size;
+ set_min_and_max_values_for_integral_type (*res, list->size, 1);
+ layout_type (*res);
+}
+
+struct GTY(()) o_record_aggr_list
+{
+ /* Type of the record. */
+ tree atype;
+ /* Type of the next field to be added. */
+ tree field;
+ /* Vector of elements. */
+ // VEC(constructor_elt,gc) *elts;
+ vec<constructor_elt,va_gc> *elts;
+};
+
+void
+start_record_aggr (struct o_record_aggr_list *list, tree atype)
+{
+ list->atype = atype;
+ list->field = TYPE_FIELDS (atype);
+ //list->elts = VEC_alloc (constructor_elt, gc, fields_length (atype));
+ vec_alloc(list->elts, fields_length (atype));
+}
+
+void
+new_record_aggr_el (struct o_record_aggr_list *list, tree value)
+{
+ CONSTRUCTOR_APPEND_ELT (list->elts, list->field, value);
+ list->field = TREE_CHAIN (list->field);
+}
+
+void
+finish_record_aggr (struct o_record_aggr_list *list, tree *res)
+{
+ *res = build_constructor (list->atype, list->elts);
+}
+
+struct GTY(()) o_array_aggr_list
+{
+ tree atype;
+ /* Vector of elements. */
+ vec<constructor_elt,va_gc> *elts;
+};
+
+void
+start_array_aggr (struct o_array_aggr_list *list, tree atype)
+{
+ tree nelts;
+ unsigned HOST_WIDE_INT n;
+
+ list->atype = atype;
+ list->elts = NULL;
+
+ nelts = array_type_nelts (atype);
+ gcc_assert (nelts != NULL_TREE && tree_fits_uhwi_p (nelts));
+
+ n = tree_to_uhwi (nelts) + 1;
+ vec_alloc(list->elts, n);
+}
+
+void
+new_array_aggr_el (struct o_array_aggr_list *list, tree value)
+{
+ CONSTRUCTOR_APPEND_ELT (list->elts, NULL_TREE, value);
+}
+
+void
+finish_array_aggr (struct o_array_aggr_list *list, tree *res)
+{
+ *res = build_constructor (list->atype, list->elts);
+}
+
+
+tree
+new_union_aggr (tree atype, tree field, tree value)
+{
+ tree res;
+
+ res = build_constructor_single (atype, field, value);
+ TREE_CONSTANT (res) = 1;
+ return res;
+}
+
+tree
+new_indexed_element (tree arr, tree index)
+{
+ ortho_mark_addressable (arr);
+ return build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (arr)),
+ arr, index, NULL_TREE, NULL_TREE);
+}
+
+tree
+new_slice (tree arr, tree res_type, tree index)
+{
+#if 0
+ tree res;
+ tree el_ptr_type;
+ tree el_type;
+ tree res_ptr_type;
+#endif
+
+ /* *((RES_TYPE *)(&ARR[INDEX]))
+ convert ARR to a pointer, add index, and reconvert to array ? */
+ gcc_assert (TREE_CODE (res_type) == ARRAY_TYPE);
+
+ ortho_mark_addressable (arr);
+ return build4 (ARRAY_RANGE_REF, res_type, arr, index, NULL_TREE, NULL_TREE);
+#if 0
+ el_type = TREE_TYPE (TREE_TYPE (arr));
+ el_ptr_type = build_pointer_type (el_type);
+
+ res = build4 (ARRAY_REF, el_type, arr, index, NULL_TREE, NULL_TREE);
+ res = build1 (ADDR_EXPR, el_ptr_type, res);
+ res_ptr_type = build_pointer_type (res_type);
+ res = build1 (NOP_EXPR, res_ptr_type, res);
+ res = build1 (INDIRECT_REF, res_type, res);
+ return res;
+#endif
+}
+
+tree
+new_selected_element (tree rec, tree el)
+{
+ tree res;
+
+ gcc_assert (TREE_CODE (TREE_TYPE (rec)) == RECORD_TYPE);
+
+ res = build3 (COMPONENT_REF, TREE_TYPE (el), rec, el, NULL_TREE);
+ return res;
+}
+
+tree
+new_access_element (tree acc)
+{
+ tree acc_type;
+
+ acc_type = TREE_TYPE (acc);
+ gcc_assert (TREE_CODE (acc_type) == POINTER_TYPE);
+
+ return build1 (INDIRECT_REF, TREE_TYPE (acc_type), acc);
+}
+
+tree
+new_offsetof (tree rec_type, tree field, tree rtype)
+{
+ tree off;
+ tree bit_off;
+ HOST_WIDE_INT pos;
+ tree res;
+
+ gcc_assert (DECL_CONTEXT (field) == rec_type);
+
+ off = DECL_FIELD_OFFSET (field);
+
+ /* The offset must be a constant. */
+ gcc_assert (tree_fits_uhwi_p (off));
+
+ bit_off = DECL_FIELD_BIT_OFFSET (field);
+
+ /* The offset must be a constant. */
+ gcc_assert (tree_fits_uhwi_p (bit_off));
+
+ pos = TREE_INT_CST_LOW (off)
+ + (TREE_INT_CST_LOW (bit_off) / BITS_PER_UNIT);
+ res = build_int_cstu (rtype, pos);
+ return res;
+}
+
+tree
+new_sizeof (tree atype, tree rtype)
+{
+ tree size;
+
+ size = TYPE_SIZE_UNIT (atype);
+
+ return fold (build1 (NOP_EXPR, rtype, size));
+}
+
+tree
+new_alignof (tree atype, tree rtype)
+{
+ return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype));
+}
+
+static tree
+ortho_build_addr (tree lvalue, tree atype)
+{
+ tree res;
+
+ if (TREE_CODE (lvalue) == INDIRECT_REF)
+ {
+ /* ADDR_REF(INDIRECT_REF(x)) -> x. */
+ res = TREE_OPERAND (lvalue, 0);
+ }
+ else
+ {
+ tree ptr_type;
+
+ /* &base[off] -> base+off. */
+ ortho_mark_addressable (lvalue);
+
+ if (TREE_TYPE (lvalue) != TREE_TYPE (atype))
+ ptr_type = build_pointer_type (TREE_TYPE (lvalue));
+ else
+ ptr_type = atype;
+ res = fold_build1 (ADDR_EXPR, ptr_type, lvalue);
+ }
+
+ if (TREE_TYPE (res) != atype)
+ res = fold_build1 (NOP_EXPR, atype, res);
+
+ return res;
+}
+
+tree
+new_unchecked_address (tree lvalue, tree atype)
+{
+ return ortho_build_addr (lvalue, atype);
+}
+
+tree
+new_address (tree lvalue, tree atype)
+{
+ return ortho_build_addr (lvalue, atype);
+}
+
+tree
+new_global_address (tree lvalue, tree atype)
+{
+ return ortho_build_addr (lvalue, atype);
+}
+
+tree
+new_global_unchecked_address (tree lvalue, tree atype)
+{
+ return ortho_build_addr (lvalue, atype);
+}
+
+/* Return a pointer to function FUNC. */
+static tree
+build_function_ptr (tree func)
+{
+ return build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (func)), func);
+}
+
+tree
+new_subprogram_address (tree subprg, tree atype)
+{
+ return fold (build1 (NOP_EXPR, atype, build_function_ptr (subprg)));
+}
+
+tree
+new_value (tree lvalue)
+{
+ return lvalue;
+}
+
+void
+new_debug_line_decl (int line)
+{
+ input_location = linemap_line_start (line_table, line, 252);
+}
+
+void
+new_type_decl (tree ident, tree atype)
+{
+ tree decl;
+
+ TYPE_NAME (atype) = ident;
+ decl = build_decl (input_location, TYPE_DECL, ident, atype);
+ TYPE_STUB_DECL (atype) = decl;
+ push_decl (decl);
+ /*
+ if Get_TYPE_SIZE (Ttype) /= NULL_TREE then
+ -- Do not generate debug info for uncompleted types.
+ Rest_Of_Type_Compilation (Ttype, C_True);
+ end if;
+ */
+}
+
+enum o_storage { o_storage_external,
+ o_storage_public,
+ o_storage_private,
+ o_storage_local };
+
+static void
+set_storage (tree Node, enum o_storage storage)
+{
+ switch (storage)
+ {
+ case o_storage_external:
+ DECL_EXTERNAL (Node) = 1;
+ TREE_PUBLIC (Node) = 1;
+ TREE_STATIC (Node) = 0;
+ break;
+ case o_storage_public:
+ DECL_EXTERNAL (Node) = 0;
+ TREE_PUBLIC (Node) = 1;
+ TREE_STATIC (Node) = 1;
+ break;
+ case o_storage_private:
+ DECL_EXTERNAL (Node) = 0;
+ TREE_PUBLIC (Node) = 0;
+ TREE_STATIC (Node) = 1;
+ break;
+ case o_storage_local:
+ DECL_EXTERNAL (Node) = 0;
+ TREE_PUBLIC (Node) = 0;
+ TREE_STATIC (Node) = 0;
+ break;
+ }
+}
+
+void
+new_const_decl (tree *res, tree ident, enum o_storage storage, tree atype)
+{
+ tree cst;
+
+ cst = build_decl (input_location, VAR_DECL, ident, atype);
+ set_storage (cst, storage);
+ TREE_READONLY (cst) = 1;
+ push_decl (cst);
+ switch (storage)
+ {
+ case o_storage_local:
+ gcc_unreachable ();
+ case o_storage_external:
+ /* We are at top level if Current_Function_Decl is null. */
+ rest_of_decl_compilation
+ (cst, current_function_decl == NULL_TREE, 0);
+ break;
+ case o_storage_public:
+ case o_storage_private:
+ break;
+ }
+ *res = cst;
+}
+
+void
+start_const_value (tree *cst ATTRIBUTE_UNUSED)
+{
+}
+
+void
+finish_const_value (tree *cst, tree val)
+{
+ DECL_INITIAL (*cst) = val;
+ TREE_CONSTANT (val) = 1;
+ TREE_STATIC (*cst) = 1;
+ rest_of_decl_compilation
+ (*cst, current_function_decl == NULL_TREE, 0);
+}
+
+void
+new_var_decl (tree *res, tree ident, enum o_storage storage, tree atype)
+{
+ tree var;
+
+ var = build_decl (input_location, VAR_DECL, ident, atype);
+ if (current_function_decl != NULL_TREE)
+ {
+ /* Local variable. */
+ TREE_STATIC (var) = 0;
+ DECL_EXTERNAL (var) = 0;
+ TREE_PUBLIC (var) = 0;
+ }
+ else
+ set_storage (var, storage);
+
+ push_decl (var);
+
+ if (current_function_decl == NULL_TREE)
+ rest_of_decl_compilation (var, 1, 0);
+
+ *res = var;
+}
+
+struct GTY(()) o_inter_list
+{
+ tree ident;
+ enum o_storage storage;
+
+ /* Return type. */
+ tree rtype;
+
+ /* List of parameter types. */
+ struct list_constr_type param_list;
+
+ /* Chain of parameters declarations. */
+ struct chain_constr_type param_chain;
+};
+
+void
+start_function_decl (struct o_inter_list *interfaces,
+ tree ident,
+ enum o_storage storage,
+ tree rtype)
+{
+ interfaces->ident = ident;
+ interfaces->storage = storage;
+ interfaces->rtype = rtype;
+ chain_init (&interfaces->param_chain);
+ list_init (&interfaces->param_list);
+}
+
+void
+start_procedure_decl (struct o_inter_list *interfaces,
+ tree ident,
+ enum o_storage storage)
+{
+ start_function_decl (interfaces, ident, storage, void_type_node);
+}
+
+void
+new_interface_decl (struct o_inter_list *interfaces,
+ tree *res,
+ tree ident,
+ tree atype)
+{
+ tree r;
+
+ r = build_decl (input_location, PARM_DECL, ident, atype);
+ /* DECL_CONTEXT (Res, Xxx); */
+
+ /* Do type conversion: convert boolean and enums to int */
+ switch (TREE_CODE (atype))
+ {
+ case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
+ DECL_ARG_TYPE (r) = integer_type_node;
+ default:
+ DECL_ARG_TYPE (r) = atype;
+ }
+
+ layout_decl (r, 0);
+
+ chain_append (&interfaces->param_chain, r);
+ ortho_list_append (&interfaces->param_list, atype);
+ *res = r;
+}
+
+void
+finish_subprogram_decl (struct o_inter_list *interfaces, tree *res)
+{
+ tree decl;
+ tree result;
+ tree parm;
+ int is_global;
+
+ /* Append a void type in the parameter types chain, so that the function
+ is known not be have variables arguments. */
+ ortho_list_append (&interfaces->param_list, void_type_node);
+
+ decl = build_decl (input_location, FUNCTION_DECL, interfaces->ident,
+ build_function_type (interfaces->rtype,
+ interfaces->param_list.first));
+ DECL_SOURCE_LOCATION (decl) = input_location;
+
+ is_global = current_function_decl == NULL_TREE
+ || interfaces->storage == o_storage_external;
+ if (is_global)
+ set_storage (decl, interfaces->storage);
+ else
+ {
+ /* A nested subprogram. */
+ DECL_EXTERNAL (decl) = 0;
+ TREE_PUBLIC (decl) = 0;
+ }
+ /* The function exist in static storage. */
+ TREE_STATIC (decl) = 1;
+ DECL_INITIAL (decl) = error_mark_node;
+ TREE_ADDRESSABLE (decl) = 1;
+
+ /* Declare the result.
+ FIXME: should be moved in start_function_body. */
+ result = build_decl (input_location,
+ RESULT_DECL, NULL_TREE, interfaces->rtype);
+ DECL_RESULT (decl) = result;
+ DECL_CONTEXT (result) = decl;
+
+ DECL_ARGUMENTS (decl) = interfaces->param_chain.first;
+ /* Set DECL_CONTEXT of parameters. */
+ for (parm = interfaces->param_chain.first;
+ parm != NULL_TREE;
+ parm = TREE_CHAIN (parm))
+ DECL_CONTEXT (parm) = decl;
+
+ push_decl (decl);
+
+ /* External functions are never nested.
+ Remove their context, which is set by push_decl. */
+ if (interfaces->storage == o_storage_external)
+ DECL_CONTEXT (decl) = NULL_TREE;
+
+ if (is_global)
+ rest_of_decl_compilation (decl, 1, 0);
+
+ *res = decl;
+}
+
+void
+start_subprogram_body (tree func)
+{
+ gcc_assert (current_function_decl == DECL_CONTEXT (func));
+ current_function_decl = func;
+
+ /* The function is not anymore external. */
+ DECL_EXTERNAL (func) = 0;
+
+ push_stmts (alloc_stmt_list ());
+ push_binding ();
+}
+
+void
+finish_subprogram_body (void)
+{
+ tree bind;
+ tree func;
+ tree parent;
+
+ bind = pop_binding ();
+ pop_stmts ();
+
+ func = current_function_decl;
+ DECL_INITIAL (func) = BIND_EXPR_BLOCK (bind);
+ DECL_SAVED_TREE (func) = bind;
+
+ /* Initialize the RTL code for the function. */
+ allocate_struct_function (func, false);
+
+ /* Store the end of the function. */
+ cfun->function_end_locus = input_location;
+
+ parent = DECL_CONTEXT (func);
+
+ if (parent != NULL)
+ cgraph_get_create_node (func);
+ else
+ cgraph_finalize_function (func, false);
+
+ current_function_decl = parent;
+ set_cfun (NULL);
+}
+
+
+void
+new_debug_line_stmt (int line)
+{
+ input_location = linemap_line_start (line_table, line, 252);
+}
+
+void
+start_declare_stmt (void)
+{
+ push_stmts (alloc_stmt_list ());
+ push_binding ();
+}
+
+void
+finish_declare_stmt (void)
+{
+ tree bind;
+
+ bind = pop_binding ();
+ pop_stmts ();
+ append_stmt (bind);
+}
+
+
+struct GTY(()) o_assoc_list
+{
+ tree subprg;
+ vec<tree, va_gc> *vecptr;
+};
+
+void
+start_association (struct o_assoc_list *assocs, tree subprg)
+{
+ assocs->subprg = subprg;
+ assocs->vecptr = NULL;
+}
+
+void
+new_association (struct o_assoc_list *assocs, tree val)
+{
+ vec_safe_push(assocs->vecptr, val);
+}
+
+tree
+new_function_call (struct o_assoc_list *assocs)
+{
+ return build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
+ build_function_ptr (assocs->subprg),
+ assocs->vecptr);
+}
+
+void
+new_procedure_call (struct o_assoc_list *assocs)
+{
+ tree res;
+
+ res = build_call_vec (TREE_TYPE (TREE_TYPE (assocs->subprg)),
+ build_function_ptr (assocs->subprg),
+ assocs->vecptr);
+ TREE_SIDE_EFFECTS (res) = 1;
+ append_stmt (res);
+}
+
+void
+new_assign_stmt (tree target, tree value)
+{
+ tree n;
+
+ n = build2 (MODIFY_EXPR, TREE_TYPE (target), target, value);
+ TREE_SIDE_EFFECTS (n) = 1;
+ append_stmt (n);
+}
+
+void
+new_func_return_stmt (tree value)
+{
+ tree assign;
+ tree stmt;
+ tree res;
+
+ res = DECL_RESULT (current_function_decl);
+ assign = build2 (MODIFY_EXPR, TREE_TYPE (value), res, value);
+ TREE_SIDE_EFFECTS (assign) = 1;
+ stmt = build1 (RETURN_EXPR, void_type_node, assign);
+ TREE_SIDE_EFFECTS (stmt) = 1;
+ append_stmt (stmt);
+}
+
+void
+new_proc_return_stmt (void)
+{
+ tree stmt;
+
+ stmt = build1 (RETURN_EXPR, void_type_node, NULL_TREE);
+ TREE_SIDE_EFFECTS (stmt) = 1;
+ append_stmt (stmt);
+}
+
+
+struct GTY(()) o_if_block
+{
+ tree stmt;
+};
+
+void
+start_if_stmt (struct o_if_block *block, tree cond)
+{
+ tree stmt;
+ tree stmts;
+
+ stmts = alloc_stmt_list ();
+ stmt = build3 (COND_EXPR, void_type_node, cond, stmts, NULL_TREE);
+ block->stmt = stmt;
+ append_stmt (stmt);
+ push_stmts (stmts);
+}
+
+void
+new_else_stmt (struct o_if_block *block)
+{
+ tree stmts;
+
+ pop_stmts ();
+ stmts = alloc_stmt_list ();
+ COND_EXPR_ELSE (block->stmt) = stmts;
+ push_stmts (stmts);
+}
+
+void
+finish_if_stmt (struct o_if_block *block ATTRIBUTE_UNUSED)
+{
+ pop_stmts ();
+}
+
+
+struct GTY(()) o_snode
+{
+ tree beg_label;
+ tree end_label;
+};
+
+/* Create an artificial label. */
+static tree
+build_label (void)
+{
+ tree res;
+
+ res = build_decl (input_location, LABEL_DECL, NULL_TREE, void_type_node);
+ DECL_CONTEXT (res) = current_function_decl;
+ DECL_ARTIFICIAL (res) = 1;
+ return res;
+}
+
+void
+start_loop_stmt (struct o_snode *label)
+{
+ tree stmt;
+
+ label->beg_label = build_label ();
+
+ stmt = build1 (LABEL_EXPR, void_type_node, label->beg_label);
+ append_stmt (stmt);
+
+ label->end_label = build_label ();
+}
+
+void
+finish_loop_stmt (struct o_snode *label)
+{
+ tree stmt;
+
+ stmt = build1 (GOTO_EXPR, void_type_node, label->beg_label);
+ TREE_USED (label->beg_label) = 1;
+ append_stmt (stmt);
+ /* Emit the end label only if there is a goto to it.
+ (Return may be used to exit from the loop). */
+ if (TREE_USED (label->end_label))
+ {
+ stmt = build1 (LABEL_EXPR, void_type_node, label->end_label);
+ append_stmt (stmt);
+ }
+}
+
+void
+new_exit_stmt (struct o_snode *l)
+{
+ tree stmt;
+
+ stmt = build1 (GOTO_EXPR, void_type_node, l->end_label);
+ append_stmt (stmt);
+ TREE_USED (l->end_label) = 1;
+}
+
+void
+new_next_stmt (struct o_snode *l)
+{
+ tree stmt;
+
+ stmt = build1 (GOTO_EXPR, void_type_node, l->beg_label);
+ TREE_USED (l->beg_label) = 1;
+ append_stmt (stmt);
+}
+
+struct GTY(()) o_case_block
+{
+ tree case_type;
+ tree end_label;
+ int add_break;
+};
+
+void
+start_case_stmt (struct o_case_block *block, tree value)
+{
+ tree stmt;
+ tree stmts;
+
+ block->case_type = TREE_TYPE (value);
+ block->end_label = build_label ();
+ block->add_break = 0;
+ stmts = alloc_stmt_list ();
+ stmt = build3 (SWITCH_EXPR, block->case_type, value, stmts, NULL_TREE);
+ append_stmt (stmt);
+ push_stmts (stmts);
+}
+
+void
+start_choice (struct o_case_block *block)
+{
+ tree stmt;
+ if (block->add_break)
+ {
+ stmt = build1 (GOTO_EXPR, block->case_type, block->end_label);
+ append_stmt (stmt);
+
+ block->add_break = 0;
+ }
+}
+
+void
+new_expr_choice (struct o_case_block *block ATTRIBUTE_UNUSED, tree expr)
+{
+ tree stmt;
+
+ stmt = build_case_label
+ (expr, NULL_TREE, create_artificial_label (input_location));
+ append_stmt (stmt);
+}
+
+void
+new_range_choice (struct o_case_block *block ATTRIBUTE_UNUSED,
+ tree low, tree high)
+{
+ tree stmt;
+
+ stmt = build_case_label
+ (low, high, create_artificial_label (input_location));
+ append_stmt (stmt);
+}
+
+void
+new_default_choice (struct o_case_block *block ATTRIBUTE_UNUSED)
+{
+ tree stmt;
+
+ stmt = build_case_label
+ (NULL_TREE, NULL_TREE, create_artificial_label (input_location));
+ append_stmt (stmt);
+}
+
+void
+finish_choice (struct o_case_block *block)
+{
+ block->add_break = 1;
+}
+
+void
+finish_case_stmt (struct o_case_block *block)
+{
+ tree stmt;
+
+ pop_stmts ();
+ stmt = build1 (LABEL_EXPR, void_type_node, block->end_label);
+ append_stmt (stmt);
+}
+
+bool
+compare_identifier_string (tree id, const char *str, size_t len)
+{
+ if (IDENTIFIER_LENGTH (id) != len)
+ return false;
+ if (!memcmp (IDENTIFIER_POINTER (id), str, len))
+ return true;
+ else
+ return false;
+}
+
+void
+get_identifier_string (tree id, const char **str, int *len)
+{
+ *len = IDENTIFIER_LENGTH (id);
+ *str = IDENTIFIER_POINTER (id);
+}
+
+// C linkage wrappers for two (now C++) functions so that
+// Ada code can call them without name mangling
+tree get_identifier_with_length_c (const char *c, size_t s)
+{
+ return get_identifier_with_length(c, s);
+}
+
+int toplev_main_c (int argc, char **argv)
+{
+ return toplev_main(argc, argv);
+}
+
+void
+debug_tree_c (tree expr)
+{
+ warning (OPT_Wall, "Debug tree");
+ debug_tree (expr);
+}
+
+} // end extern "C"
+
+#include "debug.h"
+#include "gt-vhdl-ortho-lang.h"
+#include "gtype-vhdl.h"
diff --git a/src/ortho/gcc/ortho_gcc-main.adb b/src/ortho/gcc/ortho_gcc-main.adb
new file mode 100644
index 000000000..70c8a7f79
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc-main.adb
@@ -0,0 +1,42 @@
+-- GCC back-end for ortho
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with System;
+with Ortho_Gcc_Front;
+with Ada.Command_Line; use Ada.Command_Line;
+
+procedure Ortho_Gcc.Main
+is
+ gnat_argc : Integer;
+ gnat_argv : System.Address;
+
+ pragma Import (C, gnat_argc);
+ pragma Import (C, gnat_argv);
+
+ function Toplev_Main (Argc : Integer; Argv : System.Address)
+ return Integer;
+ pragma Import (C, Toplev_Main, "toplev_main_c");
+
+ Status : Exit_Status;
+begin
+ Ortho_Gcc_Front.Init;
+
+ -- Note: GCC set signal handlers...
+ Status := Exit_Status (Toplev_Main (gnat_argc, gnat_argv));
+ Set_Exit_Status (Status);
+end Ortho_Gcc.Main;
diff --git a/src/ortho/gcc/ortho_gcc-main.ads b/src/ortho/gcc/ortho_gcc-main.ads
new file mode 100644
index 000000000..4bd73a1b6
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc-main.ads
@@ -0,0 +1 @@
+procedure Ortho_Gcc.Main;
diff --git a/src/ortho/gcc/ortho_gcc.adb b/src/ortho/gcc/ortho_gcc.adb
new file mode 100644
index 000000000..ae7b4f53b
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc.adb
@@ -0,0 +1,121 @@
+-- GCC back-end for ortho.
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along 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;
+with Ortho_Gcc_Front; use Ortho_Gcc_Front;
+
+package body Ortho_Gcc is
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ begin
+ return O_Enode (Lit);
+ end New_Lit;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode is
+ begin
+ return O_Lnode (Obj);
+ end New_Obj;
+
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode is
+ begin
+ return O_Enode (Obj);
+ end New_Obj_Value;
+
+ procedure New_Debug_Filename_Decl (Filename : String) is
+ begin
+ null;
+ end New_Debug_Filename_Decl;
+
+ procedure New_Debug_Comment_Decl (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Decl;
+
+ procedure New_Debug_Comment_Stmt (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Stmt;
+
+ -- Representation of a C String: this is an access to a bounded string.
+ -- Therefore, with GNAT, such an access is a thin pointer.
+ subtype Fat_C_String is String (Positive);
+ type C_String is access all Fat_C_String;
+ pragma Convention (C, C_String);
+
+ C_String_Null : constant C_String := null;
+
+ -- Return the length of a C String (ie, the number of characters before
+ -- the Nul).
+ function C_String_Len (Str : C_String) return Natural;
+ pragma Import (C, C_String_Len, "strlen");
+
+ function Lang_Handle_Option (Opt : C_String; Arg : C_String)
+ return Integer;
+ pragma Export (C, Lang_Handle_Option);
+
+ function Lang_Parse_File (Filename : C_String) return Integer;
+ pragma Export (C, Lang_Parse_File);
+
+ function Lang_Handle_Option (Opt : C_String; Arg : C_String)
+ return Integer
+ is
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+
+ Res : Natural;
+ Ada_Opt : String_Acc;
+ Ada_Arg : String_Acc;
+ Len : Natural;
+ begin
+ Len := C_String_Len (Opt);
+ Ada_Opt := new String'(Opt (1 .. Len));
+ if Arg /= C_String_Null then
+ Len := C_String_Len (Arg);
+ Ada_Arg := new String'(Arg (1 .. Len));
+ else
+ Ada_Arg := null;
+ end if;
+ Res := Ortho_Gcc_Front.Decode_Option (Ada_Opt, Ada_Arg);
+ Unchecked_Deallocation (Ada_Opt);
+ Unchecked_Deallocation (Ada_Arg);
+ return Res;
+ end Lang_Handle_Option;
+
+ function Lang_Parse_File (Filename : C_String) return Integer
+ is
+ Len : Natural;
+ File : String_Acc;
+ begin
+ if Filename = C_String_Null then
+ File := null;
+ else
+ Len := C_String_Len (Filename);
+ File := new String'(Filename.all (1 .. Len));
+ end if;
+
+ if Ortho_Gcc_Front.Parse (File) then
+ return 1;
+ else
+ return 0;
+ end if;
+ end Lang_Parse_File;
+
+end Ortho_Gcc;
diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads
new file mode 100644
index 000000000..0afdc0887
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc.ads
@@ -0,0 +1,701 @@
+-- DO NOT MODIFY - this file was generated from:
+-- ortho_nodes.common.ads and ortho_gcc.private.ads
+--
+-- GCC back-end for ortho.
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces; use Interfaces;
+with Ortho_Ident;
+use Ortho_Ident;
+
+-- Interface to create nodes.
+package Ortho_Gcc is
+
+-- Start of common part
+
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ type O_Tnode is private;
+ type O_Snode is private;
+ type O_Dnode is private;
+ type O_Fnode is private;
+
+ O_Cnode_Null : constant O_Cnode;
+ O_Dnode_Null : constant O_Dnode;
+ O_Enode_Null : constant O_Enode;
+ O_Fnode_Null : constant O_Fnode;
+ O_Lnode_Null : constant O_Lnode;
+ O_Snode_Null : constant O_Snode;
+ O_Tnode_Null : constant O_Tnode;
+
+ -- True if the code generated supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a boolean 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record ATYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+
+ Type_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- Line number of the next declaration.
+ procedure New_Debug_Line_Decl (Line : Natural);
+
+ -- Add a comment in the declarative region.
+ procedure New_Debug_Comment_Decl (Comment : String);
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value of a non-external constant.
+ procedure Start_Const_Value (Const : in out O_Dnode);
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- Add a comment as a statement.
+ procedure New_Debug_Comment_Stmt (Comment : String);
+
+ -- Start a declarative region.
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+-- End of common part
+private
+ -- GCC supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ pragma Convention (C, O_Storage);
+ -- pragma Convention (C, ON_Op_Kind);
+
+ subtype Tree is System.Address;
+ NULL_TREE : constant Tree := System.Null_Address;
+
+ subtype Vec_Ptr is System.Address;
+
+ type O_Cnode is new Tree;
+ type O_Enode is new Tree;
+ type O_Lnode is new Tree;
+ type O_Tnode is new Tree;
+ type O_Fnode is new Tree;
+ type O_Dnode is new Tree;
+ type O_Snode is record
+ Beg_Label : Tree;
+ End_Label : Tree;
+ end record;
+ pragma Convention (C, O_Snode);
+
+ O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE);
+ O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE);
+ O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE);
+ O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE);
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Obj);
+ pragma Inline (New_Obj_Value);
+
+ -- Efficiently append element EL to a chain.
+ -- FIRST is the first element of the chain (must NULL_TREE if the chain
+ -- is empty),
+ -- LAST is the last element of the chain (idem).
+ type Chain_Constr_Type is record
+ First : Tree;
+ Last : Tree;
+ end record;
+ pragma Convention (C, Chain_Constr_Type);
+ procedure Chain_Init (Constr : out Chain_Constr_Type);
+ pragma Import (C, Chain_Init);
+ procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree);
+ pragma Import (C, Chain_Append);
+
+ -- Efficiently append element EL to a list.
+ type List_Constr_Type is record
+ First : Tree;
+ Last : Tree;
+ end record;
+ pragma Convention (C, List_Constr_Type);
+ procedure List_Init (Constr : out List_Constr_Type);
+ pragma Import (C, List_Init);
+ procedure List_Append (Constr : in out List_Constr_Type; El : Tree);
+ pragma Import (C, List_Append, "ortho_list_append");
+
+ type O_Loop_Block is record
+ Beg_Label : Tree;
+ End_Label : Tree;
+ end record;
+ pragma Convention (C, O_Loop_Block);
+
+ type O_Inter_List is record
+ Ident : O_Ident;
+ Storage : O_Storage;
+ -- Return type.
+ Rtype : O_Tnode;
+ -- List of parameter types.
+ Param_List : List_Constr_Type;
+ -- Chain of parameters declarations.
+ Param_Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Inter_List);
+
+ type O_Element_List is record
+ Res : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Element_List);
+
+ type O_Case_Block is record
+ Case_Type : Tree;
+ End_Label : Tree;
+ Add_Break : Integer;
+ end record;
+ pragma Convention (C, O_Case_Block);
+
+ type O_If_Block is record
+ Stmt : Tree;
+ end record;
+ pragma Convention (C, O_If_Block);
+
+ type O_Aggr_List is record
+ Atype : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+
+ type O_Record_Aggr_List is record
+ Atype : Tree;
+ Afield : Tree;
+ Vec : Vec_Ptr;
+ end record;
+ pragma Convention (C, O_Record_Aggr_List);
+
+ type O_Array_Aggr_List is record
+ Atype : Tree;
+ Vec : Vec_Ptr;
+ end record;
+ pragma Convention (C, O_Array_Aggr_List);
+
+ type O_Assoc_List is record
+ Subprg : Tree;
+ List : List_Constr_Type;
+ end record;
+ pragma Convention (C, O_Assoc_List);
+
+ type O_Enum_List is record
+ -- The enumeral_type node.
+ Res : Tree;
+ -- Chain of literals.
+ Chain : Chain_Constr_Type;
+ -- Numeral value (from 0 to nbr - 1) of the next literal to be declared.
+ Num : Natural;
+ -- Size of the enumeration type.
+ Size : Natural;
+ end record;
+ pragma Convention (C, O_Enum_List);
+
+ pragma Import (C, New_Dyadic_Op);
+ pragma Import (C, New_Monadic_Op);
+ pragma Import (C, New_Compare_Op);
+
+ pragma Import (C, New_Convert_Ov);
+ pragma Import (C, New_Alloca);
+
+ pragma Import (C, New_Signed_Literal);
+ pragma Import (C, New_Unsigned_Literal);
+ pragma Import (C, New_Float_Literal);
+ pragma Import (C, New_Null_Access);
+
+ pragma Import (C, Start_Record_Type);
+ pragma Import (C, New_Record_Field);
+ pragma Import (C, Finish_Record_Type);
+ pragma Import (C, New_Uncomplete_Record_Type);
+ pragma Import (C, Start_Uncomplete_Record_Type);
+
+ pragma Import (C, Start_Union_Type);
+ pragma Import (C, New_Union_Field);
+ pragma Import (C, Finish_Union_Type);
+
+ pragma Import (C, New_Unsigned_Type);
+ pragma Import (C, New_Signed_Type);
+ pragma Import (C, New_Float_Type);
+
+ pragma Import (C, New_Access_Type);
+ pragma Import (C, Finish_Access_Type);
+
+ pragma Import (C, New_Array_Type);
+ pragma Import (C, New_Constrained_Array_Type);
+
+ pragma Import (C, New_Boolean_Type);
+ pragma Import (C, Start_Enum_Type);
+ pragma Import (C, New_Enum_Literal);
+ pragma Import (C, Finish_Enum_Type);
+
+ pragma Import (C, Start_Record_Aggr);
+ pragma Import (C, New_Record_Aggr_El);
+ pragma Import (C, Finish_Record_Aggr);
+ pragma Import (C, Start_Array_Aggr);
+ pragma Import (C, New_Array_Aggr_El);
+ pragma Import (C, Finish_Array_Aggr);
+ pragma Import (C, New_Union_Aggr);
+
+ pragma Import (C, New_Indexed_Element);
+ pragma Import (C, New_Slice);
+ pragma Import (C, New_Selected_Element);
+ pragma Import (C, New_Access_Element);
+
+ pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Alignof);
+ pragma Import (C, New_Offsetof);
+
+ pragma Import (C, New_Address);
+ pragma Import (C, New_Global_Address);
+ pragma Import (C, New_Unchecked_Address);
+ pragma Import (C, New_Global_Unchecked_Address);
+ pragma Import (C, New_Subprogram_Address);
+
+ pragma Import (C, New_Value);
+
+ pragma Import (C, New_Type_Decl);
+ pragma Import (C, New_Debug_Line_Decl);
+ pragma Import (C, New_Const_Decl);
+ pragma Import (C, New_Var_Decl);
+
+ pragma Import (C, Start_Const_Value);
+ pragma Import (C, Finish_Const_Value);
+
+ pragma Import (C, Start_Function_Decl);
+ pragma Import (C, Start_Procedure_Decl);
+ pragma Import (C, New_Interface_Decl);
+ pragma Import (C, Finish_Subprogram_Decl);
+
+ pragma Import (C, Start_Subprogram_Body);
+ pragma Import (C, Finish_Subprogram_Body);
+
+ pragma Import (C, New_Debug_Line_Stmt);
+ pragma Import (C, Start_Declare_Stmt);
+ pragma Import (C, Finish_Declare_Stmt);
+ pragma Import (C, Start_Association);
+ pragma Import (C, New_Association);
+ pragma Import (C, New_Function_Call);
+ pragma Import (C, New_Procedure_Call);
+
+ pragma Import (C, New_Assign_Stmt);
+
+ pragma Import (C, Start_If_Stmt);
+ pragma Import (C, New_Else_Stmt);
+ pragma Import (C, Finish_If_Stmt);
+
+ pragma Import (C, New_Return_Stmt);
+ pragma Import_Procedure (New_Return_Stmt,
+ "new_func_return_stmt", (O_Enode));
+ pragma Import_Procedure (New_Return_Stmt,
+ "new_proc_return_stmt", null);
+
+ pragma Import (C, Start_Loop_Stmt);
+ pragma Import (C, Finish_Loop_Stmt);
+ pragma Import (C, New_Exit_Stmt);
+ pragma Import (C, New_Next_Stmt);
+
+ pragma Import (C, Start_Case_Stmt);
+ pragma Import (C, Start_Choice);
+ pragma Import (C, New_Expr_Choice);
+ pragma Import (C, New_Range_Choice);
+ pragma Import (C, New_Default_Choice);
+ pragma Import (C, Finish_Choice);
+ pragma Import (C, Finish_Case_Stmt);
+end Ortho_Gcc;
diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads
new file mode 100644
index 000000000..cc2f556f0
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc.private.ads
@@ -0,0 +1,269 @@
+-- GCC back-end for ortho.
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces; use Interfaces;
+with Ortho_Ident;
+use Ortho_Ident;
+
+-- Interface to create nodes.
+package Ortho_Gcc is
+
+private
+ -- GCC supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ pragma Convention (C, O_Storage);
+ -- pragma Convention (C, ON_Op_Kind);
+
+ subtype Tree is System.Address;
+ NULL_TREE : constant Tree := System.Null_Address;
+
+ subtype Vec_Ptr is System.Address;
+
+ type O_Cnode is new Tree;
+ type O_Enode is new Tree;
+ type O_Lnode is new Tree;
+ type O_Tnode is new Tree;
+ type O_Fnode is new Tree;
+ type O_Dnode is new Tree;
+ type O_Snode is record
+ Beg_Label : Tree;
+ End_Label : Tree;
+ end record;
+ pragma Convention (C, O_Snode);
+
+ O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE);
+ O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE);
+ O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE);
+ O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (NULL_TREE);
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Obj);
+ pragma Inline (New_Obj_Value);
+
+ -- Efficiently append element EL to a chain.
+ -- FIRST is the first element of the chain (must NULL_TREE if the chain
+ -- is empty),
+ -- LAST is the last element of the chain (idem).
+ type Chain_Constr_Type is record
+ First : Tree;
+ Last : Tree;
+ end record;
+ pragma Convention (C, Chain_Constr_Type);
+ procedure Chain_Init (Constr : out Chain_Constr_Type);
+ pragma Import (C, Chain_Init);
+ procedure Chain_Append (Constr : in out Chain_Constr_Type; El : Tree);
+ pragma Import (C, Chain_Append);
+
+ -- Efficiently append element EL to a list.
+ type List_Constr_Type is record
+ First : Tree;
+ Last : Tree;
+ end record;
+ pragma Convention (C, List_Constr_Type);
+ procedure List_Init (Constr : out List_Constr_Type);
+ pragma Import (C, List_Init);
+ procedure List_Append (Constr : in out List_Constr_Type; El : Tree);
+ pragma Import (C, List_Append, "ortho_list_append");
+
+ type O_Loop_Block is record
+ Beg_Label : Tree;
+ End_Label : Tree;
+ end record;
+ pragma Convention (C, O_Loop_Block);
+
+ type O_Inter_List is record
+ Ident : O_Ident;
+ Storage : O_Storage;
+ -- Return type.
+ Rtype : O_Tnode;
+ -- List of parameter types.
+ Param_List : List_Constr_Type;
+ -- Chain of parameters declarations.
+ Param_Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Inter_List);
+
+ type O_Element_List is record
+ Res : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Element_List);
+
+ type O_Case_Block is record
+ Case_Type : Tree;
+ End_Label : Tree;
+ Add_Break : Integer;
+ end record;
+ pragma Convention (C, O_Case_Block);
+
+ type O_If_Block is record
+ Stmt : Tree;
+ end record;
+ pragma Convention (C, O_If_Block);
+
+ type O_Aggr_List is record
+ Atype : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+
+ type O_Record_Aggr_List is record
+ Atype : Tree;
+ Afield : Tree;
+ Vec : Vec_Ptr;
+ end record;
+ pragma Convention (C, O_Record_Aggr_List);
+
+ type O_Array_Aggr_List is record
+ Atype : Tree;
+ Vec : Vec_Ptr;
+ end record;
+ pragma Convention (C, O_Array_Aggr_List);
+
+ type O_Assoc_List is record
+ Subprg : Tree;
+ List : List_Constr_Type;
+ end record;
+ pragma Convention (C, O_Assoc_List);
+
+ type O_Enum_List is record
+ -- The enumeral_type node.
+ Res : Tree;
+ -- Chain of literals.
+ Chain : Chain_Constr_Type;
+ -- Numeral value (from 0 to nbr - 1) of the next literal to be declared.
+ Num : Natural;
+ -- Size of the enumeration type.
+ Size : Natural;
+ end record;
+ pragma Convention (C, O_Enum_List);
+
+ pragma Import (C, New_Dyadic_Op);
+ pragma Import (C, New_Monadic_Op);
+ pragma Import (C, New_Compare_Op);
+
+ pragma Import (C, New_Convert_Ov);
+ pragma Import (C, New_Alloca);
+
+ pragma Import (C, New_Signed_Literal);
+ pragma Import (C, New_Unsigned_Literal);
+ pragma Import (C, New_Float_Literal);
+ pragma Import (C, New_Null_Access);
+
+ pragma Import (C, Start_Record_Type);
+ pragma Import (C, New_Record_Field);
+ pragma Import (C, Finish_Record_Type);
+ pragma Import (C, New_Uncomplete_Record_Type);
+ pragma Import (C, Start_Uncomplete_Record_Type);
+
+ pragma Import (C, Start_Union_Type);
+ pragma Import (C, New_Union_Field);
+ pragma Import (C, Finish_Union_Type);
+
+ pragma Import (C, New_Unsigned_Type);
+ pragma Import (C, New_Signed_Type);
+ pragma Import (C, New_Float_Type);
+
+ pragma Import (C, New_Access_Type);
+ pragma Import (C, Finish_Access_Type);
+
+ pragma Import (C, New_Array_Type);
+ pragma Import (C, New_Constrained_Array_Type);
+
+ pragma Import (C, New_Boolean_Type);
+ pragma Import (C, Start_Enum_Type);
+ pragma Import (C, New_Enum_Literal);
+ pragma Import (C, Finish_Enum_Type);
+
+ pragma Import (C, Start_Record_Aggr);
+ pragma Import (C, New_Record_Aggr_El);
+ pragma Import (C, Finish_Record_Aggr);
+ pragma Import (C, Start_Array_Aggr);
+ pragma Import (C, New_Array_Aggr_El);
+ pragma Import (C, Finish_Array_Aggr);
+ pragma Import (C, New_Union_Aggr);
+
+ pragma Import (C, New_Indexed_Element);
+ pragma Import (C, New_Slice);
+ pragma Import (C, New_Selected_Element);
+ pragma Import (C, New_Access_Element);
+
+ pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Alignof);
+ pragma Import (C, New_Offsetof);
+
+ pragma Import (C, New_Address);
+ pragma Import (C, New_Global_Address);
+ pragma Import (C, New_Unchecked_Address);
+ pragma Import (C, New_Global_Unchecked_Address);
+ pragma Import (C, New_Subprogram_Address);
+
+ pragma Import (C, New_Value);
+
+ pragma Import (C, New_Type_Decl);
+ pragma Import (C, New_Debug_Line_Decl);
+ pragma Import (C, New_Const_Decl);
+ pragma Import (C, New_Var_Decl);
+
+ pragma Import (C, Start_Const_Value);
+ pragma Import (C, Finish_Const_Value);
+
+ pragma Import (C, Start_Function_Decl);
+ pragma Import (C, Start_Procedure_Decl);
+ pragma Import (C, New_Interface_Decl);
+ pragma Import (C, Finish_Subprogram_Decl);
+
+ pragma Import (C, Start_Subprogram_Body);
+ pragma Import (C, Finish_Subprogram_Body);
+
+ pragma Import (C, New_Debug_Line_Stmt);
+ pragma Import (C, Start_Declare_Stmt);
+ pragma Import (C, Finish_Declare_Stmt);
+ pragma Import (C, Start_Association);
+ pragma Import (C, New_Association);
+ pragma Import (C, New_Function_Call);
+ pragma Import (C, New_Procedure_Call);
+
+ pragma Import (C, New_Assign_Stmt);
+
+ pragma Import (C, Start_If_Stmt);
+ pragma Import (C, New_Else_Stmt);
+ pragma Import (C, Finish_If_Stmt);
+
+ pragma Import (C, New_Return_Stmt);
+ pragma Import_Procedure (New_Return_Stmt,
+ "new_func_return_stmt", (O_Enode));
+ pragma Import_Procedure (New_Return_Stmt,
+ "new_proc_return_stmt", null);
+
+ pragma Import (C, Start_Loop_Stmt);
+ pragma Import (C, Finish_Loop_Stmt);
+ pragma Import (C, New_Exit_Stmt);
+ pragma Import (C, New_Next_Stmt);
+
+ pragma Import (C, Start_Case_Stmt);
+ pragma Import (C, Start_Choice);
+ pragma Import (C, New_Expr_Choice);
+ pragma Import (C, New_Range_Choice);
+ pragma Import (C, New_Default_Choice);
+ pragma Import (C, Finish_Choice);
+ pragma Import (C, Finish_Case_Stmt);
+end Ortho_Gcc;
diff --git a/src/ortho/gcc/ortho_gcc_front.ads b/src/ortho/gcc/ortho_gcc_front.ads
new file mode 100644
index 000000000..553057b20
--- /dev/null
+++ b/src/ortho/gcc/ortho_gcc_front.ads
@@ -0,0 +1,2 @@
+with Ortho_Front;
+package Ortho_Gcc_Front renames Ortho_Front;
diff --git a/src/ortho/gcc/ortho_ident.adb b/src/ortho/gcc/ortho_ident.adb
new file mode 100644
index 000000000..770fece2b
--- /dev/null
+++ b/src/ortho/gcc/ortho_ident.adb
@@ -0,0 +1,56 @@
+-- GCC back-end for ortho (identifiers)
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along 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 is
+ function Get_Identifier_With_Length (Str : Address; Size : Integer)
+ return O_Ident;
+ pragma Import (C, Get_Identifier_With_Length,
+ "get_identifier_with_length_c");
+
+ function Compare_Identifier_String
+ (Id : O_Ident; Str : Address; Size : Integer)
+ return Boolean;
+ pragma Import (C, Compare_Identifier_String);
+ pragma Warnings (Off, Compare_Identifier_String);
+
+ function Get_Identifier (Str : String) return O_Ident is
+ begin
+ return Get_Identifier_With_Length (Str'Address, Str'Length);
+ end Get_Identifier;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean is
+ begin
+ return Compare_Identifier_String (Id, Str'Address, Str'Length);
+ end Is_Equal;
+
+ function Get_String (Id : O_Ident) return String
+ is
+ procedure Get_Identifier_String
+ (Id : O_Ident; Str_Ptr : Address; Len_Ptr : Address);
+ pragma Import (C, Get_Identifier_String);
+
+ Len : Natural;
+ type Str_Acc is access String (Positive);
+ Str : Str_Acc;
+ begin
+ Get_Identifier_String (Id, Str'Address, Len'Address);
+ return Str (1 .. Len);
+ end Get_String;
+
+end Ortho_Ident;
+
diff --git a/src/ortho/gcc/ortho_ident.ads b/src/ortho/gcc/ortho_ident.ads
new file mode 100644
index 000000000..76c09ceb9
--- /dev/null
+++ b/src/ortho/gcc/ortho_ident.ads
@@ -0,0 +1,30 @@
+-- GCC back-end for ortho (identifiers)
+-- Copyright (C) 2002-1014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with System; use System;
+
+package Ortho_Ident is
+ subtype O_Ident is Address;
+ 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 System."=";
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ O_Ident_Nul : constant O_Ident;
+private
+ O_Ident_Nul : constant O_Ident := Null_Address;
+end Ortho_Ident;
diff --git a/src/ortho/gcc/ortho_nodes.ads b/src/ortho/gcc/ortho_nodes.ads
new file mode 100644
index 000000000..7c6c4a076
--- /dev/null
+++ b/src/ortho/gcc/ortho_nodes.ads
@@ -0,0 +1,3 @@
+with Ortho_Gcc;
+
+package Ortho_Nodes renames Ortho_Gcc;
diff --git a/src/ortho/llvm/Makefile b/src/ortho/llvm/Makefile
new file mode 100644
index 000000000..135dbdf4b
--- /dev/null
+++ b/src/ortho/llvm/Makefile
@@ -0,0 +1,30 @@
+ortho_srcdir=..
+GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05
+CXX=clang++ --std=c++11
+LLVM_CONFIG=llvm-config
+SED=sed
+BE=llvm
+
+all: $(ortho_exec)
+
+$(ortho_exec): $(ortho_srcdir)/llvm/ortho_llvm.ads force llvm-cbindings.o
+ gnatmake -m -o $@ -g -aI$(ortho_srcdir)/llvm -aI$(ortho_srcdir) \
+ $(GNAT_FLAGS) ortho_code_main -bargs -E \
+ -largs llvm-cbindings.o `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ #-static
+
+llvm-cbindings.o: $(ortho_srcdir)/llvm/llvm-cbindings.cpp
+ $(CXX) -c -I`$(LLVM_CONFIG) --includedir --cflags` -g -o $@ $<
+
+clean:
+ $(RM) -f *.o *.ali ortho_code_main
+ $(RM) b~*.ad? *~
+
+distclean: clean
+
+
+force:
+
+.PHONY: force all clean
+
+ORTHO_BASENAME=ortho_llvm
+include $(ortho_srcdir)/Makefile.inc
diff --git a/src/ortho/llvm/llvm-analysis.ads b/src/ortho/llvm/llvm-analysis.ads
new file mode 100644
index 000000000..bfecec579
--- /dev/null
+++ b/src/ortho/llvm/llvm-analysis.ads
@@ -0,0 +1,53 @@
+-- LLVM binding
+-- 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 LLVM.Core; use LLVM.Core;
+
+package LLVM.Analysis is
+ type VerifierFailureAction is
+ (
+ AbortProcessAction, -- verifier will print to stderr and abort()
+ PrintMessageAction, -- verifier will print to stderr and return 1
+ ReturnStatusAction -- verifier will just return 1
+ );
+ pragma Convention (C, VerifierFailureAction);
+
+ -- Verifies that a module is valid, taking the specified action if not.
+ -- Optionally returns a human-readable description of any invalid
+ -- constructs.
+ -- OutMessage must be disposed with DisposeMessage. */
+ function VerifyModule(M : ModuleRef;
+ Action : VerifierFailureAction;
+ OutMessage : access Cstring)
+ return Integer;
+
+ -- Verifies that a single function is valid, taking the specified
+ -- action. Useful for debugging.
+ function VerifyFunction(Fn : ValueRef; Action : VerifierFailureAction)
+ return Integer;
+
+ -- Open up a ghostview window that displays the CFG of the current function.
+ -- Useful for debugging.
+ procedure ViewFunctionCFG(Fn : ValueRef);
+ procedure ViewFunctionCFGOnly(Fn : ValueRef);
+private
+ pragma Import (C, VerifyModule, "LLVMVerifyModule");
+ pragma Import (C, VerifyFunction, "LLVMVerifyFunction");
+ pragma Import (C, ViewFunctionCFG, "LLVMViewFunctionCFG");
+ pragma Import (C, ViewFunctionCFGOnly, "LLVMViewFunctionCFGOnly");
+end LLVM.Analysis;
+
diff --git a/src/ortho/llvm/llvm-bitwriter.ads b/src/ortho/llvm/llvm-bitwriter.ads
new file mode 100644
index 000000000..3f9c518e4
--- /dev/null
+++ b/src/ortho/llvm/llvm-bitwriter.ads
@@ -0,0 +1,34 @@
+-- LLVM binding
+-- 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 LLVM.Core; use LLVM.Core;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Interfaces.C; use Interfaces.C;
+
+package LLVM.BitWriter is
+ -- Writes a module to an open file descriptor. Returns 0 on success.
+ -- Closes the Handle. Use dup first if this is not what you want.
+ function WriteBitcodeToFileHandle(M : ModuleRef; Handle : File_Descriptor)
+ return int;
+
+ -- Writes a module to the specified path. Returns 0 on success.
+ function WriteBitcodeToFile(M : ModuleRef; Path : Cstring)
+ return int;
+private
+ pragma Import (C, WriteBitcodeToFileHandle, "LLVMWriteBitcodeToFileHandle");
+ pragma Import (C, WriteBitcodeToFile, "LLVMWriteBitcodeToFile");
+end LLVM.BitWriter;
diff --git a/src/ortho/llvm/llvm-cbindings.cpp b/src/ortho/llvm/llvm-cbindings.cpp
new file mode 100644
index 000000000..e4d666ade
--- /dev/null
+++ b/src/ortho/llvm/llvm-cbindings.cpp
@@ -0,0 +1,61 @@
+/* LLVM binding
+ 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. */
+#include "llvm-c/Target.h"
+#include "llvm-c/Core.h"
+#include "llvm-c/ExecutionEngine.h"
+#include "llvm/IR/Type.h"
+#include "llvm/IR/LLVMContext.h"
+#include "llvm/IR/Metadata.h"
+#include "llvm/ExecutionEngine/ExecutionEngine.h"
+
+using namespace llvm;
+
+extern "C" {
+
+void
+LLVMInitializeNativeTarget_noinline (void)
+{
+ LLVMInitializeNativeTarget ();
+}
+
+void
+LLVMInitializeNativeAsmPrinter_noinline (void)
+{
+ LLVMInitializeNativeAsmPrinter();
+}
+
+LLVMTypeRef LLVMMetadataTypeInContext(LLVMContextRef C) {
+ return (LLVMTypeRef) Type::getMetadataTy(*unwrap(C));
+}
+
+LLVMTypeRef LLVMMetadataType_extra(void) {
+ return LLVMMetadataTypeInContext(LLVMGetGlobalContext());
+}
+
+void
+LLVMMDNodeReplaceOperandWith_extra (LLVMValueRef N, unsigned i, LLVMValueRef V) {
+ MDNode *MD = cast<MDNode>(unwrap(N));
+ MD->replaceOperandWith (i, unwrap(V));
+}
+
+void *LLVMGetPointerToFunction(LLVMExecutionEngineRef EE, LLVMValueRef Func)
+{
+ return unwrap(EE)->getPointerToFunction(unwrap<Function>(Func));
+}
+
+}
diff --git a/src/ortho/llvm/llvm-core.ads b/src/ortho/llvm/llvm-core.ads
new file mode 100644
index 000000000..74a47484f
--- /dev/null
+++ b/src/ortho/llvm/llvm-core.ads
@@ -0,0 +1,1279 @@
+-- LLVM binding
+-- 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 System;
+with Interfaces.C; use Interfaces.C;
+use Interfaces;
+
+package LLVM.Core is
+
+ subtype Cstring is System.Address;
+ function "=" (L, R : Cstring) return Boolean renames System."=";
+ -- Null_Cstring : constant Cstring := Null_Address;
+ Nul : constant String := (1 => Character'Val (0));
+ Empty_Cstring : constant Cstring := Nul'Address;
+
+ -- The top-level container for all LLVM global data. See the LLVMContext
+ -- class.
+ type ContextRef is new System.Address;
+
+ -- The top-level container for all other LLVM Intermediate
+ -- Representation (IR) objects. See the llvm::Module class.
+ type ModuleRef is new System.Address;
+
+ subtype Bool is int;
+
+ -- Each value in the LLVM IR has a type, an LLVMTypeRef. See the llvm::Type
+ -- class.
+ type TypeRef is new System.Address;
+ Null_TypeRef : constant TypeRef := TypeRef (System.Null_Address);
+ type TypeRefArray is array (unsigned range <>) of TypeRef;
+ pragma Convention (C, TypeRefArray);
+
+ type ValueRef is new System.Address;
+ Null_ValueRef : constant ValueRef := ValueRef (System.Null_Address);
+ type ValueRefArray is array (unsigned range <>) of ValueRef; -- Ada
+ pragma Convention (C, ValueRefArray);
+
+ type BasicBlockRef is new System.Address;
+ Null_BasicBlockRef : constant BasicBlockRef :=
+ BasicBlockRef (System.Null_Address);
+ type BasicBlockRefArray is
+ array (unsigned range <>) of BasicBlockRef; -- Ada
+ pragma Convention (C, BasicBlockRefArray);
+
+ type BuilderRef is new System.Address;
+
+ -- Used to provide a module to JIT or interpreter.
+ -- See the llvm::MemoryBuffer class.
+ type MemoryBufferRef is new System.Address;
+
+ -- See the llvm::PassManagerBase class.
+ type PassManagerRef is new System.Address;
+
+ type Attribute is new unsigned;
+ ZExtAttribute : constant Attribute := 2**0;
+ SExtAttribute : constant Attribute := 2**1;
+ NoReturnAttribute : constant Attribute := 2**2;
+ InRegAttribute : constant Attribute := 2**3;
+ StructRetAttribute : constant Attribute := 2**4;
+ NoUnwindAttribute : constant Attribute := 2**5;
+ NoAliasAttribute : constant Attribute := 2**6;
+ ByValAttribute : constant Attribute := 2**7;
+ NestAttribute : constant Attribute := 2**8;
+ ReadNoneAttribute : constant Attribute := 2**9;
+ ReadOnlyAttribute : constant Attribute := 2**10;
+ NoInlineAttribute : constant Attribute := 1**11;
+ AlwaysInlineAttribute : constant Attribute := 1**12;
+ OptimizeForSizeAttribute : constant Attribute := 1**13;
+ StackProtectAttribute : constant Attribute := 1**14;
+ StackProtectReqAttribute : constant Attribute := 1**15;
+ Alignment : constant Attribute := 31**16;
+ NoCaptureAttribute : constant Attribute := 1**21;
+ NoRedZoneAttribute : constant Attribute := 1**22;
+ NoImplicitFloatAttribute : constant Attribute := 1**23;
+ NakedAttribute : constant Attribute := 1**24;
+ InlineHintAttribute : constant Attribute := 1**25;
+ StackAlignment : constant Attribute := 7**26;
+ ReturnsTwice : constant Attribute := 1**29;
+ UWTable : constant Attribute := 1**30;
+ NonLazyBind : constant Attribute := 1**31;
+
+ type TypeKind is
+ (
+ VoidTypeKind, -- type with no size
+ HalfTypeKind, -- 16 bit floating point type
+ FloatTypeKind, -- 32 bit floating point type
+ DoubleTypeKind, -- 64 bit floating point type
+ X86_FP80TypeKind, -- 80 bit floating point type (X87)
+ FP128TypeKind, -- 128 bit floating point type (112-bit mantissa)
+ PPC_FP128TypeKind, -- 128 bit floating point type (two 64-bits)
+ LabelTypeKind, -- Labels
+ IntegerTypeKind, -- Arbitrary bit width integers
+ FunctionTypeKind, -- Functions
+ StructTypeKind, -- Structures
+ ArrayTypeKind, -- Arrays
+ PointerTypeKind, -- Pointers
+ VectorTypeKind, -- SIMD 'packed' format, or other vector type
+ MetadataTypeKind, -- Metadata
+ X86_MMXTypeKind -- X86 MMX
+ );
+ pragma Convention (C, TypeKind);
+
+ type Linkage is
+ (
+ ExternalLinkage, -- Externally visible function
+ AvailableExternallyLinkage,
+ LinkOnceAnyLinkage, -- Keep one copy of function when linking (inline)
+ LinkOnceODRLinkage, -- Same, but only replaced by someth equivalent.
+ LinkOnceODRAutoHideLinkage, -- Obsolete
+ WeakAnyLinkage, -- Keep one copy of function when linking (weak)
+ WeakODRLinkage, -- Same, but only replaced by someth equivalent.
+ AppendingLinkage, -- Special purpose, only applies to global arrays
+ InternalLinkage, -- Rename collisions when linking (static func)
+ PrivateLinkage, -- Like Internal, but omit from symbol table
+ DLLImportLinkage, -- Obsolete
+ DLLExportLinkage, -- Obsolete
+ ExternalWeakLinkage,-- ExternalWeak linkage description
+ GhostLinkage, -- Obsolete
+ CommonLinkage, -- Tentative definitions
+ LinkerPrivateLinkage, -- Like Private, but linker removes.
+ LinkerPrivateWeakLinkage -- Like LinkerPrivate, but is weak.
+ );
+ pragma Convention (C, Linkage);
+
+ type Visibility is
+ (
+ DefaultVisibility, -- The GV is visible
+ HiddenVisibility, -- The GV is hidden
+ ProtectedVisibility -- The GV is protected
+ );
+ pragma Convention (C, Visibility);
+
+ type CallConv is new unsigned;
+ CCallConv : constant CallConv := 0;
+ FastCallConv : constant CallConv := 8;
+ ColdCallConv : constant CallConv := 9;
+ X86StdcallCallConv : constant CallConv := 64;
+ X86FastcallCallConv : constant CallConv := 6;
+
+ type IntPredicate is new unsigned;
+ IntEQ : constant IntPredicate := 32; -- equal
+ IntNE : constant IntPredicate := 33; -- not equal
+ IntUGT : constant IntPredicate := 34; -- unsigned greater than
+ IntUGE : constant IntPredicate := 35; -- unsigned greater or equal
+ IntULT : constant IntPredicate := 36; -- unsigned less than
+ IntULE : constant IntPredicate := 37; -- unsigned less or equal
+ IntSGT : constant IntPredicate := 38; -- signed greater than
+ IntSGE : constant IntPredicate := 39; -- signed greater or equal
+ IntSLT : constant IntPredicate := 40; -- signed less than
+ IntSLE : constant IntPredicate := 41; -- signed less or equal
+
+ type RealPredicate is
+ (
+ RealPredicateFalse, -- Always false (always folded)
+ RealOEQ, -- True if ordered and equal
+ RealOGT, -- True if ordered and greater than
+ RealOGE, -- True if ordered and greater than or equal
+ RealOLT, -- True if ordered and less than
+ RealOLE, -- True if ordered and less than or equal
+ RealONE, -- True if ordered and operands are unequal
+ RealORD, -- True if ordered (no nans)
+ RealUNO, -- True if unordered: isnan(X) | isnan(Y)
+ RealUEQ, -- True if unordered or equal
+ RealUGT, -- True if unordered or greater than
+ RealUGE, -- True if unordered, greater than, or equal
+ RealULT, -- True if unordered or less than
+ RealULE, -- True if unordered, less than, or equal
+ RealUNE, -- True if unordered or not equal
+ RealPredicateTrue -- Always true (always folded)
+ );
+
+ -- Error handling ----------------------------------------------------
+
+ procedure DisposeMessage (Message : Cstring);
+
+
+ -- Context
+
+ -- Create a new context.
+ -- Every call to this function should be paired with a call to
+ -- LLVMContextDispose() or the context will leak memory.
+ function ContextCreate return ContextRef;
+
+ -- Obtain the global context instance.
+ function GetGlobalContext return ContextRef;
+
+ -- Destroy a context instance.
+ -- This should be called for every call to LLVMContextCreate() or memory
+ -- will be leaked.
+ procedure ContextDispose (C : ContextRef);
+
+ function GetMDKindIDInContext
+ (C : ContextRef; Name : Cstring; Slen : unsigned)
+ return unsigned;
+
+ function GetMDKindID(Name : String; Slen : unsigned) return unsigned;
+
+ -- Modules -----------------------------------------------------------
+
+ -- Create and destroy modules.
+ -- See llvm::Module::Module.
+ function ModuleCreateWithName (ModuleID : Cstring) return ModuleRef;
+
+ -- See llvm::Module::~Module.
+ procedure DisposeModule (M : ModuleRef);
+
+ -- Data layout. See Module::getDataLayout.
+ function GetDataLayout(M : ModuleRef) return Cstring;
+ procedure SetDataLayout(M : ModuleRef; Triple : Cstring);
+
+ -- Target triple. See Module::getTargetTriple.
+ function GetTarget (M : ModuleRef) return Cstring;
+ procedure SetTarget (M : ModuleRef; Triple : Cstring);
+
+ -- See Module::dump.
+ procedure DumpModule(M : ModuleRef);
+
+ -- Print a representation of a module to a file. The ErrorMessage needs to
+ -- be disposed with LLVMDisposeMessage. Returns 0 on success, 1 otherwise.
+ --
+ -- @see Module::print()
+ function PrintModuleToFile(M : ModuleRef;
+ Filename : Cstring;
+ ErrorMessage : access Cstring) return Bool;
+
+
+ -- Types -------------------------------------------------------------
+
+ -- LLVM types conform to the following hierarchy:
+ --
+ -- types:
+ -- integer type
+ -- real type
+ -- function type
+ -- sequence types:
+ -- array type
+ -- pointer type
+ -- vector type
+ -- void type
+ -- label type
+ -- opaque type
+
+ -- See llvm::LLVMTypeKind::getTypeID.
+ function GetTypeKind (Ty : TypeRef) return TypeKind;
+
+ -- Operations on integer types
+ function Int1Type return TypeRef;
+ function Int8Type return TypeRef;
+ function Int16Type return TypeRef;
+ function Int32Type return TypeRef;
+ function Int64Type return TypeRef;
+ function IntType(NumBits : unsigned) return TypeRef;
+ function GetIntTypeWidth(IntegerTy : TypeRef) return unsigned;
+
+ function MetadataType return TypeRef;
+
+ -- Operations on real types
+ function FloatType return TypeRef;
+ function DoubleType return TypeRef;
+ function X86FP80Type return TypeRef;
+ function FP128Type return TypeRef;
+ function PPCFP128Type return TypeRef;
+
+ -- Operations on function types
+ function FunctionType(ReturnType : TypeRef;
+ ParamTypes : TypeRefArray;
+ ParamCount : unsigned;
+ IsVarArg : int) return TypeRef;
+
+ function IsFunctionVarArg(FunctionTy : TypeRef) return int;
+ function GetReturnType(FunctionTy : TypeRef) return TypeRef;
+ function CountParamTypes(FunctionTy : TypeRef) return unsigned;
+ procedure GetParamTypes(FunctionTy : TypeRef; Dest : out TypeRefArray);
+
+ -- Operations on struct types
+ function StructType(ElementTypes : TypeRefArray;
+ ElementCount : unsigned;
+ Packed : Bool) return TypeRef;
+ function StructCreateNamed(C : ContextRef; Name : Cstring) return TypeRef;
+ procedure StructSetBody(StructTy : TypeRef;
+ ElementTypes : TypeRefArray;
+ ElementCount : unsigned;
+ Packed : Bool);
+ function CountStructElementTypes(StructTy : TypeRef) return unsigned;
+ procedure GetStructElementTypes(StructTy : TypeRef;
+ Dest : out TypeRefArray);
+ function IsPackedStruct(StructTy : TypeRef) return Bool;
+
+
+ -- Operations on array, pointer, and vector types (sequence types)
+ function ArrayType(ElementType : TypeRef; ElementCount : unsigned)
+ return TypeRef;
+ function PointerType(ElementType : TypeRef; AddressSpace : unsigned := 0)
+ return TypeRef;
+ function VectorType(ElementType : TypeRef; ElementCount : unsigned)
+ return TypeRef;
+
+ function GetElementType(Ty : TypeRef) return TypeRef;
+ function GetArrayLength(ArrayTy : TypeRef) return unsigned;
+ function GetPointerAddressSpace(PointerTy : TypeRef) return unsigned;
+ function GetVectorSize(VectorTy : TypeRef) return unsigned;
+
+ -- Operations on other types.
+ function VoidType return TypeRef;
+ function LabelType return TypeRef;
+
+ -- Values ------------------------------------------------------------
+ -- The bulk of LLVM's object model consists of values, which comprise a very
+ -- rich type hierarchy.
+ --
+ -- values:
+ -- constants:
+ -- scalar constants
+ -- composite contants
+ -- globals:
+ -- global variable
+ -- function
+ -- alias
+ -- basic blocks
+
+ -- Operations on all values
+ function TypeOf(Val : ValueRef) return TypeRef;
+ function GetValueName(Val : ValueRef) return Cstring;
+ procedure SetValueName(Val : ValueRef; Name : Cstring);
+ procedure DumpValue(Val : ValueRef);
+
+ -- Operations on constants of any type
+ function ConstNull(Ty : TypeRef) return ValueRef; -- All zero
+ function ConstAllOnes(Ty : TypeRef) return ValueRef; -- Int or Vec
+ function GetUndef(Ty : TypeRef) return ValueRef;
+ function IsConstant(Val : ValueRef) return int;
+ function IsNull(Val : ValueRef) return int;
+ function IsUndef(Val : ValueRef) return int;
+
+ -- Convert value instances between types.
+ --
+ -- Internally, an LLVMValueRef is "pinned" to a specific type. This
+ -- series of functions allows you to cast an instance to a specific
+ -- type.
+ --
+ -- If the cast is not valid for the specified type, NULL is returned.
+ --
+ -- @see llvm::dyn_cast_or_null<>
+ function IsAInstruction (Val : ValueRef) return ValueRef;
+
+ -- Operations on scalar constants
+ function ConstInt(IntTy : TypeRef; N : Unsigned_64; SignExtend : int)
+ return ValueRef;
+ function ConstReal(RealTy : TypeRef; N : double) return ValueRef;
+ function ConstRealOfString(RealTy : TypeRef; Text : Cstring)
+ return ValueRef;
+
+
+ -- Obtain the zero extended value for an integer constant value.
+ -- @see llvm::ConstantInt::getZExtValue()
+ function ConstIntGetZExtValue (ConstantVal : ValueRef) return Unsigned_64;
+
+ -- Operations on composite constants
+ function ConstString(Str : Cstring;
+ Length : unsigned; DontNullTerminate : int)
+ return ValueRef;
+ function ConstArray(ElementTy : TypeRef;
+ ConstantVals : ValueRefArray; Length : unsigned)
+ return ValueRef;
+ function ConstStruct(ConstantVals : ValueRefArray;
+ Count : unsigned; packed : int) return ValueRef;
+
+ -- Create a non-anonymous ConstantStruct from values.
+ -- @see llvm::ConstantStruct::get()
+ function ConstNamedStruct(StructTy : TypeRef;
+ ConstantVals : ValueRefArray;
+ Count : unsigned) return ValueRef;
+
+ function ConstVector(ScalarConstantVals : ValueRefArray; Size : unsigned)
+ return ValueRef;
+
+ -- Constant expressions
+ function SizeOf(Ty : TypeRef) return ValueRef;
+ function AlignOf(Ty : TypeRef) return ValueRef;
+
+ function ConstNeg(ConstantVal : ValueRef) return ValueRef;
+ function ConstNot(ConstantVal : ValueRef) return ValueRef;
+ function ConstAdd(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSub(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstMul(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstUDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFDiv(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstURem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstSRem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFRem(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstAnd(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstOr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstXor(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstICmp(Predicate : IntPredicate;
+ LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstFCmp(Predicate : RealPredicate;
+ LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstShl(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstLShr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstAShr(LHSConstant : ValueRef; RHSConstant : ValueRef)
+ return ValueRef;
+ function ConstGEP(ConstantVal : ValueRef;
+ ConstantIndices : ValueRefArray; NumIndices : unsigned)
+ return ValueRef;
+ function ConstTrunc(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstSExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstZExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPTrunc(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPExt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstUIToFP(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstSIToFP(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPToUI(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstFPToSI(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstPtrToInt(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstIntToPtr(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+ function ConstBitCast(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+
+ function ConstTruncOrBitCast(ConstantVal : ValueRef; ToType : TypeRef)
+ return ValueRef;
+
+ function ConstSelect(ConstantCondition : ValueRef;
+ ConstantIfTrue : ValueRef;
+ ConstantIfFalse : ValueRef) return ValueRef;
+ function ConstExtractElement(VectorConstant : ValueRef;
+ IndexConstant : ValueRef) return ValueRef;
+ function ConstInsertElement(VectorConstant : ValueRef;
+ ElementValueConstant : ValueRef;
+ IndexConstant : ValueRef) return ValueRef;
+ function ConstShuffleVector(VectorAConstant : ValueRef;
+ VectorBConstant : ValueRef;
+ MaskConstant : ValueRef) return ValueRef;
+
+ -- Operations on global variables, functions, and aliases (globals)
+ function GetGlobalParent(Global : ValueRef) return ModuleRef;
+ function IsDeclaration(Global : ValueRef) return int;
+ function GetLinkage(Global : ValueRef) return Linkage;
+ procedure SetLinkage(Global : ValueRef; Link : Linkage);
+ function GetSection(Global : ValueRef) return Cstring;
+ procedure SetSection(Global : ValueRef; Section : Cstring);
+ function GetVisibility(Global : ValueRef) return Visibility;
+ procedure SetVisibility(Global : ValueRef; Viz : Visibility);
+ function GetAlignment(Global : ValueRef) return unsigned;
+ procedure SetAlignment(Global : ValueRef; Bytes : unsigned);
+
+ -- Operations on global variables
+ function AddGlobal(M : ModuleRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function GetNamedGlobal(M : ModuleRef; Name : Cstring) return ValueRef;
+ function GetFirstGlobal(M : ModuleRef) return ValueRef;
+ function GetLastGlobal(M : ModuleRef) return ValueRef;
+ function GetNextGlobal(GlobalVar : ValueRef) return ValueRef;
+ function GetPreviousGlobal(GlobalVar : ValueRef) return ValueRef;
+ procedure DeleteGlobal(GlobalVar : ValueRef);
+ function GetInitializer(GlobalVar : ValueRef) return ValueRef;
+ procedure SetInitializer(GlobalVar : ValueRef; ConstantVal : ValueRef);
+ function IsThreadLocal(GlobalVar : ValueRef) return int;
+ procedure SetThreadLocal(GlobalVar : ValueRef; IsThreadLocal : int);
+ function IsGlobalConstant(GlobalVar : ValueRef) return int;
+ procedure SetGlobalConstant(GlobalVar : ValueRef; IsConstant : int);
+
+ -- Obtain the number of operands for named metadata in a module.
+ -- @see llvm::Module::getNamedMetadata()
+ function GetNamedMetadataNumOperands(M : ModuleRef; Name : Cstring)
+ return unsigned;
+
+ -- Obtain the named metadata operands for a module.
+ -- The passed LLVMValueRef pointer should refer to an array of
+ -- LLVMValueRef at least LLVMGetNamedMetadataNumOperands long. This
+ -- array will be populated with the LLVMValueRef instances. Each
+ -- instance corresponds to a llvm::MDNode.
+ -- @see llvm::Module::getNamedMetadata()
+ -- @see llvm::MDNode::getOperand()
+ procedure GetNamedMetadataOperands
+ (M : ModuleRef; Name : Cstring; Dest : ValueRefArray);
+
+ -- Add an operand to named metadata.
+ -- @see llvm::Module::getNamedMetadata()
+ -- @see llvm::MDNode::addOperand()
+ procedure AddNamedMetadataOperand
+ (M : ModuleRef; Name : Cstring; Val : ValueRef);
+
+ -- Operations on functions
+ function AddFunction(M : ModuleRef; Name : Cstring; FunctionTy : TypeRef)
+ return ValueRef;
+ function GetNamedFunction(M : ModuleRef; Name : Cstring) return ValueRef;
+ function GetFirstFunction(M : ModuleRef) return ValueRef;
+ function GetLastFunction(M : ModuleRef) return ValueRef;
+ function GetNextFunction(Fn : ValueRef) return ValueRef;
+ function GetPreviousFunction(Fn : ValueRef) return ValueRef;
+ procedure DeleteFunction(Fn : ValueRef);
+ function GetIntrinsicID(Fn : ValueRef) return unsigned;
+ function GetFunctionCallConv(Fn : ValueRef) return CallConv;
+ procedure SetFunctionCallConv(Fn : ValueRef; CC : CallConv);
+ function GetGC(Fn : ValueRef) return Cstring;
+ procedure SetGC(Fn : ValueRef; Name : Cstring);
+
+ -- Add an attribute to a function.
+ -- @see llvm::Function::addAttribute()
+ procedure AddFunctionAttr (Fn : ValueRef; PA : Attribute);
+
+ -- Add a target-dependent attribute to a fuction
+ -- @see llvm::AttrBuilder::addAttribute()
+ procedure AddTargetDependentFunctionAttr
+ (Fn : ValueRef; A : Cstring; V : Cstring);
+
+ -- Obtain an attribute from a function.
+ -- @see llvm::Function::getAttributes()
+ function GetFunctionAttr (Fn : ValueRef) return Attribute;
+
+ -- Remove an attribute from a function.
+ procedure RemoveFunctionAttr (Fn : ValueRef; PA : Attribute);
+
+ -- Operations on parameters
+ function CountParams(Fn : ValueRef) return unsigned;
+ procedure GetParams(Fn : ValueRef; Params : ValueRefArray);
+ function GetParam(Fn : ValueRef; Index : unsigned) return ValueRef;
+ function GetParamParent(Inst : ValueRef) return ValueRef;
+ function GetFirstParam(Fn : ValueRef) return ValueRef;
+ function GetLastParam(Fn : ValueRef) return ValueRef;
+ function GetNextParam(Arg : ValueRef) return ValueRef;
+ function GetPreviousParam(Arg : ValueRef) return ValueRef;
+ procedure AddAttribute(Arg : ValueRef; PA : Attribute);
+ procedure RemoveAttribute(Arg : ValueRef; PA : Attribute);
+ procedure SetParamAlignment(Arg : ValueRef; align : unsigned);
+
+ -- Metadata
+
+ -- Obtain a MDString value from a context.
+ -- The returned instance corresponds to the llvm::MDString class.
+ -- The instance is specified by string data of a specified length. The
+ -- string content is copied, so the backing memory can be freed after
+ -- this function returns.
+ function MDStringInContext(C : ContextRef; Str : Cstring; Len : unsigned)
+ return ValueRef;
+
+ -- Obtain a MDString value from the global context.
+ function MDString(Str : Cstring; Len : unsigned) return ValueRef;
+
+ -- Obtain a MDNode value from a context.
+ -- The returned value corresponds to the llvm::MDNode class.
+ function MDNodeInContext
+ (C : ContextRef; Vals : ValueRefArray; Count : unsigned)
+ return ValueRef;
+
+ -- Obtain a MDNode value from the global context.
+ function MDNode(Vals : ValueRefArray; Count : unsigned) return ValueRef;
+
+ -- Obtain the underlying string from a MDString value.
+ -- @param V Instance to obtain string from.
+ -- @param Len Memory address which will hold length of returned string.
+ -- @return String data in MDString.
+ function GetMDString(V : ValueRef; Len : access unsigned) return Cstring;
+
+ -- Obtain the number of operands from an MDNode value.
+ -- @param V MDNode to get number of operands from.
+ -- @return Number of operands of the MDNode.
+ function GetMDNodeNumOperands(V : ValueRef) return unsigned;
+
+ -- Obtain the given MDNode's operands.
+ -- The passed LLVMValueRef pointer should point to enough memory to hold
+ -- all of the operands of the given MDNode (see LLVMGetMDNodeNumOperands)
+ -- as LLVMValueRefs. This memory will be populated with the LLVMValueRefs
+ -- of the MDNode's operands.
+ -- @param V MDNode to get the operands from.
+ -- @param Dest Destination array for operands.
+ procedure GetMDNodeOperands(V : ValueRef; Dest : ValueRefArray);
+
+ procedure MDNodeReplaceOperandWith
+ (N : ValueRef; I : unsigned; V : ValueRef);
+
+ -- Operations on basic blocks
+ function BasicBlockAsValue(BB : BasicBlockRef) return ValueRef;
+ function ValueIsBasicBlock(Val : ValueRef) return int;
+ function ValueAsBasicBlock(Val : ValueRef) return BasicBlockRef;
+ function GetBasicBlockParent(BB : BasicBlockRef) return ValueRef;
+ function CountBasicBlocks(Fn : ValueRef) return unsigned;
+ procedure GetBasicBlocks(Fn : ValueRef; BasicBlocks : BasicBlockRefArray);
+ function GetFirstBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function GetLastBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function GetNextBasicBlock(BB : BasicBlockRef) return BasicBlockRef;
+ function GetPreviousBasicBlock(BB : BasicBlockRef) return BasicBlockRef;
+ function GetEntryBasicBlock(Fn : ValueRef) return BasicBlockRef;
+ function AppendBasicBlock(Fn : ValueRef; Name : Cstring)
+ return BasicBlockRef;
+ function InsertBasicBlock(InsertBeforeBB : BasicBlockRef;
+ Name : Cstring) return BasicBlockRef;
+ procedure DeleteBasicBlock(BB : BasicBlockRef);
+
+ -- Operations on instructions
+
+ -- Determine whether an instruction has any metadata attached.
+ function HasMetadata(Val: ValueRef) return Bool;
+
+ -- Return metadata associated with an instruction value.
+ function GetMetadata(Val : ValueRef; KindID : unsigned) return ValueRef;
+
+ -- Set metadata associated with an instruction value.
+ procedure SetMetadata(Val : ValueRef; KindID : unsigned; Node : ValueRef);
+
+ function GetInstructionParent(Inst : ValueRef) return BasicBlockRef;
+ function GetFirstInstruction(BB : BasicBlockRef) return ValueRef;
+ function GetLastInstruction(BB : BasicBlockRef) return ValueRef;
+ function GetNextInstruction(Inst : ValueRef) return ValueRef;
+ function GetPreviousInstruction(Inst : ValueRef) return ValueRef;
+
+ -- Operations on call sites
+ procedure SetInstructionCallConv(Instr : ValueRef; CC : unsigned);
+ function GetInstructionCallConv(Instr : ValueRef) return unsigned;
+ procedure AddInstrAttribute(Instr : ValueRef;
+ index : unsigned; Attr : Attribute);
+ procedure RemoveInstrAttribute(Instr : ValueRef;
+ index : unsigned; Attr : Attribute);
+ procedure SetInstrParamAlignment(Instr : ValueRef;
+ index : unsigned; align : unsigned);
+
+ -- Operations on call instructions (only)
+ function IsTailCall(CallInst : ValueRef) return int;
+ procedure SetTailCall(CallInst : ValueRef; IsTailCall : int);
+
+ -- Operations on phi nodes
+ procedure AddIncoming(PhiNode : ValueRef; IncomingValues : ValueRefArray;
+ IncomingBlocks : BasicBlockRefArray; Count : unsigned);
+ function CountIncoming(PhiNode : ValueRef) return unsigned;
+ function GetIncomingValue(PhiNode : ValueRef; Index : unsigned)
+ return ValueRef;
+ function GetIncomingBlock(PhiNode : ValueRef; Index : unsigned)
+ return BasicBlockRef;
+
+ -- Instruction builders ----------------------------------------------
+ -- An instruction builder represents a point within a basic block,
+ -- and is the exclusive means of building instructions using the C
+ -- interface.
+
+ function CreateBuilder return BuilderRef;
+ procedure PositionBuilder(Builder : BuilderRef;
+ Block : BasicBlockRef; Instr : ValueRef);
+ procedure PositionBuilderBefore(Builder : BuilderRef; Instr : ValueRef);
+ procedure PositionBuilderAtEnd(Builder : BuilderRef; Block : BasicBlockRef);
+ function GetInsertBlock(Builder : BuilderRef) return BasicBlockRef;
+ procedure DisposeBuilder(Builder : BuilderRef);
+
+ -- Terminators
+ function BuildRetVoid(Builder : BuilderRef) return ValueRef;
+ function BuildRet(Builder : BuilderRef; V : ValueRef) return ValueRef;
+ function BuildBr(Builder : BuilderRef; Dest : BasicBlockRef)
+ return ValueRef;
+ function BuildCondBr(Builder : BuilderRef;
+ If_Br : ValueRef;
+ Then_Br : BasicBlockRef; Else_Br : BasicBlockRef)
+ return ValueRef;
+ function BuildSwitch(Builder : BuilderRef;
+ V : ValueRef;
+ Else_Br : BasicBlockRef; NumCases : unsigned)
+ return ValueRef;
+ function BuildInvoke(Builder : BuilderRef;
+ Fn : ValueRef;
+ Args : ValueRefArray;
+ NumArgs : unsigned;
+ Then_Br : BasicBlockRef;
+ Catch : BasicBlockRef;
+ Name : Cstring) return ValueRef;
+ function BuildUnwind(Builder : BuilderRef) return ValueRef;
+ function BuildUnreachable(Builder : BuilderRef) return ValueRef;
+
+ -- Add a case to the switch instruction
+ procedure AddCase(Switch : ValueRef;
+ OnVal : ValueRef; Dest : BasicBlockRef);
+
+ -- Arithmetic
+ function BuildAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNSWAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNUWAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFAdd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNSWSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNUWSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFSub(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildMul(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFMul(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ function BuildUDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildSDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFDiv(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildURem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildSRem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFRem(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildShl(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildLShr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAShr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAnd(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildOr(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildXor(Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFNeg(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildNot(Builder : BuilderRef; V : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ -- Memory
+ function BuildMalloc(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildArrayMalloc(Builder : BuilderRef;
+ Ty : TypeRef; Val : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildAlloca(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildArrayAlloca(Builder : BuilderRef;
+ Ty : TypeRef; Val : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFree(Builder : BuilderRef; PointerVal : ValueRef)
+ return ValueRef;
+ function BuildLoad(Builder : BuilderRef; PointerVal : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildStore(Builder : BuilderRef; Val : ValueRef; Ptr : ValueRef)
+ return ValueRef;
+ function BuildGEP(Builder : BuilderRef;
+ Pointer : ValueRef;
+ Indices : ValueRefArray;
+ NumIndices : unsigned; Name : Cstring) return ValueRef;
+
+ -- Casts
+ function BuildTrunc(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildZExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildSExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPToUI(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPToSI(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildUIToFP(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildSIToFP(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPTrunc(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildFPExt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildPtrToInt(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildIntToPtr(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildBitCast(Builder : BuilderRef;
+ Val : ValueRef; DestTy : TypeRef; Name : Cstring)
+ return ValueRef;
+
+ -- Comparisons
+ function BuildICmp(Builder : BuilderRef;
+ Op : IntPredicate;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ function BuildFCmp(Builder : BuilderRef;
+ Op : RealPredicate;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+
+ -- Miscellaneous instructions
+ function BuildPhi(Builder : BuilderRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildCall(Builder : BuilderRef;
+ Fn : ValueRef;
+ Args : ValueRefArray; NumArgs : unsigned; Name : Cstring)
+ return ValueRef;
+ function BuildSelect(Builder : BuilderRef;
+ If_Sel : ValueRef;
+ Then_Sel : ValueRef;
+ Else_Sel : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildVAArg(Builder : BuilderRef;
+ List : ValueRef; Ty : TypeRef; Name : Cstring)
+ return ValueRef;
+ function BuildExtractElement(Builder : BuilderRef;
+ VecVal : ValueRef;
+ Index : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildInsertElement(Builder : BuilderRef;
+ VecVal : ValueRef;
+ EltVal : ValueRef;
+ Index : ValueRef;
+ Name : Cstring) return ValueRef;
+ function BuildShuffleVector(Builder : BuilderRef;
+ V1 : ValueRef;
+ V2 : ValueRef;
+ Mask : ValueRef;
+ Name : Cstring) return ValueRef;
+
+ -- Memory buffers ----------------------------------------------------
+
+ function CreateMemoryBufferWithContentsOfFile
+ (Path : Cstring;
+ OutMemBuf : access MemoryBufferRef;
+ OutMessage : access Cstring) return int;
+ function CreateMemoryBufferWithSTDIN
+ (OutMemBuf : access MemoryBufferRef;
+ OutMessage : access Cstring) return int;
+ procedure DisposeMemoryBuffer(MemBuf : MemoryBufferRef);
+
+
+ -- Pass Managers -----------------------------------------------------
+
+ -- Constructs a new whole-module pass pipeline. This type of pipeline is
+ -- suitable for link-time optimization and whole-module transformations.
+ -- See llvm::PassManager::PassManager.
+ function CreatePassManager return PassManagerRef;
+
+ -- Constructs a new function-by-function pass pipeline over the module
+ -- provider. It does not take ownership of the module provider. This type of
+ -- pipeline is suitable for code generation and JIT compilation tasks.
+ -- See llvm::FunctionPassManager::FunctionPassManager.
+ function CreateFunctionPassManagerForModule(M : ModuleRef)
+ return PassManagerRef;
+
+ -- Initializes, executes on the provided module, and finalizes all of the
+ -- passes scheduled in the pass manager. Returns 1 if any of the passes
+ -- modified the module, 0 otherwise. See llvm::PassManager::run(Module&).
+ function RunPassManager(PM : PassManagerRef; M : ModuleRef)
+ return int;
+
+ -- Initializes all of the function passes scheduled in the function pass
+ -- manager. Returns 1 if any of the passes modified the module, 0 otherwise.
+ -- See llvm::FunctionPassManager::doInitialization.
+ function InitializeFunctionPassManager(FPM : PassManagerRef)
+ return int;
+
+ -- Executes all of the function passes scheduled in the function
+ -- pass manager on the provided function. Returns 1 if any of the
+ -- passes modified the function, false otherwise.
+ -- See llvm::FunctionPassManager::run(Function&).
+ function RunFunctionPassManager (FPM : PassManagerRef; F : ValueRef)
+ return int;
+
+ -- Finalizes all of the function passes scheduled in in the function pass
+ -- manager. Returns 1 if any of the passes modified the module, 0 otherwise.
+ -- See llvm::FunctionPassManager::doFinalization.
+ function FinalizeFunctionPassManager(FPM : PassManagerRef)
+ return int;
+
+ -- Frees the memory of a pass pipeline. For function pipelines,
+ -- does not free the module provider.
+ -- See llvm::PassManagerBase::~PassManagerBase.
+ procedure DisposePassManager(PM : PassManagerRef);
+
+private
+ pragma Import (C, ContextCreate, "LLVMContextCreate");
+ pragma Import (C, GetGlobalContext, "LLVMGetGlobalContext");
+ pragma Import (C, ContextDispose, "LLVMContextDispose");
+
+ pragma Import (C, GetMDKindIDInContext, "LLVMGetMDKindIDInContext");
+ pragma Import (C, GetMDKindID, "LLVMGetMDKindID");
+
+ pragma Import (C, DisposeMessage, "LLVMDisposeMessage");
+ pragma Import (C, ModuleCreateWithName, "LLVMModuleCreateWithName");
+ pragma Import (C, DisposeModule, "LLVMDisposeModule");
+ pragma Import (C, GetDataLayout, "LLVMGetDataLayout");
+ pragma Import (C, SetDataLayout, "LLVMSetDataLayout");
+ pragma Import (C, GetTarget, "LLVMGetTarget");
+ pragma Import (C, SetTarget, "LLVMSetTarget");
+ pragma Import (C, DumpModule, "LLVMDumpModule");
+ pragma Import (C, PrintModuleToFile, "LLVMPrintModuleToFile");
+ pragma Import (C, GetTypeKind, "LLVMGetTypeKind");
+ pragma Import (C, Int1Type, "LLVMInt1Type");
+ pragma Import (C, Int8Type, "LLVMInt8Type");
+ pragma Import (C, Int16Type, "LLVMInt16Type");
+ pragma Import (C, Int32Type, "LLVMInt32Type");
+ pragma Import (C, Int64Type, "LLVMInt64Type");
+ pragma Import (C, IntType, "LLVMIntType");
+ pragma Import (C, GetIntTypeWidth, "LLVMGetIntTypeWidth");
+ pragma Import (C, MetadataType, "LLVMMetadataType_extra");
+
+ pragma Import (C, FloatType, "LLVMFloatType");
+ pragma Import (C, DoubleType, "LLVMDoubleType");
+ pragma Import (C, X86FP80Type, "LLVMX86FP80Type");
+ pragma Import (C, FP128Type, "LLVMFP128Type");
+ pragma Import (C, PPCFP128Type, "LLVMPPCFP128Type");
+
+ pragma Import (C, FunctionType, "LLVMFunctionType");
+ pragma Import (C, IsFunctionVarArg, "LLVMIsFunctionVarArg");
+ pragma Import (C, GetReturnType, "LLVMGetReturnType");
+ pragma Import (C, CountParamTypes, "LLVMCountParamTypes");
+ pragma Import (C, GetParamTypes, "LLVMGetParamTypes");
+
+ pragma Import (C, StructType, "LLVMStructType");
+ pragma Import (C, StructCreateNamed, "LLVMStructCreateNamed");
+ pragma Import (C, StructSetBody, "LLVMStructSetBody");
+ pragma Import (C, CountStructElementTypes, "LLVMCountStructElementTypes");
+ pragma Import (C, GetStructElementTypes, "LLVMGetStructElementTypes");
+ pragma Import (C, IsPackedStruct, "LLVMIsPackedStruct");
+
+ pragma Import (C, ArrayType, "LLVMArrayType");
+ pragma Import (C, PointerType, "LLVMPointerType");
+ pragma Import (C, VectorType, "LLVMVectorType");
+ pragma Import (C, GetElementType, "LLVMGetElementType");
+ pragma Import (C, GetArrayLength, "LLVMGetArrayLength");
+ pragma Import (C, GetPointerAddressSpace, "LLVMGetPointerAddressSpace");
+ pragma Import (C, GetVectorSize, "LLVMGetVectorSize");
+
+ pragma Import (C, VoidType, "LLVMVoidType");
+ pragma Import (C, LabelType, "LLVMLabelType");
+
+ pragma Import (C, TypeOf, "LLVMTypeOf");
+ pragma Import (C, GetValueName, "LLVMGetValueName");
+ pragma Import (C, SetValueName, "LLVMSetValueName");
+ pragma Import (C, DumpValue, "LLVMDumpValue");
+
+ pragma Import (C, ConstNull, "LLVMConstNull");
+ pragma Import (C, ConstAllOnes, "LLVMConstAllOnes");
+ pragma Import (C, GetUndef, "LLVMGetUndef");
+ pragma Import (C, IsConstant, "LLVMIsConstant");
+ pragma Import (C, IsNull, "LLVMIsNull");
+ pragma Import (C, IsUndef, "LLVMIsUndef");
+ pragma Import (C, IsAInstruction, "LLVMIsAInstruction");
+
+ pragma Import (C, ConstInt, "LLVMConstInt");
+ pragma Import (C, ConstReal, "LLVMConstReal");
+ pragma Import (C, ConstIntGetZExtValue, "LLVMConstIntGetZExtValue");
+ pragma Import (C, ConstRealOfString, "LLVMConstRealOfString");
+ pragma Import (C, ConstString, "LLVMConstString");
+ pragma Import (C, ConstArray, "LLVMConstArray");
+ pragma Import (C, ConstStruct, "LLVMConstStruct");
+ pragma Import (C, ConstNamedStruct, "LLVMConstNamedStruct");
+ pragma Import (C, ConstVector, "LLVMConstVector");
+
+ pragma Import (C, SizeOf, "LLVMSizeOf");
+ pragma Import (C, AlignOf, "LLVMAlignOf");
+ pragma Import (C, ConstNeg, "LLVMConstNeg");
+ pragma Import (C, ConstNot, "LLVMConstNot");
+ pragma Import (C, ConstAdd, "LLVMConstAdd");
+ pragma Import (C, ConstSub, "LLVMConstSub");
+ pragma Import (C, ConstMul, "LLVMConstMul");
+ pragma Import (C, ConstUDiv, "LLVMConstUDiv");
+ pragma Import (C, ConstSDiv, "LLVMConstSDiv");
+ pragma Import (C, ConstFDiv, "LLVMConstFDiv");
+ pragma Import (C, ConstURem, "LLVMConstURem");
+ pragma Import (C, ConstSRem, "LLVMConstSRem");
+ pragma Import (C, ConstFRem, "LLVMConstFRem");
+ pragma Import (C, ConstAnd, "LLVMConstAnd");
+ pragma Import (C, ConstOr, "LLVMConstOr");
+ pragma Import (C, ConstXor, "LLVMConstXor");
+ pragma Import (C, ConstICmp, "LLVMConstICmp");
+ pragma Import (C, ConstFCmp, "LLVMConstFCmp");
+ pragma Import (C, ConstShl, "LLVMConstShl");
+ pragma Import (C, ConstLShr, "LLVMConstLShr");
+ pragma Import (C, ConstAShr, "LLVMConstAShr");
+ pragma Import (C, ConstGEP, "LLVMConstGEP");
+ pragma Import (C, ConstTrunc, "LLVMConstTrunc");
+ pragma Import (C, ConstSExt, "LLVMConstSExt");
+ pragma Import (C, ConstZExt, "LLVMConstZExt");
+ pragma Import (C, ConstFPTrunc, "LLVMConstFPTrunc");
+ pragma Import (C, ConstFPExt, "LLVMConstFPExt");
+ pragma Import (C, ConstUIToFP, "LLVMConstUIToFP");
+ pragma Import (C, ConstSIToFP, "LLVMConstSIToFP");
+ pragma Import (C, ConstFPToUI, "LLVMConstFPToUI");
+ pragma Import (C, ConstFPToSI, "LLVMConstFPToSI");
+ pragma Import (C, ConstPtrToInt, "LLVMConstPtrToInt");
+ pragma Import (C, ConstIntToPtr, "LLVMConstIntToPtr");
+ pragma Import (C, ConstBitCast, "LLVMConstBitCast");
+ pragma Import (C, ConstTruncOrBitCast, "LLVMConstTruncOrBitCast");
+ pragma Import (C, ConstSelect, "LLVMConstSelect");
+ pragma Import (C, ConstExtractElement, "LLVMConstExtractElement");
+ pragma Import (C, ConstInsertElement, "LLVMConstInsertElement");
+ pragma Import (C, ConstShuffleVector, "LLVMConstShuffleVector");
+
+ pragma Import (C, GetGlobalParent, "LLVMGetGlobalParent");
+ pragma Import (C, IsDeclaration, "LLVMIsDeclaration");
+ pragma Import (C, GetLinkage, "LLVMGetLinkage");
+ pragma Import (C, SetLinkage, "LLVMSetLinkage");
+ pragma Import (C, GetSection, "LLVMGetSection");
+ pragma Import (C, SetSection, "LLVMSetSection");
+ pragma Import (C, GetVisibility, "LLVMGetVisibility");
+ pragma Import (C, SetVisibility, "LLVMSetVisibility");
+ pragma Import (C, GetAlignment, "LLVMGetAlignment");
+ pragma Import (C, SetAlignment, "LLVMSetAlignment");
+
+ pragma Import (C, AddGlobal, "LLVMAddGlobal");
+ pragma Import (C, GetNamedGlobal, "LLVMGetNamedGlobal");
+ pragma Import (C, GetFirstGlobal, "LLVMGetFirstGlobal");
+ pragma Import (C, GetLastGlobal, "LLVMGetLastGlobal");
+ pragma Import (C, GetNextGlobal, "LLVMGetNextGlobal");
+ pragma Import (C, GetPreviousGlobal, "LLVMGetPreviousGlobal");
+ pragma Import (C, DeleteGlobal, "LLVMDeleteGlobal");
+ pragma Import (C, GetInitializer, "LLVMGetInitializer");
+ pragma Import (C, SetInitializer, "LLVMSetInitializer");
+ pragma Import (C, IsThreadLocal, "LLVMIsThreadLocal");
+ pragma Import (C, SetThreadLocal, "LLVMSetThreadLocal");
+ pragma Import (C, IsGlobalConstant, "LLVMIsGlobalConstant");
+ pragma Import (C, SetGlobalConstant, "LLVMSetGlobalConstant");
+
+ pragma Import (C, GetNamedMetadataNumOperands,
+ "LLVMGetNamedMetadataNumOperands");
+ pragma Import (C, GetNamedMetadataOperands, "LLVMGetNamedMetadataOperands");
+ pragma Import (C, AddNamedMetadataOperand, "LLVMAddNamedMetadataOperand");
+
+ pragma Import (C, AddFunction, "LLVMAddFunction");
+ pragma Import (C, GetNamedFunction, "LLVMGetNamedFunction");
+ pragma Import (C, GetFirstFunction, "LLVMGetFirstFunction");
+ pragma Import (C, GetLastFunction, "LLVMGetLastFunction");
+ pragma Import (C, GetNextFunction, "LLVMGetNextFunction");
+ pragma Import (C, GetPreviousFunction, "LLVMGetPreviousFunction");
+ pragma Import (C, DeleteFunction, "LLVMDeleteFunction");
+ pragma Import (C, GetIntrinsicID, "LLVMGetIntrinsicID");
+ pragma Import (C, GetFunctionCallConv, "LLVMGetFunctionCallConv");
+ pragma Import (C, SetFunctionCallConv, "LLVMSetFunctionCallConv");
+ pragma Import (C, GetGC, "LLVMGetGC");
+ pragma Import (C, SetGC, "LLVMSetGC");
+
+ pragma Import (C, AddFunctionAttr, "LLVMAddFunctionAttr");
+ pragma import (C, AddTargetDependentFunctionAttr,
+ "LLVMAddTargetDependentFunctionAttr");
+ pragma Import (C, GetFunctionAttr, "LLVMGetFunctionAttr");
+ pragma Import (C, RemoveFunctionAttr, "LLVMRemoveFunctionAttr");
+
+ pragma Import (C, CountParams, "LLVMCountParams");
+ pragma Import (C, GetParams, "LLVMGetParams");
+ pragma Import (C, GetParam, "LLVMGetParam");
+ pragma Import (C, GetParamParent, "LLVMGetParamParent");
+ pragma Import (C, GetFirstParam, "LLVMGetFirstParam");
+ pragma Import (C, GetLastParam, "LLVMGetLastParam");
+ pragma Import (C, GetNextParam, "LLVMGetNextParam");
+ pragma Import (C, GetPreviousParam, "LLVMGetPreviousParam");
+ pragma Import (C, AddAttribute, "LLVMAddAttribute");
+ pragma Import (C, RemoveAttribute, "LLVMRemoveAttribute");
+ pragma Import (C, SetParamAlignment, "LLVMSetParamAlignment");
+
+ pragma Import (C, MDStringInContext, "LLVMMDStringInContext");
+ pragma Import (C, MDString, "LLVMMDString");
+ pragma Import (C, MDNodeInContext, "LLVMMDNodeInContext");
+ pragma Import (C, MDNode, "LLVMMDNode");
+ pragma Import (C, GetMDString, "LLVMGetMDString");
+ pragma Import (C, GetMDNodeNumOperands, "LLVMGetMDNodeNumOperands");
+ pragma Import (C, GetMDNodeOperands, "LLVMGetMDNodeOperands");
+ pragma Import (C, MDNodeReplaceOperandWith,
+ "LLVMMDNodeReplaceOperandWith_extra");
+
+ pragma Import (C, BasicBlockAsValue, "LLVMBasicBlockAsValue");
+ pragma Import (C, ValueIsBasicBlock, "LLVMValueIsBasicBlock");
+ pragma Import (C, ValueAsBasicBlock, "LLVMValueAsBasicBlock");
+ pragma Import (C, GetBasicBlockParent, "LLVMGetBasicBlockParent");
+ pragma Import (C, CountBasicBlocks, "LLVMCountBasicBlocks");
+ pragma Import (C, GetBasicBlocks, "LLVMGetBasicBlocks");
+ pragma Import (C, GetFirstBasicBlock, "LLVMGetFirstBasicBlock");
+ pragma Import (C, GetLastBasicBlock, "LLVMGetLastBasicBlock");
+ pragma Import (C, GetNextBasicBlock, "LLVMGetNextBasicBlock");
+ pragma Import (C, GetPreviousBasicBlock, "LLVMGetPreviousBasicBlock");
+ pragma Import (C, GetEntryBasicBlock, "LLVMGetEntryBasicBlock");
+ pragma Import (C, AppendBasicBlock, "LLVMAppendBasicBlock");
+ pragma Import (C, InsertBasicBlock, "LLVMInsertBasicBlock");
+ pragma Import (C, DeleteBasicBlock, "LLVMDeleteBasicBlock");
+
+ pragma Import (C, HasMetadata, "LLVMHasMetadata");
+ pragma Import (C, GetMetadata, "LLVMGetMetadata");
+ pragma Import (C, SetMetadata, "LLVMSetMetadata");
+
+ pragma Import (C, GetInstructionParent, "LLVMGetInstructionParent");
+ pragma Import (C, GetFirstInstruction, "LLVMGetFirstInstruction");
+ pragma Import (C, GetLastInstruction, "LLVMGetLastInstruction");
+ pragma Import (C, GetNextInstruction, "LLVMGetNextInstruction");
+ pragma Import (C, GetPreviousInstruction, "LLVMGetPreviousInstruction");
+
+ pragma Import (C, SetInstructionCallConv, "LLVMSetInstructionCallConv");
+ pragma Import (C, GetInstructionCallConv, "LLVMGetInstructionCallConv");
+ pragma Import (C, AddInstrAttribute, "LLVMAddInstrAttribute");
+ pragma Import (C, RemoveInstrAttribute, "LLVMRemoveInstrAttribute");
+ pragma Import (C, SetInstrParamAlignment, "LLVMSetInstrParamAlignment");
+
+ pragma Import (C, IsTailCall, "LLVMIsTailCall");
+ pragma Import (C, SetTailCall, "LLVMSetTailCall");
+
+ pragma Import (C, AddIncoming, "LLVMAddIncoming");
+ pragma Import (C, CountIncoming, "LLVMCountIncoming");
+ pragma Import (C, GetIncomingValue, "LLVMGetIncomingValue");
+ pragma Import (C, GetIncomingBlock, "LLVMGetIncomingBlock");
+
+ pragma Import (C, CreateBuilder, "LLVMCreateBuilder");
+ pragma Import (C, PositionBuilder, "LLVMPositionBuilder");
+ pragma Import (C, PositionBuilderBefore, "LLVMPositionBuilderBefore");
+ pragma Import (C, PositionBuilderAtEnd, "LLVMPositionBuilderAtEnd");
+ pragma Import (C, GetInsertBlock, "LLVMGetInsertBlock");
+ pragma Import (C, DisposeBuilder, "LLVMDisposeBuilder");
+
+ -- Terminators
+ pragma Import (C, BuildRetVoid, "LLVMBuildRetVoid");
+ pragma Import (C, BuildRet, "LLVMBuildRet");
+ pragma Import (C, BuildBr, "LLVMBuildBr");
+ pragma Import (C, BuildCondBr, "LLVMBuildCondBr");
+ pragma Import (C, BuildSwitch, "LLVMBuildSwitch");
+ pragma Import (C, BuildInvoke, "LLVMBuildInvoke");
+ pragma Import (C, BuildUnwind, "LLVMBuildUnwind");
+ pragma Import (C, BuildUnreachable, "LLVMBuildUnreachable");
+
+ -- Add a case to the switch instruction
+ pragma Import (C, AddCase, "LLVMAddCase");
+
+ -- Arithmetic
+ pragma Import (C, BuildAdd, "LLVMBuildAdd");
+ pragma Import (C, BuildNSWAdd, "LLVMBuildNSWAdd");
+ pragma Import (C, BuildNUWAdd, "LLVMBuildNUWAdd");
+ pragma Import (C, BuildFAdd, "LLVMBuildFAdd");
+ pragma Import (C, BuildSub, "LLVMBuildSub");
+ pragma Import (C, BuildNSWSub, "LLVMBuildNSWSub");
+ pragma Import (C, BuildNUWSub, "LLVMBuildNUWSub");
+ pragma Import (C, BuildFSub, "LLVMBuildFSub");
+ pragma Import (C, BuildMul, "LLVMBuildMul");
+ pragma Import (C, BuildFMul, "LLVMBuildFMul");
+ pragma Import (C, BuildUDiv, "LLVMBuildUDiv");
+ pragma Import (C, BuildSDiv, "LLVMBuildSDiv");
+ pragma Import (C, BuildFDiv, "LLVMBuildFDiv");
+ pragma Import (C, BuildURem, "LLVMBuildURem");
+ pragma Import (C, BuildSRem, "LLVMBuildSRem");
+ pragma Import (C, BuildFRem, "LLVMBuildFRem");
+ pragma Import (C, BuildShl, "LLVMBuildShl");
+ pragma Import (C, BuildLShr, "LLVMBuildLShr");
+ pragma Import (C, BuildAShr, "LLVMBuildAShr");
+ pragma Import (C, BuildAnd, "LLVMBuildAnd");
+ pragma Import (C, BuildOr, "LLVMBuildOr");
+ pragma Import (C, BuildXor, "LLVMBuildXor");
+ pragma Import (C, BuildNeg, "LLVMBuildNeg");
+ pragma Import (C, BuildFNeg, "LLVMBuildFNeg");
+ pragma Import (C, BuildNot, "LLVMBuildNot");
+
+ -- Memory
+ pragma Import (C, BuildMalloc, "LLVMBuildMalloc");
+ pragma Import (C, BuildArrayMalloc, "LLVMBuildArrayMalloc");
+ pragma Import (C, BuildAlloca, "LLVMBuildAlloca");
+ pragma Import (C, BuildArrayAlloca, "LLVMBuildArrayAlloca");
+ pragma Import (C, BuildFree, "LLVMBuildFree");
+ pragma Import (C, BuildLoad, "LLVMBuildLoad");
+ pragma Import (C, BuildStore, "LLVMBuildStore");
+ pragma Import (C, BuildGEP, "LLVMBuildGEP");
+
+ -- Casts
+ pragma Import (C, BuildTrunc, "LLVMBuildTrunc");
+ pragma Import (C, BuildZExt, "LLVMBuildZExt");
+ pragma Import (C, BuildSExt, "LLVMBuildSExt");
+ pragma Import (C, BuildFPToUI, "LLVMBuildFPToUI");
+ pragma Import (C, BuildFPToSI, "LLVMBuildFPToSI");
+ pragma Import (C, BuildUIToFP, "LLVMBuildUIToFP");
+ pragma Import (C, BuildSIToFP, "LLVMBuildSIToFP");
+ pragma Import (C, BuildFPTrunc, "LLVMBuildFPTrunc");
+ pragma Import (C, BuildFPExt, "LLVMBuildFPExt");
+ pragma Import (C, BuildPtrToInt, "LLVMBuildPtrToInt");
+ pragma Import (C, BuildIntToPtr, "LLVMBuildIntToPtr");
+ pragma Import (C, BuildBitCast, "LLVMBuildBitCast");
+
+ -- Comparisons
+ pragma Import (C, BuildICmp, "LLVMBuildICmp");
+ pragma Import (C, BuildFCmp, "LLVMBuildFCmp");
+
+ -- Miscellaneous instructions
+ pragma Import (C, BuildPhi, "LLVMBuildPhi");
+ pragma Import (C, BuildCall, "LLVMBuildCall");
+ pragma Import (C, BuildSelect, "LLVMBuildSelect");
+ pragma Import (C, BuildVAArg, "LLVMBuildVAArg");
+ pragma Import (C, BuildExtractElement, "LLVMBuildExtractElement");
+ pragma Import (C, BuildInsertElement, "LLVMBuildInsertElement");
+ pragma Import (C, BuildShuffleVector, "LLVMBuildShuffleVector");
+
+ -- Memory buffers ----------------------------------------------------
+ pragma Import (C, CreateMemoryBufferWithContentsOfFile,
+ "LLVMCreateMemoryBufferWithContentsOfFile");
+ pragma Import (C, CreateMemoryBufferWithSTDIN,
+ "LLVMCreateMemoryBufferWithSTDIN");
+ pragma Import (C, DisposeMemoryBuffer, "LLVMDisposeMemoryBuffer");
+
+ -- Pass Managers -----------------------------------------------------
+ pragma Import (C, CreatePassManager, "LLVMCreatePassManager");
+ pragma Import (C, CreateFunctionPassManagerForModule,
+ "LLVMCreateFunctionPassManagerForModule");
+ pragma Import (C, RunPassManager, "LLVMRunPassManager");
+ pragma Import (C, InitializeFunctionPassManager,
+ "LLVMInitializeFunctionPassManager");
+ pragma Import (C, RunFunctionPassManager,
+ "LLVMRunFunctionPassManager");
+ pragma Import (C, FinalizeFunctionPassManager,
+ "LLVMFinalizeFunctionPassManager");
+ pragma Import (C, DisposePassManager, "LLVMDisposePassManager");
+
+end LLVM.Core;
diff --git a/src/ortho/llvm/llvm-executionengine.ads b/src/ortho/llvm/llvm-executionengine.ads
new file mode 100644
index 000000000..72d4cda2f
--- /dev/null
+++ b/src/ortho/llvm/llvm-executionengine.ads
@@ -0,0 +1,163 @@
+-- LLVM binding
+-- 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 System; use System;
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+
+package LLVM.ExecutionEngine is
+ type GenericValueRef is new Address;
+ type GenericValueRefArray is array (unsigned range <>) of GenericValueRef;
+ pragma Convention (C, GenericValueRefArray);
+ type ExecutionEngineRef is new Address;
+
+ procedure LinkInJIT;
+ procedure LinkInMCJIT;
+ procedure LinkInInterpreter;
+
+ -- Operations on generic values --------------------------------------
+
+ function CreateGenericValueOfInt(Ty : TypeRef;
+ N : Unsigned_64;
+ IsSigned : Integer)
+ return GenericValueRef;
+
+ function CreateGenericValueOfPointer(P : System.Address)
+ return GenericValueRef;
+
+ function CreateGenericValueOfFloat(Ty : TypeRef; N : double)
+ return GenericValueRef;
+
+ function GenericValueIntWidth(GenValRef : GenericValueRef)
+ return unsigned;
+
+ function GenericValueToInt(GenVal : GenericValueRef;
+ IsSigned : Integer) return Unsigned_64;
+
+ function GenericValueToPointer(GenVal : GenericValueRef)
+ return System.Address;
+
+ function GenericValueToFloat(TyRef : TypeRef; GenVal : GenericValueRef)
+ return double;
+
+ procedure DisposeGenericValue(GenVal : GenericValueRef);
+
+ -- Operations on execution engines -----------------------------------
+
+ function CreateExecutionEngineForModule
+ (EE : access ExecutionEngineRef; M : ModuleRef; Error : access Cstring)
+ return Bool;
+
+ function CreateInterpreterForModule (Interp : access ExecutionEngineRef;
+ M : ModuleRef;
+ Error : access Cstring)
+ return Bool;
+
+ function CreateJITCompilerForModule (JIT : access ExecutionEngineRef;
+ M : ModuleRef;
+ OptLevel : unsigned;
+ Error : access Cstring)
+ return Bool;
+
+
+ procedure DisposeExecutionEngine(EE : ExecutionEngineRef);
+
+ procedure RunStaticConstructors(EE : ExecutionEngineRef);
+
+ procedure RunStaticDestructors(EE : ExecutionEngineRef);
+
+ function RunFunctionAsMain(EE : ExecutionEngineRef;
+ F : ValueRef;
+ ArgC : unsigned; Argv : Address; EnvP : Address)
+ return Integer;
+
+ function RunFunction(EE : ExecutionEngineRef;
+ F : ValueRef;
+ NumArgs : unsigned;
+ Args : GenericValueRefArray)
+ return GenericValueRef;
+
+ procedure FreeMachineCodeForFunction(EE : ExecutionEngineRef; F : ValueRef);
+
+ procedure AddModule(EE : ExecutionEngineRef; M : ModuleRef);
+
+ function RemoveModule(EE : ExecutionEngineRef;
+ M : ModuleRef;
+ OutMod : access ModuleRef;
+ OutError : access Cstring) return Bool;
+
+ function FindFunction(EE : ExecutionEngineRef; Name : Cstring;
+ OutFn : access ValueRef)
+ return Integer;
+
+ function GetExecutionEngineTargetData(EE : ExecutionEngineRef)
+ return TargetDataRef;
+
+ procedure AddGlobalMapping(EE : ExecutionEngineRef; Global : ValueRef;
+ Addr : Address);
+
+ function GetPointerToGlobal (EE : ExecutionEngineRef; GV : ValueRef)
+ return Address;
+ function GetPointerToFunctionOrStub (EE : ExecutionEngineRef;
+ Func : ValueRef)
+ return Address;
+
+private
+ pragma Import (C, LinkInJIT, "LLVMLinkInJIT");
+ pragma Import (C, LinkInMCJIT, "LLVMLinkInMCJIT");
+ pragma Import (C, LinkInInterpreter, "LLVMLinkInInterpreter");
+
+ pragma Import (C, CreateGenericValueOfInt, "LLVMCreateGenericValueOfInt");
+ pragma Import (C, CreateGenericValueOfPointer,
+ "LLVMCreateGenericValueOfPointer");
+ pragma Import (C, CreateGenericValueOfFloat,
+ "LLVMCreateGenericValueOfFloat");
+ pragma Import (C, GenericValueIntWidth, "LLVMGenericValueIntWidth");
+ pragma Import (C, GenericValueToInt, "LLVMGenericValueToInt");
+ pragma Import (C, GenericValueToPointer, "LLVMGenericValueToPointer");
+ pragma Import (C, GenericValueToFloat, "LLVMGenericValueToFloat");
+ pragma Import (C, DisposeGenericValue, "LLVMDisposeGenericValue");
+
+ -- Operations on execution engines -----------------------------------
+
+ pragma Import (C, CreateExecutionEngineForModule,
+ "LLVMCreateExecutionEngineForModule");
+ pragma Import (C, CreateInterpreterForModule,
+ "LLVMCreateInterpreterForModule");
+ pragma Import (C, CreateJITCompilerForModule,
+ "LLVMCreateJITCompilerForModule");
+ pragma Import (C, DisposeExecutionEngine, "LLVMDisposeExecutionEngine");
+ pragma Import (C, RunStaticConstructors, "LLVMRunStaticConstructors");
+ pragma Import (C, RunStaticDestructors, "LLVMRunStaticDestructors");
+ pragma Import (C, RunFunctionAsMain, "LLVMRunFunctionAsMain");
+ pragma Import (C, RunFunction, "LLVMRunFunction");
+ pragma Import (C, FreeMachineCodeForFunction,
+ "LLVMFreeMachineCodeForFunction");
+ pragma Import (C, AddModule, "LLVMAddModule");
+ pragma Import (C, RemoveModule, "LLVMRemoveModule");
+ pragma Import (C, FindFunction, "LLVMFindFunction");
+ pragma Import (C, GetExecutionEngineTargetData,
+ "LLVMGetExecutionEngineTargetData");
+ pragma Import (C, AddGlobalMapping, "LLVMAddGlobalMapping");
+
+ pragma Import (C, GetPointerToFunctionOrStub,
+ "LLVMGetPointerToFunctionOrStub");
+ pragma Import (C, GetPointerToGlobal,
+ "LLVMGetPointerToGlobal");
+end LLVM.ExecutionEngine;
diff --git a/src/ortho/llvm/llvm-target.ads b/src/ortho/llvm/llvm-target.ads
new file mode 100644
index 000000000..b7c35848a
--- /dev/null
+++ b/src/ortho/llvm/llvm-target.ads
@@ -0,0 +1,84 @@
+-- LLVM binding
+-- 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 System;
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with LLVM.Core; use LLVM.Core;
+
+package LLVM.Target is
+
+ type TargetDataRef is new System.Address;
+
+ -- LLVMInitializeNativeTarget - The main program should call this function
+ -- to initialize the native target corresponding to the host. This is
+ -- useful for JIT applications to ensure that the target gets linked in
+ -- correctly.
+ procedure InitializeNativeTarget;
+ pragma Import (C, InitializeNativeTarget,
+ "LLVMInitializeNativeTarget_noinline");
+
+ -- LLVMInitializeNativeTargetAsmPrinter - The main program should call this
+ -- function to initialize the printer for the native target corresponding
+ -- to the host.
+ procedure InitializeNativeAsmPrinter;
+ pragma Import (C, InitializeNativeAsmPrinter,
+ "LLVMInitializeNativeAsmPrinter_noinline");
+
+ -- Creates target data from a target layout string.
+ -- See the constructor llvm::DataLayout::DataLayout.
+ function CreateTargetData (StringRep : Cstring) return TargetDataRef;
+ pragma Import (C, CreateTargetData, "LLVMCreateTargetData");
+
+ -- Adds target data information to a pass manager. This does not take
+ -- ownership of the target data.
+ -- See the method llvm::PassManagerBase::add.
+ procedure AddTargetData(TD : TargetDataRef; PM : PassManagerRef);
+ pragma Import (C, AddTargetData, "LLVMAddTargetData");
+
+ -- Converts target data to a target layout string. The string must be
+ -- disposed with LLVMDisposeMessage.
+ -- See the constructor llvm::DataLayout::DataLayout. */
+ function CopyStringRepOfTargetData(TD :TargetDataRef) return Cstring;
+ pragma Import (C, CopyStringRepOfTargetData,
+ "LLVMCopyStringRepOfTargetData");
+
+ -- Returns the pointer size in bytes for a target.
+ -- See the method llvm::DataLayout::getPointerSize.
+ function PointerSize(TD : TargetDataRef) return unsigned;
+ pragma Import (C, PointerSize, "LLVMPointerSize");
+
+ -- Computes the ABI size of a type in bytes for a target.
+ -- See the method llvm::DataLayout::getTypeAllocSize.
+ function ABISizeOfType (TD : TargetDataRef; Ty: TypeRef) return Unsigned_64;
+ pragma Import (C, ABISizeOfType, "LLVMABISizeOfType");
+
+ -- Computes the ABI alignment of a type in bytes for a target.
+ -- See the method llvm::DataLayout::getTypeABISize.
+ function ABIAlignmentOfType (TD : TargetDataRef; Ty: TypeRef)
+ return Unsigned_32;
+ pragma Import (C, ABIAlignmentOfType, "LLVMABIAlignmentOfType");
+
+ -- Computes the byte offset of the indexed struct element for a target.
+ -- See the method llvm::StructLayout::getElementContainingOffset.
+ function OffsetOfElement(TD : TargetDataRef;
+ StructTy : TypeRef;
+ Element : Unsigned_32)
+ return Unsigned_64;
+ pragma Import (C, OffsetOfElement, "LLVMOffsetOfElement");
+
+end LLVM.Target;
diff --git a/src/ortho/llvm/llvm-targetmachine.ads b/src/ortho/llvm/llvm-targetmachine.ads
new file mode 100644
index 000000000..cbf074940
--- /dev/null
+++ b/src/ortho/llvm/llvm-targetmachine.ads
@@ -0,0 +1,122 @@
+-- LLVM binding
+-- 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 System;
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+
+package LLVM.TargetMachine is
+
+ type TargetMachineRef is new System.Address;
+ Null_TargetMachineRef : constant TargetMachineRef :=
+ TargetMachineRef (System.Null_Address);
+
+ type TargetRef is new System.Address;
+ Null_TargetRef : constant TargetRef := TargetRef (System.Null_Address);
+
+ type CodeGenOptLevel is (CodeGenLevelNone,
+ CodeGenLevelLess,
+ CodeGenLevelDefault,
+ CodeGenLevelAggressive);
+ pragma Convention (C, CodeGenOptLevel);
+
+ type RelocMode is (RelocDefault,
+ RelocStatic,
+ RelocPIC,
+ RelocDynamicNoPic);
+ pragma Convention (C, RelocMode);
+
+ type CodeModel is (CodeModelDefault,
+ CodeModelJITDefault,
+ CodeModelSmall,
+ CodeModelKernel,
+ CodeModelMedium,
+ CodeModelLarge);
+ pragma Convention (C, CodeModel);
+
+ type CodeGenFileType is (AssemblyFile,
+ ObjectFile);
+ pragma Convention (C, CodeGenFileType);
+
+ -- Returns the first llvm::Target in the registered targets list.
+ function GetFirstTarget return TargetRef;
+ pragma Import (C, GetFirstTarget, "LLVMGetFirstTarget");
+
+ -- Returns the next llvm::Target given a previous one (or null if there's
+ -- none) */
+ function GetNextTarget(T : TargetRef) return TargetRef;
+ pragma Import (C, GetNextTarget, "LLVMGetNextTarget");
+
+ -- Target
+
+ -- Finds the target corresponding to the given name and stores it in T.
+ -- Returns 0 on success.
+ function GetTargetFromName (Name : Cstring) return TargetRef;
+ pragma Import (C, GetTargetFromName, "LLVMGetTargetFromName");
+
+ -- Finds the target corresponding to the given triple and stores it in T.
+ -- Returns 0 on success. Optionally returns any error in ErrorMessage.
+ -- Use LLVMDisposeMessage to dispose the message.
+ -- Ada: ErrorMessage is the address of a Cstring.
+ function GetTargetFromTriple
+ (Triple : Cstring; T : access TargetRef; ErrorMessage : access Cstring)
+ return Bool;
+ pragma Import (C, GetTargetFromTriple, "LLVMGetTargetFromTriple");
+
+ -- Returns the name of a target. See llvm::Target::getName
+ function GetTargetName (T: TargetRef) return Cstring;
+ pragma Import (C, GetTargetName, "LLVMGetTargetName");
+
+ -- Returns the description of a target. See llvm::Target::getDescription
+ function GetTargetDescription (T : TargetRef) return Cstring;
+ pragma Import (C, GetTargetDescription, "LLVMGetTargetDescription");
+
+ -- Target Machine ----------------------------------------------------
+
+ -- Creates a new llvm::TargetMachine. See llvm::Target::createTargetMachine
+
+ function CreateTargetMachine(T : TargetRef;
+ Triple : Cstring;
+ CPU : Cstring;
+ Features : Cstring;
+ Level : CodeGenOptLevel;
+ Reloc : RelocMode;
+ CM : CodeModel)
+ return TargetMachineRef;
+ pragma Import (C, CreateTargetMachine, "LLVMCreateTargetMachine");
+
+ -- Returns the llvm::DataLayout used for this llvm:TargetMachine.
+ function GetTargetMachineData(T : TargetMachineRef) return TargetDataRef;
+ pragma Import (C, GetTargetMachineData, "LLVMGetTargetMachineData");
+
+ -- Emits an asm or object file for the given module to the filename. This
+ -- wraps several c++ only classes (among them a file stream). Returns any
+ -- error in ErrorMessage. Use LLVMDisposeMessage to dispose the message.
+ function TargetMachineEmitToFile(T : TargetMachineRef;
+ M : ModuleRef;
+ Filename : Cstring;
+ Codegen : CodeGenFileType;
+ ErrorMessage : access Cstring)
+ return Bool;
+ pragma Import (C, TargetMachineEmitToFile,
+ "LLVMTargetMachineEmitToFile");
+
+ -- Get a triple for the host machine as a string. The result needs to be
+ -- disposed with LLVMDisposeMessage.
+ function GetDefaultTargetTriple return Cstring;
+ pragma Import (C, GetDefaultTargetTriple, "LLVMGetDefaultTargetTriple");
+end LLVM.TargetMachine;
diff --git a/src/ortho/llvm/llvm-transforms-scalar.ads b/src/ortho/llvm/llvm-transforms-scalar.ads
new file mode 100644
index 000000000..0f23ce87e
--- /dev/null
+++ b/src/ortho/llvm/llvm-transforms-scalar.ads
@@ -0,0 +1,169 @@
+-- LLVM binding
+-- 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 LLVM.Core; use LLVM.Core;
+
+package LLVM.Transforms.Scalar is
+ -- See llvm::createAggressiveDCEPass function.
+ procedure AddAggressiveDCEPass(PM : PassManagerRef);
+ pragma Import (C, AddAggressiveDCEPass, "LLVMAddAggressiveDCEPass");
+
+ -- See llvm::createCFGSimplificationPass function.
+ procedure AddCFGSimplificationPass(PM : PassManagerRef);
+ pragma Import (C, AddCFGSimplificationPass, "LLVMAddCFGSimplificationPass");
+
+ -- See llvm::createDeadStoreEliminationPass function.
+ procedure AddDeadStoreEliminationPass(PM : PassManagerRef);
+ pragma Import (C, AddDeadStoreEliminationPass,
+ "LLVMAddDeadStoreEliminationPass");
+
+ -- See llvm::createScalarizerPass function.
+ procedure AddScalarizerPass(PM : PassManagerRef);
+ pragma Import (C, AddScalarizerPass, "LLVMAddScalarizerPass");
+
+ -- See llvm::createGVNPass function.
+ procedure AddGVNPass(PM : PassManagerRef);
+ pragma Import (C, AddGVNPass, "LLVMAddGVNPass");
+
+ -- See llvm::createIndVarSimplifyPass function.
+ procedure AddIndVarSimplifyPass(PM : PassManagerRef);
+ pragma Import (C, AddIndVarSimplifyPass, "LLVMAddIndVarSimplifyPass");
+
+ -- See llvm::createInstructionCombiningPass function.
+ procedure AddInstructionCombiningPass(PM : PassManagerRef);
+ pragma Import (C, AddInstructionCombiningPass,
+ "LLVMAddInstructionCombiningPass");
+
+ -- See llvm::createJumpThreadingPass function.
+ procedure AddJumpThreadingPass(PM : PassManagerRef);
+ pragma Import (C, AddJumpThreadingPass, "LLVMAddJumpThreadingPass");
+
+ -- See llvm::createLICMPass function.
+ procedure AddLICMPass(PM : PassManagerRef);
+ pragma Import (C, AddLICMPass, "LLVMAddLICMPass");
+
+ -- See llvm::createLoopDeletionPass function.
+ procedure AddLoopDeletionPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopDeletionPass, "LLVMAddLoopDeletionPass");
+
+ -- See llvm::createLoopIdiomPass function
+ procedure AddLoopIdiomPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopIdiomPass, "LLVMAddLoopIdiomPass");
+
+ -- See llvm::createLoopRotatePass function.
+ procedure AddLoopRotatePass(PM : PassManagerRef);
+ pragma Import (C, AddLoopRotatePass, "LLVMAddLoopRotatePass");
+
+ -- See llvm::createLoopRerollPass function.
+ procedure AddLoopRerollPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopRerollPass, "LLVMAddLoopRerollPass");
+
+ -- See llvm::createLoopUnrollPass function.
+ procedure AddLoopUnrollPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopUnrollPass, "LLVMAddLoopUnrollPass");
+
+ -- See llvm::createLoopUnswitchPass function.
+ procedure AddLoopUnswitchPass(PM : PassManagerRef);
+ pragma Import (C, AddLoopUnswitchPass, "LLVMAddLoopUnswitchPass");
+
+ -- See llvm::createMemCpyOptPass function.
+ procedure AddMemCpyOptPass(PM : PassManagerRef);
+ pragma Import (C, AddMemCpyOptPass, "LLVMAddMemCpyOptPass");
+
+ -- See llvm::createPartiallyInlineLibCallsPass function.
+ procedure AddPartiallyInlineLibCallsPass(PM : PassManagerRef);
+ pragma Import (C, AddPartiallyInlineLibCallsPass,
+ "LLVMAddPartiallyInlineLibCallsPass");
+
+ -- See llvm::createPromoteMemoryToRegisterPass function.
+ procedure AddPromoteMemoryToRegisterPass(PM : PassManagerRef);
+ pragma Import (C, AddPromoteMemoryToRegisterPass,
+ "LLVMAddPromoteMemoryToRegisterPass");
+
+ -- See llvm::createReassociatePass function.
+ procedure AddReassociatePass(PM : PassManagerRef);
+ pragma Import (C, AddReassociatePass, "LLVMAddReassociatePass");
+
+ -- See llvm::createSCCPPass function.
+ procedure AddSCCPPass(PM : PassManagerRef);
+ pragma Import (C, AddSCCPPass, "LLVMAddSCCPPass");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPass(PM : PassManagerRef);
+ pragma Import (C, AddScalarReplAggregatesPass,
+ "LLVMAddScalarReplAggregatesPass");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPassSSA(PM : PassManagerRef);
+ pragma Import (C, AddScalarReplAggregatesPassSSA,
+ "LLVMAddScalarReplAggregatesPassSSA");
+
+ -- See llvm::createScalarReplAggregatesPass function.
+ procedure AddScalarReplAggregatesPassWithThreshold
+ (PM : PassManagerRef; Threshold : Integer);
+ pragma Import (C, AddScalarReplAggregatesPassWithThreshold,
+ "LLVMAddScalarReplAggregatesPassWithThreshold");
+
+ -- See llvm::createSimplifyLibCallsPass function.
+ procedure AddSimplifyLibCallsPass(PM : PassManagerRef);
+ pragma Import (C, AddSimplifyLibCallsPass, "LLVMAddSimplifyLibCallsPass");
+
+ -- See llvm::createTailCallEliminationPass function.
+ procedure AddTailCallEliminationPass(PM : PassManagerRef);
+ pragma Import (C, AddTailCallEliminationPass,
+ "LLVMAddTailCallEliminationPass");
+
+ -- See llvm::createConstantPropagationPass function.
+ procedure AddConstantPropagationPass(PM : PassManagerRef);
+ pragma Import (C, AddConstantPropagationPass,
+ "LLVMAddConstantPropagationPass");
+
+ -- See llvm::demotePromoteMemoryToRegisterPass function.
+ procedure AddDemoteMemoryToRegisterPass(PM : PassManagerRef);
+ pragma Import (C, AddDemoteMemoryToRegisterPass,
+ "LLVMAddDemoteMemoryToRegisterPass");
+
+ -- See llvm::createVerifierPass function.
+ procedure AddVerifierPass(PM : PassManagerRef);
+ pragma Import (C, AddVerifierPass, "LLVMAddVerifierPass");
+
+ -- See llvm::createCorrelatedValuePropagationPass function
+ procedure AddCorrelatedValuePropagationPass(PM : PassManagerRef);
+ pragma Import (C, AddCorrelatedValuePropagationPass,
+ "LLVMAddCorrelatedValuePropagationPass");
+
+ -- See llvm::createEarlyCSEPass function
+ procedure AddEarlyCSEPass(PM : PassManagerRef);
+ pragma Import (C, AddEarlyCSEPass, "LLVMAddEarlyCSEPass");
+
+ -- See llvm::createLowerExpectIntrinsicPass function
+ procedure AddLowerExpectIntrinsicPass(PM : PassManagerRef);
+ pragma Import (C, AddLowerExpectIntrinsicPass,
+ "LLVMAddLowerExpectIntrinsicPass");
+
+ -- See llvm::createTypeBasedAliasAnalysisPass function
+ procedure AddTypeBasedAliasAnalysisPass(PM : PassManagerRef);
+ pragma Import (C, AddTypeBasedAliasAnalysisPass,
+ "LLVMAddTypeBasedAliasAnalysisPass");
+
+ -- See llvm::createBasicAliasAnalysisPass function
+ procedure AddBasicAliasAnalysisPass(PM : PassManagerRef);
+ pragma Import (C, AddBasicAliasAnalysisPass,
+ "LLVMAddBasicAliasAnalysisPass");
+end LLVM.Transforms.Scalar;
+
+
diff --git a/src/ortho/llvm/llvm-transforms.ads b/src/ortho/llvm/llvm-transforms.ads
new file mode 100644
index 000000000..d5a8011ce
--- /dev/null
+++ b/src/ortho/llvm/llvm-transforms.ads
@@ -0,0 +1,21 @@
+-- LLVM binding
+-- 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 LLVM.Transforms is
+ pragma Pure (LLVM.Transforms);
+end LLVM.Transforms;
diff --git a/src/ortho/llvm/llvm.ads b/src/ortho/llvm/llvm.ads
new file mode 100644
index 000000000..80d036b84
--- /dev/null
+++ b/src/ortho/llvm/llvm.ads
@@ -0,0 +1,21 @@
+-- LLVM binding
+-- 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 LLVM is
+ pragma Pure (LLVM);
+end LLVM;
diff --git a/src/ortho/llvm/ortho_code_main.adb b/src/ortho/llvm/ortho_code_main.adb
new file mode 100644
index 000000000..300bb32d1
--- /dev/null
+++ b/src/ortho/llvm/ortho_code_main.adb
@@ -0,0 +1,391 @@
+-- LLVM back-end for ortho - Main subprogram.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Ortho_Front; use Ortho_Front;
+with LLVM.BitWriter;
+with LLVM.Core; use LLVM.Core;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+with LLVM.Target; use LLVM.Target;
+with LLVM.TargetMachine; use LLVM.TargetMachine;
+with LLVM.Analysis;
+with LLVM.Transforms.Scalar;
+with Ortho_LLVM; use Ortho_LLVM;
+with Interfaces;
+with Interfaces.C; use Interfaces.C;
+
+procedure Ortho_Code_Main is
+ -- Name of the output filename (given by option '-o').
+ Output : String_Acc := null;
+
+ type Output_Kind_Type is (Output_Llvm, Output_Bytecode,
+ Output_Assembly, Output_Object);
+ Output_Kind : Output_Kind_Type := Output_Llvm;
+
+ -- True if the LLVM output must be displayed (set by '--dump-llvm')
+ Flag_Dump_Llvm : Boolean := False;
+
+ -- Index of the first file argument.
+ First_File : Natural;
+
+ -- Set by '--exec': function to call and its argument (an integer)
+ Exec_Func : String_Acc := null;
+ Exec_Val : Integer := 0;
+
+ -- Current option index.
+ Optind : Natural;
+
+ -- Number of arguments.
+ Argc : constant Natural := Argument_Count;
+
+ -- Name of the module.
+ Module_Name : String := "ortho" & Ascii.Nul;
+
+ -- Target triple.
+ Triple : Cstring := Empty_Cstring;
+
+ -- Execution engine
+ Engine : aliased ExecutionEngineRef;
+
+ Target : aliased TargetRef;
+
+ CPU : constant Cstring := Empty_Cstring;
+ Features : constant Cstring := Empty_Cstring;
+ Reloc : constant RelocMode := RelocDefault;
+
+ procedure Dump_Llvm
+ is
+ use LLVM.Analysis;
+ Msg : aliased Cstring;
+ begin
+ DumpModule (Module);
+ if LLVM.Analysis.VerifyModule
+ (Module, PrintMessageAction, Msg'Access) /= 0
+ then
+ null;
+ end if;
+ end Dump_Llvm;
+
+ function To_String (C : Cstring) return String is
+ function Strlen (C : Cstring) return Natural;
+ pragma Import (C, Strlen);
+
+ subtype Fat_String is String (Positive);
+ type Fat_String_Acc is access Fat_String;
+
+ function To_Fat_String_Acc is new
+ Ada.Unchecked_Conversion (Cstring, Fat_String_Acc);
+ begin
+ return To_Fat_String_Acc (C)(1 .. Strlen (C));
+ end To_String;
+
+ Codegen : CodeGenFileType := ObjectFile;
+
+ Msg : aliased Cstring;
+begin
+ Ortho_Front.Init;
+
+ -- Decode options.
+ First_File := Natural'Last;
+ Optind := 1;
+ while Optind <= Argc loop
+ declare
+ Arg : constant String := Argument (Optind);
+ begin
+ if Arg (1) = '-' then
+ if Arg = "--dump-llvm" then
+ Flag_Dump_Llvm := True;
+ elsif Arg = "-o" then
+ if Optind = Argc then
+ Put_Line (Standard_Error, "error: missing filename to '-o'");
+ return;
+ end if;
+ Output := new String'(Argument (Optind + 1) & ASCII.Nul);
+ Optind := Optind + 1;
+ elsif Arg = "-quiet" then
+ -- Skip silently.
+ null;
+ elsif Arg = "-S" then
+ Output_Kind := Output_Assembly;
+ Codegen := AssemblyFile;
+ elsif Arg = "-c" then
+ Output_Kind := Output_Object;
+ Codegen := ObjectFile;
+ elsif Arg = "-O0" then
+ Optimization := CodeGenLevelNone;
+ elsif Arg = "-O1" then
+ Optimization := CodeGenLevelLess;
+ elsif Arg = "-O2" then
+ Optimization := CodeGenLevelDefault;
+ elsif Arg = "-O3" then
+ Optimization := CodeGenLevelAggressive;
+ elsif Arg = "--emit-llvm" then
+ Output_Kind := Output_Llvm;
+ elsif Arg = "--emit-bc" then
+ Output_Kind := Output_Bytecode;
+ elsif Arg = "--exec" then
+ if Optind + 1 >= Argc then
+ Put_Line (Standard_Error,
+ "error: missing function name to '--exec'");
+ return;
+ end if;
+ Exec_Func := new String'(Argument (Optind + 1));
+ Exec_Val := Integer'Value (Argument (Optind + 2));
+ Optind := Optind + 2;
+ elsif Arg = "-g" then
+ Flag_Debug := True;
+ else
+ -- This is really an argument.
+ declare
+ procedure Unchecked_Deallocation is
+ new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+
+ Opt : String_Acc := new String'(Arg);
+ Opt_Arg : String_Acc;
+ Res : Natural;
+ begin
+ if Optind < Argument_Count then
+ Opt_Arg := new String'(Argument (Optind + 1));
+ else
+ Opt_Arg := null;
+ end if;
+ Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
+ case Res is
+ when 0 =>
+ Put_Line (Standard_Error,
+ "unknown option '" & Arg & "'");
+ return;
+ when 1 =>
+ null;
+ when 2 =>
+ Optind := Optind + 1;
+ when others =>
+ raise Program_Error;
+ end case;
+ Unchecked_Deallocation (Opt);
+ Unchecked_Deallocation (Opt_Arg);
+ end;
+ end if;
+ else
+ First_File := Optind;
+ exit;
+ end if;
+ end;
+ Optind := Optind + 1;
+ end loop;
+
+ -- Link with LLVM libraries.
+ InitializeNativeTarget;
+ InitializeNativeAsmPrinter;
+
+ LinkInJIT;
+
+ Module := ModuleCreateWithName (Module_Name'Address);
+
+ if Output = null and then Exec_Func /= null then
+ -- Now we going to create JIT
+ if CreateExecutionEngineForModule
+ (Engine'Access, Module, Msg'Access) /= 0
+ then
+ Put_Line (Standard_Error,
+ "cannot create execute: " & To_String (Msg));
+ raise Program_Error;
+ end if;
+
+ Target_Data := GetExecutionEngineTargetData (Engine);
+ else
+ -- Extract target triple
+ Triple := GetDefaultTargetTriple;
+ SetTarget (Module, Triple);
+
+ -- Get Target
+ if GetTargetFromTriple (Triple, Target'Access, Msg'Access) /= 0 then
+ raise Program_Error;
+ end if;
+
+ -- Create a target machine
+ Target_Machine := CreateTargetMachine
+ (Target, Triple, CPU, Features, Optimization, Reloc, CodeModelDefault);
+
+ Target_Data := GetTargetMachineData (Target_Machine);
+ end if;
+
+ SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));
+
+ if False then
+ declare
+ Targ : TargetRef;
+ begin
+ Put_Line ("Triple: " & To_String (Triple));
+ New_Line;
+ Put_Line ("Targets:");
+ Targ := GetFirstTarget;
+ while Targ /= Null_TargetRef loop
+ Put_Line (" " & To_String (GetTargetName (Targ))
+ & ": " & To_String (GetTargetDescription (Targ)));
+ Targ := GetNextTarget (Targ);
+ end loop;
+ end;
+ -- Target_Data := CreateTargetData (Triple);
+ end if;
+
+ Ortho_LLVM.Init;
+
+ Set_Exit_Status (Failure);
+
+ if First_File > Argument_Count then
+ begin
+ if not Parse (null) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ else
+ for I in First_File .. Argument_Count loop
+ declare
+ Filename : constant String_Acc :=
+ new String'(Argument (First_File));
+ begin
+ if not Parse (Filename) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ end loop;
+ end if;
+
+ if Flag_Debug then
+ Ortho_LLVM.Finish_Debug;
+ end if;
+
+ -- Ortho_Mcode.Finish;
+
+ if Flag_Dump_Llvm then
+ Dump_Llvm;
+ end if;
+
+ -- Verify module.
+ if LLVM.Analysis.VerifyModule
+ (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
+ then
+ DisposeMessage (Msg);
+ raise Program_Error;
+ end if;
+
+ if Optimization > CodeGenLevelNone then
+ declare
+ use LLVM.Transforms.Scalar;
+ Global_Manager : constant Boolean := False;
+ Pass_Manager : PassManagerRef;
+ Res : Bool;
+ pragma Unreferenced (Res);
+ A_Func : ValueRef;
+ begin
+ if Global_Manager then
+ Pass_Manager := CreatePassManager;
+ else
+ Pass_Manager := CreateFunctionPassManagerForModule (Module);
+ end if;
+
+ LLVM.Target.AddTargetData (Target_Data, Pass_Manager);
+ AddPromoteMemoryToRegisterPass (Pass_Manager);
+ AddCFGSimplificationPass (Pass_Manager);
+
+ if Global_Manager then
+ Res := RunPassManager (Pass_Manager, Module);
+ else
+ A_Func := GetFirstFunction (Module);
+ while A_Func /= Null_ValueRef loop
+ Res := RunFunctionPassManager (Pass_Manager, A_Func);
+ A_Func := GetNextFunction (A_Func);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ if Output /= null then
+ declare
+ Error : Boolean;
+ begin
+ Msg := Empty_Cstring;
+
+ case Output_Kind is
+ when Output_Assembly
+ | Output_Object =>
+ Error := LLVM.TargetMachine.TargetMachineEmitToFile
+ (Target_Machine, Module,
+ Output.all'Address, Codegen, Msg'Access) /= 0;
+ when Output_Bytecode =>
+ Error := LLVM.BitWriter.WriteBitcodeToFile
+ (Module, Output.all'Address) /= 0;
+ when Output_Llvm =>
+ Error := PrintModuleToFile
+ (Module, Output.all'Address, Msg'Access) /= 0;
+ end case;
+ if Error then
+ Put_Line (Standard_Error,
+ "error while writing to " & Output.all);
+ if Msg /= Empty_Cstring then
+ Put_Line (Standard_Error,
+ "message: " & To_String (Msg));
+ DisposeMessage (Msg);
+ end if;
+ Set_Exit_Status (2);
+ return;
+ end if;
+ end;
+ elsif Exec_Func /= null then
+ declare
+ use Interfaces;
+ Res : GenericValueRef;
+ Vals : GenericValueRefArray (0 .. 0);
+ Func : aliased ValueRef;
+ begin
+ if FindFunction (Engine, Exec_Func.all'Address, Func'Access) /= 0 then
+ raise Program_Error;
+ end if;
+
+ -- Call the function with argument n:
+ Vals (0) := CreateGenericValueOfInt
+ (Int32Type, Unsigned_64 (Exec_Val), 0);
+ Res := RunFunction (Engine, Func, 1, Vals);
+
+ -- import result of execution
+ Put_Line ("Result is "
+ & Unsigned_64'Image (GenericValueToInt (Res, 0)));
+
+ end;
+ else
+ Dump_Llvm;
+ end if;
+
+ Set_Exit_Status (Success);
+exception
+ when others =>
+ Set_Exit_Status (2);
+ raise;
+end Ortho_Code_Main;
diff --git a/src/ortho/llvm/ortho_ident.adb b/src/ortho/llvm/ortho_ident.adb
new file mode 100644
index 000000000..e7b650539
--- /dev/null
+++ b/src/ortho/llvm/ortho_ident.adb
@@ -0,0 +1,134 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Ortho_Ident is
+ type Chunk (Max : Positive);
+ type Chunk_Acc is access Chunk;
+
+ type Chunk (Max : Positive) is record
+ Prev : Chunk_Acc;
+ Len : Natural := 0;
+ S : String (1 .. Max);
+ end record;
+
+ Cur_Chunk : Chunk_Acc := null;
+
+ subtype Fat_String is String (Positive);
+
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ Len : constant Natural := Str'Length;
+ Max : Positive;
+ Org : Positive;
+ begin
+ if Cur_Chunk = null or else Cur_Chunk.Len + Len >= Cur_Chunk.Max then
+ if Cur_Chunk = null then
+ Max := 32 * 1024;
+ else
+ Max := 2 * Cur_Chunk.Max;
+ end if;
+ if Len + 2 > Max then
+ Max := 2 * (Len + 2);
+ end if;
+ declare
+ New_Chunk : Chunk_Acc;
+ begin
+ -- Do not use allocator by expression, as we don't want to
+ -- initialize S.
+ New_Chunk := new Chunk (Max);
+ New_Chunk.Len := 0;
+ New_Chunk.Prev := Cur_Chunk;
+ Cur_Chunk := New_Chunk;
+ end;
+ end if;
+
+ Org := Cur_Chunk.Len + 1;
+ Cur_Chunk.S (Org .. Org + Len - 1) := Str;
+ Cur_Chunk.S (Org + Len) := ASCII.NUL;
+ Cur_Chunk.Len := Org + Len;
+
+ return (Addr => Cur_Chunk.S (Org)'Address);
+ end Get_Identifier;
+
+ function Is_Equal (L, R : O_Ident) return Boolean
+ is
+ begin
+ return L = R;
+ end Is_Equal;
+
+ function Get_String_Length (Id : O_Ident) return Natural
+ is
+ Str : Fat_String;
+ pragma Import (Ada, Str);
+ for Str'Address use Id.Addr;
+ begin
+ for I in Str'Range loop
+ if Str (I) = ASCII.NUL then
+ return I - 1;
+ end if;
+ end loop;
+ raise Program_Error;
+ end Get_String_Length;
+
+ function Get_String (Id : O_Ident) return String
+ is
+ Str : Fat_String;
+ pragma Import (Ada, Str);
+ for Str'Address use Id.Addr;
+ begin
+ for I in Str'Range loop
+ if Str (I) = ASCII.NUL then
+ return Str (1 .. I - 1);
+ end if;
+ end loop;
+ raise Program_Error;
+ end Get_String;
+
+ function Get_Cstring (Id : O_Ident) return System.Address is
+ begin
+ return Id.Addr;
+ end Get_Cstring;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean
+ is
+ Istr : Fat_String;
+ pragma Import (Ada, Istr);
+ for Istr'Address use Id.Addr;
+
+ Str_Len : constant Natural := Str'Length;
+ begin
+ for I in Istr'Range loop
+ if Istr (I) = ASCII.NUL then
+ return I - 1 = Str_Len;
+ end if;
+ if I > Str_Len then
+ return False;
+ end if;
+ if Istr (I) /= Str (Str'First + I - 1) then
+ return False;
+ end if;
+ end loop;
+ raise Program_Error;
+ end Is_Equal;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = O_Ident_Nul;
+ end Is_Nul;
+
+end Ortho_Ident;
diff --git a/src/ortho/llvm/ortho_ident.ads b/src/ortho/llvm/ortho_ident.ads
new file mode 100644
index 000000000..7d3955c02
--- /dev/null
+++ b/src/ortho/llvm/ortho_ident.ads
@@ -0,0 +1,42 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+
+package Ortho_Ident is
+ type O_Ident is private;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Is_Equal (L, R : O_Ident) return Boolean;
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+ function Get_String (Id : O_Ident) return String;
+ function Get_String_Length (Id : O_Ident) return Natural;
+
+ -- Note: the address is always valid.
+ function Get_Cstring (Id : O_Ident) return System.Address;
+
+ O_Ident_Nul : constant O_Ident;
+
+private
+ type O_Ident is record
+ Addr : System.Address;
+ end record;
+ O_Ident_Nul : constant O_Ident := (Addr => System.Null_Address);
+
+ pragma Inline (Get_Cstring);
+end Ortho_Ident;
diff --git a/src/ortho/llvm/ortho_jit.adb b/src/ortho/llvm/ortho_jit.adb
new file mode 100644
index 000000000..fdda667d9
--- /dev/null
+++ b/src/ortho/llvm/ortho_jit.adb
@@ -0,0 +1,151 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Ortho_LLVM; use Ortho_LLVM;
+with Ortho_LLVM.Jit;
+
+with LLVM.Core; use LLVM.Core;
+with LLVM.Target; use LLVM.Target;
+-- with LLVM.TargetMachine; use LLVM.TargetMachine;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+with LLVM.Analysis;
+-- with Interfaces;
+with Interfaces.C; use Interfaces.C;
+
+package body Ortho_Jit is
+ -- Snap_Filename : GNAT.OS_Lib.String_Access := null;
+
+ Flag_Dump_Llvm : Boolean := False;
+
+ -- Name of the module.
+ Module_Name : String := "ortho" & Ascii.Nul;
+
+ -- procedure DisableLazyCompilation (EE : ExecutionEngineRef;
+ -- Disable : int);
+ -- pragma Import (C, DisableLazyCompilation,
+ -- "LLVMDisableLazyCompilation");
+
+ -- Initialize the whole engine.
+ procedure Init
+ is
+ Msg : aliased Cstring;
+ begin
+ InitializeNativeTarget;
+ InitializeNativeAsmPrinter;
+
+ LinkInJIT;
+
+ Module := ModuleCreateWithName (Module_Name'Address);
+
+ -- Now we going to create JIT
+ if CreateExecutionEngineForModule
+ (Ortho_LLVM.Jit.Engine'Access, Module, Msg'Access) /= 0
+ then
+ Put_Line (Standard_Error, "cannot create execution engine");
+ raise Program_Error;
+ end if;
+
+ Target_Data := GetExecutionEngineTargetData (Ortho_LLVM.Jit.Engine);
+ SetDataLayout (Module, CopyStringRepOfTargetData (Target_Data));
+
+ Ortho_LLVM.Init;
+ end Init;
+
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ renames Ortho_LLVM.Jit.Set_Address;
+
+ function Get_Address (Decl : O_Dnode) return Address
+ renames Ortho_LLVM.Jit.Get_Address;
+
+ -- procedure InstallLazyFunctionCreator (EE : ExecutionEngineRef;
+ -- Func : Address);
+ -- pragma Import (C, InstallLazyFunctionCreator,
+ -- "LLVMInstallLazyFunctionCreator");
+
+ -- Do link.
+ procedure Link (Status : out Boolean)
+ is
+ use LLVM.Analysis;
+ Msg : aliased Cstring;
+ begin
+ if Flag_Debug then
+ Ortho_LLVM.Finish_Debug;
+ end if;
+
+ if Flag_Dump_Llvm then
+ DumpModule (Module);
+ end if;
+
+ -- Verify module.
+ if LLVM.Analysis.VerifyModule
+ (Module, LLVM.Analysis.PrintMessageAction, Msg'Access) /= 0
+ then
+ DisposeMessage (Msg);
+ Status := False;
+ return;
+ end if;
+
+ -- FIXME: optim
+ end Link;
+
+ procedure Finish
+ is
+ -- F : ValueRef;
+ -- Addr : Address;
+ -- pragma Unreferenced (Addr);
+ begin
+ null;
+
+ -- if No_Lazy then
+ -- -- Be sure all functions code has been generated.
+ -- F := GetFirstFunction (Module);
+ -- while F /= Null_ValueRef loop
+ -- if GetFirstBasicBlock (F) /= Null_BasicBlockRef then
+ -- -- Only care about defined functions.
+ -- Addr := GetPointerToFunction (EE, F);
+ -- end if;
+ -- F := GetNextFunction (F);
+ -- end loop;
+ -- end if;
+ end Finish;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt = "--llvm-dump" then
+ Flag_Dump_Llvm := True;
+ return True;
+ end if;
+ return False;
+ end Decode_Option;
+
+ procedure Disp_Help is
+ begin
+ null;
+ end Disp_Help;
+
+ function Get_Jit_Name return String is
+ begin
+ return "LLVM";
+ end Get_Jit_Name;
+
+end Ortho_Jit;
diff --git a/src/ortho/llvm/ortho_llvm-jit.adb b/src/ortho/llvm/ortho_llvm-jit.adb
new file mode 100644
index 000000000..9155a02c7
--- /dev/null
+++ b/src/ortho/llvm/ortho_llvm-jit.adb
@@ -0,0 +1,55 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Ortho_LLVM.Jit is
+ -- procedure AddExternalFunction (Name : Cstring; Val : Address);
+ -- pragma Import (C, AddExternalFunction, "ortho_AddExternalFunction");
+
+ function GetPointerToFunction (EE : ExecutionEngineRef; Func : ValueRef)
+ return Address;
+ pragma Import (C, GetPointerToFunction, "LLVMGetPointerToFunction");
+
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address) is
+ begin
+ case Decl.Kind is
+ when ON_Var_Decl | ON_Const_Decl =>
+ AddGlobalMapping (Engine, Decl.LLVM, Addr);
+ when ON_Subprg_Decl =>
+ null;
+ -- AddExternalFunction (GetValueName (Decl.LLVM), Addr);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ is
+ begin
+ case Decl.Kind is
+ when ON_Var_Decl | ON_Const_Decl =>
+ return GetPointerToGlobal (Engine, Decl.LLVM);
+ when ON_Subprg_Decl =>
+ return GetPointerToFunction (Engine, Decl.LLVM);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Get_Address;
+
+end Ortho_LLVM.Jit;
diff --git a/src/ortho/llvm/ortho_llvm-jit.ads b/src/ortho/llvm/ortho_llvm-jit.ads
new file mode 100644
index 000000000..5296e2ed8
--- /dev/null
+++ b/src/ortho/llvm/ortho_llvm-jit.ads
@@ -0,0 +1,31 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with System; use System;
+with LLVM.ExecutionEngine; use LLVM.ExecutionEngine;
+
+package Ortho_LLVM.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address);
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address;
+
+ -- Execution engine
+ Engine : aliased ExecutionEngineRef;
+
+end Ortho_LLVM.Jit;
diff --git a/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb
new file mode 100644
index 000000000..dd8e64971
--- /dev/null
+++ b/src/ortho/llvm/ortho_llvm.adb
@@ -0,0 +1,2881 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with LLVM.Target; use LLVM.Target;
+with GNAT.Directory_Operations;
+
+package body Ortho_LLVM is
+ -- The current function for LLVM (needed to add new basic blocks).
+ Cur_Func : ValueRef;
+
+ -- The current function node (needed for return type).
+ Cur_Func_Decl : O_Dnode;
+
+ -- Wether the code is currently unreachable. LLVM doesn't accept basic
+ -- blocks that cannot be reached (using trivial rules). So we need to
+ -- discard instructions after a return, a next or an exit statement.
+ Unreach : Boolean;
+
+ -- Builder for statements.
+ Builder : BuilderRef;
+
+ -- Builder for declarations (local variables).
+ Decl_Builder : BuilderRef;
+
+ -- Temporary builder.
+ Extra_Builder : BuilderRef;
+
+ -- Declaration of llvm.dbg.declare
+ Llvm_Dbg_Declare : ValueRef;
+
+ Debug_ID : unsigned;
+
+ Current_Directory : constant String :=
+ GNAT.Directory_Operations.Get_Current_Dir;
+
+ -- Additional data for declare blocks.
+ type Declare_Block_Type;
+ type Declare_Block_Acc is access Declare_Block_Type;
+
+ type Declare_Block_Type is record
+ -- First basic block of the declare.
+ Stmt_Bb : BasicBlockRef;
+
+ -- Stack pointer at entry of the block. This value has to be restore
+ -- when leaving the block (either normally or via exit/next). Set only
+ -- if New_Alloca was used.
+ -- FIXME: TODO: restore stack pointer on exit/next stmts.
+ Stack_Value : ValueRef;
+
+ -- Debug data for the scope of the declare block.
+ Dbg_Scope : ValueRef;
+
+ -- Previous element in the stack.
+ Prev : Declare_Block_Acc;
+ end record;
+
+ -- Current declare block.
+ Cur_Declare_Block : Declare_Block_Acc;
+
+ -- Chain of unused blocks to be recycled.
+ Old_Declare_Block : Declare_Block_Acc;
+
+ Stacksave_Fun : ValueRef;
+ Stacksave_Name : constant String := "llvm.stacksave" & ASCII.NUL;
+ Stackrestore_Fun : ValueRef;
+ Stackrestore_Name : constant String := "llvm.stackrestore" & ASCII.NUL;
+
+ -- For debugging
+
+ DW_Version : constant := 16#c_0000#;
+ DW_TAG_Array_Type : constant := DW_Version + 16#01#;
+ DW_TAG_Enumeration_Type : constant := DW_Version + 16#04#;
+ DW_TAG_Lexical_Block : constant := DW_Version + 16#0b#;
+ DW_TAG_Member : constant := DW_Version + 16#0d#;
+ DW_TAG_Pointer_Type : constant := DW_Version + 16#0f#;
+ DW_TAG_Compile_Unit : constant := DW_Version + 16#11#;
+ DW_TAG_Structure_Type : constant := DW_Version + 16#13#;
+ DW_TAG_Subroutine_Type : constant := DW_Version + 16#15#;
+ DW_TAG_Subrange_Type : constant := DW_Version + 16#21#;
+ DW_TAG_Base_Type : constant := DW_Version + 16#24#;
+ DW_TAG_Enumerator : constant := DW_Version + 16#28#;
+ DW_TAG_File_Type : constant := DW_Version + 16#29#;
+ DW_TAG_Subprogram : constant := DW_Version + 16#2e#;
+ DW_TAG_Variable : constant := DW_Version + 16#34#;
+
+ DW_TAG_Auto_Variable : constant := DW_Version + 16#100#;
+ DW_TAG_Arg_Variable : constant := DW_Version + 16#101#;
+
+ DW_ATE_address : constant := 16#01#;
+ DW_ATE_boolean : constant := 16#02#;
+ DW_ATE_float : constant := 16#04#;
+ DW_ATE_signed : constant := 16#05#;
+ DW_ATE_unsigned : constant := 16#07#;
+ pragma Unreferenced (DW_ATE_address, DW_ATE_boolean);
+
+ -- File + Dir metadata
+ Dbg_Current_Filedir : ValueRef;
+ Dbg_Current_File : ValueRef; -- The DW_TAG_File_Type
+
+ Dbg_Current_Line : unsigned := 0;
+
+ Dbg_Current_Scope : ValueRef;
+ Scope_Uniq_Id : Unsigned_64 := 0;
+
+ -- Metadata for the instruction
+ Dbg_Insn_MD : ValueRef;
+ Dbg_Insn_MD_Line : unsigned := 0;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (ValueRefArray, ValueRefArray_Acc);
+
+ package Dbg_Utils is
+ type Dyn_MDNode is private;
+
+ procedure Append (D : in out Dyn_MDNode; Val : ValueRef);
+ function Get_Value (D : Dyn_MDNode) return ValueRef;
+
+ -- Reset D. FIXME: should be done automatically within Get_Value.
+ procedure Clear (D : out Dyn_MDNode);
+ private
+ Chunk_Length : constant unsigned := 32;
+ type MD_Chunk;
+ type MD_Chunk_Acc is access MD_Chunk;
+
+ type MD_Chunk is record
+ Vals : ValueRefArray (1 .. Chunk_Length);
+ Next : MD_Chunk_Acc;
+ end record;
+
+ type Dyn_MDNode is record
+ First : MD_Chunk_Acc;
+ Last : MD_Chunk_Acc;
+ Nbr : unsigned := 0;
+ end record;
+ end Dbg_Utils;
+
+ package body Dbg_Utils is
+ procedure Append (D : in out Dyn_MDNode; Val : ValueRef) is
+ Chunk : MD_Chunk_Acc;
+ Pos : constant unsigned := D.Nbr rem Chunk_Length;
+ begin
+ if Pos = 0 then
+ Chunk := new MD_Chunk;
+ if D.First = null then
+ D.First := Chunk;
+ else
+ D.Last.Next := Chunk;
+ end if;
+ D.Last := Chunk;
+ else
+ Chunk := D.Last;
+ end if;
+ Chunk.Vals (Pos + 1) := Val;
+ D.Nbr := D.Nbr + 1;
+ end Append;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (MD_Chunk, MD_Chunk_Acc);
+
+ function Get_Value (D : Dyn_MDNode) return ValueRef
+ is
+ Vals : ValueRefArray (1 .. D.Nbr);
+ Pos : unsigned;
+ Chunk : MD_Chunk_Acc := D.First;
+ Next_Chunk : MD_Chunk_Acc;
+ Nbr : constant unsigned := D.Nbr;
+ begin
+ Pos := 0;
+ -- Copy by chunks
+ while Pos + Chunk_Length < Nbr loop
+ Vals (Pos + 1 .. Pos + Chunk_Length) := Chunk.Vals;
+ Pos := Pos + Chunk_Length;
+ Next_Chunk := Chunk.Next;
+ Free (Chunk);
+ Chunk := Next_Chunk;
+ end loop;
+ -- Last chunk
+ if Pos < Nbr then
+ Vals (Pos + 1 .. Pos + Nbr - Pos) := Chunk.Vals (1 .. Nbr - Pos);
+ Free (Chunk);
+ end if;
+ return MDNode (Vals, Vals'Length);
+ end Get_Value;
+
+ procedure Clear (D : out Dyn_MDNode) is
+ begin
+ D := (null, null, 0);
+ end Clear;
+ end Dbg_Utils;
+
+ use Dbg_Utils;
+
+ -- List of debug info for subprograms.
+ Subprg_Nodes: Dyn_MDNode;
+
+ -- List of literals for enumerated type
+ Enum_Nodes : Dyn_MDNode;
+
+ -- List of global variables
+ Global_Nodes : Dyn_MDNode;
+
+ -- Create a MDString from an Ada string.
+ function MDString (Str : String) return ValueRef is
+ begin
+ return MDString (Str'Address, Str'Length);
+ end MDString;
+
+ function MDString (Id : O_Ident) return ValueRef is
+ begin
+ return MDString (Get_Cstring (Id), unsigned (Get_String_Length (Id)));
+ end MDString;
+
+ function Dbg_Size (Atype : TypeRef) return ValueRef is
+ begin
+ return ConstInt (Int64Type, 8 * ABISizeOfType (Target_Data, Atype), 0);
+ end Dbg_Size;
+
+ function Dbg_Align (Atype : TypeRef) return ValueRef is
+ begin
+ return ConstInt
+ (Int64Type,
+ Unsigned_64 (8 * ABIAlignmentOfType (Target_Data, Atype)), 0);
+ end Dbg_Align;
+
+ function Dbg_Line return ValueRef is
+ begin
+ return ConstInt (Int32Type, Unsigned_64 (Dbg_Current_Line), 0);
+ end Dbg_Line;
+
+ -- Set debug metadata on instruction INSN.
+ -- FIXME: check if INSN is really an instruction
+ procedure Set_Insn_Dbg (Insn : ValueRef) is
+ begin
+ if Flag_Debug then
+ if Dbg_Current_Line /= Dbg_Insn_MD_Line then
+ declare
+ Vals : ValueRefArray (0 .. 3);
+ begin
+ Vals := (Dbg_Line,
+ ConstInt (Int32Type, 0, 0), -- col
+ Dbg_Current_Scope, -- context
+ Null_ValueRef); -- inline
+ Dbg_Insn_MD := MDNode (Vals, Vals'Length);
+ Dbg_Insn_MD_Line := Dbg_Current_Line;
+ end;
+ end if;
+ SetMetadata (Insn, Debug_ID, Dbg_Insn_MD);
+ end if;
+ end Set_Insn_Dbg;
+
+ procedure Dbg_Create_Variable (Tag : Unsigned_32;
+ Ident : O_Ident;
+ Vtype : O_Tnode;
+ Argno : Natural;
+ Addr : ValueRef)
+ is
+ Vals : ValueRefArray (0 .. 7);
+ Str : constant ValueRef := MDString (Ident);
+ Call_Vals : ValueRefArray (0 .. 1);
+ Call : ValueRef;
+ begin
+ Vals := (ConstInt (Int32Type, Unsigned_64 (Tag), 0),
+ Dbg_Current_Scope,
+ Str,
+ Dbg_Current_File,
+ ConstInt (Int32Type,
+ Unsigned_64 (Dbg_Current_Line)
+ + Unsigned_64 (Argno) * 2 ** 24, 0),
+ Vtype.Dbg,
+ ConstInt (Int32Type, 0, 0), -- flags
+ ConstInt (Int32Type, 0, 0));
+
+ Call_Vals := (MDNode ((0 => Addr), 1),
+ MDNode (Vals, Vals'Length));
+ Call := BuildCall (Decl_Builder, Llvm_Dbg_Declare,
+ Call_Vals, Call_Vals'Length, Empty_Cstring);
+ Set_Insn_Dbg (Call);
+ end Dbg_Create_Variable;
+
+ procedure Create_Declare_Block
+ is
+ Res : Declare_Block_Acc;
+ begin
+ -- Try to recycle an unused record.
+ if Old_Declare_Block /= null then
+ Res := Old_Declare_Block;
+ Old_Declare_Block := Res.Prev;
+ else
+ -- Create a new one if no unused records.
+ Res := new Declare_Block_Type;
+ end if;
+
+ -- Chain.
+ Res.all := (Stmt_Bb => Null_BasicBlockRef,
+ Stack_Value => Null_ValueRef,
+ Dbg_Scope => Null_ValueRef,
+ Prev => Cur_Declare_Block);
+ Cur_Declare_Block := Res;
+
+ if not Unreach then
+ Res.Stmt_Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ end if;
+ end Create_Declare_Block;
+
+ procedure Destroy_Declare_Block
+ is
+ Blk : constant Declare_Block_Acc := Cur_Declare_Block;
+ begin
+ -- Unchain.
+ Cur_Declare_Block := Blk.Prev;
+
+ -- Put on the recyle list.
+ Blk.Prev := Old_Declare_Block;
+ Old_Declare_Block := Blk;
+ end Destroy_Declare_Block;
+
+ -----------------------
+ -- Start_Record_Type --
+ -----------------------
+
+ procedure Start_Record_Type (Elements : out O_Element_List) is
+ begin
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => O_Tnode_Null,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Record_Type;
+
+ ----------------------
+ -- New_Record_Field --
+ ----------------------
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode)
+ is
+ O_El : O_Element_Acc;
+ begin
+ El := (Kind => OF_Record,
+ Index => Elements.Nbr_Elements,
+ Ftype => Etype);
+ Elements.Nbr_Elements := Elements.Nbr_Elements + 1;
+ O_El := new O_Element'(Next => null,
+ Etype => Etype,
+ Ident => Ident);
+ if Elements.First_Elem = null then
+ Elements.First_Elem := O_El;
+ else
+ Elements.Last_Elem.Next := O_El;
+ end if;
+ Elements.Last_Elem := O_El;
+ end New_Record_Field;
+
+ ------------------------
+ -- Finish_Record_Type --
+ ------------------------
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List;
+ Res : out O_Tnode)
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (O_Element, O_Element_Acc);
+
+ Count : constant unsigned := unsigned (Elements.Nbr_Elements);
+ El : O_Element_Acc;
+ Next_El : O_Element_Acc;
+ Types : TypeRefArray (1 .. Count);
+ begin
+ El := Elements.First_Elem;
+ for I in Types'Range loop
+ Types (I) := Get_LLVM_Type (El.Etype);
+ El := El.Next;
+ end loop;
+
+ if Elements.Rec_Type /= null then
+ -- Completion
+ StructSetBody (Elements.Rec_Type.LLVM, Types, Count, 0);
+ Res := Elements.Rec_Type;
+ else
+ Res := new O_Tnode_Type'(Kind => ON_Record_Type,
+ LLVM => StructType (Types, Count, 0),
+ Dbg => Null_ValueRef);
+ end if;
+
+ if Flag_Debug then
+ declare
+ Fields : ValueRefArray (1 .. Count);
+ Vals : ValueRefArray (0 .. 9);
+ Ftype : TypeRef;
+ Fields_Arr : ValueRef;
+ begin
+ El := Elements.First_Elem;
+ for I in Fields'Range loop
+ Ftype := Get_LLVM_Type (El.Etype);
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Member, 0),
+ Dbg_Current_File,
+ Null_ValueRef,
+ MDString (El.Ident),
+ ConstInt (Int32Type, 0, 0), -- linenum
+ Dbg_Size (Ftype),
+ Dbg_Align (Ftype),
+ ConstInt
+ (Int32Type,
+ 8 * OffsetOfElement (Target_Data,
+ Res.LLVM, Unsigned_32 (I - 1)), 0),
+ ConstInt (Int32Type, 0, 0), -- Flags
+ El.Etype.Dbg);
+ Fields (I) := MDNode (Vals, Vals'Length);
+ El := El.Next;
+ end loop;
+ Fields_Arr := MDNode (Fields, Fields'Length);
+ if Elements.Rec_Type /= null then
+ -- Completion
+ MDNodeReplaceOperandWith (Res.Dbg, 10, Fields_Arr);
+ MDNodeReplaceOperandWith (Res.Dbg, 5, Dbg_Size (Res.LLVM));
+ MDNodeReplaceOperandWith (Res.Dbg, 6, Dbg_Align (Res.LLVM));
+ else
+ -- Temporary borrowed.
+ Res.Dbg := Fields_Arr;
+ end if;
+ end;
+ end if;
+
+ -- Free elements
+ El := Elements.First_Elem;
+ for I in Types'Range loop
+ Next_El := El.Next;
+ Free (El);
+ El := Next_El;
+ end loop;
+ end Finish_Record_Type;
+
+ --------------------------------
+ -- New_Uncomplete_Record_Type --
+ --------------------------------
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
+ begin
+ -- LLVM type will be created when the type is declared.
+ Res := new O_Tnode_Type'(Kind => ON_Incomplete_Record_Type,
+ LLVM => Null_TypeRef,
+ Dbg => Null_ValueRef);
+ end New_Uncomplete_Record_Type;
+
+ ----------------------------------
+ -- Start_Uncomplete_Record_Type --
+ ----------------------------------
+
+ procedure Start_Uncomplete_Record_Type
+ (Res : O_Tnode;
+ Elements : out O_Element_List)
+ is
+ begin
+ if Res.Kind /= ON_Incomplete_Record_Type then
+ raise Program_Error;
+ end if;
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => Res,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Uncomplete_Record_Type;
+
+ ----------------------
+ -- Start_Union_Type --
+ ----------------------
+
+ procedure Start_Union_Type (Elements : out O_Element_List) is
+ begin
+ Elements := (Nbr_Elements => 0,
+ Rec_Type => O_Tnode_Null,
+ Size => 0,
+ Align => 0,
+ Align_Type => Null_TypeRef,
+ First_Elem => null,
+ Last_Elem => null);
+ end Start_Union_Type;
+
+ ---------------------
+ -- New_Union_Field --
+ ---------------------
+
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode)
+ is
+ pragma Unreferenced (Ident);
+
+ El_Type : constant TypeRef := Get_LLVM_Type (Etype);
+ Size : constant unsigned :=
+ unsigned (ABISizeOfType (Target_Data, El_Type));
+ Align : constant Unsigned_32 :=
+ ABIAlignmentOfType (Target_Data, El_Type);
+ begin
+ El := (Kind => OF_Union, Utype => El_Type, Ftype => Etype);
+ if Size > Elements.Size then
+ Elements.Size := Size;
+ end if;
+ if Elements.Align_Type = Null_TypeRef or else Align > Elements.Align then
+ Elements.Align := Align;
+ Elements.Align_Type := El_Type;
+ end if;
+ end New_Union_Field;
+
+ -----------------------
+ -- Finish_Union_Type --
+ -----------------------
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List;
+ Res : out O_Tnode)
+ is
+ Count : unsigned;
+ Types : TypeRefArray (1 .. 2);
+ Pad : unsigned;
+ begin
+ if Elements.Align_Type = Null_TypeRef then
+ -- An empty union. Is it allowed ?
+ Count := 0;
+ else
+ -- The first element is the field with the biggest alignment
+ Types (1) := Elements.Align_Type;
+ -- Possibly complete with an array of bytes.
+ Pad := Elements.Size
+ - unsigned (ABISizeOfType (Target_Data, Elements.Align_Type));
+ if Pad /= 0 then
+ Types (2) := ArrayType (Int8Type, Pad);
+ Count := 2;
+ else
+ Count := 1;
+ end if;
+ end if;
+ Res := new O_Tnode_Type'(Kind => ON_Union_Type,
+ LLVM => StructType (Types, Count, 0),
+ Dbg => Null_ValueRef,
+ Un_Size => Elements.Size,
+ Un_Main_Field => Elements.Align_Type);
+ end Finish_Union_Type;
+
+ ---------------------
+ -- New_Access_Type --
+ ---------------------
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode is
+ begin
+ if Dtype = O_Tnode_Null then
+ -- LLVM type will be built by New_Type_Decl, so that the name
+ -- can be used for the structure.
+ return new O_Tnode_Type'(Kind => ON_Incomplete_Access_Type,
+ LLVM => Null_TypeRef,
+ Dbg => Null_ValueRef,
+ Acc_Type => O_Tnode_Null);
+ else
+ return new O_Tnode_Type'(Kind => ON_Access_Type,
+ LLVM => PointerType (Get_LLVM_Type (Dtype)),
+ Dbg => Null_ValueRef,
+ Acc_Type => Dtype);
+ end if;
+ end New_Access_Type;
+
+ ------------------------
+ -- Finish_Access_Type --
+ ------------------------
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
+ is
+ Types : TypeRefArray (1 .. 1);
+ begin
+ if Atype.Kind /= ON_Incomplete_Access_Type then
+ -- Not an incomplete access type.
+ raise Program_Error;
+ end if;
+ if Atype.Acc_Type /= O_Tnode_Null then
+ -- Already completed.
+ raise Program_Error;
+ end if;
+ -- Completion
+ Types (1) := Get_LLVM_Type (Dtype);
+ StructSetBody (GetElementType (Atype.LLVM), Types, Types'Length, 0);
+ Atype.Acc_Type := Dtype;
+
+ -- Debug.
+ -- FIXME.
+ end Finish_Access_Type;
+
+ --------------------
+ -- New_Array_Type --
+ --------------------
+
+ function Dbg_Array (El_Type : O_Tnode; Len : ValueRef; Atype : O_Tnode)
+ return ValueRef
+ is
+ Rng : ValueRefArray (0 .. 2);
+ Rng_Arr : ValueRefArray (0 .. 0);
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Rng := (ConstInt (Int32Type, DW_TAG_Subrange_Type, 0),
+ ConstInt (Int64Type, 0, 0), -- Lo
+ Len); -- Count
+ Rng_Arr := (0 => MDNode (Rng, Rng'Length));
+ Vals := (ConstInt (Int32Type, DW_TAG_Array_Type, 0),
+ Null_ValueRef,
+ Null_ValueRef, -- context
+ Null_ValueRef,
+ ConstInt (Int32Type, 0, 0), -- line
+ Dbg_Size (Atype.LLVM),
+ Dbg_Align (Atype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ El_Type.Dbg, -- element type
+ MDNode (Rng_Arr, Rng_Arr'Length), -- subscript
+ ConstInt (Int32Type, 0, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ Null_ValueRef); -- Runtime lang
+ return MDNode (Vals, Vals'Length);
+ end Dbg_Array;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode
+ is
+ pragma Unreferenced (Index_Type);
+ Res : O_Tnode;
+ begin
+ Res := new O_Tnode_Type'
+ (Kind => ON_Array_Type,
+ LLVM => ArrayType (Get_LLVM_Type (El_Type), 0),
+ Dbg => Null_ValueRef,
+ Arr_El_Type => El_Type);
+
+ if Flag_Debug then
+ Res.Dbg := Dbg_Array
+ (El_Type, ConstInt (Int64Type, Unsigned_64'Last, 1), Res);
+ end if;
+
+ return Res;
+ end New_Array_Type;
+
+ --------------------------------
+ -- New_Constrained_Array_Type --
+ --------------------------------
+
+ function New_Constrained_Array_Type
+ (Atype : O_Tnode; Length : O_Cnode) return O_Tnode
+ is
+ Res : O_Tnode;
+ Len : constant unsigned := unsigned (ConstIntGetZExtValue (Length.LLVM));
+ begin
+ Res := new O_Tnode_Type'
+ (Kind => ON_Array_Sub_Type,
+ LLVM => ArrayType (GetElementType (Get_LLVM_Type (Atype)), Len),
+ Dbg => Null_ValueRef,
+ Arr_El_Type => Atype.Arr_El_Type);
+
+ if Flag_Debug then
+ Res.Dbg := Dbg_Array
+ (Atype.Arr_El_Type,
+ ConstInt (Int64Type, Unsigned_64 (Len), 0), Res);
+ end if;
+
+ return Res;
+ end New_Constrained_Array_Type;
+
+ -----------------------
+ -- New_Unsigned_Type --
+ -----------------------
+
+ function Size_To_Llvm (Size : Natural) return TypeRef is
+ Llvm : TypeRef;
+ begin
+ case Size is
+ when 8 =>
+ Llvm := Int8Type;
+ when 32 =>
+ Llvm := Int32Type;
+ when 64 =>
+ Llvm := Int64Type;
+ when others =>
+ raise Program_Error;
+ end case;
+ return Llvm;
+ end Size_To_Llvm;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Unsigned_Type,
+ LLVM => Size_To_Llvm (Size),
+ Dbg => Null_ValueRef,
+ Scal_Size => Size);
+ end New_Unsigned_Type;
+
+ ---------------------
+ -- New_Signed_Type --
+ ---------------------
+
+ function New_Signed_Type (Size : Natural) return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Signed_Type,
+ LLVM => Size_To_Llvm (Size),
+ Dbg => Null_ValueRef,
+ Scal_Size => Size);
+ end New_Signed_Type;
+
+ --------------------
+ -- New_Float_Type --
+ --------------------
+
+ function New_Float_Type return O_Tnode is
+ begin
+ return new O_Tnode_Type'(Kind => ON_Float_Type,
+ LLVM => DoubleType,
+ Dbg => Null_ValueRef,
+ Scal_Size => 64);
+ end New_Float_Type;
+
+ procedure Dbg_Add_Enumeration (Id : O_Ident; Val : Unsigned_64) is
+ Vals : ValueRefArray (0 .. 2);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Enumerator, 0),
+ MDString (Id),
+ ConstInt (Int64Type, Val, 0));
+ -- FIXME: make it local to List ?
+ Append (Enum_Nodes, MDNode (Vals, Vals'Length));
+ end Dbg_Add_Enumeration;
+
+ ----------------------
+ -- New_Boolean_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
+ begin
+ Res := new O_Tnode_Type'(Kind => ON_Boolean_Type,
+ LLVM => Int1Type,
+ Dbg => Null_ValueRef,
+ Scal_Size => 1);
+ False_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 0, 0),
+ Ctype => Res);
+ True_E := O_Cnode'(LLVM => ConstInt (Res.LLVM, 1, 0),
+ Ctype => Res);
+ if Flag_Debug then
+ Dbg_Add_Enumeration (False_Id, 0);
+ Dbg_Add_Enumeration (True_Id, 1);
+ end if;
+ end New_Boolean_Type;
+
+ ---------------------
+ -- Start_Enum_Type --
+ ---------------------
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
+ is
+ LLVM : constant TypeRef := Size_To_Llvm (Size);
+ begin
+ List := (LLVM => LLVM,
+ Num => 0,
+ Etype => new O_Tnode_Type'(Kind => ON_Enum_Type,
+ LLVM => LLVM,
+ Scal_Size => Size,
+ Dbg => Null_ValueRef));
+
+ end Start_Enum_Type;
+
+ ----------------------
+ -- New_Enum_Literal --
+ ----------------------
+
+ procedure New_Enum_Literal
+ (List : in out O_Enum_List; Ident : O_Ident; Res : out O_Cnode)
+ is
+ begin
+ Res := O_Cnode'(LLVM => ConstInt (List.LLVM, Unsigned_64 (List.Num), 0),
+ Ctype => List.Etype);
+ if Flag_Debug then
+ Dbg_Add_Enumeration (Ident, Unsigned_64 (List.Num));
+ end if;
+
+ List.Num := List.Num + 1;
+ end New_Enum_Literal;
+
+ ----------------------
+ -- Finish_Enum_Type --
+ ----------------------
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Res := List.Etype;
+ end Finish_Enum_Type;
+
+ ------------------------
+ -- New_Signed_Literal --
+ ------------------------
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode
+ is
+ function To_Unsigned_64 is new Ada.Unchecked_Conversion
+ (Integer_64, Unsigned_64);
+ begin
+ return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype),
+ To_Unsigned_64 (Value), 1),
+ Ctype => Ltype);
+ end New_Signed_Literal;
+
+ --------------------------
+ -- New_Unsigned_Literal --
+ --------------------------
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstInt (Get_LLVM_Type (Ltype), Value, 0),
+ Ctype => Ltype);
+ end New_Unsigned_Literal;
+
+ -----------------------
+ -- New_Float_Literal --
+ -----------------------
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstReal (Get_LLVM_Type (Ltype),
+ Interfaces.C.double (Value)),
+ Ctype => Ltype);
+ end New_Float_Literal;
+
+ ---------------------
+ -- New_Null_Access --
+ ---------------------
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstNull (Get_LLVM_Type (Ltype)),
+ Ctype => Ltype);
+ end New_Null_Access;
+
+ -----------------------
+ -- Start_Record_Aggr --
+ -----------------------
+
+ procedure Start_Record_Aggr
+ (List : out O_Record_Aggr_List;
+ Atype : O_Tnode)
+ is
+ Llvm : constant TypeRef := Get_LLVM_Type (Atype);
+ begin
+ List :=
+ (Len => 0,
+ Vals => new ValueRefArray (1 .. CountStructElementTypes (Llvm)),
+ Atype => Atype);
+ end Start_Record_Aggr;
+
+ ------------------------
+ -- New_Record_Aggr_El --
+ ------------------------
+
+ procedure New_Record_Aggr_El
+ (List : in out O_Record_Aggr_List; Value : O_Cnode)
+ is
+ begin
+ List.Len := List.Len + 1;
+ List.Vals (List.Len) := Value.LLVM;
+ end New_Record_Aggr_El;
+
+ ------------------------
+ -- Finish_Record_Aggr --
+ ------------------------
+
+ procedure Finish_Record_Aggr
+ (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode)
+ is
+ begin
+ Res := (LLVM => ConstStruct (List.Vals.all, List.Len, 0),
+ Ctype => List.Atype);
+ Free (List.Vals);
+ end Finish_Record_Aggr;
+
+ ----------------------
+ -- Start_Array_Aggr --
+ ----------------------
+
+ procedure Start_Array_Aggr
+ (List : out O_Array_Aggr_List;
+ Atype : O_Tnode)
+ is
+ Llvm : constant TypeRef := Get_LLVM_Type (Atype);
+ begin
+ List := (Len => 0,
+ Vals => new ValueRefArray (1 .. GetArrayLength (Llvm)),
+ El_Type => GetElementType (Llvm),
+ Atype => Atype);
+ end Start_Array_Aggr;
+
+ -----------------------
+ -- New_Array_Aggr_El --
+ -----------------------
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode)
+ is
+ begin
+ List.Len := List.Len + 1;
+ List.Vals (List.Len) := Value.LLVM;
+ end New_Array_Aggr_El;
+
+ -----------------------
+ -- Finish_Array_Aggr --
+ -----------------------
+
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode)
+ is
+ begin
+ Res := (LLVM => ConstArray (List.El_Type,
+ List.Vals.all, List.Len),
+ Ctype => List.Atype);
+ Free (List.Vals);
+ end Finish_Array_Aggr;
+
+ --------------------
+ -- New_Union_Aggr --
+ --------------------
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode
+ is
+ Values : ValueRefArray (1 .. 2);
+ Count : unsigned;
+ Size : constant unsigned :=
+ unsigned (ABISizeOfType (Target_Data, Field.Utype));
+
+ begin
+ Values (1) := Value.LLVM;
+ if Size < Atype.Un_Size then
+ Values (2) := GetUndef (ArrayType (Int8Type, Atype.Un_Size - Size));
+ Count := 2;
+ else
+ Count := 1;
+ end if;
+
+ -- If `FIELD` is the main field of the union, create a struct using
+ -- the same type as the union (and possibly pad).
+ if Field.Utype = Atype.Un_Main_Field then
+ return O_Cnode'
+ (LLVM => ConstNamedStruct (Atype.LLVM, Values, Count),
+ Ctype => Atype);
+ else
+ -- Create an on-the-fly record.
+ return O_Cnode'(LLVM => ConstStruct (Values, Count, 0),
+ Ctype => Atype);
+ end if;
+ end New_Union_Aggr;
+
+ ----------------
+ -- New_Sizeof --
+ ----------------
+
+ -- Return VAL with type RTYPE (either unsigned or access)
+ function Const_To_Cnode (Rtype : O_Tnode; Val : Unsigned_64) return O_Cnode
+ is
+ Tmp : ValueRef;
+ begin
+ case Rtype.Kind is
+ when ON_Scalar_Types =>
+ -- Well, unsigned in fact.
+ return O_Cnode'(LLVM => ConstInt (Rtype.LLVM, Val, 0),
+ Ctype => Rtype);
+ when ON_Access_Type =>
+ Tmp := ConstInt (Int64Type, Val, 0);
+ return O_Cnode'(LLVM => ConstIntToPtr (Tmp, Rtype.LLVM),
+ Ctype => Rtype);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Const_To_Cnode;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype, ABISizeOfType (Target_Data, Get_LLVM_Type (Atype)));
+ end New_Sizeof;
+
+ -----------------
+ -- New_Alignof --
+ -----------------
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype,
+ Unsigned_64
+ (ABIAlignmentOfType (Target_Data, Get_LLVM_Type (Atype))));
+ end New_Alignof;
+
+ ------------------
+ -- New_Offsetof --
+ ------------------
+
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ return Const_To_Cnode
+ (Rtype,
+ OffsetOfElement (Target_Data,
+ Get_LLVM_Type (Atype),
+ Unsigned_32 (Field.Index)));
+ end New_Offsetof;
+
+ ----------------------------
+ -- New_Subprogram_Address --
+ ----------------------------
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode'
+ (LLVM => ConstBitCast (Subprg.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Subprogram_Address;
+
+ ------------------------
+ -- New_Global_Address --
+ ------------------------
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Global_Address;
+
+ ----------------------------------
+ -- New_Global_Unchecked_Address --
+ ----------------------------------
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ begin
+ return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ Ctype => Atype);
+ end New_Global_Unchecked_Address;
+
+ -------------
+ -- New_Lit --
+ -------------
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ begin
+ return O_Enode'(LLVM => Lit.LLVM,
+ Etype => Lit.Ctype);
+ end New_Lit;
+
+ -------------------
+ -- New_Dyadic_Op --
+ -------------------
+
+ function New_Smod (L, R : ValueRef; Res_Type : TypeRef)
+ return ValueRef
+ is
+ Cond : ValueRef;
+ Br : ValueRef;
+ pragma Unreferenced (Br);
+
+ -- The result of 'L rem R'.
+ Rm : ValueRef;
+
+ -- Rm + R
+ Rm_Plus_R : ValueRef;
+
+ -- The result of 'L xor R'.
+ R_Xor : ValueRef;
+
+ Adj : ValueRef;
+ Phi : ValueRef;
+
+ -- Basic basic for the non-overflow branch
+ Normal_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ Adjust_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ -- Basic block after the result
+ Next_Bb : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ Vals : ValueRefArray (1 .. 3);
+ BBs : BasicBlockRefArray (1 .. 3);
+ begin
+ -- Avoid overflow with -1:
+ -- if R = -1 then
+ -- result := 0;
+ -- else
+ -- ...
+ Cond := BuildICmp
+ (Builder, IntEQ, R, ConstAllOnes (Res_Type), Empty_Cstring);
+ Br := BuildCondBr (Builder, Cond, Next_Bb, Normal_Bb);
+ Vals (1) := ConstNull (Res_Type);
+ BBs (1) := GetInsertBlock (Builder);
+
+ -- Rm := Left rem Right
+ PositionBuilderAtEnd (Builder, Normal_Bb);
+ Rm := BuildSRem (Builder, L, R, Empty_Cstring);
+
+ -- if R = 0 then
+ -- result := 0
+ -- else
+ Cond := BuildICmp
+ (Builder, IntEQ, Rm, ConstNull (Res_Type), Empty_Cstring);
+ Br := BuildCondBr (Builder, Cond, Next_Bb, Adjust_Bb);
+ Vals (2) := ConstNull (Res_Type);
+ BBs (2) := Normal_Bb;
+
+ -- if L xor R < 0 then
+ -- result := Rm + R
+ -- else
+ -- result := Rm;
+ -- end if;
+ PositionBuilderAtEnd (Builder, Adjust_Bb);
+ R_Xor := BuildXor (Builder, L, R, Empty_Cstring);
+ Cond := BuildICmp
+ (Builder, IntSLT, R_Xor, ConstNull (Res_Type), Empty_Cstring);
+ Rm_Plus_R := BuildAdd (Builder, Rm, R, Empty_Cstring);
+ Adj := BuildSelect (Builder, Cond, Rm_Plus_R, Rm, Empty_Cstring);
+ Br := BuildBr (Builder, Next_Bb);
+ Vals (3) := Adj;
+ BBs (3) := Adjust_Bb;
+
+ -- The Phi node
+ PositionBuilderAtEnd (Builder, Next_Bb);
+ Phi := BuildPhi (Builder, Res_Type, Empty_Cstring);
+ AddIncoming (Phi, Vals, BBs, Vals'Length);
+
+ return Phi;
+ end New_Smod;
+
+ type Dyadic_Builder_Acc is access
+ function (Builder : BuilderRef;
+ LHS : ValueRef; RHS : ValueRef; Name : Cstring)
+ return ValueRef;
+ pragma Convention (C, Dyadic_Builder_Acc);
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ Build : Dyadic_Builder_Acc := null;
+ Res : ValueRef := Null_ValueRef;
+ begin
+ if Unreach then
+ return O_Enode'(LLVM => Null_ValueRef, Etype => Left.Etype);
+ end if;
+
+ case Left.Etype.Kind is
+ when ON_Integer_Types =>
+ case Kind is
+ when ON_And =>
+ Build := BuildAnd'Access;
+ when ON_Or =>
+ Build := BuildOr'Access;
+ when ON_Xor =>
+ Build := BuildXor'Access;
+
+ when ON_Add_Ov =>
+ Build := BuildAdd'Access;
+ when ON_Sub_Ov =>
+ Build := BuildSub'Access;
+ when ON_Mul_Ov =>
+ Build := BuildMul'Access;
+
+ when ON_Div_Ov =>
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type =>
+ Build := BuildUDiv'Access;
+ when ON_Signed_Type =>
+ Build := BuildSDiv'Access;
+ when others =>
+ null;
+ end case;
+
+ when ON_Mod_Ov
+ | ON_Rem_Ov => -- FIXME...
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type =>
+ Build := BuildURem'Access;
+ when ON_Signed_Type =>
+ if Kind = ON_Rem_Ov then
+ Build := BuildSRem'Access;
+ else
+ Res := New_Smod
+ (Left.LLVM, Right.LLVM, Left.Etype.LLVM);
+ end if;
+ when others =>
+ null;
+ end case;
+ end case;
+
+ when ON_Float_Type =>
+ case Kind is
+ when ON_Add_Ov =>
+ Build := BuildFAdd'Access;
+ when ON_Sub_Ov =>
+ Build := BuildFSub'Access;
+ when ON_Mul_Ov =>
+ Build := BuildFMul'Access;
+ when ON_Div_Ov =>
+ Build := BuildFDiv'Access;
+
+ when others =>
+ null;
+ end case;
+
+ when others =>
+ null;
+ end case;
+
+ if Build /= null then
+ pragma Assert (Res = Null_ValueRef);
+ Res := Build.all (Builder, Left.LLVM, Right.LLVM, Empty_Cstring);
+ end if;
+
+ if Res = Null_ValueRef then
+ raise Program_Error with "Unimplemented New_Dyadic_Op "
+ & ON_Dyadic_Op_Kind'Image (Kind)
+ & " for type "
+ & ON_Type_Kind'Image (Left.Etype.Kind);
+ end if;
+
+ Set_Insn_Dbg (Res);
+
+ return O_Enode'(LLVM => Res, Etype => Left.Etype);
+ end New_Dyadic_Op;
+
+ --------------------
+ -- New_Monadic_Op --
+ --------------------
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ case Operand.Etype.Kind is
+ when ON_Integer_Types =>
+ case Kind is
+ when ON_Not =>
+ Res := BuildNot (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Neg_Ov =>
+ Res := BuildNeg (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Abs_Ov =>
+ Res := BuildSelect
+ (Builder,
+ BuildICmp (Builder, IntSLT,
+ Operand.LLVM,
+ ConstInt (Get_LLVM_Type (Operand.Etype), 0, 0),
+ Empty_Cstring),
+ BuildNeg (Builder, Operand.LLVM, Empty_Cstring),
+ Operand.LLVM,
+ Empty_Cstring);
+ end case;
+ when ON_Float_Type =>
+ case Kind is
+ when ON_Not =>
+ raise Program_Error;
+ when ON_Neg_Ov =>
+ Res := BuildFNeg (Builder, Operand.LLVM, Empty_Cstring);
+ when ON_Abs_Ov =>
+ Res := BuildSelect
+ (Builder,
+ BuildFCmp (Builder, RealOLT,
+ Operand.LLVM,
+ ConstReal (Get_LLVM_Type (Operand.Etype), 0.0),
+ Empty_Cstring),
+ BuildFNeg (Builder, Operand.LLVM, Empty_Cstring),
+ Operand.LLVM,
+ Empty_Cstring);
+ end case;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ if IsAInstruction (Res) /= Null_ValueRef then
+ Set_Insn_Dbg (Res);
+ end if;
+
+ return O_Enode'(LLVM => Res, Etype => Operand.Etype);
+ end New_Monadic_Op;
+
+ --------------------
+ -- New_Compare_Op --
+ --------------------
+
+ type Compare_Op_Entry is record
+ Signed_Pred : IntPredicate;
+ Unsigned_Pred : IntPredicate;
+ Real_Pred : RealPredicate;
+ end record;
+
+ type Compare_Op_Table_Type is array (ON_Compare_Op_Kind) of
+ Compare_Op_Entry;
+
+ Compare_Op_Table : constant Compare_Op_Table_Type :=
+ (ON_Eq => (IntEQ, IntEQ, RealOEQ),
+ ON_Neq => (IntNE, IntNE, RealONE),
+ ON_Le => (IntSLE, IntULE, RealOLE),
+ ON_Lt => (IntSLT, IntULT, RealOLT),
+ ON_Ge => (IntSGE, IntUGE, RealOGE),
+ ON_Gt => (IntSGT, IntUGT, RealOGT));
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind;
+ Left, Right : O_Enode;
+ Ntype : O_Tnode)
+ return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ case Left.Etype.Kind is
+ when ON_Unsigned_Type
+ | ON_Boolean_Type
+ | ON_Enum_Type
+ | ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ Res := BuildICmp (Builder, Compare_Op_Table (Kind).Unsigned_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Signed_Type =>
+ Res := BuildICmp (Builder, Compare_Op_Table (Kind).Signed_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Float_Type =>
+ Res := BuildFCmp (Builder, Compare_Op_Table (Kind).Real_Pred,
+ Left.LLVM, Right.LLVM, Empty_Cstring);
+ when ON_Array_Type
+ | ON_Array_Sub_Type
+ | ON_Record_Type
+ | ON_Incomplete_Record_Type
+ | ON_Union_Type
+ | ON_No_Type =>
+ raise Program_Error;
+ end case;
+ Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Ntype);
+ end New_Compare_Op;
+
+ -------------------------
+ -- New_Indexed_Element --
+ -------------------------
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) return O_Lnode
+ is
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ Index.LLVM);
+ begin
+ return O_Lnode'
+ (Direct => False,
+ LLVM => BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring),
+ Ltype => Arr.Ltype.Arr_El_Type);
+ end New_Indexed_Element;
+
+ ---------------
+ -- New_Slice --
+ ---------------
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ Index.LLVM);
+ Tmp : ValueRef;
+ begin
+ Tmp := BuildGEP (Builder, Arr.LLVM, Idx, Idx'Length, Empty_Cstring);
+ Tmp := BuildBitCast
+ (Builder, Tmp, PointerType (Get_LLVM_Type (Res_Type)), Empty_Cstring);
+ return O_Lnode'(Direct => False, LLVM => Tmp, Ltype => Res_Type);
+ end New_Slice;
+
+ --------------------------
+ -- New_Selected_Element --
+ --------------------------
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ Res := Null_ValueRef;
+ else
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+ begin
+ Res := BuildGEP (Builder, Rec.LLVM, Idx, 2, Empty_Cstring);
+ end;
+ end if;
+ return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
+ end New_Selected_Element;
+
+ ------------------------
+ -- New_Access_Element --
+ ------------------------
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ Res : ValueRef;
+ begin
+ case Acc.Etype.Kind is
+ when ON_Access_Type =>
+ Res := Acc.LLVM;
+ when ON_Incomplete_Access_Type =>
+ -- Unwrap the structure
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0), ConstInt (Int32Type, 0, 0));
+ begin
+ Res := BuildGEP (Builder, Acc.LLVM, Idx, 2, Empty_Cstring);
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ return O_Lnode'(Direct => False,
+ LLVM => Res,
+ Ltype => Acc.Etype.Acc_Type);
+ end New_Access_Element;
+
+ --------------------
+ -- New_Convert_Ov --
+ --------------------
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
+ is
+ Res : ValueRef := Null_ValueRef;
+ begin
+ if Rtype = Val.Etype then
+ -- Convertion to itself: nothing to do.
+ return Val;
+ end if;
+ if Rtype.LLVM = Val.Etype.LLVM then
+ -- Same underlying LLVM type: nothing to do.
+ return Val;
+ end if;
+
+ case Rtype.Kind is
+ when ON_Integer_Types =>
+ case Val.Etype.Kind is
+ when ON_Integer_Types =>
+ -- Int to Int
+ if Val.Etype.Scal_Size > Rtype.Scal_Size then
+ -- Truncate
+ Res := BuildTrunc
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ elsif Val.Etype.Scal_Size < Rtype.Scal_Size then
+ if Val.Etype.Kind = ON_Signed_Type then
+ Res := BuildSExt
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ else
+ -- Unsigned, enum
+ Res := BuildZExt
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+ else
+ Res := BuildBitCast
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when ON_Float_Type =>
+ -- Float to Int
+ if Rtype.Kind = ON_Signed_Type then
+ Res := BuildFPToSI
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ when ON_Float_Type =>
+ if Val.Etype.Kind = ON_Signed_Type then
+ Res := BuildSIToFP
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ elsif Val.Etype.Kind = ON_Unsigned_Type then
+ Res := BuildUIToFP
+ (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+ end if;
+
+ when ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ if GetTypeKind (TypeOf (Val.LLVM)) /= PointerTypeKind then
+ raise Program_Error;
+ end if;
+ Res := BuildBitCast (Builder, Val.LLVM, Get_LLVM_Type (Rtype),
+ Empty_Cstring);
+
+ when others =>
+ null;
+ end case;
+ if Res /= Null_ValueRef then
+ -- FIXME: only if insn was generated
+ -- Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Rtype);
+ else
+ raise Program_Error with "New_Convert_Ov: not implemented for "
+ & ON_Type_Kind'Image (Val.Etype.Kind)
+ & " -> "
+ & ON_Type_Kind'Image (Rtype.Kind);
+ end if;
+ end New_Convert_Ov;
+
+ -----------------
+ -- New_Address --
+ -----------------
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is
+ begin
+ return O_Enode'
+ (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
+ Empty_Cstring),
+ Etype => Atype);
+ end New_Address;
+
+ ---------------------------
+ -- New_Unchecked_Address --
+ ---------------------------
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode
+ is
+ begin
+ return O_Enode'
+ (LLVM => BuildBitCast (Builder, Lvalue.LLVM, Get_LLVM_Type (Atype),
+ Empty_Cstring),
+ Etype => Atype);
+ end New_Unchecked_Address;
+
+ ---------------
+ -- New_Value --
+ ---------------
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ Res := Null_ValueRef;
+ else
+ Res := Lvalue.LLVM;
+ if not Lvalue.Direct then
+ Res := BuildLoad (Builder, Res, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ end if;
+ end if;
+ return O_Enode'(LLVM => Res, Etype => Lvalue.Ltype);
+ end New_Value;
+
+ -------------------
+ -- New_Obj_Value --
+ -------------------
+
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode is
+ begin
+ return New_Value (New_Obj (Obj));
+ end New_Obj_Value;
+
+ -------------
+ -- New_Obj --
+ -------------
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode is
+ begin
+ case Obj.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl
+ | ON_Local_Decl =>
+ return O_Lnode'(Direct => False,
+ LLVM => Obj.LLVM,
+ Ltype => Obj.Dtype);
+
+ when ON_Interface_Decl =>
+ if Flag_Debug then
+ -- The argument was allocated.
+ return O_Lnode'(Direct => False,
+ LLVM => Obj.Inter.Ival,
+ Ltype => Obj.Dtype);
+ else
+ return O_Lnode'(Direct => True,
+ LLVM => Obj.Inter.Ival,
+ Ltype => Obj.Dtype);
+ end if;
+
+ when ON_Type_Decl
+ | ON_Completed_Type_Decl
+ | ON_Subprg_Decl
+ | ON_No_Decl =>
+ raise Program_Error;
+ end case;
+ end New_Obj;
+
+ ----------------
+ -- New_Alloca --
+ ----------------
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ Res := Null_ValueRef;
+ else
+ if Cur_Declare_Block.Stack_Value = Null_ValueRef
+ and then Cur_Declare_Block.Prev /= null
+ then
+ -- Save stack pointer at entry of block
+ PositionBuilderBefore
+ (Extra_Builder, GetFirstInstruction (Cur_Declare_Block.Stmt_Bb));
+ Cur_Declare_Block.Stack_Value :=
+ BuildCall (Extra_Builder, Stacksave_Fun,
+ (1 .. 0 => Null_ValueRef), 0, Empty_Cstring);
+ end if;
+
+ Res := BuildArrayAlloca
+ (Builder, Int8Type, Size.LLVM, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+
+ Res := BuildBitCast
+ (Builder, Res, Get_LLVM_Type (Rtype), Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ end if;
+
+ return O_Enode'(LLVM => Res, Etype => Rtype);
+ end New_Alloca;
+
+ -------------------
+ -- New_Type_Decl --
+ -------------------
+
+ function Add_Dbg_Basic_Type (Id : O_Ident; Btype : O_Tnode; Enc : Natural)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 9);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Base_Type, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ MDString (Id),
+ ConstInt (Int32Type, 0, 0), -- linenum
+ Dbg_Size (Btype.LLVM),
+ Dbg_Align (Btype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ ConstInt (Int32Type, Unsigned_64 (Enc), 0)); -- Encoding
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Basic_Type;
+
+ function Add_Dbg_Enum_Type (Id : O_Ident; Etype : O_Tnode) return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Enumeration_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Dbg_Size (Etype.LLVM),
+ Dbg_Align (Etype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 0, 0), -- Flags
+ Null_ValueRef,
+ Get_Value (Enum_Nodes),
+ ConstInt (Int32Type, 0, 0),
+ Null_ValueRef,
+ Null_ValueRef,
+ Null_ValueRef); -- Runtime lang
+ Clear (Enum_Nodes);
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Enum_Type;
+
+ function Add_Dbg_Pointer_Type (Id : O_Ident; Ptype : O_Tnode)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 9);
+ begin
+ pragma Assert (Ptype.Acc_Type.Dbg /= Null_ValueRef);
+
+ Vals := (ConstInt (Int32Type, DW_TAG_Pointer_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Dbg_Size (Ptype.LLVM),
+ Dbg_Align (Ptype.LLVM),
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 1024, 0), -- Flags
+ Ptype.Acc_Type.Dbg);
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Pointer_Type;
+
+ function Add_Dbg_Record_Type (Id : O_Ident; Rtype : O_Tnode)
+ return ValueRef
+ is
+ Vals : ValueRefArray (0 .. 14);
+ begin
+ Vals := (ConstInt (Int32Type, DW_TAG_Structure_Type, 0),
+ Dbg_Current_Filedir,
+ Null_ValueRef, -- context
+ MDString (Id),
+ Dbg_Line,
+ Null_ValueRef, -- 5: Size
+ Null_ValueRef, -- 6: Align
+ ConstInt (Int32Type, 0, 0), -- Offset
+ ConstInt (Int32Type, 1024, 0), -- Flags
+ Null_ValueRef,
+ Null_ValueRef, -- 10
+ ConstInt (Int32Type, 0, 0), -- Runtime lang
+ Null_ValueRef, -- Vtable Holder
+ Null_ValueRef, -- ?
+ Null_ValueRef); -- Uniq Id
+ if Rtype /= O_Tnode_Null then
+ Vals (5) := Dbg_Size (Rtype.LLVM);
+ Vals (6) := Dbg_Align (Rtype.LLVM);
+ Vals (10) := Rtype.Dbg;
+ end if;
+
+ return MDNode (Vals, Vals'Length);
+ end Add_Dbg_Record_Type;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Incomplete_Record_Type =>
+ Atype.LLVM :=
+ StructCreateNamed (GetGlobalContext, Get_Cstring (Ident));
+ when ON_Incomplete_Access_Type =>
+ Atype.LLVM := PointerType
+ (StructCreateNamed (GetGlobalContext, Get_Cstring (Ident)));
+ when others =>
+ null;
+ end case;
+
+ -- Emit debug info
+ if Flag_Debug then
+ case Atype.Kind is
+ when ON_Unsigned_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_unsigned);
+ when ON_Signed_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_signed);
+ when ON_Float_Type =>
+ Atype.Dbg := Add_Dbg_Basic_Type (Ident, Atype, DW_ATE_float);
+ when ON_Enum_Type =>
+ Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
+ when ON_Boolean_Type =>
+ Atype.Dbg := Add_Dbg_Enum_Type (Ident, Atype);
+ when ON_Access_Type =>
+ Atype.Dbg := Add_Dbg_Pointer_Type (Ident, Atype);
+ when ON_Record_Type =>
+ Atype.Dbg := Add_Dbg_Record_Type (Ident, Atype);
+ when ON_Incomplete_Record_Type =>
+ Atype.Dbg := Add_Dbg_Record_Type (Ident, O_Tnode_Null);
+ when ON_Array_Type
+ | ON_Array_Sub_Type =>
+ -- FIXME: typedef
+ null;
+ when ON_Incomplete_Access_Type =>
+ -- FIXME: todo
+ null;
+ when ON_Union_Type =>
+ -- FIXME: todo
+ null;
+ when ON_No_Type =>
+ raise Program_Error;
+ end case;
+ end if;
+ end New_Type_Decl;
+
+ -----------------------------
+ -- New_Debug_Filename_Decl --
+ -----------------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String) is
+ Vals : ValueRefArray (1 .. 2);
+ begin
+ if Flag_Debug then
+ Vals := (MDString (Filename),
+ MDString (Current_Directory));
+ Dbg_Current_Filedir := MDNode (Vals, 2);
+
+ Vals := (ConstInt (Int32Type, DW_TAG_File_Type, 0),
+ Dbg_Current_Filedir);
+ Dbg_Current_File := MDNode (Vals, 2);
+ end if;
+ end New_Debug_Filename_Decl;
+
+ -------------------------
+ -- New_Debug_Line_Decl --
+ -------------------------
+
+ procedure New_Debug_Line_Decl (Line : Natural) is
+ begin
+ Dbg_Current_Line := unsigned (Line);
+ end New_Debug_Line_Decl;
+
+ ----------------------------
+ -- New_Debug_Comment_Decl --
+ ----------------------------
+
+ procedure New_Debug_Comment_Decl (Comment : String) is
+ begin
+ null;
+ end New_Debug_Comment_Decl;
+
+ --------------------
+ -- New_Const_Decl --
+ --------------------
+
+ procedure Dbg_Add_Global_Var (Id : O_Ident;
+ Atype : O_Tnode;
+ Storage : O_Storage;
+ Decl : O_Dnode)
+ is
+ pragma Assert (Atype.Dbg /= Null_ValueRef);
+ Vals : ValueRefArray (0 .. 12);
+ Name : constant ValueRef := MDString (Id);
+ Is_Local : constant Boolean := Storage = O_Storage_Private;
+ Is_Def : constant Boolean := Storage /= O_Storage_External;
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Variable, 0),
+ Null_ValueRef,
+ Null_ValueRef, -- context
+ Name,
+ Name,
+ Null_ValueRef, -- linkageName
+ Dbg_Current_File,
+ Dbg_Line,
+ Atype.Dbg,
+ ConstInt (Int1Type, Boolean'Pos (Is_Local), 0), -- isLocal
+ ConstInt (Int1Type, Boolean'Pos (Is_Def), 0), -- isDef
+ Decl.LLVM,
+ Null_ValueRef);
+ Append (Global_Nodes, MDNode (Vals, Vals'Length));
+ end Dbg_Add_Global_Var;
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
+ is
+ Decl : ValueRef;
+ begin
+ if Storage = O_Storage_External then
+ Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddGlobal
+ (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
+ end if;
+
+ Res := (Kind => ON_Const_Decl, LLVM => Decl, Dtype => Atype);
+ SetGlobalConstant (Res.LLVM, 1);
+ if Storage = O_Storage_Private then
+ SetLinkage (Res.LLVM, InternalLinkage);
+ end if;
+ if Flag_Debug then
+ Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
+ end if;
+ end New_Const_Decl;
+
+ -----------------------
+ -- Start_Const_Value --
+ -----------------------
+
+ procedure Start_Const_Value (Const : in out O_Dnode) is
+ begin
+ null;
+ end Start_Const_Value;
+
+ ------------------------
+ -- Finish_Const_Value --
+ ------------------------
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) is
+ begin
+ SetInitializer (Const.LLVM, Val.LLVM);
+ end Finish_Const_Value;
+
+ ------------------
+ -- New_Var_Decl --
+ ------------------
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode; Ident : O_Ident; Storage : O_Storage; Atype : O_Tnode)
+ is
+ Decl : ValueRef;
+ begin
+ if Storage = O_Storage_Local then
+ Res := (Kind => ON_Local_Decl,
+ LLVM => BuildAlloca
+ (Decl_Builder, Get_LLVM_Type (Atype), Get_Cstring (Ident)),
+ Dtype => Atype);
+ if Flag_Debug then
+ Dbg_Create_Variable (DW_TAG_Auto_Variable,
+ Ident, Atype, 0, Res.LLVM);
+ end if;
+ else
+ if Storage = O_Storage_External then
+ Decl := GetNamedGlobal (Module, Get_Cstring (Ident));
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddGlobal
+ (Module, Get_LLVM_Type (Atype), Get_Cstring (Ident));
+ end if;
+
+ Res := (Kind => ON_Var_Decl, LLVM => Decl, Dtype => Atype);
+
+ -- Set linkage.
+ case Storage is
+ when O_Storage_Private =>
+ SetLinkage (Res.LLVM, InternalLinkage);
+ when O_Storage_Public
+ | O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ raise Program_Error;
+ end case;
+
+ -- Set initializer.
+ case Storage is
+ when O_Storage_Private
+ | O_Storage_Public =>
+ SetInitializer (Res.LLVM, ConstNull (Get_LLVM_Type (Atype)));
+ when O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ raise Program_Error;
+ end case;
+
+ if Flag_Debug then
+ Dbg_Add_Global_Var (Ident, Atype, Storage, Res);
+ end if;
+ end if;
+ end New_Var_Decl;
+
+ -------------------------
+ -- Start_Function_Decl --
+ -------------------------
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ begin
+ Interfaces := (Ident => Ident,
+ Storage => Storage,
+ Res_Type => Rtype,
+ Nbr_Inter => 0,
+ First_Inter => null,
+ Last_Inter => null);
+ end Start_Function_Decl;
+
+ --------------------------
+ -- Start_Procedure_Decl --
+ --------------------------
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage)
+ is
+ begin
+ Interfaces := (Ident => Ident,
+ Storage => Storage,
+ Res_Type => O_Tnode_Null,
+ Nbr_Inter => 0,
+ First_Inter => null,
+ Last_Inter => null);
+ end Start_Procedure_Decl;
+
+ ------------------------
+ -- New_Interface_Decl --
+ ------------------------
+
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode)
+ is
+ Inter : constant O_Inter_Acc := new O_Inter'(Itype => Atype,
+ Ival => Null_ValueRef,
+ Ident => Ident,
+ Next => null);
+ begin
+ Res := (Kind => ON_Interface_Decl,
+ Dtype => Atype,
+ LLVM => Null_ValueRef,
+ Inter => Inter);
+ Interfaces.Nbr_Inter := Interfaces.Nbr_Inter + 1;
+ if Interfaces.First_Inter = null then
+ Interfaces.First_Inter := Inter;
+ else
+ Interfaces.Last_Inter.Next := Inter;
+ end if;
+ Interfaces.Last_Inter := Inter;
+ end New_Interface_Decl;
+
+ ----------------------------
+ -- Finish_Subprogram_Decl --
+ ----------------------------
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode)
+ is
+ Count : constant unsigned := unsigned (Interfaces.Nbr_Inter);
+ Inter : O_Inter_Acc;
+ Types : TypeRefArray (1 .. Count);
+ Ftype : TypeRef;
+ Rtype : TypeRef;
+ Decl : ValueRef;
+ Id : constant Cstring := Get_Cstring (Interfaces.Ident);
+ begin
+ -- Fill Types (from interfaces list)
+ Inter := Interfaces.First_Inter;
+ for I in 1 .. Count loop
+ Types (I) := Inter.Itype.LLVM;
+ Inter := Inter.Next;
+ end loop;
+
+ -- Build function type.
+ if Interfaces.Res_Type = O_Tnode_Null then
+ Rtype := VoidType;
+ else
+ Rtype := Interfaces.Res_Type.LLVM;
+ end if;
+ Ftype := FunctionType (Rtype, Types, Count, 0);
+
+ if Interfaces.Storage = O_Storage_External then
+ Decl := GetNamedFunction (Module, Id);
+ else
+ Decl := Null_ValueRef;
+ end if;
+ if Decl = Null_ValueRef then
+ Decl := AddFunction (Module, Id, Ftype);
+ end if;
+
+ Res := (Kind => ON_Subprg_Decl,
+ Dtype => Interfaces.Res_Type,
+ Subprg_Id => Interfaces.Ident,
+ Nbr_Args => Count,
+ Subprg_Inters => Interfaces.First_Inter,
+ LLVM => Decl);
+ SetFunctionCallConv (Res.LLVM, CCallConv);
+
+ -- Translate interfaces.
+ Inter := Interfaces.First_Inter;
+ for I in 1 .. Count loop
+ Inter.Ival := GetParam (Res.LLVM, I - 1);
+ SetValueName (Inter.Ival, Get_Cstring (Inter.Ident));
+ Inter := Inter.Next;
+ end loop;
+ end Finish_Subprogram_Decl;
+
+ ---------------------------
+ -- Start_Subprogram_Body --
+ ---------------------------
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ -- Basic block at function entry that contains all the declarations.
+ Decl_BB : BasicBlockRef;
+ begin
+ if Cur_Func /= Null_ValueRef then
+ -- No support for nested subprograms.
+ raise Program_Error;
+ end if;
+
+ Cur_Func := Func.LLVM;
+ Cur_Func_Decl := Func;
+ Unreach := False;
+
+ Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ PositionBuilderAtEnd (Decl_Builder, Decl_BB);
+
+ Create_Declare_Block;
+
+ PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ if Flag_Debug then
+ declare
+ Type_Vals : ValueRefArray (0 .. Func.Nbr_Args);
+ Vals : ValueRefArray (0 .. 14);
+ Arg : O_Inter_Acc;
+ Subprg_Type : ValueRef;
+
+ Subprg_Vals : ValueRefArray (0 .. 19);
+ Name : ValueRef;
+ begin
+ Arg := Func.Subprg_Inters;
+ if Func.Dtype /= O_Tnode_Null then
+ Type_Vals (0) := Func.Dtype.Dbg;
+ else
+ -- Void
+ Type_Vals (0) := Null_ValueRef;
+ end if;
+ for I in 1 .. Type_Vals'Last loop
+ Type_Vals (I) := Arg.Itype.Dbg;
+ Arg := Arg.Next;
+ end loop;
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Subroutine_Type, 0),
+ ConstInt (Int32Type, 0, 0), -- 1 ??
+ Null_ValueRef, -- 2 Context
+ MDString (Empty_Cstring, 0), -- 3 name
+ ConstInt (Int32Type, 0, 0), -- 4 linenum
+ ConstInt (Int64Type, 0, 0), -- 5 size
+ ConstInt (Int64Type, 0, 0), -- 6 align
+ ConstInt (Int64Type, 0, 0), -- 7 offset
+ ConstInt (Int32Type, 0, 0), -- 8 flags
+ Null_ValueRef, -- 9 derived from
+ MDNode (Type_Vals, Type_Vals'Length), -- 10 type
+ ConstInt (Int32Type, 0, 0), -- 11 runtime lang
+ Null_ValueRef, -- 12 containing type
+ Null_ValueRef, -- 13 template params
+ Null_ValueRef); -- 14 ??
+ Subprg_Type := MDNode (Vals, Vals'Length);
+
+ -- Create TAG_subprogram.
+ Name := MDString (Func.Subprg_Id);
+
+ Subprg_Vals :=
+ (ConstInt (Int32Type, DW_TAG_Subprogram, 0),
+ Dbg_Current_Filedir, -- 1 loc
+ Dbg_Current_File, -- 2 context
+ Name, -- 3 name
+ Name, -- 4 display name
+ Null_ValueRef, -- 5 linkage name
+ Dbg_Line, -- 6 line num
+ Subprg_Type, -- 7 type
+ ConstInt (Int1Type, 0, 0), -- 8 islocal (FIXME)
+ ConstInt (Int1Type, 1, 0), -- 9 isdef (FIXME)
+ ConstInt (Int32Type, 0, 0), -- 10 virtuality
+ ConstInt (Int32Type, 0, 0), -- 11 virtual index
+ Null_ValueRef, -- 12 containing type
+ ConstInt (Int32Type, 256, 0), -- 13 flags: prototyped
+ ConstInt (Int1Type, 0, 0), -- 14 isOpt (FIXME)
+ Cur_Func, -- 15 function
+ Null_ValueRef, -- 16 template param
+ Null_ValueRef, -- 17 function decl
+ Null_ValueRef, -- 18 variables ???
+ Dbg_Line); -- 19 scope ln
+ Cur_Declare_Block.Dbg_Scope :=
+ MDNode (Subprg_Vals, Subprg_Vals'Length);
+ Append (Subprg_Nodes, Cur_Declare_Block.Dbg_Scope);
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ end;
+
+ -- Create local variables for arguments.
+ declare
+ Arg : O_Inter_Acc;
+ Tmp : ValueRef;
+ St : ValueRef;
+ pragma Unreferenced (St);
+ Argno : Natural;
+ begin
+ Arg := Func.Subprg_Inters;
+ Argno := 1;
+ while Arg /= null loop
+ Tmp := BuildAlloca (Decl_Builder, Get_LLVM_Type (Arg.Itype),
+ Empty_Cstring);
+ Dbg_Create_Variable (DW_TAG_Arg_Variable,
+ Arg.Ident, Arg.Itype, Argno, Tmp);
+ St := BuildStore (Decl_Builder, Arg.Ival, Tmp);
+ Arg.Ival := Tmp;
+
+ Arg := Arg.Next;
+ Argno := Argno + 1;
+ end loop;
+ end;
+ end if;
+ end Start_Subprogram_Body;
+
+ ----------------------------
+ -- Finish_Subprogram_Body --
+ ----------------------------
+
+ procedure Finish_Subprogram_Body is
+ Ret : ValueRef;
+ pragma Unreferenced (Ret);
+ begin
+ -- Add a jump from the declare basic block to the first statement BB.
+ Ret := BuildBr (Decl_Builder, Cur_Declare_Block.Stmt_Bb);
+
+ -- Terminate the statement BB.
+ if not Unreach then
+ if Cur_Func_Decl.Dtype = O_Tnode_Null then
+ Ret := BuildRetVoid (Builder);
+ else
+ Ret := BuildUnreachable (Builder);
+ end if;
+ end if;
+
+ Destroy_Declare_Block;
+
+ Cur_Func := Null_ValueRef;
+ Dbg_Current_Scope := Null_ValueRef;
+ end Finish_Subprogram_Body;
+
+ -------------------------
+ -- New_Debug_Line_Stmt --
+ -------------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural) is
+ begin
+ Dbg_Current_Line := unsigned (Line);
+ end New_Debug_Line_Stmt;
+
+ ----------------------------
+ -- New_Debug_Comment_Stmt --
+ ----------------------------
+
+ procedure New_Debug_Comment_Stmt (Comment : String) is
+ begin
+ null;
+ end New_Debug_Comment_Stmt;
+
+ ------------------------
+ -- Start_Declare_Stmt --
+ ------------------------
+
+ procedure Start_Declare_Stmt
+ is
+ Br : ValueRef;
+ pragma Unreferenced (Br);
+ begin
+ Create_Declare_Block;
+
+ if Unreach then
+ return;
+ end if;
+
+ -- Add a jump to the new BB.
+ Br := BuildBr (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ PositionBuilderAtEnd (Builder, Cur_Declare_Block.Stmt_Bb);
+
+ if Flag_Debug then
+ declare
+ Vals : ValueRefArray (0 .. 5);
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Lexical_Block, 0),
+ Dbg_Current_Filedir, -- 1 loc
+ Dbg_Current_Scope, -- 2 context
+ Dbg_Line, -- 3 line num
+ ConstInt (Int32Type, 0, 0), -- 4 col
+ ConstInt (Int32Type, Scope_Uniq_Id, 0));
+ Cur_Declare_Block.Dbg_Scope := MDNode (Vals, Vals'Length);
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ Scope_Uniq_Id := Scope_Uniq_Id + 1;
+ end;
+ end if;
+ end Start_Declare_Stmt;
+
+ -------------------------
+ -- Finish_Declare_Stmt --
+ -------------------------
+
+ procedure Finish_Declare_Stmt
+ is
+ Bb : BasicBlockRef;
+ Br : ValueRef;
+ Tmp : ValueRef;
+ pragma Unreferenced (Br, Tmp);
+ begin
+ if not Unreach then
+ -- Create a basic block for the statements after the declare.
+ Bb := AppendBasicBlock (Cur_Func, Empty_Cstring);
+
+ if Cur_Declare_Block.Stack_Value /= Null_ValueRef then
+ -- Restore stack pointer.
+ Tmp := BuildCall (Builder, Stackrestore_Fun,
+ (1 .. 1 => Cur_Declare_Block.Stack_Value), 1,
+ Empty_Cstring);
+ end if;
+
+ -- Execution will continue on the next statement
+ Br := BuildBr (Builder, Bb);
+
+ PositionBuilderAtEnd (Builder, Bb);
+ end if;
+
+ -- Do not reset Unread.
+
+ Destroy_Declare_Block;
+
+ Dbg_Current_Scope := Cur_Declare_Block.Dbg_Scope;
+ end Finish_Declare_Stmt;
+
+ -----------------------
+ -- Start_Association --
+ -----------------------
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ begin
+ Assocs := (Subprg => Subprg,
+ Idx => 0,
+ Vals => new ValueRefArray (1 .. Subprg.Nbr_Args));
+ end Start_Association;
+
+ ---------------------
+ -- New_Association --
+ ---------------------
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is
+ begin
+ Assocs.Idx := Assocs.Idx + 1;
+ Assocs.Vals (Assocs.Idx) := Val.LLVM;
+ end New_Association;
+
+ -----------------------
+ -- New_Function_Call --
+ -----------------------
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ Res : ValueRef;
+ Old_Vals : ValueRefArray_Acc;
+ begin
+ Res := BuildCall (Builder, Assocs.Subprg.LLVM,
+ Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
+ Old_Vals := Assocs.Vals;
+ Free (Old_Vals);
+ Set_Insn_Dbg (Res);
+ return O_Enode'(LLVM => Res, Etype => Assocs.Subprg.Dtype);
+ end New_Function_Call;
+
+ ------------------------
+ -- New_Procedure_Call --
+ ------------------------
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
+ is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildCall (Builder, Assocs.Subprg.LLVM,
+ Assocs.Vals.all, Assocs.Vals'Last, Empty_Cstring);
+ Set_Insn_Dbg (Res);
+ end if;
+ Free (Assocs.Vals);
+ end New_Procedure_Call;
+
+ ---------------------
+ -- New_Assign_Stmt --
+ ---------------------
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ Res : ValueRef;
+ begin
+ if Target.Direct then
+ raise Program_Error;
+ end if;
+ if not Unreach then
+ Res := BuildStore (Builder, Value.LLVM, Target.LLVM);
+ Set_Insn_Dbg (Res);
+ end if;
+ end New_Assign_Stmt;
+
+ ---------------------
+ -- New_Return_Stmt --
+ ---------------------
+
+ procedure New_Return_Stmt (Value : O_Enode) is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ return;
+ end if;
+ Res := BuildRet (Builder, Value.LLVM);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end New_Return_Stmt;
+
+ ---------------------
+ -- New_Return_Stmt --
+ ---------------------
+
+ procedure New_Return_Stmt is
+ Res : ValueRef;
+ begin
+ if Unreach then
+ return;
+ end if;
+ Res := BuildRetVoid (Builder);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end New_Return_Stmt;
+
+ -------------------
+ -- Start_If_Stmt --
+ -------------------
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
+ Res : ValueRef;
+ Bb_Then : BasicBlockRef;
+ begin
+ -- FIXME: check Unreach
+ Bb_Then := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Block := (Bb => AppendBasicBlock (Cur_Func, Empty_Cstring));
+ Res := BuildCondBr (Builder, Cond.LLVM, Bb_Then, Block.Bb);
+ Set_Insn_Dbg (Res);
+
+ PositionBuilderAtEnd (Builder, Bb_Then);
+ end Start_If_Stmt;
+
+ -------------------
+ -- New_Else_Stmt --
+ -------------------
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ Bb_Next : BasicBlockRef;
+ begin
+ if not Unreach then
+ Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Res := BuildBr (Builder, Bb_Next);
+ else
+ Bb_Next := Null_BasicBlockRef;
+ end if;
+
+ PositionBuilderAtEnd (Builder, Block.Bb);
+
+ Block := (Bb => Bb_Next);
+ Unreach := False;
+ end New_Else_Stmt;
+
+ --------------------
+ -- Finish_If_Stmt --
+ --------------------
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ Bb_Next : BasicBlockRef;
+ begin
+ if not Unreach then
+ -- The branch can continue.
+ if Block.Bb = Null_BasicBlockRef then
+ Bb_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ else
+ Bb_Next := Block.Bb;
+ end if;
+ Res := BuildBr (Builder, Bb_Next);
+ PositionBuilderAtEnd (Builder, Bb_Next);
+ else
+ -- The branch doesn't continue.
+ if Block.Bb /= Null_BasicBlockRef then
+ -- There is a fall-through (either from the then branch, or
+ -- there is no else).
+ Unreach := False;
+ PositionBuilderAtEnd (Builder, Block.Bb);
+ else
+ Unreach := True;
+ end if;
+ end if;
+ end Finish_If_Stmt;
+
+ ---------------------
+ -- Start_Loop_Stmt --
+ ---------------------
+
+ procedure Start_Loop_Stmt (Label : out O_Snode)
+ is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ -- FIXME: check Unreach
+ Label := (Bb_Entry => AppendBasicBlock (Cur_Func, Empty_Cstring),
+ Bb_Exit => AppendBasicBlock (Cur_Func, Empty_Cstring));
+ Res := BuildBr (Builder, Label.Bb_Entry);
+ PositionBuilderAtEnd (Builder, Label.Bb_Entry);
+ end Start_Loop_Stmt;
+
+ ----------------------
+ -- Finish_Loop_Stmt --
+ ----------------------
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, Label.Bb_Entry);
+ end if;
+ if Label.Bb_Exit /= Null_BasicBlockRef then
+ -- FIXME: always true...
+ PositionBuilderAtEnd (Builder, Label.Bb_Exit);
+ Unreach := False;
+ else
+ Unreach := True;
+ end if;
+ end Finish_Loop_Stmt;
+
+ -------------------
+ -- New_Exit_Stmt --
+ -------------------
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, L.Bb_Exit);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end if;
+ end New_Exit_Stmt;
+
+ -------------------
+ -- New_Next_Stmt --
+ -------------------
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ Res : ValueRef;
+ begin
+ if not Unreach then
+ Res := BuildBr (Builder, L.Bb_Entry);
+ Set_Insn_Dbg (Res);
+ Unreach := True;
+ end if;
+ end New_Next_Stmt;
+
+ ---------------------
+ -- Start_Case_Stmt --
+ ---------------------
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is
+ begin
+ Block := (BB_Prev => GetInsertBlock (Builder),
+ Value => Value.LLVM,
+ Vtype => Value.Etype,
+ BB_Next => Null_BasicBlockRef,
+ BB_Others => Null_BasicBlockRef,
+ BB_Choice => Null_BasicBlockRef,
+ Nbr_Choices => 0,
+ Choices => new O_Choice_Array (1 .. 8));
+ end Start_Case_Stmt;
+
+ ------------------
+ -- Start_Choice --
+ ------------------
+
+ procedure Finish_Branch (Block : in out O_Case_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ -- Close previous branch.
+ if not Unreach then
+ if Block.BB_Next = Null_BasicBlockRef then
+ Block.BB_Next := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ end if;
+ Res := BuildBr (Builder, Block.BB_Next);
+ end if;
+ end Finish_Branch;
+
+ procedure Start_Choice (Block : in out O_Case_Block) is
+ Res : ValueRef;
+ pragma Unreferenced (Res);
+ begin
+ if Block.BB_Choice /= Null_BasicBlockRef then
+ -- Close previous branch.
+ Finish_Branch (Block);
+ end if;
+
+ Unreach := False;
+ Block.BB_Choice := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ PositionBuilderAtEnd (Builder, Block.BB_Choice);
+ end Start_Choice;
+
+ ---------------------
+ -- New_Expr_Choice --
+ ---------------------
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (O_Choice_Array, O_Choice_Array_Acc);
+
+ procedure New_Choice (Block : in out O_Case_Block;
+ Low, High : ValueRef)
+ is
+ Choices : O_Choice_Array_Acc;
+ begin
+ if Block.Nbr_Choices = Block.Choices'Last then
+ Choices := new O_Choice_Array (1 .. Block.Choices'Last * 2);
+ Choices (1 .. Block.Choices'Last) := Block.Choices.all;
+ Free (Block.Choices);
+ Block.Choices := Choices;
+ end if;
+ Block.Nbr_Choices := Block.Nbr_Choices + 1;
+ Block.Choices (Block.Nbr_Choices) := (Low => Low,
+ High => High,
+ Bb => Block.BB_Choice);
+ end New_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is
+ begin
+ New_Choice (Block, Expr.LLVM, Null_ValueRef);
+ end New_Expr_Choice;
+
+ ----------------------
+ -- New_Range_Choice --
+ ----------------------
+
+ procedure New_Range_Choice
+ (Block : in out O_Case_Block; Low, High : O_Cnode)
+ is
+ begin
+ New_Choice (Block, Low.LLVM, High.LLVM);
+ end New_Range_Choice;
+
+ ------------------------
+ -- New_Default_Choice --
+ ------------------------
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ Block.BB_Others := Block.BB_Choice;
+ end New_Default_Choice;
+
+ -------------------
+ -- Finish_Choice --
+ -------------------
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ null;
+ end Finish_Choice;
+
+ ----------------------
+ -- Finish_Case_Stmt --
+ ----------------------
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block)
+ is
+ Bb_Default : constant BasicBlockRef :=
+ AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Bb_Default_Last : BasicBlockRef;
+ Nbr_Cases : unsigned := 0;
+ GE, LE : IntPredicate;
+ Res : ValueRef;
+ begin
+ if Block.BB_Choice /= Null_BasicBlockRef then
+ -- Close previous branch.
+ Finish_Branch (Block);
+ end if;
+
+ -- Strategy: use a switch instruction for simple choices, put range
+ -- choices in the default using if statements.
+ case Block.Vtype.Kind is
+ when ON_Unsigned_Type
+ | ON_Enum_Type
+ | ON_Boolean_Type =>
+ GE := IntUGE;
+ LE := IntULE;
+ when ON_Signed_Type =>
+ GE := IntSGE;
+ LE := IntSLE;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- BB for the default case of the LLVM switch.
+ PositionBuilderAtEnd (Builder, Bb_Default);
+ Bb_Default_Last := Bb_Default;
+
+ for I in 1 .. Block.Nbr_Choices loop
+ declare
+ C : O_Choice_Type renames Block.Choices (I);
+ begin
+ if C.High /= Null_ValueRef then
+ Bb_Default_Last := AppendBasicBlock (Cur_Func, Empty_Cstring);
+ Res := BuildCondBr (Builder,
+ BuildAnd (Builder,
+ BuildICmp (Builder, GE,
+ Block.Value, C.Low,
+ Empty_Cstring),
+ BuildICmp (Builder, LE,
+ Block.Value, C.High,
+ Empty_Cstring),
+ Empty_Cstring),
+ C.Bb, Bb_Default_Last);
+ PositionBuilderAtEnd (Builder, Bb_Default_Last);
+ else
+ Nbr_Cases := Nbr_Cases + 1;
+ end if;
+ end;
+ end loop;
+
+ -- Insert the switch
+ PositionBuilderAtEnd (Builder, Block.BB_Prev);
+ Res := BuildSwitch (Builder, Block.Value, Bb_Default, Nbr_Cases);
+ for I in 1 .. Block.Nbr_Choices loop
+ declare
+ C : O_Choice_Type renames Block.Choices (I);
+ begin
+ if C.High = Null_ValueRef then
+ AddCase (Res, C.Low, C.Bb);
+ end if;
+ end;
+ end loop;
+
+ -- Insert the others.
+ PositionBuilderAtEnd (Builder, Bb_Default_Last);
+ if Block.BB_Others /= Null_BasicBlockRef then
+ Res := BuildBr (Builder, Block.BB_Others);
+ else
+ Res := BuildUnreachable (Builder);
+ end if;
+
+ if Block.BB_Next /= Null_BasicBlockRef then
+ Unreach := False;
+ PositionBuilderAtEnd (Builder, Block.BB_Next);
+ else
+ Unreach := True;
+ end if;
+
+ Free (Block.Choices);
+ end Finish_Case_Stmt;
+
+ function Get_LLVM_Type (Atype : O_Tnode) return TypeRef is
+ begin
+ case Atype.Kind is
+ when ON_Incomplete_Record_Type
+ | ON_Incomplete_Access_Type =>
+ if Atype.LLVM = Null_TypeRef then
+ raise Program_Error with "early use of incomplete type";
+ end if;
+ return Atype.LLVM;
+ when ON_Union_Type
+ | ON_Scalar_Types
+ | ON_Access_Type
+ | ON_Array_Type
+ | ON_Array_Sub_Type
+ | ON_Record_Type =>
+ return Atype.LLVM;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Get_LLVM_Type;
+
+ procedure Finish_Debug is
+ begin
+ declare
+ Dbg_Cu : constant String := "llvm.dbg.cu" & ASCII.NUL;
+ Producer : constant String := "ortho llvm";
+ Vals : ValueRefArray (0 .. 12);
+ begin
+ Vals :=
+ (ConstInt (Int32Type, DW_TAG_Compile_Unit, 0),
+ Dbg_Current_Filedir, -- 1 file+dir
+ ConstInt (Int32Type, 1, 0), -- 2 language (C)
+ MDString (Producer), -- 3 producer
+ ConstInt (Int1Type, 0, 0), -- 4 isOpt
+ MDString (""), -- 5 flags
+ ConstInt (Int32Type, 0, 0), -- 6 runtime version
+ Null_ValueRef, -- 7 enum types
+ Null_ValueRef, -- 8 retained types
+ Get_Value (Subprg_Nodes), -- 9 subprograms
+ Get_Value (Global_Nodes), -- 10 global var
+ Null_ValueRef, -- 11 imported entities
+ Null_ValueRef); -- 12 split debug
+
+ AddNamedMetadataOperand
+ (Module, Dbg_Cu'Address, MDNode (Vals, Vals'Length));
+ end;
+
+ declare
+ Module_Flags : constant String := "llvm.module.flags" & ASCII.NUL;
+ Flags1 : ValueRefArray (0 .. 2);
+ Flags2 : ValueRefArray (0 .. 2);
+ begin
+ Flags1 := (ConstInt (Int32Type, 1, 0),
+ MDString ("Debug Info Version"),
+ ConstInt (Int32Type, 1, 0));
+ AddNamedMetadataOperand
+ (Module, Module_Flags'Address, MDNode (Flags1, Flags1'Length));
+ Flags2 := (ConstInt (Int32Type, 2, 0),
+ MDString ("Dwarf Version"),
+ ConstInt (Int32Type, 2, 0));
+ AddNamedMetadataOperand
+ (Module, Module_Flags'Address, MDNode (Flags2, Flags2'Length));
+ end;
+ end Finish_Debug;
+
+ Dbg_Str : constant String := "dbg";
+
+ procedure Init is
+ -- Some predefined types and functions.
+ I8_Ptr_Type : TypeRef;
+ begin
+ Builder := CreateBuilder;
+ Decl_Builder := CreateBuilder;
+ Extra_Builder := CreateBuilder;
+
+ -- Create type i8 *.
+ I8_Ptr_Type := PointerType (Int8Type);
+
+ -- Create intrinsic 'i8 *stacksave (void)'.
+ Stacksave_Fun := AddFunction
+ (Module, Stacksave_Name'Address,
+ FunctionType (I8_Ptr_Type, (1 .. 0 => Null_TypeRef), 0, 0));
+
+ -- Create intrinsic 'void stackrestore (i8 *)'.
+ Stackrestore_Fun := AddFunction
+ (Module, Stackrestore_Name'Address,
+ FunctionType (VoidType, (1 => I8_Ptr_Type), 1, 0));
+
+ if Flag_Debug then
+ Debug_ID := GetMDKindID (Dbg_Str, Dbg_Str'Length);
+
+ declare
+ Atypes : TypeRefArray (1 .. 2);
+ Ftype : TypeRef;
+ Name : String := "llvm.dbg.declare" & ASCII.NUL;
+ begin
+ Atypes := (MetadataType, MetadataType);
+ Ftype := FunctionType (VoidType, Atypes, Atypes'Length, 0);
+ Llvm_Dbg_Declare := AddFunction (Module, Name'Address, Ftype);
+ AddFunctionAttr (Llvm_Dbg_Declare,
+ NoUnwindAttribute + ReadNoneAttribute);
+ end;
+ end if;
+ end Init;
+
+end Ortho_LLVM;
diff --git a/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads
new file mode 100644
index 000000000..8e68eb139
--- /dev/null
+++ b/src/ortho/llvm/ortho_llvm.ads
@@ -0,0 +1,737 @@
+-- DO NOT MODIFY - this file was generated from:
+-- ortho_nodes.common.ads and ortho_llvm.private.ads
+--
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with Ortho_Ident; use Ortho_Ident;
+with LLVM.Core; use LLVM.Core;
+with LLVM.TargetMachine;
+with LLVM.Target;
+
+-- Interface to create nodes.
+package Ortho_LLVM is
+ procedure Init;
+ procedure Finish_Debug;
+
+ -- LLVM specific: the module.
+ Module : ModuleRef;
+
+ -- Descriptor for the layout.
+ Target_Data : LLVM.Target.TargetDataRef;
+
+ Target_Machine : LLVM.TargetMachine.TargetMachineRef;
+
+ -- Optimization level
+ Optimization : LLVM.TargetMachine.CodeGenOptLevel :=
+ LLVM.TargetMachine.CodeGenLevelDefault;
+
+ -- Set by -g to generate debug info.
+ Flag_Debug : Boolean := False;
+
+-- Start of common part
+
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ type O_Tnode is private;
+ type O_Snode is private;
+ type O_Dnode is private;
+ type O_Fnode is private;
+
+ O_Cnode_Null : constant O_Cnode;
+ O_Dnode_Null : constant O_Dnode;
+ O_Enode_Null : constant O_Enode;
+ O_Fnode_Null : constant O_Fnode;
+ O_Lnode_Null : constant O_Lnode;
+ O_Snode_Null : constant O_Snode;
+ O_Tnode_Null : constant O_Tnode;
+
+ -- True if the code generated supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a boolean 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record ATYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+
+ Type_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- Line number of the next declaration.
+ procedure New_Debug_Line_Decl (Line : Natural);
+
+ -- Add a comment in the declarative region.
+ procedure New_Debug_Comment_Decl (Comment : String);
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value of a non-external constant.
+ procedure Start_Const_Value (Const : in out O_Dnode);
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- Add a comment as a statement.
+ procedure New_Debug_Comment_Stmt (Comment : String);
+
+ -- Start a declarative region.
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+-- End of common part
+private
+ -- No support for nested subprograms in LLVM.
+ Has_Nested_Subprograms : constant Boolean := False;
+
+ type O_Tnode_Type (<>);
+ type O_Tnode is access O_Tnode_Type;
+ O_Tnode_Null : constant O_Tnode := null;
+
+ type ON_Type_Kind is
+ (ON_No_Type,
+ ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type,
+ ON_Float_Type,
+ ON_Array_Type, ON_Array_Sub_Type,
+ ON_Incomplete_Record_Type,
+ ON_Record_Type, ON_Union_Type,
+ ON_Incomplete_Access_Type, ON_Access_Type);
+
+ subtype ON_Scalar_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Float_Type;
+
+ subtype ON_Integer_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Boolean_Type;
+
+ type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record
+ LLVM : TypeRef;
+ Dbg : ValueRef;
+ case Kind is
+ when ON_No_Type =>
+ null;
+ when ON_Union_Type =>
+ Un_Size : unsigned;
+ Un_Main_Field : TypeRef;
+ when ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ Acc_Type : O_Tnode;
+ when ON_Scalar_Types =>
+ Scal_Size : Natural;
+ when ON_Array_Type
+ | ON_Array_Sub_Type =>
+ -- Type of the element
+ Arr_El_Type : O_Tnode;
+ when ON_Record_Type
+ | ON_Incomplete_Record_Type =>
+ null;
+ end case;
+ end record;
+
+ type O_Inter;
+ type O_Inter_Acc is access O_Inter;
+ type O_Inter is record
+ Itype : O_Tnode;
+ Ival : ValueRef;
+ Ident : O_Ident;
+ Next : O_Inter_Acc;
+ end record;
+
+ type On_Decl_Kind is
+ (ON_Type_Decl, ON_Completed_Type_Decl,
+ ON_Const_Decl,
+ ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl,
+ ON_Subprg_Decl,
+ ON_No_Decl);
+
+ type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record
+ Dtype : O_Tnode;
+ LLVM : ValueRef;
+ case Kind is
+ when ON_Var_Decl
+ | ON_Const_Decl
+ | ON_Local_Decl =>
+ null;
+ when ON_Subprg_Decl =>
+ Subprg_Id : O_Ident;
+ Nbr_Args : unsigned;
+ Subprg_Inters : O_Inter_Acc;
+ when ON_Interface_Decl =>
+ Inter : O_Inter_Acc;
+ when others =>
+ null;
+ end case;
+ end record;
+
+ O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl,
+ Dtype => O_Tnode_Null,
+ LLVM => Null_ValueRef);
+
+ type OF_Kind is (OF_None, OF_Record, OF_Union);
+ type O_Fnode (Kind : OF_Kind := OF_None) is record
+ Ftype : O_Tnode;
+ case Kind is
+ when OF_None =>
+ null;
+ when OF_Record =>
+ Index : Natural;
+ when OF_Union =>
+ Utype : TypeRef;
+ end case;
+ end record;
+
+ O_Fnode_Null : constant O_Fnode := (Kind => OF_None,
+ Ftype => O_Tnode_Null);
+
+ 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 O_Cnode is record
+ LLVM : ValueRef;
+ Ctype : O_Tnode;
+ end record;
+ O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef,
+ Ctype => O_Tnode_Null);
+
+ type O_Enode is record
+ LLVM : ValueRef;
+ Etype : O_Tnode;
+ end record;
+ O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef,
+ Etype => O_Tnode_Null);
+
+
+ type O_Lnode is record
+ -- If True, the LLVM component is the value (used for arguments).
+ -- If False, the LLVM component is the address of the value (used
+ -- for everything else).
+ Direct : Boolean;
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+
+ type O_Snode is record
+ -- First BB in the loop body.
+ Bb_Entry : BasicBlockRef;
+
+ -- BB after the loop.
+ Bb_Exit : BasicBlockRef;
+ end record;
+
+ O_Snode_Null : constant O_Snode := (Null_BasicBlockRef,
+ Null_BasicBlockRef);
+
+ type O_Inter_List is record
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Res_Type : O_Tnode;
+ Nbr_Inter : Natural;
+ First_Inter, Last_Inter : O_Inter_Acc;
+ end record;
+
+ type O_Element;
+ type O_Element_Acc is access O_Element;
+ type O_Element is record
+ -- Identifier for the element
+ Ident : O_Ident;
+
+ -- Type of the element
+ Etype : O_Tnode;
+
+ -- Next element (in the linked list)
+ Next : O_Element_Acc;
+ end record;
+
+ -- Record and union builder.
+ type O_Element_List is record
+ Nbr_Elements : Natural;
+
+ -- For record: the access to the incomplete (but named) type.
+ Rec_Type : O_Tnode;
+
+ -- For unions: biggest for size and alignment
+ Size : unsigned;
+ Align : Unsigned_32;
+ Align_Type : TypeRef;
+
+ First_Elem, Last_Elem : O_Element_Acc;
+ end record;
+
+ type ValueRefArray_Acc is access ValueRefArray;
+
+ type O_Record_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Array_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+ El_Type : TypeRef;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Assoc_List is record
+ Subprg : O_Dnode;
+ Idx : unsigned;
+ Vals : ValueRefArray_Acc;
+ end record;
+
+ type O_Enum_List is record
+ LLVM : TypeRef;
+ Num : Natural;
+ Etype : O_Tnode;
+ end record;
+
+ type O_Choice_Type is record
+ Low, High : ValueRef;
+ Bb : BasicBlockRef;
+ end record;
+
+ type O_Choice_Array is array (Natural range <>) of O_Choice_Type;
+ type O_Choice_Array_Acc is access O_Choice_Array;
+
+ type O_Case_Block is record
+ -- BB before the case.
+ BB_Prev : BasicBlockRef;
+
+ -- Select expression
+ Value : ValueRef;
+ Vtype : O_Tnode;
+
+ -- BB after the case statement.
+ BB_Next : BasicBlockRef;
+
+ -- BB for others
+ BB_Others : BasicBlockRef;
+
+ -- BB for the current choice
+ BB_Choice : BasicBlockRef;
+
+ -- List of choices.
+ Nbr_Choices : Natural;
+ Choices : O_Choice_Array_Acc;
+ end record;
+
+ type O_If_Block is record
+ -- The next basic block.
+ -- After the 'If', this is the BB for the else part. If there is no
+ -- else part, this is the BB for statements after the if.
+ -- After the 'else', this is the BB for statements after the if.
+ Bb : BasicBlockRef;
+ end record;
+
+ function Get_LLVM_Type (Atype : O_Tnode) return TypeRef;
+end Ortho_LLVM;
diff --git a/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads
new file mode 100644
index 000000000..842a119b5
--- /dev/null
+++ b/src/ortho/llvm/ortho_llvm.private.ads
@@ -0,0 +1,305 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Interfaces; use Interfaces;
+with Interfaces.C; use Interfaces.C;
+with Ortho_Ident; use Ortho_Ident;
+with LLVM.Core; use LLVM.Core;
+with LLVM.TargetMachine;
+with LLVM.Target;
+
+-- Interface to create nodes.
+package Ortho_LLVM is
+ procedure Init;
+ procedure Finish_Debug;
+
+ -- LLVM specific: the module.
+ Module : ModuleRef;
+
+ -- Descriptor for the layout.
+ Target_Data : LLVM.Target.TargetDataRef;
+
+ Target_Machine : LLVM.TargetMachine.TargetMachineRef;
+
+ -- Optimization level
+ Optimization : LLVM.TargetMachine.CodeGenOptLevel :=
+ LLVM.TargetMachine.CodeGenLevelDefault;
+
+ -- Set by -g to generate debug info.
+ Flag_Debug : Boolean := False;
+
+private
+ -- No support for nested subprograms in LLVM.
+ Has_Nested_Subprograms : constant Boolean := False;
+
+ type O_Tnode_Type (<>);
+ type O_Tnode is access O_Tnode_Type;
+ O_Tnode_Null : constant O_Tnode := null;
+
+ type ON_Type_Kind is
+ (ON_No_Type,
+ ON_Unsigned_Type, ON_Signed_Type, ON_Enum_Type, ON_Boolean_Type,
+ ON_Float_Type,
+ ON_Array_Type, ON_Array_Sub_Type,
+ ON_Incomplete_Record_Type,
+ ON_Record_Type, ON_Union_Type,
+ ON_Incomplete_Access_Type, ON_Access_Type);
+
+ subtype ON_Scalar_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Float_Type;
+
+ subtype ON_Integer_Types is ON_Type_Kind range
+ ON_Unsigned_Type .. ON_Boolean_Type;
+
+ type O_Tnode_Type (Kind : ON_Type_Kind := ON_No_Type) is record
+ LLVM : TypeRef;
+ Dbg : ValueRef;
+ case Kind is
+ when ON_No_Type =>
+ null;
+ when ON_Union_Type =>
+ Un_Size : unsigned;
+ Un_Main_Field : TypeRef;
+ when ON_Access_Type
+ | ON_Incomplete_Access_Type =>
+ Acc_Type : O_Tnode;
+ when ON_Scalar_Types =>
+ Scal_Size : Natural;
+ when ON_Array_Type
+ | ON_Array_Sub_Type =>
+ -- Type of the element
+ Arr_El_Type : O_Tnode;
+ when ON_Record_Type
+ | ON_Incomplete_Record_Type =>
+ null;
+ end case;
+ end record;
+
+ type O_Inter;
+ type O_Inter_Acc is access O_Inter;
+ type O_Inter is record
+ Itype : O_Tnode;
+ Ival : ValueRef;
+ Ident : O_Ident;
+ Next : O_Inter_Acc;
+ end record;
+
+ type On_Decl_Kind is
+ (ON_Type_Decl, ON_Completed_Type_Decl,
+ ON_Const_Decl,
+ ON_Var_Decl, ON_Local_Decl, ON_Interface_Decl,
+ ON_Subprg_Decl,
+ ON_No_Decl);
+
+ type O_Dnode (Kind : On_Decl_Kind := ON_No_Decl) is record
+ Dtype : O_Tnode;
+ LLVM : ValueRef;
+ case Kind is
+ when ON_Var_Decl
+ | ON_Const_Decl
+ | ON_Local_Decl =>
+ null;
+ when ON_Subprg_Decl =>
+ Subprg_Id : O_Ident;
+ Nbr_Args : unsigned;
+ Subprg_Inters : O_Inter_Acc;
+ when ON_Interface_Decl =>
+ Inter : O_Inter_Acc;
+ when others =>
+ null;
+ end case;
+ end record;
+
+ O_Dnode_Null : constant O_Dnode := (Kind => ON_No_Decl,
+ Dtype => O_Tnode_Null,
+ LLVM => Null_ValueRef);
+
+ type OF_Kind is (OF_None, OF_Record, OF_Union);
+ type O_Fnode (Kind : OF_Kind := OF_None) is record
+ Ftype : O_Tnode;
+ case Kind is
+ when OF_None =>
+ null;
+ when OF_Record =>
+ Index : Natural;
+ when OF_Union =>
+ Utype : TypeRef;
+ end case;
+ end record;
+
+ O_Fnode_Null : constant O_Fnode := (Kind => OF_None,
+ Ftype => O_Tnode_Null);
+
+ 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 O_Cnode is record
+ LLVM : ValueRef;
+ Ctype : O_Tnode;
+ end record;
+ O_Cnode_Null : constant O_Cnode := (LLVM => Null_ValueRef,
+ Ctype => O_Tnode_Null);
+
+ type O_Enode is record
+ LLVM : ValueRef;
+ Etype : O_Tnode;
+ end record;
+ O_Enode_Null : constant O_Enode := (LLVM => Null_ValueRef,
+ Etype => O_Tnode_Null);
+
+
+ type O_Lnode is record
+ -- If True, the LLVM component is the value (used for arguments).
+ -- If False, the LLVM component is the address of the value (used
+ -- for everything else).
+ Direct : Boolean;
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+
+ type O_Snode is record
+ -- First BB in the loop body.
+ Bb_Entry : BasicBlockRef;
+
+ -- BB after the loop.
+ Bb_Exit : BasicBlockRef;
+ end record;
+
+ O_Snode_Null : constant O_Snode := (Null_BasicBlockRef,
+ Null_BasicBlockRef);
+
+ type O_Inter_List is record
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Res_Type : O_Tnode;
+ Nbr_Inter : Natural;
+ First_Inter, Last_Inter : O_Inter_Acc;
+ end record;
+
+ type O_Element;
+ type O_Element_Acc is access O_Element;
+ type O_Element is record
+ -- Identifier for the element
+ Ident : O_Ident;
+
+ -- Type of the element
+ Etype : O_Tnode;
+
+ -- Next element (in the linked list)
+ Next : O_Element_Acc;
+ end record;
+
+ -- Record and union builder.
+ type O_Element_List is record
+ Nbr_Elements : Natural;
+
+ -- For record: the access to the incomplete (but named) type.
+ Rec_Type : O_Tnode;
+
+ -- For unions: biggest for size and alignment
+ Size : unsigned;
+ Align : Unsigned_32;
+ Align_Type : TypeRef;
+
+ First_Elem, Last_Elem : O_Element_Acc;
+ end record;
+
+ type ValueRefArray_Acc is access ValueRefArray;
+
+ type O_Record_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Array_Aggr_List is record
+ -- Current number of elements in Vals.
+ Len : unsigned;
+
+ -- Value of elements.
+ Vals : ValueRefArray_Acc;
+ El_Type : TypeRef;
+
+ -- Type of the aggregate.
+ Atype : O_Tnode;
+ end record;
+
+ type O_Assoc_List is record
+ Subprg : O_Dnode;
+ Idx : unsigned;
+ Vals : ValueRefArray_Acc;
+ end record;
+
+ type O_Enum_List is record
+ LLVM : TypeRef;
+ Num : Natural;
+ Etype : O_Tnode;
+ end record;
+
+ type O_Choice_Type is record
+ Low, High : ValueRef;
+ Bb : BasicBlockRef;
+ end record;
+
+ type O_Choice_Array is array (Natural range <>) of O_Choice_Type;
+ type O_Choice_Array_Acc is access O_Choice_Array;
+
+ type O_Case_Block is record
+ -- BB before the case.
+ BB_Prev : BasicBlockRef;
+
+ -- Select expression
+ Value : ValueRef;
+ Vtype : O_Tnode;
+
+ -- BB after the case statement.
+ BB_Next : BasicBlockRef;
+
+ -- BB for others
+ BB_Others : BasicBlockRef;
+
+ -- BB for the current choice
+ BB_Choice : BasicBlockRef;
+
+ -- List of choices.
+ Nbr_Choices : Natural;
+ Choices : O_Choice_Array_Acc;
+ end record;
+
+ type O_If_Block is record
+ -- The next basic block.
+ -- After the 'If', this is the BB for the else part. If there is no
+ -- else part, this is the BB for statements after the if.
+ -- After the 'else', this is the BB for statements after the if.
+ Bb : BasicBlockRef;
+ end record;
+
+ function Get_LLVM_Type (Atype : O_Tnode) return TypeRef;
+end Ortho_LLVM;
diff --git a/src/ortho/llvm/ortho_nodes.ads b/src/ortho/llvm/ortho_nodes.ads
new file mode 100644
index 000000000..34d1dbbc9
--- /dev/null
+++ b/src/ortho/llvm/ortho_nodes.ads
@@ -0,0 +1,20 @@
+-- LLVM back-end for ortho.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ortho_LLVM;
+package Ortho_Nodes renames Ortho_LLVM;
diff --git a/src/ortho/mcode/Makefile b/src/ortho/mcode/Makefile
new file mode 100644
index 000000000..19d5d26aa
--- /dev/null
+++ b/src/ortho/mcode/Makefile
@@ -0,0 +1,37 @@
+ortho_srcdir=..
+GNAT_FLAGS=-gnaty3befhkmr -gnata -gnatf -gnatwlcru -gnat05
+CC=gcc
+BE=mcode
+SED=sed
+
+all: $(ortho_exec)
+
+$(ortho_exec): $(ortho_srcdir)/mcode/ortho_mcode.ads memsegs_c.o force
+ gnatmake -m -o $@ -g -aI$(ortho_srcdir)/mcode -aI$(ortho_srcdir) \
+ $(GNAT_FLAGS) ortho_code_main -bargs -E -largs memsegs_c.o #-static
+
+memsegs_c.o: $(ortho_srcdir)/mcode/memsegs_c.c
+ $(CC) -c $(CFLAGS) -o $@ $<
+
+oread: force
+ gnatmake -m -o $@ -g $(GNAT_FLAGS) -aI../oread ortho_code_main -aI.. -largs memsegs_c.o
+
+elfdump: force
+ gnatmake -m -g $(GNAT_FLAGS) $@
+
+coffdump: force
+ gnatmake -m $(GNAT_FLAGS) $@
+
+clean:
+ $(RM) -f *.o *.ali ortho_code_main elfdump
+ $(RM) b~*.ad? *~
+
+distclean: clean
+
+
+force:
+
+.PHONY: force all clean
+
+ORTHO_BASENAME=ortho_mcode
+include $(ortho_srcdir)/Makefile.inc
diff --git a/src/ortho/mcode/binary_file-coff.adb b/src/ortho/mcode/binary_file-coff.adb
new file mode 100644
index 000000000..cf3cba3f4
--- /dev/null
+++ b/src/ortho/mcode/binary_file-coff.adb
@@ -0,0 +1,407 @@
+-- Binary file COFF writer.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Characters.Latin_1;
+with Coff; use Coff;
+
+package body Binary_File.Coff is
+ NUL : Character renames Ada.Characters.Latin_1.NUL;
+
+ procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor)
+ is
+ use GNAT.OS_Lib;
+
+ procedure Xwrite (Data : System.Address; Len : Natural) is
+ begin
+ if Write (Fd, Data, Len) /= Len then
+ raise Write_Error;
+ end if;
+ end Xwrite;
+
+ type Section_Info_Type is record
+ Sect : Section_Acc;
+ -- File offset for the data.
+ Data_Offset : Natural;
+ -- File offset for the relocs.
+ Reloc_Offset : Natural;
+ -- Number of relocs to write.
+ Nbr_Relocs : Natural;
+ end record;
+ type Section_Info_Array is array (Natural range <>) of Section_Info_Type;
+ Sections : Section_Info_Array (1 .. Nbr_Sections + 3);
+ Nbr_Sect : Natural;
+ Sect_Text : constant Natural := 1;
+ Sect_Data : constant Natural := 2;
+ Sect_Bss : constant Natural := 3;
+ Sect : Section_Acc;
+
+ --Section_Align : constant Natural := 2;
+
+ Offset : Natural;
+ Symtab_Offset : Natural;
+ -- Number of symtab entries.
+ Nbr_Symbols : Natural;
+ Strtab_Offset : Natural;
+
+ function Gen_String (Str : String) return Sym_Name
+ is
+ Res : Sym_Name;
+ begin
+ if Str'Length <= 8 then
+ Res.E_Name := (others => NUL);
+ Res.E_Name (1 .. Str'Length) := Str;
+ else
+ Res.E := (E_Zeroes => 0, E_Offset => Unsigned_32 (Offset));
+ Offset := Offset + Str'Length + 1;
+ end if;
+ return Res;
+ end Gen_String;
+
+ -- Well known sections name.
+ type String_Array is array (Sect_Text .. Sect_Bss) of String (1 .. 8);
+ Sect_Name : constant String_Array :=
+ (Sect_Text => ".text" & NUL & NUL & NUL,
+ Sect_Data => ".data" & NUL & NUL & NUL,
+ Sect_Bss => ".bss" & NUL & NUL & NUL & NUL);
+ type Unsigned32_Array is array (Sect_Text .. Sect_Bss) of Unsigned_32;
+ Sect_Flags : constant Unsigned32_Array :=
+ (Sect_Text => STYP_TEXT,
+ Sect_Data => STYP_DATA,
+ Sect_Bss => STYP_BSS);
+
+ -- If true, do local relocs.
+ Flag_Reloc : constant Boolean := True;
+ -- If true, discard local symbols;
+ Flag_Discard_Local : Boolean := True;
+ begin
+ -- If relocations are not performs, then local symbols cannot be
+ -- discarded.
+ if not Flag_Reloc then
+ Flag_Discard_Local := False;
+ end if;
+
+ -- Fill sections.
+ Sect := Section_Chain;
+ Nbr_Sect := 3;
+ declare
+ N : Natural;
+ begin
+ while Sect /= null loop
+ if Sect.Name.all = ".text" then
+ N := Sect_Text;
+ elsif Sect.Name.all = ".data" then
+ N := Sect_Data;
+ elsif Sect.Name.all = ".bss" then
+ N := Sect_Bss;
+ else
+ Nbr_Sect := Nbr_Sect + 1;
+ N := Nbr_Sect;
+ end if;
+ Sections (N).Sect := Sect;
+ Sect.Number := N;
+ Sect := Sect.Next;
+ end loop;
+ end;
+
+ -- Set data offset.
+ Offset := Filehdr_Size + Nbr_Sect * Scnhdr_Size;
+ for I in 1 .. Nbr_Sect loop
+ if Sections (I).Sect /= null
+ and then Sections (I).Sect.Data /= null
+ then
+ Sections (I).Data_Offset := Offset;
+ Offset := Offset + Natural (Sections (I).Sect.Pc);
+ else
+ Sections (I).Data_Offset := 0;
+ end if;
+ end loop;
+
+ -- Set relocs offset.
+ declare
+ Rel : Reloc_Acc;
+ begin
+ for I in 1 .. Nbr_Sect loop
+ Sections (I).Nbr_Relocs := 0;
+ if Sections (I).Sect /= null then
+ Sections (I).Reloc_Offset := Offset;
+ if not Flag_Reloc then
+ -- Do local relocations.
+ Rel := Sections (I).Sect.First_Reloc;
+ while Rel /= null loop
+ if S_Local (Rel.Sym) then
+ if Get_Section (Rel.Sym) = Sections (I).Sect
+ then
+ -- Intra section local reloc.
+ Apply_Reloc (Sections (I).Sect, Rel);
+ else
+ -- Inter section local reloc.
+ -- A relocation is still required.
+ Sections (I).Nbr_Relocs :=
+ Sections (I).Nbr_Relocs + 1;
+ -- FIXME: todo.
+ raise Program_Error;
+ end if;
+ else
+ Sections (I).Nbr_Relocs := Sections (I).Nbr_Relocs + 1;
+ end if;
+ Rel := Rel.Sect_Next;
+ end loop;
+ else
+ Sections (I).Nbr_Relocs := Sections (I).Sect.Nbr_Relocs;
+ end if;
+ Offset := Offset + Sections (I).Nbr_Relocs * Relsz;
+ else
+ Sections (I).Reloc_Offset := 0;
+ end if;
+ end loop;
+ end;
+
+ Symtab_Offset := Offset;
+ Nbr_Symbols := 2 + Nbr_Sect * 2; -- 2 for file.
+ for I in Symbols.First .. Symbols.Last loop
+ Set_Number (I, Nbr_Symbols);
+ Nbr_Symbols := Nbr_Symbols + 1;
+ end loop;
+ Offset := Offset + Nbr_Symbols * Symesz;
+ Strtab_Offset := Offset;
+ Offset := Offset + 4;
+
+ -- Write file header.
+ declare
+ Hdr : Filehdr;
+ begin
+ Hdr.F_Magic := I386magic;
+ Hdr.F_Nscns := Unsigned_16 (Nbr_Sect);
+ Hdr.F_Timdat := 0;
+ Hdr.F_Symptr := Unsigned_32 (Symtab_Offset);
+ Hdr.F_Nsyms := Unsigned_32 (Nbr_Symbols);
+ Hdr.F_Opthdr := 0;
+ Hdr.F_Flags := F_Lnno;
+ Xwrite (Hdr'Address, Filehdr_Size);
+ end;
+
+ -- Write sections header.
+ for I in 1 .. Nbr_Sect loop
+ declare
+ Hdr : Scnhdr;
+ L : Natural;
+ begin
+ case I is
+ when Sect_Text
+ | Sect_Data
+ | Sect_Bss =>
+ Hdr.S_Name := Sect_Name (I);
+ Hdr.S_Flags := Sect_Flags (I);
+ when others =>
+ Hdr.S_Flags := 0;
+ L := Sections (I).Sect.Name'Length;
+ if L > Hdr.S_Name'Length then
+ Hdr.S_Name := Sections (I).Sect.Name
+ (Sections (I).Sect.Name'First ..
+ Sections (I).Sect.Name'First + Hdr.S_Name'Length - 1);
+ else
+ Hdr.S_Name (1 .. L) := Sections (I).Sect.Name.all;
+ Hdr.S_Name (L + 1 .. Hdr.S_Name'Last) := (others => NUL);
+ end if;
+ end case;
+ Hdr.S_Paddr := 0;
+ Hdr.S_Vaddr := 0;
+ Hdr.S_Scnptr := Unsigned_32 (Sections (I).Data_Offset);
+ Hdr.S_Relptr := Unsigned_32 (Sections (I).Reloc_Offset);
+ Hdr.S_Lnnoptr := 0;
+ Hdr.S_Nreloc := Unsigned_16 (Sections (I).Nbr_Relocs);
+ if Sections (I).Sect /= null then
+ Hdr.S_Size := Unsigned_32 (Sections (I).Sect.Pc);
+ else
+ Hdr.S_Size := 0;
+ end if;
+ Hdr.S_Nlnno := 0;
+ Xwrite (Hdr'Address, Scnhdr_Size);
+ end;
+ end loop;
+
+ -- Write sections content.
+ for I in 1 .. Nbr_Sect loop
+ if Sections (I).Sect /= null
+ and then Sections (I).Sect.Data /= null
+ then
+ Xwrite (Sections (I).Sect.Data (0)'Address,
+ Natural (Sections (I).Sect.Pc));
+ end if;
+ end loop;
+
+ -- Write sections reloc.
+ for I in 1 .. Nbr_Sect loop
+ if Sections (I).Sect /= null then
+ declare
+ R : Reloc_Acc;
+ Rel : Reloc;
+ begin
+ R := Sections (I).Sect.First_Reloc;
+ while R /= null loop
+ case R.Kind is
+ when Reloc_32 =>
+ Rel.R_Type := Reloc_Addr32;
+ when Reloc_Pc32 =>
+ Rel.R_Type := Reloc_Rel32;
+ when others =>
+ raise Program_Error;
+ end case;
+ Rel.R_Vaddr := Unsigned_32 (R.Addr);
+ Rel.R_Symndx := Unsigned_32 (Get_Number (R.Sym));
+ Xwrite (Rel'Address, Relsz);
+ R := R.Sect_Next;
+ end loop;
+ end;
+ end if;
+ end loop;
+
+ -- Write symtab.
+ -- Write file symbol + aux
+ declare
+ Sym : Syment;
+ A_File : Auxent_File;
+ begin
+ Sym := (E => (Inline => True,
+ E_Name => ".file" & NUL & NUL & NUL),
+ E_Value => 0,
+ E_Scnum => N_DEBUG,
+ E_Type => 0,
+ E_Sclass => C_FILE,
+ E_Numaux => 1);
+ Xwrite (Sym'Address, Symesz);
+ A_File := (Inline => True,
+ X_Fname => "testfile.xxxxx");
+ Xwrite (A_File'Address, Symesz);
+ end;
+ -- Write sections symbol + aux
+ for I in 1 .. Nbr_Sect loop
+ declare
+ A_Scn : Auxent_Scn;
+ Sym : Syment;
+ begin
+ Sym := (E => (Inline => True, E_Name => (others => NUL)),
+ E_Value => 0,
+ E_Scnum => Unsigned_16 (I),
+ E_Type => 0,
+ E_Sclass => C_STAT,
+ E_Numaux => 1);
+ if I <= Sect_Bss then
+ Sym.E.E_Name := Sect_Name (I);
+ else
+ Sym.E := Gen_String (Sections (I).Sect.Name.all);
+ end if;
+ Xwrite (Sym'Address, Symesz);
+ if Sections (I).Sect /= null
+ and then Sections (I).Sect.Data /= null
+ then
+ A_Scn :=
+ (X_Scnlen => Unsigned_32 (Sections (I).Sect.Pc),
+ X_Nreloc => Unsigned_16 (Sections (I).Nbr_Relocs),
+ X_Nlinno => 0);
+ else
+ A_Scn := (X_Scnlen => 0, X_Nreloc => 0, X_Nlinno => 0);
+ end if;
+ Xwrite (A_Scn'Address, Symesz);
+ end;
+ end loop;
+
+ -- Write symbols.
+ declare
+ procedure Write_Symbol (S : Symbol)
+ is
+ Sym : Syment;
+ begin
+ Sym := (E => Gen_String (Get_Symbol_Name (S)),
+ E_Value => Unsigned_32 (Get_Symbol_Value (S)),
+ E_Scnum => 0,
+ E_Type => 0,
+ E_Sclass => C_EXT,
+ E_Numaux => 0);
+ case Get_Scope (S) is
+ when Sym_Local
+ | Sym_Private =>
+ Sym.E_Sclass := C_STAT;
+ when Sym_Undef
+ | Sym_Global =>
+ Sym.E_Sclass := C_EXT;
+ end case;
+ if Get_Section (S) /= null then
+ Sym.E_Scnum := Unsigned_16 (Get_Section (S).Number);
+ end if;
+ Xwrite (Sym'Address, Symesz);
+ end Write_Symbol;
+ begin
+ -- First the non-local symbols (1).
+ for I in Symbols.First .. Symbols.Last loop
+ if Get_Scope (I) in Symbol_Scope_External then
+ Write_Symbol (I);
+ end if;
+ end loop;
+ -- Then the local symbols (2).
+ if not Flag_Discard_Local then
+ for I in Symbols.First .. Symbols.Last loop
+ if Get_Scope (I) not in Symbol_Scope_External then
+ Write_Symbol (I);
+ end if;
+ end loop;
+ end if;
+ end;
+
+ -- Write strtab.
+ -- Write strtab length.
+ declare
+ L : Unsigned_32;
+
+ procedure Write_String (Str : String) is
+ begin
+ if Str (Str'Last) /= NUL then
+ raise Program_Error;
+ end if;
+ if Str'Length <= 9 then
+ return;
+ end if;
+ Xwrite (Str'Address, Str'Length);
+ Strtab_Offset := Strtab_Offset + Str'Length;
+ end Write_String;
+ begin
+ L := Unsigned_32 (Offset - Strtab_Offset);
+ Xwrite (L'Address, 4);
+
+ -- Write section name string.
+ for I in Sect_Bss + 1 .. Nbr_Sect loop
+ if Sections (I).Sect /= null
+ and then Sections (I).Sect.Name'Length > 8
+ then
+ Write_String (Sections (I).Sect.Name.all & NUL);
+ end if;
+ end loop;
+
+ for I in Symbols.First .. Symbols.Last loop
+ declare
+ Str : constant String := Get_Symbol_Name (I);
+ begin
+ Write_String (Str & NUL);
+ end;
+ end loop;
+ if Strtab_Offset + 4 /= Offset then
+ raise Program_Error;
+ end if;
+ end;
+ end Write_Coff;
+
+end Binary_File.Coff;
diff --git a/src/ortho/mcode/binary_file-coff.ads b/src/ortho/mcode/binary_file-coff.ads
new file mode 100644
index 000000000..e671555ea
--- /dev/null
+++ b/src/ortho/mcode/binary_file-coff.ads
@@ -0,0 +1,23 @@
+-- Binary file COFF writer.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.OS_Lib;
+
+package Binary_File.Coff is
+ procedure Write_Coff (Fd : GNAT.OS_Lib.File_Descriptor);
+end Binary_File.Coff;
+
diff --git a/src/ortho/mcode/binary_file-elf.adb b/src/ortho/mcode/binary_file-elf.adb
new file mode 100644
index 000000000..329dbacd3
--- /dev/null
+++ b/src/ortho/mcode/binary_file-elf.adb
@@ -0,0 +1,679 @@
+-- Binary file ELF writer.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Latin_1;
+with Elf_Common;
+with Elf32;
+
+package body Binary_File.Elf is
+ NUL : Character renames Ada.Characters.Latin_1.NUL;
+
+ type Arch_Bool is array (Arch_Kind) of Boolean;
+ Is_Rela : constant Arch_Bool := (Arch_Unknown => False,
+ Arch_X86 => False,
+ Arch_Sparc => True,
+ Arch_Ppc => True);
+
+ procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor)
+ is
+ use Elf_Common;
+ use Elf32;
+ use GNAT.OS_Lib;
+
+ procedure Xwrite (Data : System.Address; Len : Natural) is
+ begin
+ if Write (Fd, Data, Len) /= Len then
+ raise Write_Error;
+ end if;
+ end Xwrite;
+
+ procedure Check_File_Pos (Off : Elf32_Off)
+ is
+ L : Long_Integer;
+ begin
+ L := File_Length (Fd);
+ if L /= Long_Integer (Off) then
+ Put_Line (Standard_Error, "check_file_pos error: expect "
+ & Elf32_Off'Image (Off) & ", found "
+ & Long_Integer'Image (L));
+ raise Write_Error;
+ end if;
+ end Check_File_Pos;
+
+ function Sect_Align (V : Elf32_Off) return Elf32_Off
+ is
+ Tmp : Elf32_Off;
+ begin
+ Tmp := V + 2 ** 2 - 1;
+ return Tmp - (Tmp mod 2 ** 2);
+ end Sect_Align;
+
+ type Section_Info_Type is record
+ Sect : Section_Acc;
+ -- Index of the section symbol (in symtab).
+ Sym : Elf32_Word;
+ -- Number of relocs to write.
+ --Nbr_Relocs : Natural;
+ end record;
+ type Section_Info_Array is array (Natural range <>) of Section_Info_Type;
+ Sections : Section_Info_Array (0 .. 3 + 2 * Nbr_Sections);
+ type Elf32_Shdr_Array is array (Natural range <>) of Elf32_Shdr;
+ Shdr : Elf32_Shdr_Array (0 .. 3 + 2 * Nbr_Sections);
+ Nbr_Sect : Natural;
+ Sect : Section_Acc;
+
+ -- The first 4 sections are always present.
+ Sect_Null : constant Natural := 0;
+ Sect_Shstrtab : constant Natural := 1;
+ Sect_Symtab : constant Natural := 2;
+ Sect_Strtab : constant Natural := 3;
+ Sect_First : constant Natural := 4;
+
+ Offset : Elf32_Off;
+
+ -- Size of a relocation entry.
+ Rel_Size : Natural;
+
+ -- If true, do local relocs.
+ Flag_Reloc : constant Boolean := True;
+ -- If true, discard local symbols;
+ Flag_Discard_Local : Boolean := True;
+
+ -- Number of symbols.
+ Nbr_Symbols : Natural := 0;
+ begin
+ -- If relocations are not performs, then local symbols cannot be
+ -- discarded.
+ if not Flag_Reloc then
+ Flag_Discard_Local := False;
+ end if;
+
+ -- Set size of a relocation entry. This avoids severals conditionnal.
+ if Is_Rela (Arch) then
+ Rel_Size := Elf32_Rela_Size;
+ else
+ Rel_Size := Elf32_Rel_Size;
+ end if;
+
+ -- Set section header.
+
+ -- SHT_NULL.
+ Shdr (Sect_Null) :=
+ Elf32_Shdr'(Sh_Name => 0,
+ Sh_Type => SHT_NULL,
+ Sh_Flags => 0,
+ Sh_Addr => 0,
+ Sh_Offset => 0,
+ Sh_Size => 0,
+ Sh_Link => 0,
+ Sh_Info => 0,
+ Sh_Addralign => 0,
+ Sh_Entsize => 0);
+
+ -- shstrtab.
+ Shdr (Sect_Shstrtab) :=
+ Elf32_Shdr'(Sh_Name => 1,
+ Sh_Type => SHT_STRTAB,
+ Sh_Flags => 0,
+ Sh_Addr => 0,
+ Sh_Offset => 0, -- Filled latter.
+ -- NUL: 1, .symtab: 8, .strtab: 8 and .shstrtab: 10.
+ Sh_Size => 1 + 10 + 8 + 8,
+ Sh_Link => 0,
+ Sh_Info => 0,
+ Sh_Addralign => 1,
+ Sh_Entsize => 0);
+
+ -- Symtab
+ Shdr (Sect_Symtab) :=
+ Elf32_Shdr'(Sh_Name => 11,
+ Sh_Type => SHT_SYMTAB,
+ Sh_Flags => 0,
+ Sh_Addr => 0,
+ Sh_Offset => 0,
+ Sh_Size => 0,
+ Sh_Link => Elf32_Word (Sect_Strtab),
+ Sh_Info => 0, -- FIXME
+ Sh_Addralign => 4,
+ Sh_Entsize => Elf32_Word (Elf32_Sym_Size));
+
+ -- strtab.
+ Shdr (Sect_Strtab) :=
+ Elf32_Shdr'(Sh_Name => 19,
+ Sh_Type => SHT_STRTAB,
+ Sh_Flags => 0,
+ Sh_Addr => 0,
+ Sh_Offset => 0,
+ Sh_Size => 0,
+ Sh_Link => 0,
+ Sh_Info => 0,
+ Sh_Addralign => 1,
+ Sh_Entsize => 0);
+
+ -- Fill sections.
+ Sect := Section_Chain;
+ Nbr_Sect := Sect_First;
+ Nbr_Symbols := 1;
+ while Sect /= null loop
+ Sections (Nbr_Sect) := (Sect => Sect,
+ Sym => Elf32_Word (Nbr_Symbols));
+ Nbr_Symbols := Nbr_Symbols + 1;
+ Sect.Number := Nbr_Sect;
+
+ Shdr (Nbr_Sect) :=
+ Elf32_Shdr'(Sh_Name => Shdr (Sect_Shstrtab).Sh_Size,
+ Sh_Type => SHT_PROGBITS,
+ Sh_Flags => 0,
+ Sh_Addr => Elf32_Addr (Sect.Vaddr),
+ Sh_Offset => 0,
+ Sh_Size => 0,
+ Sh_Link => 0,
+ Sh_Info => 0,
+ Sh_Addralign => 2 ** Sect.Align,
+ Sh_Entsize => Elf32_Word (Sect.Esize));
+ if Sect.Data = null then
+ Shdr (Nbr_Sect).Sh_Type := SHT_NOBITS;
+ end if;
+ if (Sect.Flags and Section_Read) /= 0 then
+ Shdr (Nbr_Sect).Sh_Flags :=
+ Shdr (Nbr_Sect).Sh_Flags or SHF_ALLOC;
+ end if;
+ if (Sect.Flags and Section_Exec) /= 0 then
+ Shdr (Nbr_Sect).Sh_Flags :=
+ Shdr (Nbr_Sect).Sh_Flags or SHF_EXECINSTR;
+ end if;
+ if (Sect.Flags and Section_Write) /= 0 then
+ Shdr (Nbr_Sect).Sh_Flags :=
+ Shdr (Nbr_Sect).Sh_Flags or SHF_WRITE;
+ end if;
+ if Sect.Flags = Section_Strtab then
+ Shdr (Nbr_Sect).Sh_Type := SHT_STRTAB;
+ Shdr (Nbr_Sect).Sh_Addralign := 1;
+ Shdr (Nbr_Sect).Sh_Entsize := 0;
+ end if;
+
+ Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size
+ + Sect.Name'Length + 1; -- 1 for Nul.
+
+ Nbr_Sect := Nbr_Sect + 1;
+ if Flag_Reloc then
+ if Sect.First_Reloc /= null then
+ Do_Intra_Section_Reloc (Sect);
+ end if;
+ end if;
+ if Sect.First_Reloc /= null then
+ -- Add a section for the relocs.
+ Shdr (Nbr_Sect) := Elf32_Shdr'
+ (Sh_Name => Shdr (Sect_Shstrtab).Sh_Size,
+ Sh_Type => SHT_NULL,
+ Sh_Flags => 0,
+ Sh_Addr => 0,
+ Sh_Offset => 0,
+ Sh_Size => 0,
+ Sh_Link => Elf32_Word (Sect_Symtab),
+ Sh_Info => Elf32_Word (Nbr_Sect - 1),
+ Sh_Addralign => 4,
+ Sh_Entsize => Elf32_Word (Rel_Size));
+
+ if Is_Rela (Arch) then
+ Shdr (Nbr_Sect).Sh_Type := SHT_RELA;
+ else
+ Shdr (Nbr_Sect).Sh_Type := SHT_REL;
+ end if;
+ Shdr (Sect_Shstrtab).Sh_Size := Shdr (Sect_Shstrtab).Sh_Size
+ + Sect.Name'Length + 4 -- 4 for ".rel"
+ + Boolean'Pos (Is_Rela (Arch)) + 1; -- 1 for 'a', 1 for Nul.
+
+ Nbr_Sect := Nbr_Sect + 1;
+ end if;
+ Sect := Sect.Next;
+ end loop;
+
+ -- Lay-out sections.
+ Offset := Elf32_Off (Elf32_Ehdr_Size);
+
+ -- Section table
+ Offset := Offset + Elf32_Off (Nbr_Sect * Elf32_Shdr_Size);
+
+ -- shstrtab.
+ Shdr (Sect_Shstrtab).Sh_Offset := Offset;
+
+ Offset := Sect_Align (Offset + Shdr (Sect_Shstrtab).Sh_Size);
+
+ -- user-sections and relocation.
+ for I in Sect_First .. Nbr_Sect - 1 loop
+ Sect := Sections (I).Sect;
+ if Sect /= null then
+ Sect.Pc := Pow_Align (Sect.Pc, Sect.Align);
+ Shdr (Sect.Number).Sh_Size := Elf32_Word (Sect.Pc);
+ if Sect.Data /= null then
+ -- Set data offset.
+ Shdr (Sect.Number).Sh_Offset := Offset;
+ Offset := Offset + Shdr (Sect.Number).Sh_Size;
+
+ -- Set relocs offset.
+ if Sect.First_Reloc /= null then
+ Shdr (Sect.Number + 1).Sh_Offset := Offset;
+ Shdr (Sect.Number + 1).Sh_Size :=
+ Elf32_Word (Sect.Nbr_Relocs * Rel_Size);
+ Offset := Offset + Shdr (Sect.Number + 1).Sh_Size;
+ end if;
+ end if;
+ -- Set link.
+ if Sect.Link /= null then
+ Shdr (Sect.Number).Sh_Link := Elf32_Word (Sect.Link.Number);
+ end if;
+ end if;
+ end loop;
+
+ -- Number symbols, put local before globals.
+ Nbr_Symbols := 1 + Nbr_Sections;
+
+ -- First local symbols.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Private =>
+ Set_Number (I, Nbr_Symbols);
+ Nbr_Symbols := Nbr_Symbols + 1;
+ when Sym_Local =>
+ if not Flag_Discard_Local then
+ Set_Number (I, Nbr_Symbols);
+ Nbr_Symbols := Nbr_Symbols + 1;
+ end if;
+ when Sym_Undef
+ | Sym_Global =>
+ null;
+ end case;
+ end loop;
+
+ Shdr (Sect_Symtab).Sh_Info := Elf32_Word (Nbr_Symbols);
+
+ -- Then globals.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Private
+ | Sym_Local =>
+ null;
+ when Sym_Undef =>
+ if Get_Used (I) then
+ Set_Number (I, Nbr_Symbols);
+ Nbr_Symbols := Nbr_Symbols + 1;
+ end if;
+ when Sym_Global =>
+ Set_Number (I, Nbr_Symbols);
+ Nbr_Symbols := Nbr_Symbols + 1;
+ end case;
+ end loop;
+
+ -- Symtab.
+ Shdr (Sect_Symtab).Sh_Offset := Offset;
+ -- 1 for nul.
+ Shdr (Sect_Symtab).Sh_Size := Elf32_Word (Nbr_Symbols * Elf32_Sym_Size);
+
+ Offset := Offset + Shdr (Sect_Symtab).Sh_Size;
+
+ -- Strtab offset.
+ Shdr (Sect_Strtab).Sh_Offset := Offset;
+ Shdr (Sect_Strtab).Sh_Size := 1;
+
+ -- Compute length of strtab.
+ -- First, sections names.
+ Sect := Section_Chain;
+-- while Sect /= null loop
+-- Shdr (Sect_Strtab).Sh_Size :=
+-- Shdr (Sect_Strtab).Sh_Size + Sect.Name'Length + 1;
+-- Sect := Sect.Prev;
+-- end loop;
+ -- Then symbols.
+ declare
+ Len : Natural;
+ L : Natural;
+ begin
+ Len := 0;
+ for I in Symbols.First .. Symbols.Last loop
+ L := Get_Symbol_Name_Length (I) + 1;
+ case Get_Scope (I) is
+ when Sym_Local =>
+ if Flag_Discard_Local then
+ L := 0;
+ end if;
+ when Sym_Private =>
+ null;
+ when Sym_Global =>
+ null;
+ when Sym_Undef =>
+ if not Get_Used (I) then
+ L := 0;
+ end if;
+ end case;
+ Len := Len + L;
+ end loop;
+
+ Shdr (Sect_Strtab).Sh_Size :=
+ Shdr (Sect_Strtab).Sh_Size + Elf32_Word (Len);
+ end;
+
+ -- Write file header.
+ declare
+ Ehdr : Elf32_Ehdr;
+ begin
+ Ehdr := (E_Ident => (EI_MAG0 => ELFMAG0,
+ EI_MAG1 => ELFMAG1,
+ EI_MAG2 => ELFMAG2,
+ EI_MAG3 => ELFMAG3,
+ EI_CLASS => ELFCLASS32,
+ EI_DATA => ELFDATANONE,
+ EI_VERSION => EV_CURRENT,
+ EI_PAD .. 15 => 0),
+ E_Type => ET_REL,
+ E_Machine => EM_NONE,
+ E_Version => Elf32_Word (EV_CURRENT),
+ E_Entry => 0,
+ E_Phoff => 0,
+ E_Shoff => Elf32_Off (Elf32_Ehdr_Size),
+ E_Flags => 0,
+ E_Ehsize => Elf32_Half (Elf32_Ehdr_Size),
+ E_Phentsize => 0,
+ E_Phnum => 0,
+ E_Shentsize => Elf32_Half (Elf32_Shdr_Size),
+ E_Shnum => Elf32_Half (Nbr_Sect),
+ E_Shstrndx => 1);
+ case Arch is
+ when Arch_X86 =>
+ Ehdr.E_Ident (EI_DATA) := ELFDATA2LSB;
+ Ehdr.E_Machine := EM_386;
+ when Arch_Sparc =>
+ Ehdr.E_Ident (EI_DATA) := ELFDATA2MSB;
+ Ehdr.E_Machine := EM_SPARC;
+ when others =>
+ raise Program_Error;
+ end case;
+ Xwrite (Ehdr'Address, Elf32_Ehdr_Size);
+ end;
+
+ -- Write shdr.
+ Xwrite (Shdr'Address, Nbr_Sect * Elf32_Shdr_Size);
+
+ -- Write shstrtab
+ Check_File_Pos (Shdr (Sect_Shstrtab).Sh_Offset);
+ declare
+ Str : String :=
+ NUL & ".shstrtab" & NUL & ".symtab" & NUL & ".strtab" & NUL;
+ Rela : String := NUL & ".rela";
+ begin
+ Xwrite (Str'Address, Str'Length);
+ Sect := Section_Chain;
+ while Sect /= null loop
+ Xwrite (Sect.Name.all'Address, Sect.Name'Length);
+ if Sect.First_Reloc /= null then
+ if Is_Rela (Arch) then
+ Xwrite (Rela'Address, Rela'Length);
+ else
+ Xwrite (Rela'Address, Rela'Length - 1);
+ end if;
+ Xwrite (Sect.Name.all'Address, Sect.Name'Length);
+ end if;
+ Xwrite (NUL'Address, 1);
+ Sect := Sect.Next;
+ end loop;
+ end;
+ -- Pad.
+ declare
+ Delt : Elf32_Word;
+ Nul_Str : String (1 .. 4) := (others => NUL);
+ begin
+ Delt := Shdr (Sect_Shstrtab).Sh_Size and 3;
+ if Delt /= 0 then
+ Xwrite (Nul_Str'Address, Natural (4 - Delt));
+ end if;
+ end;
+
+ -- Write sections content and reloc.
+ for I in 1 .. Nbr_Sect loop
+ Sect := Sections (I).Sect;
+ if Sect /= null then
+ if Sect.Data /= null then
+ Check_File_Pos (Shdr (Sect.Number).Sh_Offset);
+ Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc));
+ end if;
+ declare
+ R : Reloc_Acc;
+ Rel : Elf32_Rel;
+ Rela : Elf32_Rela;
+ S : Elf32_Word;
+ Nbr_Reloc : Natural;
+ begin
+ R := Sect.First_Reloc;
+ Nbr_Reloc := 0;
+ while R /= null loop
+ if R.Done then
+ S := Sections (Get_Section (R.Sym).Number).Sym;
+ else
+ S := Elf32_Word (Get_Number (R.Sym));
+ end if;
+
+ if Is_Rela (Arch) then
+ case R.Kind is
+ when Reloc_Disp22 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP22);
+ when Reloc_Disp30 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_WDISP30);
+ when Reloc_Hi22 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_HI22);
+ when Reloc_Lo10 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_LO10);
+ when Reloc_32 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_32);
+ when Reloc_Ua_32 =>
+ Rela.R_Info := Elf32_R_Info (S, R_SPARC_UA32);
+ when others =>
+ raise Program_Error;
+ end case;
+ Rela.R_Addend := 0;
+ Rela.R_Offset := Elf32_Addr (R.Addr);
+ Xwrite (Rela'Address, Elf32_Rela_Size);
+ else
+ case R.Kind is
+ when Reloc_32 =>
+ Rel.R_Info := Elf32_R_Info (S, R_386_32);
+ when Reloc_Pc32 =>
+ Rel.R_Info := Elf32_R_Info (S, R_386_PC32);
+ when others =>
+ raise Program_Error;
+ end case;
+ Rel.R_Offset := Elf32_Addr (R.Addr);
+ Xwrite (Rel'Address, Elf32_Rel_Size);
+ end if;
+ Nbr_Reloc := Nbr_Reloc + 1;
+ R := R.Sect_Next;
+ end loop;
+ if Nbr_Reloc /= Sect.Nbr_Relocs then
+ raise Program_Error;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ -- Write symbol table.
+ Check_File_Pos (Shdr (Sect_Symtab).Sh_Offset);
+ declare
+ Str_Off : Elf32_Word;
+
+ procedure Gen_Sym (S : Symbol)
+ is
+ Sym : Elf32_Sym;
+ Bind : Elf32_Uchar;
+ Typ : Elf32_Uchar;
+ begin
+ Sym := Elf32_Sym'(St_Name => Str_Off,
+ St_Value => Elf32_Addr (Get_Symbol_Value (S)),
+ St_Size => 0,
+ St_Info => 0,
+ St_Other => 0,
+ St_Shndx => SHN_UNDEF);
+ if Get_Section (S) /= null then
+ Sym.St_Shndx := Elf32_Half (Get_Section (S).Number);
+ end if;
+ case Get_Scope (S) is
+ when Sym_Private
+ | Sym_Local =>
+ Bind := STB_LOCAL;
+ Typ := STT_NOTYPE;
+ when Sym_Global =>
+ Bind := STB_GLOBAL;
+ if Get_Section (S) /= null
+ and then (Get_Section (S).Flags and Section_Exec) /= 0
+ then
+ Typ := STT_FUNC;
+ else
+ Typ := STT_OBJECT;
+ end if;
+ when Sym_Undef =>
+ Bind := STB_GLOBAL;
+ Typ := STT_NOTYPE;
+ end case;
+ Sym.St_Info := Elf32_St_Info (Bind, Typ);
+
+ Xwrite (Sym'Address, Elf32_Sym_Size);
+
+ Str_Off := Str_Off + Elf32_Off (Get_Symbol_Name_Length (S) + 1);
+ end Gen_Sym;
+
+ Sym : Elf32_Sym;
+ begin
+
+ Str_Off := 1;
+
+ -- write null entry
+ Sym := Elf32_Sym'(St_Name => 0,
+ St_Value => 0,
+ St_Size => 0,
+ St_Info => 0,
+ St_Other => 0,
+ St_Shndx => SHN_UNDEF);
+ Xwrite (Sym'Address, Elf32_Sym_Size);
+
+ -- write section entries
+ Sect := Section_Chain;
+ while Sect /= null loop
+-- Sym := Elf32_Sym'(St_Name => Str_Off,
+-- St_Value => 0,
+-- St_Size => 0,
+-- St_Info => Elf32_St_Info (STB_LOCAL,
+-- STT_NOTYPE),
+-- St_Other => 0,
+-- St_Shndx => Elf32_Half (Sect.Number));
+-- Xwrite (Sym'Address, Elf32_Sym_Size);
+-- Str_Off := Str_Off + Sect.Name'Length + 1;
+
+ Sym := Elf32_Sym'(St_Name => 0,
+ St_Value => 0,
+ St_Size => 0,
+ St_Info => Elf32_St_Info (STB_LOCAL,
+ STT_SECTION),
+ St_Other => 0,
+ St_Shndx => Elf32_Half (Sect.Number));
+ Xwrite (Sym'Address, Elf32_Sym_Size);
+ Sect := Sect.Next;
+ end loop;
+
+ -- First local symbols.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Private =>
+ Gen_Sym (I);
+ when Sym_Local =>
+ if not Flag_Discard_Local then
+ Gen_Sym (I);
+ end if;
+ when Sym_Global
+ | Sym_Undef =>
+ null;
+ end case;
+ end loop;
+
+ -- Then global symbols.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Global =>
+ Gen_Sym (I);
+ when Sym_Undef =>
+ if Get_Used (I) then
+ Gen_Sym (I);
+ end if;
+ when Sym_Private
+ | Sym_Local =>
+ null;
+ end case;
+ end loop;
+ end;
+
+ -- Write strtab.
+ Check_File_Pos (Shdr (Sect_Strtab).Sh_Offset);
+ -- First is NUL.
+ Xwrite (NUL'Address, 1);
+ -- Then the sections name.
+-- Sect := Section_List;
+-- while Sect /= null loop
+-- Xwrite (Sect.Name.all'Address, Sect.Name'Length);
+-- Xwrite (NUL'Address, 1);
+-- Sect := Sect.Prev;
+-- end loop;
+
+ -- Then the symbols name.
+ declare
+ procedure Write_Sym_Name (S : Symbol)
+ is
+ Str : String := Get_Symbol_Name (S) & NUL;
+ begin
+ Xwrite (Str'Address, Str'Length);
+ end Write_Sym_Name;
+ begin
+ -- First locals.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Private =>
+ Write_Sym_Name (I);
+ when Sym_Local =>
+ if not Flag_Discard_Local then
+ Write_Sym_Name (I);
+ end if;
+ when Sym_Global
+ | Sym_Undef =>
+ null;
+ end case;
+ end loop;
+
+ -- Then global symbols.
+ for I in Symbols.First .. Symbols.Last loop
+ case Get_Scope (I) is
+ when Sym_Global =>
+ Write_Sym_Name (I);
+ when Sym_Undef =>
+ if Get_Used (I) then
+ Write_Sym_Name (I);
+ end if;
+ when Sym_Private
+ | Sym_Local =>
+ null;
+ end case;
+ end loop;
+ end;
+ end Write_Elf;
+
+end Binary_File.Elf;
diff --git a/src/ortho/mcode/binary_file-elf.ads b/src/ortho/mcode/binary_file-elf.ads
new file mode 100644
index 000000000..e0d3a4d2a
--- /dev/null
+++ b/src/ortho/mcode/binary_file-elf.ads
@@ -0,0 +1,22 @@
+-- Binary file ELF writer.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.OS_Lib;
+
+package Binary_File.Elf is
+ procedure Write_Elf (Fd : GNAT.OS_Lib.File_Descriptor);
+end Binary_File.Elf;
diff --git a/src/ortho/mcode/binary_file-memory.adb b/src/ortho/mcode/binary_file-memory.adb
new file mode 100644
index 000000000..a37af9cb7
--- /dev/null
+++ b/src/ortho/mcode/binary_file-memory.adb
@@ -0,0 +1,101 @@
+-- Binary file execute in memory handler.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Unchecked_Conversion;
+
+package body Binary_File.Memory is
+ -- Absolute section.
+ Sect_Abs : Section_Acc;
+
+ function To_Pc_Type is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Pc_Type);
+
+ procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address)
+ is
+ begin
+ Set_Symbol_Value (Sym, To_Pc_Type (Addr));
+ Set_Scope (Sym, Sym_Global);
+ Set_Section (Sym, Sect_Abs);
+ end Set_Symbol_Address;
+
+ procedure Write_Memory_Init is
+ begin
+ Create_Section (Sect_Abs, "*ABS*", Section_Exec);
+ Sect_Abs.Vaddr := 0;
+ end Write_Memory_Init;
+
+ procedure Write_Memory_Relocate (Error : out Boolean)
+ is
+ Sect : Section_Acc;
+ Rel : Reloc_Acc;
+ N_Rel : Reloc_Acc;
+ begin
+ -- Relocate section in memory.
+ Sect := Section_Chain;
+ while Sect /= null loop
+ if Sect.Data = null then
+ if Sect.Pc > 0 then
+ Resize (Sect, Sect.Pc);
+ Sect.Data (0 .. Sect.Pc - 1) := (others => 0);
+ else
+ null;
+ --Sect.Data := new Byte_Array (1 .. 0);
+ end if;
+ end if;
+ if Sect.Data_Max > 0
+ and (Sect /= Sect_Abs and Sect.Flags /= Section_Debug)
+ then
+ Sect.Vaddr := To_Pc_Type (Sect.Data (0)'Address);
+ end if;
+ Sect := Sect.Next;
+ end loop;
+
+ -- Do all relocations.
+ Sect := Section_Chain;
+ Error := False;
+ while Sect /= null loop
+-- Put_Line ("Section: " & Sect.Name.all & ", Flags:"
+-- & Section_Flags'Image (Sect.Flags));
+ Rel := Sect.First_Reloc;
+ while Rel /= null loop
+ N_Rel := Rel.Sect_Next;
+ if Get_Scope (Rel.Sym) = Sym_Undef then
+ Put_Line ("symbol " & Get_Symbol_Name (Rel.Sym)
+ & " is undefined");
+ Error := True;
+ else
+ Apply_Reloc (Sect, Rel);
+ end if;
+ Free (Rel);
+ Rel := N_Rel;
+ end loop;
+
+ Sect.First_Reloc := null;
+ Sect.Last_Reloc := null;
+ Sect.Nbr_Relocs := 0;
+
+ if (Sect.Flags and Section_Exec) /= 0
+ and (Sect.Flags and Section_Write) = 0
+ then
+ Memsegs.Set_Rx (Sect.Seg);
+ end if;
+
+ Sect := Sect.Next;
+ end loop;
+ end Write_Memory_Relocate;
+end Binary_File.Memory;
diff --git a/src/ortho/mcode/binary_file-memory.ads b/src/ortho/mcode/binary_file-memory.ads
new file mode 100644
index 000000000..a205da527
--- /dev/null
+++ b/src/ortho/mcode/binary_file-memory.ads
@@ -0,0 +1,25 @@
+-- Binary file execute in memory handler.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Binary_File.Memory is
+
+ -- Must be called before set_symbol_address.
+ procedure Write_Memory_Init;
+ procedure Set_Symbol_Address (Sym : Symbol; Addr : System.Address);
+
+ procedure Write_Memory_Relocate (Error : out Boolean);
+end Binary_File.Memory;
diff --git a/src/ortho/mcode/binary_file.adb b/src/ortho/mcode/binary_file.adb
new file mode 100644
index 000000000..6043d7319
--- /dev/null
+++ b/src/ortho/mcode/binary_file.adb
@@ -0,0 +1,977 @@
+-- Binary file handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System.Storage_Elements;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Latin_1;
+with Ada.Unchecked_Conversion;
+with Hex_Images; use Hex_Images;
+with Disassemble;
+
+package body Binary_File is
+ Cur_Sect : Section_Acc := null;
+
+ HT : Character renames Ada.Characters.Latin_1.HT;
+
+ function To_Byte_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Byte_Array_Acc);
+
+ -- Resize a section to SIZE bytes.
+ procedure Resize (Sect : Section_Acc; Size : Pc_Type)
+ is
+ begin
+ Sect.Data_Max := Size;
+ Memsegs.Resize (Sect.Seg, Natural (Size));
+ Sect.Data := To_Byte_Array_Acc (Memsegs.Get_Address (Sect.Seg));
+ end Resize;
+
+ function Get_Scope (Sym : Symbol) return Symbol_Scope is
+ begin
+ return Symbols.Table (Sym).Scope;
+ end Get_Scope;
+
+ procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope) is
+ begin
+ Symbols.Table (Sym).Scope := Scope;
+ end Set_Scope;
+
+ function Get_Section (Sym : Symbol) return Section_Acc is
+ begin
+ return Symbols.Table (Sym).Section;
+ end Get_Section;
+
+ procedure Set_Section (Sym : Symbol; Sect : Section_Acc) is
+ begin
+ Symbols.Table (Sym).Section := Sect;
+ end Set_Section;
+
+ function Get_Number (Sym : Symbol) return Natural is
+ begin
+ return Symbols.Table (Sym).Number;
+ end Get_Number;
+
+ procedure Set_Number (Sym : Symbol; Num : Natural) is
+ begin
+ Symbols.Table (Sym).Number := Num;
+ end Set_Number;
+
+ function Get_Relocs (Sym : Symbol) return Reloc_Acc is
+ begin
+ return Symbols.Table (Sym).Relocs;
+ end Get_Relocs;
+
+ procedure Set_Relocs (Sym : Symbol; Reloc : Reloc_Acc) is
+ begin
+ Symbols.Table (Sym).Relocs := Reloc;
+ end Set_Relocs;
+
+ function Get_Name (Sym : Symbol) return O_Ident is
+ begin
+ return Symbols.Table (Sym).Name;
+ end Get_Name;
+
+ function Get_Used (Sym : Symbol) return Boolean is
+ begin
+ return Symbols.Table (Sym).Used;
+ end Get_Used;
+
+ procedure Set_Used (Sym : Symbol; Val : Boolean) is
+ begin
+ Symbols.Table (Sym).Used := Val;
+ end Set_Used;
+
+ function Get_Symbol_Value (Sym : Symbol) return Pc_Type is
+ begin
+ return Symbols.Table (Sym).Value;
+ end Get_Symbol_Value;
+
+ procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type) is
+ begin
+ Symbols.Table (Sym).Value := Val;
+ end Set_Symbol_Value;
+
+ function S_Defined (Sym : Symbol) return Boolean is
+ begin
+ return Get_Scope (Sym) /= Sym_Undef;
+ end S_Defined;
+ pragma Unreferenced (S_Defined);
+
+ function S_Local (Sym : Symbol) return Boolean is
+ begin
+ return Get_Scope (Sym) = Sym_Local;
+ end S_Local;
+
+ procedure Create_Section (Sect : out Section_Acc;
+ Name : String; Flags : Section_Flags)
+ is
+ begin
+ Sect := new Section_Type'(Next => null,
+ Flags => Flags,
+ Name => new String'(Name),
+ Link => null,
+ Align => 2,
+ Esize => 0,
+ Pc => 0,
+ Insn_Pc => 0,
+ Data => null,
+ Data_Max => 0,
+ First_Reloc => null,
+ Last_Reloc => null,
+ Nbr_Relocs => 0,
+ Number => 0,
+ Seg => Memsegs.Create,
+ Vaddr => 0);
+ if (Flags and Section_Zero) = 0 then
+ -- Allocate memory for the segment, unless BSS.
+ Resize (Sect, 8192);
+ end if;
+ if (Flags and Section_Strtab) /= 0 then
+ Sect.Align := 0;
+ end if;
+ if Section_Chain = null then
+ Section_Chain := Sect;
+ else
+ Section_Last.Next := Sect;
+ end if;
+ Section_Last := Sect;
+ Nbr_Sections := Nbr_Sections + 1;
+ end Create_Section;
+
+ procedure Sect_Prealloc (Sect : Section_Acc; L : Pc_Type)
+ is
+ New_Max : Pc_Type;
+ begin
+ if Sect.Pc + L < Sect.Data_Max then
+ return;
+ end if;
+ New_Max := Sect.Data_Max;
+ loop
+ New_Max := New_Max * 2;
+ exit when Sect.Pc + L < New_Max;
+ end loop;
+ Resize (Sect, New_Max);
+ end Sect_Prealloc;
+
+ procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc)
+ is
+ Rel : Reloc_Acc;
+ begin
+ -- Sanity checks.
+ if Src = null or else Dest = Src then
+ raise Program_Error;
+ end if;
+
+ Rel := Src.First_Reloc;
+
+ if Rel /= null then
+ -- Move relocs.
+ if Dest.Last_Reloc = null then
+ Dest.First_Reloc := Rel;
+ Dest.Last_Reloc := Rel;
+ else
+ Dest.Last_Reloc.Sect_Next := Rel;
+ Dest.Last_Reloc := Rel;
+ end if;
+ Dest.Nbr_Relocs := Dest.Nbr_Relocs + Src.Nbr_Relocs;
+
+
+ -- Reloc reloc, since the pc has changed.
+ while Rel /= null loop
+ Rel.Addr := Rel.Addr + Dest.Pc;
+ Rel := Rel.Sect_Next;
+ end loop;
+ end if;
+
+ if Src.Pc > 0 then
+ Sect_Prealloc (Dest, Src.Pc);
+ Dest.Data (Dest.Pc .. Dest.Pc + Src.Pc - 1) :=
+ Src.Data (0 .. Src.Pc - 1);
+ Dest.Pc := Dest.Pc + Src.Pc;
+ end if;
+
+ Memsegs.Delete (Src.Seg);
+ Src.Pc := 0;
+ Src.Data_Max := 0;
+ Src.Data := null;
+ Src.First_Reloc := null;
+ Src.Last_Reloc := null;
+ Src.Nbr_Relocs := 0;
+
+ -- Remove from section_chain.
+ if Section_Chain = Src then
+ Section_Chain := Src.Next;
+ else
+ declare
+ Sect : Section_Acc;
+ begin
+ Sect := Section_Chain;
+ while Sect.Next /= Src loop
+ Sect := Sect.Next;
+ end loop;
+ Sect.Next := Src.Next;
+ if Section_Last = Src then
+ Section_Last := Sect;
+ end if;
+ end;
+ end if;
+ Nbr_Sections := Nbr_Sections - 1;
+ end Merge_Section;
+
+ procedure Set_Section_Info (Sect : Section_Acc;
+ Link : Section_Acc;
+ Align : Natural;
+ Esize : Natural)
+ is
+ begin
+ Sect.Link := Link;
+ Sect.Align := Align;
+ Sect.Esize := Esize;
+ end Set_Section_Info;
+
+ procedure Set_Current_Section (Sect : Section_Acc) is
+ begin
+ -- If the current section does not change, this is a no-op.
+ if Cur_Sect = Sect then
+ return;
+ end if;
+
+ if Dump_Asm then
+ Put_Line (HT & ".section """ & Sect.Name.all & """");
+ end if;
+ Cur_Sect := Sect;
+ end Set_Current_Section;
+
+ function Get_Current_Pc return Pc_Type is
+ begin
+ return Cur_Sect.Pc;
+ end Get_Current_Pc;
+
+ function Get_Pc (Sect : Section_Acc) return Pc_Type is
+ begin
+ return Sect.Pc;
+ end Get_Pc;
+
+
+ procedure Prealloc (L : Pc_Type) is
+ begin
+ Sect_Prealloc (Cur_Sect, L);
+ end Prealloc;
+
+ procedure Start_Insn is
+ begin
+ -- Check there is enough memory for the next instruction.
+ Sect_Prealloc (Cur_Sect, 16);
+ if Cur_Sect.Insn_Pc /= 0 then
+ -- end_insn was not called.
+ raise Program_Error;
+ end if;
+ Cur_Sect.Insn_Pc := Cur_Sect.Pc;
+ end Start_Insn;
+
+ procedure Get_Symbol_At_Addr (Addr : System.Address;
+ Line : in out String;
+ Line_Len : in out Natural)
+ is
+ use System;
+ use System.Storage_Elements;
+ Off : Pc_Type;
+ Reloc : Reloc_Acc;
+ begin
+ -- Check if addr is in the current section.
+ if Addr < Cur_Sect.Data (0)'Address
+ or else Addr > Cur_Sect.Data (Cur_Sect.Pc)'Address
+ then
+ raise Program_Error;
+ --return;
+ end if;
+ Off := Pc_Type
+ (To_Integer (Addr) - To_Integer (Cur_Sect.Data (0)'Address));
+
+ -- Find a relocation at OFF.
+ Reloc := Cur_Sect.First_Reloc;
+ while Reloc /= null loop
+ if Reloc.Addr = Off then
+ declare
+ Str : constant String := Get_Symbol_Name (Reloc.Sym);
+ begin
+ Line (Line'First .. Line'First + Str'Length - 1) := Str;
+ Line_Len := Line_Len + Str'Length;
+ return;
+ end;
+ end if;
+ Reloc := Reloc.Sect_Next;
+ end loop;
+ end Get_Symbol_At_Addr;
+
+ procedure End_Insn
+ is
+ Str : String (1 .. 256);
+ Len : Natural;
+ Insn_Len : Natural;
+ begin
+ --if Insn_Pc = 0 then
+ -- -- start_insn was not called.
+ -- raise Program_Error;
+ --end if;
+ if Debug_Hex then
+ Put (HT);
+ Put ('#');
+ for I in Cur_Sect.Insn_Pc .. Cur_Sect.Pc - 1 loop
+ Put (' ');
+ Put (Hex_Image (Unsigned_8 (Cur_Sect.Data (I))));
+ end loop;
+ New_Line;
+ end if;
+
+ if Dump_Asm then
+ Disassemble.Disassemble_Insn
+ (Cur_Sect.Data (Cur_Sect.Insn_Pc)'Address,
+ Unsigned_32 (Cur_Sect.Insn_Pc),
+ Str, Len, Insn_Len,
+ Get_Symbol_At_Addr'Access);
+ Put (HT);
+ Put_Line (Str (1 .. Len));
+ end if;
+ --if Natural (Cur_Pc - Insn_Pc) /= Insn_Len then
+ -- raise Program_Error;
+ --end if;
+ Cur_Sect.Insn_Pc := 0;
+ end End_Insn;
+
+ procedure Gen_B8 (B : Byte) is
+ begin
+ Cur_Sect.Data (Cur_Sect.Pc) := B;
+ Cur_Sect.Pc := Cur_Sect.Pc + 1;
+ end Gen_B8;
+
+ procedure Gen_B16 (B0, B1 : Byte) is
+ begin
+ Cur_Sect.Data (Cur_Sect.Pc + 0) := B0;
+ Cur_Sect.Data (Cur_Sect.Pc + 1) := B1;
+ Cur_Sect.Pc := Cur_Sect.Pc + 2;
+ end Gen_B16;
+
+ procedure Gen_Le8 (B : Unsigned_32) is
+ begin
+ Cur_Sect.Data (Cur_Sect.Pc) := Byte (B and 16#Ff#);
+ Cur_Sect.Pc := Cur_Sect.Pc + 1;
+ end Gen_Le8;
+
+ procedure Gen_Le16 (B : Unsigned_32) is
+ begin
+ Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 0) and 16#Ff#);
+ Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 8) and 16#Ff#);
+ Cur_Sect.Pc := Cur_Sect.Pc + 2;
+ end Gen_Le16;
+
+ procedure Gen_Be16 (B : Unsigned_32) is
+ begin
+ Cur_Sect.Data (Cur_Sect.Pc + 0) := Byte (Shift_Right (B, 8) and 16#Ff#);
+ Cur_Sect.Data (Cur_Sect.Pc + 1) := Byte (Shift_Right (B, 0) and 16#Ff#);
+ Cur_Sect.Pc := Cur_Sect.Pc + 2;
+ end Gen_Be16;
+
+ procedure Write_B8 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_8) is
+ begin
+ Sect.Data (Pc) := Byte (V);
+ end Write_B8;
+
+ procedure Write_Be16 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ Sect.Data (Pc + 0) := Byte (Shift_Right (V, 8) and 16#Ff#);
+ Sect.Data (Pc + 1) := Byte (Shift_Right (V, 0) and 16#Ff#);
+ end Write_Be16;
+
+ procedure Write_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ Sect.Data (Pc + 0) := Byte (Shift_Right (V, 0) and 16#Ff#);
+ Sect.Data (Pc + 1) := Byte (Shift_Right (V, 8) and 16#Ff#);
+ Sect.Data (Pc + 2) := Byte (Shift_Right (V, 16) and 16#Ff#);
+ Sect.Data (Pc + 3) := Byte (Shift_Right (V, 24) and 16#Ff#);
+ end Write_Le32;
+
+ procedure Write_Be32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ Sect.Data (Pc + 0) := Byte (Shift_Right (V, 24) and 16#Ff#);
+ Sect.Data (Pc + 1) := Byte (Shift_Right (V, 16) and 16#Ff#);
+ Sect.Data (Pc + 2) := Byte (Shift_Right (V, 8) and 16#Ff#);
+ Sect.Data (Pc + 3) := Byte (Shift_Right (V, 0) and 16#Ff#);
+ end Write_Be32;
+
+ procedure Write_16 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32)
+ is
+ subtype B2 is Byte_Array_Base (0 .. 1);
+ function To_B2 is new Ada.Unchecked_Conversion
+ (Source => Unsigned_16, Target => B2);
+ begin
+ Sect.Data (Pc + 0 .. Pc + 1) := To_B2 (Unsigned_16 (B));
+ end Write_16;
+
+ procedure Write_32 (Sect : Section_Acc; Pc : Pc_Type; B : Unsigned_32)
+ is
+ subtype B4 is Byte_Array_Base (0 .. 3);
+ function To_B4 is new Ada.Unchecked_Conversion
+ (Source => Unsigned_32, Target => B4);
+ begin
+ Sect.Data (Pc + 0 .. Pc + 3) := To_B4 (B);
+ end Write_32;
+
+ procedure Gen_16 (B : Unsigned_32) is
+ begin
+ Write_16 (Cur_Sect, Cur_Sect.Pc, B);
+ Cur_Sect.Pc := Cur_Sect.Pc + 2;
+ end Gen_16;
+
+ procedure Gen_32 (B : Unsigned_32) is
+ begin
+ Write_32 (Cur_Sect, Cur_Sect.Pc, B);
+ Cur_Sect.Pc := Cur_Sect.Pc + 4;
+ end Gen_32;
+
+ function Read_Le32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is
+ begin
+ return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 0)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 8)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 16)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 24);
+ end Read_Le32;
+
+ function Read_Be32 (Sect : Section_Acc; Pc : Pc_Type) return Unsigned_32 is
+ begin
+ return Shift_Left (Unsigned_32 (Sect.Data (Pc + 0)), 24)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 1)), 16)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 2)), 8)
+ or Shift_Left (Unsigned_32 (Sect.Data (Pc + 3)), 0);
+ end Read_Be32;
+
+ procedure Add_Le32 (Sect : Section_Acc; Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ Write_Le32 (Sect, Pc, V + Read_Le32 (Sect, Pc));
+ end Add_Le32;
+
+ procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ if Pc + 4 > Get_Current_Pc then
+ raise Program_Error;
+ end if;
+ Write_Le32 (Cur_Sect, Pc, V);
+ end Patch_Le32;
+
+ procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ if Pc + 4 > Get_Current_Pc then
+ raise Program_Error;
+ end if;
+ Write_Be32 (Cur_Sect, Pc, V);
+ end Patch_Be32;
+
+ procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ if Pc + 2 > Get_Current_Pc then
+ raise Program_Error;
+ end if;
+ Write_Be16 (Cur_Sect, Pc, V);
+ end Patch_Be16;
+
+ procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8) is
+ begin
+ if Pc >= Get_Current_Pc then
+ raise Program_Error;
+ end if;
+ Write_B8 (Cur_Sect, Pc, V);
+ end Patch_B8;
+
+ procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32) is
+ begin
+ if Pc + 4 > Get_Current_Pc then
+ raise Program_Error;
+ end if;
+ Write_32 (Cur_Sect, Pc, V);
+ end Patch_32;
+
+ procedure Gen_Le32 (B : Unsigned_32) is
+ begin
+ Write_Le32 (Cur_Sect, Cur_Sect.Pc, B);
+ Cur_Sect.Pc := Cur_Sect.Pc + 4;
+ end Gen_Le32;
+
+ procedure Gen_Be32 (B : Unsigned_32) is
+ begin
+ Write_Be32 (Cur_Sect, Cur_Sect.Pc, B);
+ Cur_Sect.Pc := Cur_Sect.Pc + 4;
+ end Gen_Be32;
+
+ procedure Gen_Data_Le8 (B : Unsigned_32) is
+ begin
+ if Dump_Asm then
+ Put_Line (HT & ".byte 0x" & Hex_Image (Unsigned_8 (B)));
+ end if;
+ Gen_Le8 (B);
+ end Gen_Data_Le8;
+
+ procedure Gen_Data_Le16 (B : Unsigned_32) is
+ begin
+ if Dump_Asm then
+ Put_Line (HT & ".half 0x" & Hex_Image (Unsigned_16 (B)));
+ end if;
+ Gen_Le16 (B);
+ end Gen_Data_Le16;
+
+ procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32) is
+ begin
+ if Dump_Asm then
+ if Sym = Null_Symbol then
+ Put_Line (HT & ".word 0x" & Hex_Image (Offset));
+ else
+ if Offset = 0 then
+ Put_Line (HT & ".word " & Get_Symbol_Name (Sym));
+ else
+ Put_Line (HT & ".word " & Get_Symbol_Name (Sym) & " + "
+ & Hex_Image (Offset));
+ end if;
+ end if;
+ end if;
+ case Arch is
+ when Arch_X86 =>
+ Gen_X86_32 (Sym, Offset);
+ when Arch_Sparc =>
+ Gen_Sparc_32 (Sym, Offset);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Gen_Data_32;
+
+ function Create_Symbol (Name : O_Ident) return Symbol
+ is
+ begin
+ Symbols.Append (Symbol_Type'(Section => null,
+ Value => 0,
+ Scope => Sym_Undef,
+ Used => False,
+ Name => Name,
+ Relocs => null,
+ Number => 0));
+ return Symbols.Last;
+ end Create_Symbol;
+
+ Last_Label : Natural := 1;
+
+ function Create_Local_Symbol return Symbol is
+ begin
+ Symbols.Append (Symbol_Type'(Section => Cur_Sect,
+ Value => 0,
+ Scope => Sym_Local,
+ Used => False,
+ Name => O_Ident_Nul,
+ Relocs => null,
+ Number => Last_Label));
+
+ Last_Label := Last_Label + 1;
+
+ return Symbols.Last;
+ end Create_Local_Symbol;
+
+ function Get_Symbol_Name (Sym : Symbol) return String
+ is
+ Res : String (1 .. 10);
+ N : Natural;
+ P : Natural;
+ begin
+ if S_Local (Sym) then
+ N := Get_Number (Sym);
+ P := Res'Last;
+ loop
+ Res (P) := Character'Val ((N mod 10) + Character'Pos ('0'));
+ N := N / 10;
+ P := P - 1;
+ exit when N = 0;
+ end loop;
+ Res (P) := 'L';
+ Res (P - 1) := '.';
+ return Res (P - 1 .. Res'Last);
+ else
+ if Is_Nul (Get_Name (Sym)) then
+ return "ANON";
+ else
+ return Get_String (Get_Name (Sym));
+ end if;
+ end if;
+ end Get_Symbol_Name;
+
+ function Get_Symbol_Name_Length (Sym : Symbol) return Natural
+ is
+ N : Natural;
+ begin
+ if S_Local (Sym) then
+ N := 10;
+ for I in 3 .. 8 loop
+ if Get_Number (Sym) < N then
+ return I;
+ end if;
+ N := N * 10;
+ end loop;
+ raise Program_Error;
+ else
+ return Get_String_Length (Get_Name (Sym));
+ end if;
+ end Get_Symbol_Name_Length;
+
+ function Get_Symbol (Name : String) return Symbol is
+ begin
+ for I in Symbols.First .. Symbols.Last loop
+ if Get_Symbol_Name (I) = Name then
+ return I;
+ end if;
+ end loop;
+ return Null_Symbol;
+ end Get_Symbol;
+
+ function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type
+ is
+ Tmp : Pc_Type;
+ begin
+ Tmp := V + 2 ** Align - 1;
+ return Tmp - (Tmp mod Pc_Type (2 ** Align));
+ end Pow_Align;
+
+ procedure Gen_Pow_Align (Align : Natural) is
+ begin
+ if Align = 0 then
+ return;
+ end if;
+ if Dump_Asm then
+ Put_Line (HT & ".align" & Natural'Image (Align));
+ end if;
+ Cur_Sect.Pc := Pow_Align (Cur_Sect.Pc, Align);
+ end Gen_Pow_Align;
+
+ -- Generate LENGTH bytes set to 0.
+ procedure Gen_Space (Length : Integer_32) is
+ begin
+ if Dump_Asm then
+ Put_Line (HT & ".space" & Integer_32'Image (Length));
+ end if;
+ Cur_Sect.Pc := Cur_Sect.Pc + Pc_Type (Length);
+ end Gen_Space;
+
+ procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean) is
+ begin
+ case Get_Scope (Sym) is
+ when Sym_Local =>
+ if Export then
+ raise Program_Error;
+ end if;
+ when Sym_Private
+ | Sym_Global =>
+ raise Program_Error;
+ when Sym_Undef =>
+ if Export then
+ Set_Scope (Sym, Sym_Global);
+ else
+ Set_Scope (Sym, Sym_Private);
+ end if;
+ end case;
+ -- Set value/section.
+ Set_Symbol_Value (Sym, Cur_Sect.Pc);
+ Set_Section (Sym, Cur_Sect);
+
+ if Dump_Asm then
+ if Export then
+ Put_Line (HT & ".globl " & Get_Symbol_Name (Sym));
+ end if;
+ Put (Get_Symbol_Name (Sym));
+ Put_Line (":");
+ end if;
+ end Set_Symbol_Pc;
+
+ procedure Add_Reloc (Sym : Symbol; Kind : Reloc_Kind)
+ is
+ Reloc : Reloc_Acc;
+ begin
+ Reloc := new Reloc_Type'(Kind => Kind,
+ Done => False,
+ Sym_Next => Get_Relocs (Sym),
+ Sect_Next => null,
+ Addr => Cur_Sect.Pc,
+ Sym => Sym);
+ Set_Relocs (Sym, Reloc);
+ if Cur_Sect.First_Reloc = null then
+ Cur_Sect.First_Reloc := Reloc;
+ else
+ Cur_Sect.Last_Reloc.Sect_Next := Reloc;
+ end if;
+ Cur_Sect.Last_Reloc := Reloc;
+ Cur_Sect.Nbr_Relocs := Cur_Sect.Nbr_Relocs + 1;
+ end Add_Reloc;
+
+ procedure Gen_X86_Pc32 (Sym : Symbol)
+ is
+ begin
+ Add_Reloc (Sym, Reloc_Pc32);
+ Gen_Le32 (16#ff_ff_ff_fc#);
+ end Gen_X86_Pc32;
+
+ procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol)
+ is
+ begin
+ Add_Reloc (Sym, Reloc_Disp22);
+ Gen_Be32 (W);
+ end Gen_Sparc_Disp22;
+
+ procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol)
+ is
+ begin
+ Add_Reloc (Sym, Reloc_Disp30);
+ Gen_Be32 (W);
+ end Gen_Sparc_Disp30;
+
+ procedure Gen_Sparc_Hi22 (W : Unsigned_32;
+ Sym : Symbol; Off : Unsigned_32)
+ is
+ pragma Unreferenced (Off);
+ begin
+ Add_Reloc (Sym, Reloc_Hi22);
+ Gen_Be32 (W);
+ end Gen_Sparc_Hi22;
+
+ procedure Gen_Sparc_Lo10 (W : Unsigned_32;
+ Sym : Symbol; Off : Unsigned_32)
+ is
+ pragma Unreferenced (Off);
+ begin
+ Add_Reloc (Sym, Reloc_Lo10);
+ Gen_Be32 (W);
+ end Gen_Sparc_Lo10;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Integer_32, Target => Unsigned_32);
+
+ procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32) is
+ begin
+ if Sym /= Null_Symbol then
+ Add_Reloc (Sym, Reloc_32);
+ end if;
+ Gen_Le32 (Conv (Offset));
+ end Gen_X86_32;
+
+ procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32) is
+ begin
+ if Sym /= Null_Symbol then
+ Add_Reloc (Sym, Reloc_32);
+ end if;
+ Gen_Be32 (Conv (Offset));
+ end Gen_Sparc_32;
+
+ procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32)
+ is
+ pragma Unreferenced (Offset);
+ begin
+ if Sym /= Null_Symbol then
+ Add_Reloc (Sym, Reloc_Ua_32);
+ end if;
+ Gen_Be32 (0);
+ end Gen_Sparc_Ua_32;
+
+ procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32) is
+ begin
+ case Arch is
+ when Arch_X86 =>
+ Gen_X86_32 (Sym, Offset);
+ when Arch_Sparc =>
+ Gen_Sparc_Ua_32 (Sym, Offset);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Gen_Ua_32;
+
+ procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol)
+ is
+ begin
+ Add_Reloc (Sym, Reloc_Ppc_Addr24);
+ Gen_32 (V);
+ end Gen_Ppc_24;
+
+ function Get_Symbol_Vaddr (Sym : Symbol) return Pc_Type is
+ begin
+ return Get_Section (Sym).Vaddr + Get_Symbol_Value (Sym);
+ end Get_Symbol_Vaddr;
+
+ procedure Write_Left_Be32 (Sect : Section_Acc;
+ Addr : Pc_Type;
+ Size : Natural;
+ Val : Unsigned_32)
+ is
+ W : Unsigned_32;
+ Mask : Unsigned_32;
+ begin
+ -- Write value.
+ Mask := Shift_Left (1, Size) - 1;
+ W := Read_Be32 (Sect, Addr);
+ Write_Be32 (Sect, Addr, (W and not Mask) or (Val and Mask));
+ end Write_Left_Be32;
+
+ procedure Set_Wdisp (Sect : Section_Acc;
+ Addr : Pc_Type;
+ Sym : Symbol;
+ Size : Natural)
+ is
+ D : Unsigned_32;
+ Mask : Unsigned_32;
+ begin
+ D := Unsigned_32 (Get_Symbol_Vaddr (Sym) - (Sect.Vaddr + Addr));
+ -- Check overflow.
+ Mask := Shift_Left (1, Size + 2) - 1;
+ if (D and Shift_Left (1, Size + 1)) = 0 then
+ if (D and not Mask) /= 0 then
+ raise Program_Error;
+ end if;
+ else
+ if (D and not Mask) /= not Mask then
+ raise Program_Error;
+ end if;
+ end if;
+ -- Write value.
+ Write_Left_Be32 (Sect, Addr, Size, D / 4);
+ end Set_Wdisp;
+
+ procedure Do_Reloc (Kind : Reloc_Kind;
+ Sect : Section_Acc; Addr : Pc_Type; Sym : Symbol)
+ is
+ begin
+ if Get_Scope (Sym) = Sym_Undef then
+ raise Program_Error;
+ end if;
+
+ case Kind is
+ when Reloc_32 =>
+ Add_Le32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym)));
+
+ when Reloc_Pc32 =>
+ Add_Le32 (Sect, Addr,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym)
+ - (Sect.Vaddr + Addr)));
+ when Reloc_Disp22 =>
+ Set_Wdisp (Sect, Addr, Sym, 22);
+ when Reloc_Disp30 =>
+ Set_Wdisp (Sect, Addr, Sym, 30);
+ when Reloc_Hi22 =>
+ Write_Left_Be32 (Sect, Addr, 22,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym) / 1024));
+ when Reloc_Lo10 =>
+ Write_Left_Be32 (Sect, Addr, 10,
+ Unsigned_32 (Get_Symbol_Vaddr (Sym)));
+ when Reloc_Ua_32 =>
+ Write_Be32 (Sect, Addr, Unsigned_32 (Get_Symbol_Vaddr (Sym)));
+ when Reloc_Ppc_Addr24 =>
+ raise Program_Error;
+ end case;
+ end Do_Reloc;
+
+ function Is_Reloc_Relative (Reloc : Reloc_Acc) return Boolean is
+ begin
+ case Reloc.Kind is
+ when Reloc_Pc32
+ | Reloc_Disp22
+ | Reloc_Disp30 =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Reloc_Relative;
+
+ procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc) is
+ begin
+ Do_Reloc (Reloc.Kind, Sect, Reloc.Addr, Reloc.Sym);
+ end Apply_Reloc;
+
+ procedure Do_Intra_Section_Reloc (Sect : Section_Acc)
+ is
+ Prev : Reloc_Acc;
+ Rel : Reloc_Acc;
+ Next : Reloc_Acc;
+ begin
+ Rel := Sect.First_Reloc;
+ Prev := null;
+ while Rel /= null loop
+ Next := Rel.Sect_Next;
+ if Get_Scope (Rel.Sym) /= Sym_Undef then
+ Do_Reloc (Rel.Kind, Sect, Rel.Addr, Rel.Sym);
+ Rel.Done := True;
+
+ if Get_Section (Rel.Sym) = Sect
+ and then Is_Reloc_Relative (Rel)
+ then
+ -- Remove reloc.
+ Sect.Nbr_Relocs := Sect.Nbr_Relocs - 1;
+ if Prev = null then
+ Sect.First_Reloc := Next;
+ else
+ Prev.Sect_Next := Next;
+ end if;
+ if Next = null then
+ Sect.Last_Reloc := Prev;
+ end if;
+ Free (Rel);
+ else
+ Prev := Rel;
+ end if;
+ else
+ Set_Used (Rel.Sym, True);
+ Prev := Rel;
+ end if;
+ Rel := Next;
+ end loop;
+ end Do_Intra_Section_Reloc;
+
+ -- Return VAL rounded up to 2 ^ POW.
+-- function Align_Pow (Val : Integer; Pow : Natural) return Integer
+-- is
+-- N : Integer;
+-- Tmp : Integer;
+-- begin
+-- N := 2 ** Pow;
+-- Tmp := Val + N - 1;
+-- return Tmp - (Tmp mod N);
+-- end Align_Pow;
+
+ procedure Disp_Stats is
+ begin
+ Put_Line ("Number of Symbols: " & Symbol'Image (Symbols.Last));
+ end Disp_Stats;
+
+ procedure Finish
+ is
+ Sect : Section_Acc;
+ Rel, N_Rel : Reloc_Acc;
+ begin
+ Symbols.Free;
+ Sect := Section_Chain;
+ while Sect /= null loop
+ -- Free relocs.
+ Rel := Sect.First_Reloc;
+ while Rel /= null loop
+ N_Rel := Rel.Sect_Next;
+ Free (Rel);
+ Rel := N_Rel;
+ end loop;
+ Sect.First_Reloc := null;
+ Sect.Last_Reloc := null;
+
+ Sect := Sect.Next;
+ end loop;
+ end Finish;
+end Binary_File;
diff --git a/src/ortho/mcode/binary_file.ads b/src/ortho/mcode/binary_file.ads
new file mode 100644
index 000000000..1a2bf588d
--- /dev/null
+++ b/src/ortho/mcode/binary_file.ads
@@ -0,0 +1,305 @@
+-- Binary file handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces; use Interfaces;
+with Ada.Unchecked_Deallocation;
+with Ortho_Ident; use Ortho_Ident;
+with GNAT.Table;
+with Memsegs;
+
+package Binary_File is
+ type Section_Type is limited private;
+ type Section_Acc is access Section_Type;
+
+ type Section_Flags is new Unsigned_32;
+ Section_None : constant Section_Flags;
+ Section_Exec : constant Section_Flags;
+ Section_Read : constant Section_Flags;
+ Section_Write : constant Section_Flags;
+ Section_Zero : constant Section_Flags;
+ Section_Strtab : constant Section_Flags;
+ Section_Debug : constant Section_Flags;
+
+ type Byte is new Unsigned_8;
+
+ type Symbol is range -2 ** 31 .. 2 ** 31 - 1;
+ for Symbol'Size use 32;
+ Null_Symbol : constant Symbol := 0;
+
+ type Pc_Type is mod System.Memory_Size;
+ Null_Pc : constant Pc_Type := 0;
+
+ type Arch_Kind is (Arch_Unknown, Arch_X86, Arch_Sparc, Arch_Ppc);
+ Arch : Arch_Kind := Arch_Unknown;
+
+ -- Dump assembly when generated.
+ Dump_Asm : Boolean := False;
+
+ Debug_Hex : Boolean := False;
+
+ -- Create a section.
+ procedure Create_Section (Sect : out Section_Acc;
+ Name : String; Flags : Section_Flags);
+ procedure Set_Section_Info (Sect : Section_Acc;
+ Link : Section_Acc;
+ Align : Natural;
+ Esize : Natural);
+
+ procedure Merge_Section (Dest : Section_Acc; Src : Section_Acc);
+
+ -- Set the current section.
+ procedure Set_Current_Section (Sect : Section_Acc);
+
+ -- Create an undefined local (anonymous) symbol in the current section.
+ function Create_Local_Symbol return Symbol;
+ function Create_Symbol (Name : O_Ident) return Symbol;
+
+ -- Research symbol NAME, very expansive call.
+ -- Return NULL_Symbol if not found.
+ function Get_Symbol (Name : String) return Symbol;
+
+ -- Get the virtual address of a symbol.
+ function Get_Symbol_Vaddr (Sym : Symbol) return Pc_Type;
+ pragma Inline (Get_Symbol_Vaddr);
+
+ -- Set the value of a symbol.
+ procedure Set_Symbol_Pc (Sym : Symbol; Export : Boolean);
+ function Get_Symbol_Value (Sym : Symbol) return Pc_Type;
+
+ -- Get the current PC.
+ function Get_Current_Pc return Pc_Type;
+ pragma Inline (Get_Current_Pc);
+
+ function Get_Pc (Sect : Section_Acc) return Pc_Type;
+ pragma Inline (Get_Pc);
+
+ -- Align the current section of 2 ** ALIGN.
+ procedure Gen_Pow_Align (Align : Natural);
+
+ -- Generate LENGTH times 0.
+ procedure Gen_Space (Length : Integer_32);
+
+ -- Add a reloc in the current section at the current address.
+ procedure Gen_X86_Pc32 (Sym : Symbol);
+ procedure Gen_Sparc_Disp22 (W : Unsigned_32; Sym : Symbol);
+ procedure Gen_Sparc_Disp30 (W : Unsigned_32; Sym : Symbol);
+ procedure Gen_Sparc_Hi22 (W : Unsigned_32;
+ Sym : Symbol; Off : Unsigned_32);
+ procedure Gen_Sparc_Lo10 (W : Unsigned_32;
+ Sym : Symbol; Off : Unsigned_32);
+
+ -- Add a 32 bits value with a symbol relocation in the current section at
+ -- the current address.
+ procedure Gen_X86_32 (Sym : Symbol; Offset : Integer_32);
+ procedure Gen_Sparc_32 (Sym : Symbol; Offset : Integer_32);
+ procedure Gen_Sparc_Ua_32 (Sym : Symbol; Offset : Integer_32);
+
+ procedure Gen_Ppc_24 (V : Unsigned_32; Sym : Symbol);
+
+ procedure Gen_Ua_32 (Sym : Symbol; Offset : Integer_32);
+
+ -- Start/finish an instruction in the current section.
+ procedure Start_Insn;
+ procedure End_Insn;
+ -- Pre allocate L bytes.
+ procedure Prealloc (L : Pc_Type);
+
+ -- Add bits in the current section.
+ procedure Gen_B8 (B : Byte);
+ procedure Gen_B16 (B0, B1 : Byte);
+ procedure Gen_Le8 (B : Unsigned_32);
+ procedure Gen_Le16 (B : Unsigned_32);
+ procedure Gen_Be16 (B : Unsigned_32);
+ procedure Gen_Le32 (B : Unsigned_32);
+ procedure Gen_Be32 (B : Unsigned_32);
+
+ procedure Gen_16 (B : Unsigned_32);
+ procedure Gen_32 (B : Unsigned_32);
+
+ -- Add bits in the current section, but as stand-alone data.
+ procedure Gen_Data_Le8 (B : Unsigned_32);
+ procedure Gen_Data_Le16 (B : Unsigned_32);
+ procedure Gen_Data_32 (Sym : Symbol; Offset : Integer_32);
+
+ -- Modify already generated code.
+ procedure Patch_B8 (Pc : Pc_Type; V : Unsigned_8);
+ procedure Patch_Le32 (Pc : Pc_Type; V : Unsigned_32);
+ procedure Patch_Be32 (Pc : Pc_Type; V : Unsigned_32);
+ procedure Patch_Be16 (Pc : Pc_Type; V : Unsigned_32);
+ procedure Patch_32 (Pc : Pc_Type; V : Unsigned_32);
+
+ -- Binary writers:
+
+ -- Set ERROR in case of error (undefined symbol).
+ --procedure Write_Memory (Error : out Boolean);
+
+ procedure Disp_Stats;
+ procedure Finish;
+private
+ type Byte_Array_Base is array (Pc_Type range <>) of Byte;
+ subtype Byte_Array is Byte_Array_Base (Pc_Type);
+ type Byte_Array_Acc is access Byte_Array;
+ type String_Acc is access String;
+ --type Section_Flags is new Unsigned_32;
+
+ -- Relocations.
+ type Reloc_Kind is (Reloc_32, Reloc_Pc32,
+ Reloc_Ua_32,
+ Reloc_Disp22, Reloc_Disp30,
+ Reloc_Hi22, Reloc_Lo10,
+ Reloc_Ppc_Addr24);
+ type Reloc_Type;
+ type Reloc_Acc is access Reloc_Type;
+ type Reloc_Type is record
+ Kind : Reloc_Kind;
+ -- If true, the reloc was already applied.
+ Done : Boolean;
+ -- Next in simply linked list.
+ -- next reloc in the section.
+ Sect_Next : Reloc_Acc;
+ -- next reloc for the symbol.
+ Sym_Next : Reloc_Acc;
+ -- Address that must be relocated.
+ Addr : Pc_Type;
+ -- Symbol.
+ Sym : Symbol;
+ end record;
+
+ type Section_Type is record
+ -- Simply linked list of sections.
+ Next : Section_Acc;
+ -- Flags.
+ Flags : Section_Flags;
+ -- Name of the section.
+ Name : String_Acc;
+ -- Link to another section (used by ELF).
+ Link : Section_Acc;
+ -- Alignment (in power of 2).
+ Align : Natural;
+ -- Entry size (if any).
+ Esize : Natural;
+ -- Offset of the next data in DATA.
+ Pc : Pc_Type;
+ -- Offset of the current instruction.
+ Insn_Pc : Pc_Type;
+ -- Data for this section.
+ Data : Byte_Array_Acc;
+ -- Max address for data (before extending the area).
+ Data_Max : Pc_Type;
+ -- Chain of relocs defined in this section.
+ First_Reloc : Reloc_Acc;
+ Last_Reloc : Reloc_Acc;
+ -- Number of relocs in this section.
+ Nbr_Relocs : Natural;
+ -- Section number (set and used by binary writer).
+ Number : Natural;
+ -- Virtual address, if set.
+ Vaddr : Pc_Type; -- SSE.Integer_Address;
+ -- Memory for this segment.
+ Seg : Memsegs.Memseg_Type;
+ end record;
+
+ Section_Exec : constant Section_Flags := 2#0000_0001#;
+ Section_Read : constant Section_Flags := 2#0000_0010#;
+ Section_Write : constant Section_Flags := 2#0000_0100#;
+ Section_Zero : constant Section_Flags := 2#0000_1000#;
+ Section_Strtab : constant Section_Flags := 2#0001_0000#;
+ Section_Debug : constant Section_Flags := 2#0010_0000#;
+ Section_None : constant Section_Flags := 2#0000_0000#;
+
+ -- Scope of a symbol:
+ -- SYM_PRIVATE: not visible outside of the file.
+ -- SYM_UNDEF: not (yet) defined, unresolved.
+ -- SYM_GLOBAL: visible to all files.
+ -- SYM_LOCAL: locally generated symbol.
+ type Symbol_Scope is (Sym_Undef, Sym_Global, Sym_Private, Sym_Local);
+ subtype Symbol_Scope_External is Symbol_Scope range Sym_Undef .. Sym_Global;
+ type Symbol_Type is record
+ Section : Section_Acc;
+ Value : Pc_Type;
+ Scope : Symbol_Scope;
+ -- True if the symbol is referenced/used.
+ Used : Boolean;
+ -- Name of the symbol.
+ Name : O_Ident;
+ -- List of relocation made with this symbol.
+ Relocs : Reloc_Acc;
+ -- Symbol number, from 0.
+ Number : Natural;
+ end record;
+
+ -- Number of sections.
+ Nbr_Sections : Natural := 0;
+ -- Simply linked list of sections.
+ Section_Chain : Section_Acc := null;
+ Section_Last : Section_Acc := null;
+
+ package Symbols is new GNAT.Table
+ (Table_Component_Type => Symbol_Type,
+ Table_Index_Type => Symbol,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ function Pow_Align (V : Pc_Type; Align : Natural) return Pc_Type;
+
+ function Get_Symbol_Name (Sym : Symbol) return String;
+ function Get_Symbol_Name_Length (Sym : Symbol) return Natural;
+
+ procedure Set_Symbol_Value (Sym : Symbol; Val : Pc_Type);
+ pragma Inline (Set_Symbol_Value);
+
+ procedure Set_Scope (Sym : Symbol; Scope : Symbol_Scope);
+ pragma Inline (Set_Scope);
+
+ function Get_Scope (Sym : Symbol) return Symbol_Scope;
+ pragma Inline (Get_Scope);
+
+ function Get_Section (Sym : Symbol) return Section_Acc;
+ pragma Inline (Get_Section);
+
+ procedure Set_Section (Sym : Symbol; Sect : Section_Acc);
+ pragma Inline (Set_Section);
+
+ function Get_Name (Sym : Symbol) return O_Ident;
+ pragma Inline (Get_Name);
+
+ procedure Apply_Reloc (Sect : Section_Acc; Reloc : Reloc_Acc);
+ pragma Inline (Apply_Reloc);
+
+ procedure Set_Number (Sym : Symbol; Num : Natural);
+ pragma Inline (Set_Number);
+
+ function Get_Number (Sym : Symbol) return Natural;
+ pragma Inline (Get_Number);
+
+ function Get_Used (Sym : Symbol) return Boolean;
+ pragma Inline (Get_Used);
+
+ procedure Do_Intra_Section_Reloc (Sect : Section_Acc);
+
+ function S_Local (Sym : Symbol) return Boolean;
+ pragma Inline (S_Local);
+
+ procedure Resize (Sect : Section_Acc; Size : Pc_Type);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => Reloc_Acc, Object => Reloc_Type);
+
+ Write_Error : exception;
+end Binary_File;
diff --git a/src/ortho/mcode/coff.ads b/src/ortho/mcode/coff.ads
new file mode 100644
index 000000000..6ef9cdde9
--- /dev/null
+++ b/src/ortho/mcode/coff.ads
@@ -0,0 +1,208 @@
+-- COFF definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with System; use System;
+
+package Coff is
+ type Filehdr is record
+ F_Magic : Unsigned_16; -- Magic number.
+ F_Nscns : Unsigned_16; -- Number of sections.
+ F_Timdat : Unsigned_32; -- Time and date stamp.
+ F_Symptr : Unsigned_32; -- File pointer to symtab.
+ F_Nsyms : Unsigned_32; -- Number of symtab entries.
+ F_Opthdr : Unsigned_16; -- Size of optionnal header.
+ F_Flags : Unsigned_16; -- Flags;
+ end record;
+
+ -- Size of Filehdr.
+ Filehdr_Size : constant Natural := Filehdr'Size / Storage_Unit;
+
+ -- Magic numbers.
+ I386magic : constant Unsigned_16 := 16#014c#;
+
+ -- Flags of file header.
+ -- Relocation info stripped from file.
+ F_Relflg : constant Unsigned_16 := 16#0001#;
+
+ -- File is executable (no unresolved symbols).
+ F_Exec : constant Unsigned_16 := 16#0002#;
+
+ -- Line numbers stripped from file.
+ F_Lnno : constant Unsigned_16 := 16#0004#;
+
+ -- Local symbols stripped from file.
+ F_Lsyms : constant Unsigned_16 := 16#0008#;
+
+ type Scnhdr is record
+ S_Name : String (1 .. 8); -- Section name.
+ S_Paddr : Unsigned_32; -- Physical address.
+ S_Vaddr : Unsigned_32; -- Virtual address.
+ S_Size : Unsigned_32; -- Section size.
+ S_Scnptr : Unsigned_32; -- File pointer to raw section data.
+ S_Relptr : Unsigned_32; -- File pointer to relocation data.
+ S_Lnnoptr : Unsigned_32; -- File pointer to line number data.
+ S_Nreloc : Unsigned_16; -- Number of relocation entries.
+ S_Nlnno : Unsigned_16; -- Number of line number entries.
+ S_Flags : Unsigned_32; -- Flags.
+ end record;
+ Scnhdr_Size : constant Natural := Scnhdr'Size / Storage_Unit;
+
+ -- section contains text only.
+ STYP_TEXT : constant Unsigned_32 := 16#0020#;
+ -- section contains data only.
+ STYP_DATA : constant Unsigned_32 := 16#0040#;
+ -- section contains bss only.
+ STYP_BSS : constant Unsigned_32 := 16#0080#;
+
+ type Strent_Type is record
+ E_Zeroes : Unsigned_32;
+ E_Offset : Unsigned_32;
+ end record;
+
+ type Sym_Name (Inline : Boolean := True) is record
+ case Inline is
+ when True =>
+ E_Name : String (1 .. 8);
+ when False =>
+ E : Strent_Type;
+ end case;
+ end record;
+ pragma Unchecked_Union (Sym_Name);
+ for Sym_Name'Size use 64;
+
+ type Syment is record
+ E : Sym_Name; -- Name of the symbol
+ E_Value : Unsigned_32; -- Value
+ E_Scnum : Unsigned_16; -- Section
+ E_Type : Unsigned_16;
+ E_Sclass : Unsigned_8;
+ E_Numaux : Unsigned_8;
+ end record;
+ Symesz : constant Natural := 18;
+ for Syment'Size use Symesz * Storage_Unit;
+
+ -- An undefined (extern) symbol.
+ N_UNDEF : constant Unsigned_16 := 16#00_00#;
+ -- An absolute symbol (e_value is a constant, not an address).
+ N_ABS : constant Unsigned_16 := 16#Ff_Ff#;
+ -- A debugging symbol.
+ N_DEBUG : constant Unsigned_16 := 16#Ff_Fe#;
+
+ C_NULL : constant Unsigned_8 := 0;
+ C_AUTO : constant Unsigned_8 := 1;
+ C_EXT : constant Unsigned_8 := 2;
+ C_STAT : constant Unsigned_8 := 3;
+ C_REG : constant Unsigned_8 := 4;
+ C_EXTDEF : constant Unsigned_8 := 5;
+ C_LABEL : constant Unsigned_8 := 6;
+ C_ULABEL : constant Unsigned_8 := 7;
+ C_MOS : constant Unsigned_8 := 8;
+ C_ARG : constant Unsigned_8 := 9;
+ C_STRTAG : constant Unsigned_8 := 10;
+ C_MOU : constant Unsigned_8 := 11;
+ C_UNTAG : constant Unsigned_8 := 12;
+ C_TPDEF : constant Unsigned_8 := 13;
+ C_USTATIC : constant Unsigned_8 := 14;
+ C_ENTAG : constant Unsigned_8 := 15;
+ C_MOE : constant Unsigned_8 := 16;
+ C_REGPARM : constant Unsigned_8 := 17;
+ C_FIELD : constant Unsigned_8 := 18;
+ C_AUTOARG : constant Unsigned_8 := 19;
+ C_LASTENT : constant Unsigned_8 := 20;
+ C_BLOCK : constant Unsigned_8 := 100;
+ C_FCN : constant Unsigned_8 := 101;
+ C_EOS : constant Unsigned_8 := 102;
+ C_FILE : constant Unsigned_8 := 103;
+ C_LINE : constant Unsigned_8 := 104;
+ C_ALIAS : constant Unsigned_8 := 105;
+ C_HIDDEN : constant Unsigned_8 := 106;
+ C_EFCN : constant Unsigned_8 := 255;
+
+ -- Textual description of sclass.
+ type Const_String_Acc is access constant String;
+ type Sclass_Desc_Type is record
+ Name : Const_String_Acc;
+ Meaning : Const_String_Acc;
+ end record;
+ type Sclass_Desc_Array_Type is array (Unsigned_8) of Sclass_Desc_Type;
+ Sclass_Desc : constant Sclass_Desc_Array_Type;
+
+ type Auxent_File (Inline : Boolean := True) is record
+ case Inline is
+ when True =>
+ X_Fname : String (1 .. 14);
+ when False =>
+ X_N : Strent_Type;
+ end case;
+ end record;
+ pragma Unchecked_Union (Auxent_File);
+
+ type Auxent_Scn is record
+ X_Scnlen : Unsigned_32;
+ X_Nreloc : Unsigned_16;
+ X_Nlinno : Unsigned_16;
+ end record;
+
+ -- Relocation.
+ type Reloc is record
+ R_Vaddr : Unsigned_32;
+ R_Symndx : Unsigned_32;
+ R_Type : Unsigned_16;
+ end record;
+ Relsz : constant Natural := Reloc'Size / Storage_Unit;
+
+ Reloc_Rel32 : constant Unsigned_16 := 20;
+ Reloc_Addr32 : constant Unsigned_16 := 6;
+
+private
+ subtype S is String;
+ Sclass_Desc : constant Sclass_Desc_Array_Type :=
+ (C_NULL => (new S'("C_NULL"), new S'("No entry")),
+ C_AUTO => (new S'("C_AUTO"), new S'("Automatic variable")),
+ C_EXT => (new S'("C_EXT"), new S'("External/public symbol")),
+ C_STAT => (new S'("C_STAT"), new S'("static (private) symbol")),
+ C_REG => (new S'("C_REG"), new S'("register variable")),
+ C_EXTDEF => (new S'("C_EXTDEF"), new S'("External definition")),
+ C_LABEL => (new S'("C_LABEL"), new S'("label")),
+ C_ULABEL => (new S'("C_ULABEL"), new S'("undefined label")),
+ C_MOS => (new S'("C_MOS"), new S'("member of structure")),
+ C_ARG => (new S'("C_ARG"), new S'("function argument")),
+ C_STRTAG => (new S'("C_STRTAG"), new S'("structure tag")),
+ C_MOU => (new S'("C_MOU"), new S'("member of union")),
+ C_UNTAG => (new S'("C_UNTAG"), new S'("union tag")),
+ C_TPDEF => (new S'("C_TPDEF"), new S'("type definition")),
+ C_USTATIC => (new S'("C_USTATIC"), new S'("undefined static")),
+ C_ENTAG => (new S'("C_ENTAG"), new S'("enumaration tag")),
+ C_MOE => (new S'("C_MOE"), new S'("member of enumeration")),
+ C_REGPARM => (new S'("C_REGPARM"), new S'("register parameter")),
+ C_FIELD => (new S'("C_FIELD"), new S'("bit field")),
+ C_AUTOARG => (new S'("C_AUTOARG"), new S'("auto argument")),
+ C_LASTENT => (new S'("C_LASTENT"), new S'("dummy entry (end of block)")),
+ C_BLOCK => (new S'("C_BLOCK"), new S'("beginning or end of block")),
+ C_FCN => (new S'("C_FCN"), new S'("beginning or end of function")),
+ C_EOS => (new S'("C_EOS"), new S'("end of structure")),
+ C_FILE => (new S'("C_FILE"), new S'("file name")),
+ C_LINE => (new S'("C_LINE"),
+ new S'("line number, reformatted as symbol")),
+ C_ALIAS => (new S'("C_ALIAS"), new S'("duplicate tag")),
+ C_HIDDEN => (new S'("C_HIDDEN"),
+ new S'("ext symbol in dmert public lib")),
+ C_EFCN => (new S'("C_EFCN"), new S'("physical end of function")),
+ others => (null, null));
+
+end Coff;
diff --git a/src/ortho/mcode/coffdump.adb b/src/ortho/mcode/coffdump.adb
new file mode 100644
index 000000000..6384b6c27
--- /dev/null
+++ b/src/ortho/mcode/coffdump.adb
@@ -0,0 +1,274 @@
+-- COFF dumper.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Coff; use Coff;
+with Interfaces; use Interfaces;
+with System;
+with Ada.Unchecked_Conversion;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Text_IO; use Ada.Text_IO;
+with Hex_Images; use Hex_Images;
+
+procedure Coffdump is
+ type Cstring is array (Unsigned_32 range <>) of Character;
+ type Cstring_Acc is access Cstring;
+ type Section_Array is array (Unsigned_16 range <>) of Scnhdr;
+ type Section_Array_Acc is access Section_Array;
+ -- Array of sections.
+ Sections : Section_Array_Acc;
+
+ type External_Symbol is array (0 .. Symesz - 1) of Character;
+ type External_Symbol_Array is array (Unsigned_32 range <>)
+ of External_Symbol;
+ type Symbol_Array_Acc is access External_Symbol_Array;
+ -- Symbols table.
+ External_Symbols : Symbol_Array_Acc;
+
+ -- String table.
+ Str : Cstring_Acc;
+ Str_Size : Natural;
+
+ Hdr : Filehdr;
+ --Sym : Syment;
+ Fd : File_Descriptor;
+ Skip : Natural;
+ Skip_Kind : Unsigned_8;
+ Aux_File : Auxent_File;
+ Aux_Scn : Auxent_Scn;
+ Rel : Reloc;
+ Len : Natural;
+
+ Nul : constant Character := Character'Val (0);
+
+ function Find_Nul (S : String) return String is
+ begin
+ for I in S'Range loop
+ if S (I) = Nul then
+ return S (S'First .. I - 1);
+ end if;
+ end loop;
+ return S;
+ end Find_Nul;
+
+ function Get_String (N : Strent_Type; S : String) return String
+ is
+ begin
+ if N.E_Zeroes /= 0 then
+ return Find_Nul (S);
+ else
+ for I in N.E_Offset .. Str'Last loop
+ if Str (I) = Nul then
+ return String (Str (N.E_Offset .. I - 1));
+ end if;
+ end loop;
+ raise Program_Error;
+ end if;
+ end Get_String;
+
+ procedure Memcpy
+ (Dst : System.Address; Src : System.Address; Size : Natural);
+ pragma Import (C, Memcpy);
+
+ function Get_Section_Name (N : Unsigned_16) return String is
+ begin
+ if N = N_UNDEF then
+ return "UNDEF";
+ elsif N = N_ABS then
+ return "ABS";
+ elsif N = N_DEBUG then
+ return "DEBUG";
+ elsif N > Hdr.F_Nscns then
+ return "???";
+ else
+ return Find_Nul (Sections (N).S_Name);
+ end if;
+ end Get_Section_Name;
+
+ function Get_Symbol (N : Unsigned_32) return Syment is
+ function Unchecked_Conv is new Ada.Unchecked_Conversion
+ (Source => External_Symbol, Target => Syment);
+ begin
+ if N > Hdr.F_Nsyms then
+ raise Constraint_Error;
+ end if;
+ return Unchecked_Conv (External_Symbols (N));
+ end Get_Symbol;
+
+ function Get_Symbol_Name (N : Unsigned_32) return String
+ is
+ S : Syment := Get_Symbol (N);
+ begin
+ return Get_String (S.E.E, S.E.E_Name);
+ end Get_Symbol_Name;
+begin
+ for I in 1 .. Argument_Count loop
+ Fd := Open_Read (Argument (I), Binary);
+ if Fd = Invalid_FD then
+ Put_Line ("cannot open " & Argument (I));
+ return;
+ end if;
+ -- Read file header.
+ if Read (Fd, Hdr'Address, Filehdr_Size) /= Filehdr_Size then
+ Put_Line ("cannot read header");
+ return;
+ end if;
+ Put_Line ("File: " & Argument (I));
+ Put_Line ("magic: " & Hex_Image (Hdr.F_Magic));
+ Put_Line ("number of sections: " & Hex_Image (Hdr.F_Nscns));
+ Put_Line ("time and date stamp: " & Hex_Image (Hdr.F_Timdat));
+ Put_Line ("symtab file pointer: " & Hex_Image (Hdr.F_Symptr));
+ Put_Line ("nbr symtab entries: " & Hex_Image (Hdr.F_Nsyms));
+ Put_Line ("opt header size: " & Hex_Image (Hdr.F_Opthdr));
+ Put_Line ("flags: " & Hex_Image (Hdr.F_Flags));
+
+ -- Read sections header.
+ Lseek (Fd, Long_Integer (Hdr.F_Opthdr), Seek_Cur);
+ Sections := new Section_Array (1 .. Hdr.F_Nscns);
+ Len := Scnhdr_Size * Natural (Hdr.F_Nscns);
+ if Read (Fd, Sections (1)'Address, Len) /= Len then
+ Put_Line ("cannot read section header");
+ return;
+ end if;
+ for I in 1 .. Hdr.F_Nscns loop
+ declare
+ S: Scnhdr renames Sections (I);
+ begin
+ Put_Line ("Section " & Find_Nul (S.S_Name));
+ Put_Line ("Physical address : " & Hex_Image (S.S_Paddr));
+ Put_Line ("Virtual address : " & Hex_Image (S.S_Vaddr));
+ Put_Line ("section size : " & Hex_Image (S.S_Size));
+ Put_Line ("section pointer : " & Hex_Image (S.S_Scnptr));
+ Put_Line ("relocation pointer : " & Hex_Image (S.S_Relptr));
+ Put_Line ("line num pointer : " & Hex_Image (S.S_Lnnoptr));
+ Put_Line ("Nbr reloc entries : " & Hex_Image (S.S_Nreloc));
+ Put_Line ("Nbr line num entries : " & Hex_Image (S.S_Nlnno));
+ Put_Line ("Flags : " & Hex_Image (S.S_Flags));
+ end;
+ end loop;
+
+ -- Read string table.
+ Lseek (Fd,
+ Long_Integer (Hdr.F_Symptr + Hdr.F_Nsyms * Unsigned_32 (Symesz)),
+ Seek_Set);
+ if Read (Fd, Str_Size'Address, 4) /= 4 then
+ Put_Line ("cannot read string table size");
+ return;
+ end if;
+ Str := new Cstring (0 .. Unsigned_32 (Str_Size));
+ if Read (Fd, Str (4)'Address, Str_Size - 4) /= Str_Size - 4 then
+ Put_Line ("cannot read string table");
+ return;
+ end if;
+
+ -- Read symbol table.
+ Lseek (Fd, Long_Integer (Hdr.F_Symptr), Seek_Set);
+ External_Symbols := new External_Symbol_Array (0 .. Hdr.F_Nsyms - 1);
+ Len := Natural (Hdr.F_Nsyms) * Symesz;
+ if Read (Fd, External_Symbols (0)'Address, Len) /= Len then
+ Put_Line ("cannot read symbol");
+ return;
+ end if;
+
+ Skip := 0;
+ Skip_Kind := C_NULL;
+ for I in External_Symbols'range loop
+ if Skip > 0 then
+ case Skip_Kind is
+ when C_FILE =>
+ Memcpy (Aux_File'Address, External_Symbols (I)'Address,
+ Aux_File'Size / 8);
+ Put_Line ("aux file : " & Get_String (Aux_File.X_N,
+ Aux_File.X_Fname));
+ Skip_Kind := C_NULL;
+ when C_STAT =>
+ Memcpy (Aux_Scn'Address, External_Symbols (I)'Address,
+ Aux_Scn'Size / 8);
+ Put_Line ("section len: " & Hex_Image (Aux_Scn.X_Scnlen));
+ Put_Line ("nbr reloc ent: " & Hex_Image (Aux_Scn.X_Nreloc));
+ Put_Line ("nbr line num: " & Hex_Image (Aux_Scn.X_Nlinno));
+ when others =>
+ Put_Line ("skip");
+ end case;
+ Skip := Skip - 1;
+ else
+ declare
+ S : Syment := Get_Symbol (I);
+ begin
+ Put_Line ("Symbol #" & Hex_Image (I));
+ Put_Line ("symbol name : " & Get_Symbol_Name (I));
+ Put_Line ("symbol value: " & Hex_Image (S.E_Value));
+ Put_Line ("section num : " & Hex_Image (S.E_Scnum)
+ & " " & Get_Section_Name (S.E_Scnum));
+ Put_Line ("type : " & Hex_Image (S.E_Type));
+ Put ("sclass : " & Hex_Image (S.E_Sclass));
+ if Sclass_Desc (S.E_Sclass).Name /= null then
+ Put (" (");
+ Put (Sclass_Desc (S.E_Sclass).Name.all);
+ Put (" - ");
+ Put (Sclass_Desc (S.E_Sclass).Meaning.all);
+ Put (")");
+ end if;
+ New_Line;
+ Put_Line ("numaux : " & Hex_Image (S.E_Numaux));
+ if S.E_Numaux > 0 then
+ case S.E_Sclass is
+ when C_FILE =>
+ Skip_Kind := C_FILE;
+ when C_STAT =>
+ Skip_Kind := C_STAT;
+ when others =>
+ Skip_Kind := C_NULL;
+ end case;
+ end if;
+ Skip := Natural (S.E_Numaux);
+ end;
+ end if;
+ end loop;
+
+ -- Disp relocs.
+ for I in 1 .. Hdr.F_Nscns loop
+ if Sections (I).S_Nreloc > 0 then
+ -- Read relocations.
+ Put_Line ("Relocations for section " & Get_Section_Name (I));
+ Lseek (Fd, Long_Integer (Sections (I).S_Relptr), Seek_Set);
+ for J in 1 .. Sections (I).S_Nreloc loop
+ if Read (Fd, Rel'Address, Relsz) /= Relsz then
+ Put_Line ("cannot read reloc");
+ return;
+ end if;
+ Put_Line ("reloc virtual addr: " & Hex_Image (Rel.R_Vaddr));
+ Put_Line ("symbol index : " & Hex_Image (Rel.R_Symndx)
+ & " " & Get_Symbol_Name (Rel.R_Symndx));
+ Put ("type of relocation: " & Hex_Image (Rel.R_Type));
+ case Rel.R_Type is
+ when Reloc_Rel32 =>
+ Put (" RELOC_REL32");
+ when Reloc_Addr32 =>
+ Put (" RELOC_ADDR32");
+ when others =>
+ null;
+ end case;
+ New_Line;
+ end loop;
+ end if;
+ end loop;
+
+ Close (Fd);
+ end loop;
+end Coffdump;
+
diff --git a/src/ortho/mcode/disa_sparc.adb b/src/ortho/mcode/disa_sparc.adb
new file mode 100644
index 000000000..8c9176ff8
--- /dev/null
+++ b/src/ortho/mcode/disa_sparc.adb
@@ -0,0 +1,274 @@
+with System; use System;
+with Interfaces; use Interfaces;
+with Ada.Unchecked_Conversion;
+with Hex_Images; use Hex_Images;
+
+package body Disa_Sparc is
+ subtype Reg_Type is Unsigned_32 range 0 .. 31;
+
+ type Hex_Map_Type is array (Unsigned_32 range 0 .. 15) of Character;
+ Hex_Digit : constant Hex_Map_Type := "0123456789abcdef";
+
+ type Cstring_Acc is access constant String;
+ type Cond_Map_Type is array (Unsigned_32 range 0 .. 15) of Cstring_Acc;
+ subtype S is String;
+ Bicc_Map : constant Cond_Map_Type :=
+ (0 => new S'("n"),
+ 1 => new S'("e"),
+ 2 => new S'("le"),
+ 3 => new S'("l"),
+ 4 => new S'("leu"),
+ 5 => new S'("cs"),
+ 6 => new S'("neg"),
+ 7 => new S'("vs"),
+ 8 => new S'("a"),
+ 9 => new S'("ne"),
+ 10 => new S'("g"),
+ 11 => new S'("ge"),
+ 12 => new S'("gu"),
+ 13 => new S'("cc"),
+ 14 => new S'("pos"),
+ 15 => new S'("vc")
+ );
+
+
+ type Format_Type is
+ (
+ Format_Bad,
+ Format_Regimm, -- format 3, rd, rs1, rs2 or imm13
+ Format_Rd, -- format 3, rd only.
+ Format_Copro, -- format 3, fpu or coprocessor
+ Format_Asi -- format 3, rd, rs1, asi and rs2.
+ );
+
+ type Insn_Desc_Type is record
+ Name : Cstring_Acc;
+ Format : Format_Type;
+ end record;
+
+ type Insn_Desc_Array is array (Unsigned_32 range 0 .. 63) of Insn_Desc_Type;
+ Insn_Desc_10 : constant Insn_Desc_Array :=
+ (
+ 2#000_000# => (new S'("add"), Format_Regimm),
+ 2#000_001# => (new S'("and"), Format_Regimm),
+ 2#000_010# => (new S'("or"), Format_Regimm),
+ 2#000_011# => (new S'("xor"), Format_Regimm),
+ 2#000_100# => (new S'("sub"), Format_Regimm),
+ 2#000_101# => (new S'("andn"), Format_Regimm),
+ 2#000_110# => (new S'("orn"), Format_Regimm),
+ 2#000_111# => (new S'("xnor"), Format_Regimm),
+ 2#001_000# => (new S'("addx"), Format_Regimm),
+
+ 2#001_100# => (new S'("subx"), Format_Regimm),
+
+ 2#010_000# => (new S'("addcc"), Format_Regimm),
+ 2#010_001# => (new S'("andcc"), Format_Regimm),
+ 2#010_010# => (new S'("orcc"), Format_Regimm),
+ 2#010_011# => (new S'("xorcc"), Format_Regimm),
+ 2#010_100# => (new S'("subcc"), Format_Regimm),
+ 2#010_101# => (new S'("andncc"), Format_Regimm),
+ 2#010_110# => (new S'("orncc"), Format_Regimm),
+ 2#010_111# => (new S'("xnorcc"), Format_Regimm),
+ 2#011_000# => (new S'("addxcc"), Format_Regimm),
+
+ 2#011_100# => (new S'("subxcc"), Format_Regimm),
+
+ 2#111_000# => (new S'("jmpl"), Format_Regimm),
+
+ 2#111_100# => (new S'("save"), Format_Regimm),
+ 2#111_101# => (new S'("restore"), Format_Regimm),
+
+ others => (null, Format_Bad)
+ );
+
+ Insn_Desc_11 : constant Insn_Desc_Array :=
+ (
+ 2#000_000# => (new S'("ld"), Format_Regimm),
+ 2#000_001# => (new S'("ldub"), Format_Regimm),
+ 2#000_010# => (new S'("lduh"), Format_Regimm),
+ 2#000_011# => (new S'("ldd"), Format_Regimm),
+ 2#000_100# => (new S'("st"), Format_Regimm),
+ 2#000_101# => (new S'("stb"), Format_Regimm),
+
+ 2#010_000# => (new S'("lda"), Format_Asi),
+ 2#010_011# => (new S'("ldda"), Format_Asi),
+
+ 2#110_000# => (new S'("ldc"), Format_Regimm),
+ 2#110_001# => (new S'("ldcsr"), Format_Regimm),
+
+ others => (null, Format_Bad)
+ );
+
+ -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN.
+ procedure Disassemble_Insn (Addr : Address;
+ Line : in out String;
+ Line_Len : out Natural;
+ Insn_Len : out Natural;
+ Proc_Cb : Symbol_Proc_Type)
+ is
+ type Unsigned_32_Acc is access Unsigned_32;
+ function To_Unsigned_32_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Unsigned_32_Acc);
+
+ W : Unsigned_32;
+ Lo : Natural;
+
+ -- Add CHAR to the line.
+ procedure Add_Char (C : Character);
+ pragma Inline (Add_Char);
+
+ procedure Add_Char (C : Character) is
+ begin
+ Line (Lo) := C;
+ Lo := Lo + 1;
+ end Add_Char;
+
+ -- Add STR to the line.
+ procedure Add_String (Str : String) is
+ begin
+ Line (Lo .. Lo + Str'Length - 1) := Str;
+ Lo := Lo + Str'Length;
+ end Add_String;
+
+ -- Add BYTE to the line.
+-- procedure Add_Byte (V : Byte) is
+-- type My_Str is array (Natural range 0 .. 15) of Character;
+-- Hex_Digit : constant My_Str := "0123456789abcdef";
+-- begin
+-- Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#)));
+-- Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#)));
+-- end Add_Byte;
+
+ procedure Disp_Const (Mask : Unsigned_32)
+ is
+ L : Natural;
+ V : Unsigned_32;
+ begin
+ L := Lo;
+ Proc_Cb.all (Addr, Line (Lo .. Line'Last), Lo);
+ V := W and Mask;
+
+ -- Extend sign.
+ if (W and ((Mask + 1) / 2)) /= 0 then
+ V := V or not Mask;
+ end if;
+ if L /= Lo then
+ if V = 0 then
+ return;
+ end if;
+ Add_String (" + ");
+ end if;
+ Add_String ("0x");
+ Add_String (Hex_Image (V));
+ end Disp_Const;
+
+ procedure Add_Cond (Str : String)
+ is
+ begin
+ Add_String (Str);
+ Add_String (Bicc_Map (Shift_Right (W, 25) and 2#1111#).all);
+ if (W and 16#2000_0000#) /= 0 then
+ Add_String (",a");
+ end if;
+ Add_Char (' ');
+ Disp_Const (16#3f_Ffff#);
+ end Add_Cond;
+
+
+ procedure Add_Ireg (R : Reg_Type)
+ is
+ begin
+ Add_Char ('%');
+ if R <= 7 then
+ Add_Char ('g');
+ elsif R <= 15 then
+ if R = 14 then
+ Add_String ("sp");
+ return;
+ else
+ Add_Char ('o');
+ end if;
+ elsif R <= 23 then
+ Add_Char ('l');
+ else
+ if R = 30 then
+ Add_String ("fp");
+ return;
+ else
+ Add_Char ('i');
+ end if;
+ end if;
+ Add_Char (Hex_Digit (R and 7));
+ end Add_Ireg;
+
+ procedure Disp_Unknown is
+ begin
+ Add_String ("unknown ");
+ Add_String (Hex_Image (W));
+ end Disp_Unknown;
+
+ procedure Disp_Format3 (Map : Insn_Desc_Array)
+ is
+ Op2 : Unsigned_32 range 0 .. 63;
+ begin
+ Op2 := Shift_Right (W, 19) and 2#111_111#;
+
+ case Map (Op2).Format is
+ when Format_Regimm =>
+ Add_String (Map (Op2).Name.all);
+ Add_Char (' ');
+ Add_Ireg (Shift_Right (W, 25) and 31);
+ Add_Char (',');
+ Add_Ireg (Shift_Right (W, 14) and 31);
+ Add_Char (',');
+ if (W and 16#2000#) /= 0 then
+ Disp_Const (16#1fff#);
+ else
+ Add_Ireg (W and 31);
+ end if;
+ when others =>
+ Add_String ("unknown3, op2=");
+ Add_String (Hex_Image (Op2));
+ end case;
+ end Disp_Format3;
+
+
+ begin
+ W := To_Unsigned_32_Acc (Addr).all;
+ Insn_Len := 4;
+ Lo := Line'First;
+
+ case Shift_Right (W, 30) is
+ when 2#00# =>
+ -- BIcc, SETHI
+ case Shift_Right (W, 22) and 2#111# is
+ when 2#000# =>
+ Add_String ("unimp ");
+ Disp_Const (16#3f_Ffff#);
+ when 2#010# =>
+ Add_Cond ("b");
+ when 2#100# =>
+ Add_String ("sethi ");
+ Add_Ireg (Shift_Right (W, 25));
+ Add_String (", ");
+ Disp_Const (16#3f_Ffff#);
+ when others =>
+ Disp_Unknown;
+ end case;
+ when 2#01# =>
+ -- Call
+ Add_String ("call ");
+ Disp_Const (16#3fff_Ffff#);
+ when 2#10# =>
+ Disp_Format3 (Insn_Desc_10);
+ when 2#11# =>
+ Disp_Format3 (Insn_Desc_11);
+ when others =>
+ -- Misc.
+ Disp_Unknown;
+ end case;
+
+ Line_Len := Lo - Line'First;
+ end Disassemble_Insn;
+
+end Disa_Sparc;
diff --git a/src/ortho/mcode/disa_sparc.ads b/src/ortho/mcode/disa_sparc.ads
new file mode 100644
index 000000000..486dff977
--- /dev/null
+++ b/src/ortho/mcode/disa_sparc.ads
@@ -0,0 +1,15 @@
+with System;
+
+package Disa_Sparc is
+ -- Call-back used to find a relocation symbol.
+ type Symbol_Proc_Type is access procedure (Addr : System.Address;
+ Line : in out String;
+ Line_Len : in out Natural);
+
+ -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN.
+ procedure Disassemble_Insn (Addr : System.Address;
+ Line : in out String;
+ Line_Len : out Natural;
+ Insn_Len : out Natural;
+ Proc_Cb : Symbol_Proc_Type);
+end Disa_Sparc;
diff --git a/src/ortho/mcode/disa_x86.adb b/src/ortho/mcode/disa_x86.adb
new file mode 100644
index 000000000..1d2d48565
--- /dev/null
+++ b/src/ortho/mcode/disa_x86.adb
@@ -0,0 +1,997 @@
+-- X86 disassembler.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System.Address_To_Access_Conversions;
+
+package body Disa_X86 is
+ type Byte is new Interfaces.Unsigned_8;
+ type Bf_2 is mod 2 ** 2;
+ type Bf_3 is mod 2 ** 3;
+ type Byte_Vector is array (Natural) of Byte;
+ package Bv_Addr2acc is new System.Address_To_Access_Conversions
+ (Object => Byte_Vector);
+ use Bv_Addr2acc;
+
+ type Cstring_Acc is access constant String;
+ type Index_Type is
+ (
+ N_None,
+ N_Push,
+ N_Pop,
+ N_Ret,
+ N_Mov,
+ N_Add,
+ N_Or,
+ N_Adc,
+ N_Sbb,
+ N_And,
+ N_Sub,
+ N_Xor,
+ N_Cmp,
+ N_Into,
+ N_Jmp,
+ N_Jcc,
+ N_Setcc,
+ N_Call,
+ N_Int,
+ N_Cdq,
+ N_Imul,
+ N_Mul,
+ N_Leave,
+ N_Test,
+ N_Lea,
+ N_O,
+ N_No,
+ N_B,
+ N_AE,
+ N_E,
+ N_Ne,
+ N_Be,
+ N_A,
+ N_S,
+ N_Ns,
+ N_P,
+ N_Np,
+ N_L,
+ N_Ge,
+ N_Le,
+ N_G,
+ N_Not,
+ N_Neg,
+ N_Cbw,
+ N_Div,
+ N_Idiv,
+ N_Movsx,
+ N_Movzx,
+ N_Nop,
+ N_Hlt,
+ N_Inc,
+ N_Dec,
+ N_Rol,
+ N_Ror,
+ N_Rcl,
+ N_Rcr,
+ N_Shl,
+ N_Shr,
+ N_Sar,
+ N_Fadd,
+ N_Fmul,
+ N_Fcom,
+ N_Fcomp,
+ N_Fsub,
+ N_Fsubr,
+ N_Fdiv,
+ N_Fdivr,
+
+ G_1,
+ G_2,
+ G_3,
+ G_5
+ );
+
+ type Names_Type is array (Index_Type range <>) of Cstring_Acc;
+ subtype S is String;
+ Names : constant Names_Type :=
+ (N_None => new S'("none"),
+ N_Push => new S'("push"),
+ N_Pop => new S'("pop"),
+ N_Ret => new S'("ret"),
+ N_Mov => new S'("mov"),
+ N_Add => new S'("add"),
+ N_Or => new S'("or"),
+ N_Adc => new S'("adc"),
+ N_Sbb => new S'("sbb"),
+ N_And => new S'("and"),
+ N_Sub => new S'("sub"),
+ N_Xor => new S'("xor"),
+ N_Cmp => new S'("cmp"),
+ N_Into => new S'("into"),
+ N_Jmp => new S'("jmp"),
+ N_Jcc => new S'("j"),
+ N_Int => new S'("int"),
+ N_Cdq => new S'("cdq"),
+ N_Call => new S'("call"),
+ N_Imul => new S'("imul"),
+ N_Mul => new S'("mul"),
+ N_Leave => new S'("leave"),
+ N_Test => new S'("test"),
+ N_Setcc => new S'("set"),
+ N_Lea => new S'("lea"),
+ N_O => new S'("o"),
+ N_No => new S'("no"),
+ N_B => new S'("b"),
+ N_AE => new S'("ae"),
+ N_E => new S'("e"),
+ N_Ne => new S'("ne"),
+ N_Be => new S'("be"),
+ N_A => new S'("a"),
+ N_S => new S'("s"),
+ N_Ns => new S'("ns"),
+ N_P => new S'("p"),
+ N_Np => new S'("np"),
+ N_L => new S'("l"),
+ N_Ge => new S'("ge"),
+ N_Le => new S'("le"),
+ N_G => new S'("g"),
+ N_Not => new S'("not"),
+ N_Neg => new S'("neg"),
+ N_Cbw => new S'("cbw"),
+ N_Div => new S'("div"),
+ N_Idiv => new S'("idiv"),
+ N_Movsx => new S'("movsx"),
+ N_Movzx => new S'("movzx"),
+ N_Nop => new S'("nop"),
+ N_Hlt => new S'("hlt"),
+ N_Inc => new S'("inc"),
+ N_Dec => new S'("dec"),
+ N_Rol => new S'("rol"),
+ N_Ror => new S'("ror"),
+ N_Rcl => new S'("rcl"),
+ N_Rcr => new S'("rcr"),
+ N_Shl => new S'("shl"),
+ N_Shr => new S'("shr"),
+ N_Sar => new S'("sar"),
+ N_Fadd => new S'("fadd"),
+ N_Fmul => new S'("fmul"),
+ N_Fcom => new S'("fcom"),
+ N_Fcomp => new S'("fcomp"),
+ N_Fsub => new S'("fsub"),
+ N_Fsubr => new S'("fsubr"),
+ N_Fdiv => new S'("fdiv"),
+ N_Fdivr => new S'("fdivr")
+ );
+
+
+
+ -- Format of an instruction.
+ -- MODRM_SRC_8 : modrm byte follow, and modrm is source, witdh = 8bits
+ -- MODRM_DST_8 : modrm byte follow, and modrm is dest, width = 8 bits.
+ -- MODRM_SRC_W : modrm byte follow, and modrm is source, width = 16/32 bits
+ -- MODRM_DST_W : modrm byte follow, and modrm is dest, width =16/32 bits.
+ -- MODRM_IMM_W : modrm byte follow, with an opcode in the reg field,
+ -- followed by an immediat, width = 16/32 bits.
+ -- MODRM_IMM_8 : modrm byte follow, with an opcode in the reg field,
+ -- followed by an immediat, width = 8 bits.
+ -- IMM : the opcode is followed by an immediate value.
+ -- PREFIX : the opcode is a prefix (1 byte).
+ -- OPCODE : inherent addressing.
+ -- OPCODE2 : a second byte specify the instruction.
+ -- REG_IMP : register is in the 3 LSB of the opcode.
+ -- REG_IMM_W : register is in the 3 LSB of the opcode, followed by an
+ -- immediat, width = 16/32 bits.
+ -- DISP_W : a wide displacement (16/32 bits).
+ -- DISP_8 : short displacement (8 bits).
+ -- INVALID : bad opcode.
+ type Format_Type is (Modrm_Src, Modrm_Dst,
+ Modrm_Imm, Modrm_Imm_S,
+ Modrm,
+ Modrm_Ax,
+ Modrm_Imm8,
+ Imm, Imm_S, Imm_8,
+ Eax_Imm,
+ Prefix, Opcode, Opcode2, Reg_Imp,
+ Reg_Imm,
+ Imp,
+ Disp_W, Disp_8,
+ Cond_Disp_W, Cond_Disp_8,
+ Cond_Modrm,
+ Ax_Off_Src, Ax_Off_Dst,
+ Invalid);
+
+ type Width_Type is (W_None, W_8, W_16, W_32, W_Data);
+
+ -- Description for one instruction.
+ type Insn_Desc_Type is record
+ -- Name of the operation.
+ Name : Index_Type;
+
+ -- Width of the instruction.
+ -- This is used to add a suffix (b,w,l) to the instruction.
+ -- This may also be the size of a data.
+ Width : Width_Type;
+
+ -- Format of the instruction.
+ Format : Format_Type;
+ end record;
+
+ Desc_Invalid : constant Insn_Desc_Type := (N_None, W_None, Invalid);
+
+ type Insn_Desc_Array_Type is array (Byte) of Insn_Desc_Type;
+ type Group_Desc_Array_Type is array (Bf_3) of Insn_Desc_Type;
+ Insn_Desc : constant Insn_Desc_Array_Type :=
+ (
+ 2#00_000_000# => (N_Add, W_8, Modrm_Dst),
+ 2#00_000_001# => (N_Add, W_Data, Modrm_Dst),
+ 2#00_000_010# => (N_Add, W_8, Modrm_Src),
+ 2#00_000_011# => (N_Add, W_Data, Modrm_Src),
+
+ 2#00_001_000# => (N_Or, W_8, Modrm_Dst),
+ 2#00_001_001# => (N_Or, W_Data, Modrm_Dst),
+ 2#00_001_010# => (N_Or, W_8, Modrm_Src),
+ 2#00_001_011# => (N_Or, W_Data, Modrm_Src),
+
+ 2#00_011_000# => (N_Sbb, W_8, Modrm_Dst),
+ 2#00_011_001# => (N_Sbb, W_Data, Modrm_Dst),
+ 2#00_011_010# => (N_Sbb, W_8, Modrm_Src),
+ 2#00_011_011# => (N_Sbb, W_Data, Modrm_Src),
+
+ 2#00_100_000# => (N_And, W_8, Modrm_Dst),
+ 2#00_100_001# => (N_And, W_Data, Modrm_Dst),
+ 2#00_100_010# => (N_And, W_8, Modrm_Src),
+ 2#00_100_011# => (N_And, W_Data, Modrm_Src),
+
+ 2#00_101_000# => (N_Sub, W_8, Modrm_Dst),
+ 2#00_101_001# => (N_Sub, W_Data, Modrm_Dst),
+ 2#00_101_010# => (N_Sub, W_8, Modrm_Src),
+ 2#00_101_011# => (N_Sub, W_Data, Modrm_Src),
+
+ 2#00_110_000# => (N_Xor, W_8, Modrm_Dst),
+ 2#00_110_001# => (N_Xor, W_Data, Modrm_Dst),
+ 2#00_110_010# => (N_Xor, W_8, Modrm_Src),
+ 2#00_110_011# => (N_Xor, W_Data, Modrm_Src),
+
+ 2#00_111_000# => (N_Cmp, W_8, Modrm_Dst),
+ 2#00_111_001# => (N_Cmp, W_Data, Modrm_Dst),
+ 2#00_111_010# => (N_Cmp, W_8, Modrm_Src),
+ 2#00_111_011# => (N_Cmp, W_Data, Modrm_Src),
+
+ 2#00_111_100# => (N_Cmp, W_8, Eax_Imm),
+ 2#00_111_101# => (N_Cmp, W_Data, Eax_Imm),
+
+ 2#0101_0_000# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_001# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_010# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_011# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_100# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_101# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_110# => (N_Push, W_Data, Reg_Imp),
+ 2#0101_0_111# => (N_Push, W_Data, Reg_Imp),
+
+ 2#0101_1_000# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_001# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_010# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_011# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_100# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_101# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_110# => (N_Pop, W_Data, Reg_Imp),
+ 2#0101_1_111# => (N_Pop, W_Data, Reg_Imp),
+
+ 2#0110_1000# => (N_Push, W_Data, Imm),
+ 2#0110_1010# => (N_Push, W_Data, Imm_S),
+
+ 2#0111_0000# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0001# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0010# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0011# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0100# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0101# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0110# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_0111# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1000# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1001# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1010# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1011# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1100# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1101# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1110# => (N_Jcc, W_None, Cond_Disp_8),
+ 2#0111_1111# => (N_Jcc, W_None, Cond_Disp_8),
+
+ 2#1000_0000# => (G_1, W_8, Modrm_Imm),
+ 2#1000_0001# => (G_1, W_Data, Modrm_Imm),
+ 2#1000_0011# => (G_1, W_Data, Modrm_Imm_S),
+
+ 2#1000_0101# => (N_Test, W_Data, Modrm_Src),
+ 2#1000_1101# => (N_Lea, W_Data, Modrm_Src),
+
+ 2#1000_1010# => (N_Mov, W_8, Modrm_Src),
+ 2#1000_1011# => (N_Mov, W_Data, Modrm_Src),
+ 2#1000_1000# => (N_Mov, W_8, Modrm_Dst),
+ 2#1000_1001# => (N_Mov, W_Data, Modrm_Dst),
+
+ 2#1001_0000# => (N_Nop, W_None, Opcode),
+ 2#1001_1001# => (N_Cdq, W_Data, Imp),
+
+ 2#1010_0000# => (N_Mov, W_8, Ax_Off_Src),
+ 2#1010_0001# => (N_Mov, W_Data, Ax_Off_Src),
+ 2#1010_0010# => (N_Mov, W_8, Ax_Off_Dst),
+ 2#1010_0011# => (N_Mov, W_Data, Ax_Off_Dst),
+
+ 2#1011_0000# => (N_Mov, W_8, Reg_Imm),
+
+ 2#1011_1000# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1001# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1010# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1011# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1100# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1101# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1110# => (N_Mov, W_Data, Reg_Imm),
+ 2#1011_1111# => (N_Mov, W_Data, Reg_Imm),
+
+ 2#1100_0000# => (G_2, W_8, Modrm_Imm8),
+ 2#1100_0001# => (G_2, W_Data, Modrm_Imm8),
+
+ 2#1100_0011# => (N_Ret, W_None, Opcode),
+ 2#1100_0110# => (N_Mov, W_8, Modrm_Imm),
+ 2#1100_0111# => (N_Mov, W_Data, Modrm_Imm),
+ 2#1100_1001# => (N_Leave, W_None, Opcode),
+ 2#1100_1101# => (N_Int, W_None, Imm_8),
+ 2#1100_1110# => (N_Into, W_None, Opcode),
+
+ 2#1110_1000# => (N_Call, W_None, Disp_W),
+ 2#1110_1001# => (N_Jmp, W_None, Disp_W),
+ 2#1110_1011# => (N_Jmp, W_None, Disp_8),
+
+ 2#1111_0100# => (N_Hlt, W_None, Opcode),
+
+ 2#1111_0110# => (G_3, W_None, Invalid),
+ 2#1111_0111# => (G_3, W_None, Invalid),
+
+ 2#1111_1111# => (G_5, W_None, Invalid),
+ --2#1111_1111# => (N_Push, W_Data, Modrm),
+ others => (N_None, W_None, Invalid));
+
+ Insn_Desc_0F : constant Insn_Desc_Array_Type :=
+ (2#1000_0000# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0001# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0010# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0011# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0100# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0101# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0110# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_0111# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1000# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1001# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1010# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1011# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1100# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1101# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1110# => (N_Jcc, W_None, Cond_Disp_W),
+ 2#1000_1111# => (N_Jcc, W_None, Cond_Disp_W),
+
+ 2#1001_0000# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0001# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0010# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0011# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0100# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0101# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0110# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_0111# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1000# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1001# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1010# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1011# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1100# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1101# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1110# => (N_Setcc, W_8, Cond_Modrm),
+ 2#1001_1111# => (N_Setcc, W_8, Cond_Modrm),
+
+ 2#1011_0110# => (N_Movzx, W_Data, Modrm_Dst),
+ 2#1011_1110# => (N_Movsx, W_Data, Modrm_Dst),
+ others => (N_None, W_None, Invalid));
+
+ -- 16#F7#
+ Insn_Desc_G3 : constant Group_Desc_Array_Type :=
+ (2#000# => (N_Test, W_Data, Reg_Imm),
+ 2#010# => (N_Not, W_Data, Modrm_Dst),
+ 2#011# => (N_Neg, W_Data, Modrm_Dst),
+ 2#100# => (N_Mul, W_Data, Modrm_Ax),
+ 2#101# => (N_Imul, W_Data, Modrm_Ax),
+ 2#110# => (N_Div, W_Data, Modrm_Ax),
+ 2#111# => (N_Idiv, W_Data, Modrm_Ax),
+ others => (N_None, W_None, Invalid));
+
+ Insn_Desc_G5 : constant Group_Desc_Array_Type :=
+ (2#000# => (N_Inc, W_Data, Modrm),
+ 2#001# => (N_Dec, W_Data, Modrm),
+ 2#010# => (N_Call, W_Data, Modrm),
+ --2#011# => (N_Call, W_Data, Modrm_Ax),
+ 2#100# => (N_Jmp, W_Data, Modrm),
+ --2#101# => (N_Jmp, W_Data, Modrm_Ax),
+ 2#110# => (N_Push, W_Data, Modrm_Ax),
+ others => (N_None, W_None, Invalid));
+
+ type Group_Name_Array_Type is array (Index_Type range G_1 .. G_2, Bf_3)
+ of Index_Type;
+ Group_Name : constant Group_Name_Array_Type :=
+ (
+ G_1 => (N_Add, N_Or, N_Adc, N_Sbb, N_And, N_Sub, N_Xor, N_Cmp),
+ G_2 => (N_Rol, N_Ror, N_Rcl, N_Rcr, N_Shl, N_Shr, N_None, N_Sar)
+ );
+
+ -- Standard widths of operations.
+ type Width_Array_Type is array (Width_Type) of Character;
+ Width_Char : constant Width_Array_Type :=
+ (W_None => '-', W_8 => 'b', W_16 => 'w', W_32 => 'l', W_Data => '?');
+ type Width_Len_Type is array (Width_Type) of Natural;
+ Width_Len : constant Width_Len_Type :=
+ (W_None => 0, W_8 => 1, W_16 => 2, W_32 => 4, W_Data => 0);
+
+ -- Registers.
+-- type Reg_Type is (Reg_Ax, Reg_Bx, Reg_Cx, Reg_Dx,
+-- Reg_Bp, Reg_Sp, Reg_Si, Reg_Di,
+-- Reg_Al, Reg_Ah, Reg_Bl, Reg_Bh,
+-- Reg_Cl, Reg_Ch, Reg_Dl, Reg_Dh);
+
+ -- Bits extraction from byte functions.
+ -- For a byte, MSB (most significant bit) is bit 7 while
+ -- LSB (least significant bit) is bit 0.
+
+ -- Extract bits 2, 1 and 0.
+ function Ext_210 (B : Byte) return Bf_3;
+ pragma Inline (Ext_210);
+
+ -- Extract bits 5-3 of byte B.
+ function Ext_543 (B : Byte) return Bf_3;
+ pragma Inline (Ext_543);
+
+ -- Extract bits 7-6 of byte B.
+ function Ext_76 (B : Byte) return Bf_2;
+ pragma Inline (Ext_76);
+
+ function Ext_210 (B : Byte) return Bf_3 is
+ begin
+ return Bf_3 (B and 2#111#);
+ end Ext_210;
+
+ function Ext_543 (B : Byte) return Bf_3 is
+ begin
+ return Bf_3 (Shift_Right (B, 3) and 2#111#);
+ end Ext_543;
+
+ function Ext_76 (B : Byte) return Bf_2 is
+ begin
+ return Bf_2 (Shift_Right (B, 6) and 2#11#);
+ end Ext_76;
+
+ function Ext_Modrm_Mod (B : Byte) return Bf_2 renames Ext_76;
+ function Ext_Modrm_Rm (B : Byte) return Bf_3 renames Ext_210;
+ function Ext_Modrm_Reg (B : Byte) return Bf_3 renames Ext_543;
+ function Ext_Sib_Base (B : Byte) return Bf_3 renames Ext_210;
+ function Ext_Sib_Index (B : Byte) return Bf_3 renames Ext_543;
+ function Ext_Sib_Scale (B : Byte) return Bf_2 renames Ext_76;
+
+ procedure Disassemble_Insn (Addr : System.Address;
+ Pc : Unsigned_32;
+ Line : in out String;
+ Line_Len : out Natural;
+ Insn_Len : out Natural;
+ Proc_Cb : Symbol_Proc_Type)
+ is
+ -- Index in LINE of the next character to be written.
+ Lo : Natural;
+
+ -- Default width.
+ W_Default : constant Width_Type := W_32;
+
+ -- The instruction memory, 0 based.
+ Mem : Bv_Addr2acc.Object_Pointer;
+
+ -- Add NAME to the line.
+ procedure Add_Name (Name : Index_Type);
+ pragma Inline (Add_Name);
+
+ -- Add CHAR to the line.
+ procedure Add_Char (C : Character);
+ pragma Inline (Add_Char);
+
+ -- Add STR to the line.
+ procedure Add_String (Str : String) is
+ begin
+ Line (Lo .. Lo + Str'Length - 1) := Str;
+ Lo := Lo + Str'Length;
+ end Add_String;
+
+ -- Add BYTE to the line.
+ procedure Add_Byte (V : Byte) is
+ type My_Str is array (Natural range 0 .. 15) of Character;
+ Hex_Digit : constant My_Str := "0123456789abcdef";
+ begin
+ Add_Char (Hex_Digit (Natural (Shift_Right (V, 4) and 16#0f#)));
+ Add_Char (Hex_Digit (Natural (Shift_Right (V, 0) and 16#0f#)));
+ end Add_Byte;
+
+ procedure Add_Name (Name : Index_Type) is
+ begin
+ Add_String (Names (Name).all);
+ end Add_Name;
+
+ procedure Add_Char (C : Character) is
+ begin
+ Line (Lo) := C;
+ Lo := Lo + 1;
+ end Add_Char;
+
+ procedure Add_Comma is
+ begin
+ Add_String (", ");
+ end Add_Comma;
+
+ procedure Name_Align (Orig : Natural) is
+ begin
+ Add_Char (' ');
+ while Lo - Orig < 8 loop
+ Add_Char (' ');
+ end loop;
+ end Name_Align;
+
+ procedure Add_Opcode (Name : Index_Type; Width : Width_Type)
+ is
+ L : constant Natural := Lo;
+ begin
+ Add_Name (Name);
+ if False and Width /= W_None then
+ Add_Char (Width_Char (Width));
+ end if;
+ Name_Align (L);
+ end Add_Opcode;
+
+ procedure Add_Cond_Opcode (Name : Index_Type; B : Byte)
+ is
+ L : constant Natural := Lo;
+ begin
+ Add_Name (Name);
+ Add_Name (Index_Type'Val (Index_Type'Pos (N_O)
+ + Byte'Pos (B and 16#0f#)));
+ Name_Align (L);
+ end Add_Cond_Opcode;
+
+ procedure Decode_Reg_Field (F : Bf_3; W : Width_Type) is
+ type Reg_Name2_Array is array (Bf_3) of String (1 .. 2);
+ type Reg_Name3_Array is array (Bf_3) of String (1 .. 3);
+ Regs_8 : constant Reg_Name2_Array :=
+ ("al", "cl", "dl", "bl", "ah", "ch", "dh", "bh");
+ Regs_16 : constant Reg_Name2_Array :=
+ ("ax", "cx", "dx", "bx", "sp", "bp", "si", "di");
+ Regs_32 : constant Reg_Name3_Array :=
+ ("eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi");
+ begin
+ Add_Char ('%');
+ case W is
+ when W_8 =>
+ Add_String (Regs_8 (F));
+ when W_16 =>
+ Add_String (Regs_16 (F));
+ when W_32 =>
+ Add_String (Regs_32 (F));
+ when W_None
+ | W_Data =>
+ raise Program_Error;
+ end case;
+ end Decode_Reg_Field;
+
+ procedure Decode_Val (Off : Natural; Width : Width_Type)
+ is
+ begin
+ case Width is
+ when W_8 =>
+ Add_Byte (Mem (Off));
+ when W_16 =>
+ Add_Byte (Mem (Off + 1));
+ Add_Byte (Mem (Off));
+ when W_32 =>
+ Add_Byte (Mem (Off + 3));
+ Add_Byte (Mem (Off + 2));
+ Add_Byte (Mem (Off + 1));
+ Add_Byte (Mem (Off + 0));
+ when W_None
+ | W_Data =>
+ raise Program_Error;
+ end case;
+ end Decode_Val;
+
+ function Decode_Val (Off : Natural; Width : Width_Type)
+ return Unsigned_32
+ is
+ V : Unsigned_32;
+ begin
+ case Width is
+ when W_8 =>
+ V := Unsigned_32 (Mem (Off));
+ -- Sign extension.
+ if V >= 16#80# then
+ V := 16#Ffff_Ff00# or V;
+ end if;
+ return V;
+ when W_16 =>
+ return Shift_Left (Unsigned_32 (Mem (Off + 1)), 8)
+ or Unsigned_32 (Mem (Off));
+ when W_32 =>
+ return Shift_Left (Unsigned_32 (Mem (Off + 3)), 24)
+ or Shift_Left (Unsigned_32 (Mem (Off + 2)), 16)
+ or Shift_Left (Unsigned_32 (Mem (Off + 1)), 8)
+ or Shift_Left (Unsigned_32 (Mem (Off + 0)), 0);
+ when W_None
+ | W_Data =>
+ raise Program_Error;
+ end case;
+ end Decode_Val;
+
+ procedure Decode_Imm (Off : in out Natural; Width : Width_Type)
+ is
+ begin
+ Add_String ("$0x");
+ Decode_Val (Off, Width);
+ Off := Off + Width_Len (Width);
+ end Decode_Imm;
+
+ procedure Decode_Disp (Off : in out Natural;
+ Width : Width_Type;
+ Offset : Unsigned_32 := 0)
+ is
+ L : Natural;
+ V : Unsigned_32;
+ Off_Orig : constant Natural := Off;
+ begin
+ L := Lo;
+ V := Decode_Val (Off, Width) + Offset;
+ Off := Off + Width_Len (Width);
+ if Proc_Cb /= null then
+ Proc_Cb.all (Mem (Off)'Address,
+ Line (Lo .. Line'Last), Lo);
+ end if;
+ if L /= Lo then
+ if V = 0 then
+ return;
+ end if;
+ Add_String (" + ");
+ end if;
+ Add_String ("0x");
+ if Offset = 0 then
+ Decode_Val (Off_Orig, Width);
+ else
+ Add_Byte (Byte (Shift_Right (V, 24) and 16#Ff#));
+ Add_Byte (Byte (Shift_Right (V, 16) and 16#Ff#));
+ Add_Byte (Byte (Shift_Right (V, 8) and 16#Ff#));
+ Add_Byte (Byte (Shift_Right (V, 0) and 16#Ff#));
+ end if;
+ end Decode_Disp;
+
+ procedure Decode_Modrm_Reg (B : Byte; Width : Width_Type) is
+ begin
+ Decode_Reg_Field (Ext_Modrm_Reg (B), Width);
+ end Decode_Modrm_Reg;
+
+ procedure Decode_Sib (Sib : Byte; B_Mod : Bf_2)
+ is
+ S : Bf_2;
+ I : Bf_3;
+ B : Bf_3;
+ begin
+ S := Ext_Sib_Scale (Sib);
+ B := Ext_Sib_Base (Sib);
+ I := Ext_Sib_Index (Sib);
+ Add_Char ('(');
+ if B = 2#101# and then B_Mod /= 0 then
+ Decode_Reg_Field (B, W_32);
+ Add_Char (',');
+ end if;
+ if I /= 2#100# then
+ Decode_Reg_Field (I, W_32);
+ case S is
+ when 2#00# =>
+ null;
+ when 2#01# =>
+ Add_String (",2");
+ when 2#10# =>
+ Add_String (",4");
+ when 2#11# =>
+ Add_String (",8");
+ end case;
+ end if;
+ Add_Char (')');
+ end Decode_Sib;
+
+ procedure Decode_Modrm_Mem (Off : in out Natural; Width : Width_Type)
+ is
+ B : Byte;
+ B_Mod : Bf_2;
+ B_Rm : Bf_3;
+ Off_Orig : Natural;
+ begin
+ B := Mem (Off);
+ B_Mod := Ext_Modrm_Mod (B);
+ B_Rm := Ext_Modrm_Rm (B);
+ Off_Orig := Off;
+ case B_Mod is
+ when 2#11# =>
+ Decode_Reg_Field (B_Rm, Width);
+ Off := Off + 1;
+ when 2#10# =>
+ if B_Rm = 2#100# then
+ Off := Off + 2;
+ Decode_Disp (Off, W_32);
+ Decode_Sib (Mem (Off_Orig + 1), B_Mod);
+ else
+ Off := Off + 1;
+ Decode_Disp (Off, W_32);
+ Add_Char ('(');
+ Decode_Reg_Field (B_Rm, W_32);
+ Add_Char (')');
+ end if;
+ when 2#01# =>
+ if B_Rm = 2#100# then
+ Off := Off + 2;
+ Decode_Disp (Off, W_8);
+ Decode_Sib (Mem (Off_Orig + 1), B_Mod);
+ else
+ Off := Off + 1;
+ Decode_Disp (Off, W_8);
+ Add_Char ('(');
+ Decode_Reg_Field (B_Rm, W_32);
+ Add_Char (')');
+ end if;
+ when 2#00# =>
+ if B_Rm = 2#100# then
+ Off := Off + 2;
+ Decode_Sib (Mem (Off_Orig + 1), B_Mod);
+ elsif B_Rm = 2#101# then
+ Off := Off + 1;
+ Decode_Disp (Off, W_32);
+ else
+ Add_Char ('(');
+ Decode_Reg_Field (B_Rm, W_32);
+ Add_Char (')');
+ Off := Off + 1;
+ end if;
+ end case;
+ end Decode_Modrm_Mem;
+
+ -- Return the length of the modrm bytes.
+ -- At least 1 (mod/rm), at most 6 (mod/rm + SUB + disp32).
+ function Decode_Modrm_Len (Off : Natural) return Natural
+ is
+ B : Byte;
+ M_Mod : Bf_2;
+ M_Rm : Bf_3;
+ begin
+ B := Mem (Off);
+ M_Mod := Ext_Modrm_Mod (B);
+ M_Rm := Ext_Modrm_Rm (B);
+ case M_Mod is
+ when 2#11# =>
+ return 1;
+ when 2#10# =>
+ if M_Rm = 2#100# then
+ return 1 + 1 + 4;
+ else
+ return 1 + 4;
+ end if;
+ when 2#01# =>
+ if M_Rm = 2#100# then
+ return 1 + 1 + 1;
+ else
+ return 1 + 1;
+ end if;
+ when 2#00# =>
+ if M_Rm = 2#101# then
+ -- disp32.
+ return 1 + 4;
+ elsif M_Rm = 2#100# then
+ -- SIB
+ return 1 + 1;
+ else
+ return 1;
+ end if;
+ end case;
+ end Decode_Modrm_Len;
+
+
+ Off : Natural;
+ B : Byte;
+ B1 : Byte;
+ Desc : Insn_Desc_Type;
+ Name : Index_Type;
+ W : Width_Type;
+ begin
+ Mem := To_Pointer (Addr);
+ Off := 0;
+ Lo := Line'First;
+
+ B := Mem (0);
+ if B = 2#0000_1111# then
+ B := Mem (1);
+ Off := 2;
+ Insn_Len := 2;
+ Desc := Insn_Desc_0F (B);
+ else
+ Off := 1;
+ Insn_Len := 1;
+ Desc := Insn_Desc (B);
+ end if;
+
+ if Desc.Name >= G_1 then
+ B1 := Mem (Off);
+ case Desc.Name is
+ when G_1
+ | G_2 =>
+ Name := Group_Name (Desc.Name, Ext_543 (B1));
+ when G_3 =>
+ Desc := Insn_Desc_G3 (Ext_543 (B1));
+ Name := Desc.Name;
+ when G_5 =>
+ Desc := Insn_Desc_G5 (Ext_543 (B1));
+ Name := Desc.Name;
+ when others =>
+ Desc := Desc_Invalid;
+ end case;
+ else
+ Name := Desc.Name;
+ end if;
+
+ case Desc.Width is
+ when W_Data =>
+ W := W_Default;
+ when W_8
+ | W_16
+ | W_32 =>
+ W := Desc.Width;
+ when W_None =>
+ case Desc.Format is
+ when Disp_8
+ | Cond_Disp_8
+ | Imm_8 =>
+ W := W_8;
+ when Disp_W
+ | Cond_Disp_W =>
+ W := W_Default;
+ when Invalid
+ | Opcode =>
+ W := W_None;
+ when others =>
+ raise Program_Error;
+ end case;
+ end case;
+
+ case Desc.Format is
+ when Reg_Imp =>
+ Add_Opcode (Desc.Name, W_Default);
+ Decode_Reg_Field (Ext_210 (B), W_Default);
+ when Opcode =>
+ Add_Opcode (Desc.Name, W_None);
+ when Modrm =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Modrm_Mem (Insn_Len, W);
+ when Modrm_Src =>
+ Add_Opcode (Desc.Name, W);
+ -- Disp source first.
+ Decode_Modrm_Mem (Insn_Len, W);
+ Add_Comma;
+ B := Mem (Off);
+ Decode_Modrm_Reg (Mem (Off), W);
+ when Modrm_Dst =>
+ Add_Opcode (Desc.Name, W);
+ -- Disp source first.
+ B := Mem (Off);
+ Decode_Modrm_Reg (B, W);
+ Add_Comma;
+ Decode_Modrm_Mem (Insn_Len, W);
+ when Modrm_Imm =>
+ Add_Opcode (Name, W);
+ Insn_Len := Off + Decode_Modrm_Len (Off);
+ Decode_Imm (Insn_Len, W);
+ Add_Comma;
+ Decode_Modrm_Mem (Off, W);
+ when Modrm_Imm_S =>
+ Add_Opcode (Name, W);
+ Insn_Len := Off + Decode_Modrm_Len (Off);
+ Decode_Imm (Insn_Len, W_8);
+ Add_Comma;
+ Decode_Modrm_Mem (Off, W);
+ when Modrm_Imm8 =>
+ Add_Opcode (Name, W);
+ Decode_Modrm_Mem (Off, W);
+ Add_Comma;
+ Decode_Imm (Off, W_8);
+
+ when Reg_Imm =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Imm (Insn_Len, W);
+ Add_Comma;
+ Decode_Reg_Field (Ext_210 (B), W);
+ when Eax_Imm =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Imm (Insn_Len, W);
+ Add_Comma;
+ Decode_Reg_Field (2#000#, W);
+
+ when Disp_W
+ | Disp_8 =>
+ Add_Opcode (Desc.Name, W_None);
+ Decode_Disp (Insn_Len, W,
+ Pc + Unsigned_32 (Insn_Len + Width_Len (W)));
+
+ when Cond_Disp_8
+ | Cond_Disp_W =>
+ Add_Cond_Opcode (Desc.Name, B);
+ Decode_Disp (Insn_Len, W,
+ Pc + Unsigned_32 (Insn_Len + Width_Len (W)));
+
+ when Cond_Modrm =>
+ Add_Cond_Opcode (Desc.Name, B);
+ Decode_Modrm_Mem (Insn_Len, W);
+
+ when Imm =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Imm (Insn_Len, W);
+
+ when Imm_S
+ | Imm_8 =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Imm (Insn_Len, W_8);
+
+ when Modrm_Ax =>
+ if (B and 2#1#) = 2#0# then
+ W := W_8;
+ else
+ W := W_Default;
+ end if;
+ Add_Opcode (Desc.Name, W);
+ Decode_Reg_Field (0, W);
+ Add_Comma;
+ Decode_Modrm_Mem (Off, W);
+
+ when Ax_Off_Src =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Disp (Insn_Len, W);
+ Add_Comma;
+ Decode_Reg_Field (0, W);
+
+ when Ax_Off_Dst =>
+ Add_Opcode (Desc.Name, W);
+ Decode_Reg_Field (0, W);
+ Add_Comma;
+ Decode_Disp (Insn_Len, W);
+
+ when Imp =>
+ Add_Opcode (Desc.Name, W_Default);
+
+ when Invalid
+ | Prefix
+ | Opcode2 =>
+ Add_String ("invalid ");
+ if Insn_Len = 2 then
+ Add_Byte (Mem (0));
+ end if;
+ Add_Byte (B);
+ Insn_Len := 1;
+ end case;
+
+ Line_Len := Lo - Line'First;
+ end Disassemble_Insn;
+end Disa_X86;
+
+
diff --git a/src/ortho/mcode/disa_x86.ads b/src/ortho/mcode/disa_x86.ads
new file mode 100644
index 000000000..c215cf0a3
--- /dev/null
+++ b/src/ortho/mcode/disa_x86.ads
@@ -0,0 +1,34 @@
+-- X86 disassembler.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Interfaces; use Interfaces;
+
+package Disa_X86 is
+ -- Call-back used to find a relocation symbol.
+ type Symbol_Proc_Type is access procedure (Addr : System.Address;
+ Line : in out String;
+ Line_Len : in out Natural);
+
+ -- Disassemble instruction at ADDR, and put the result in LINE/LINE_LEN.
+ procedure Disassemble_Insn (Addr : System.Address;
+ Pc : Unsigned_32;
+ Line : in out String;
+ Line_Len : out Natural;
+ Insn_Len : out Natural;
+ Proc_Cb : Symbol_Proc_Type);
+end Disa_X86;
diff --git a/src/ortho/mcode/disassemble.ads b/src/ortho/mcode/disassemble.ads
new file mode 100644
index 000000000..5c9811fed
--- /dev/null
+++ b/src/ortho/mcode/disassemble.ads
@@ -0,0 +1,3 @@
+with Disa_X86;
+
+package Disassemble renames Disa_X86;
diff --git a/src/ortho/mcode/dwarf.ads b/src/ortho/mcode/dwarf.ads
new file mode 100644
index 000000000..40ee94f10
--- /dev/null
+++ b/src/ortho/mcode/dwarf.ads
@@ -0,0 +1,446 @@
+-- DWARF definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Dwarf is
+ DW_TAG_Array_Type : constant := 16#01#;
+ DW_TAG_Class_Type : constant := 16#02#;
+ DW_TAG_Entry_Point : constant := 16#03#;
+ DW_TAG_Enumeration_Type : constant := 16#04#;
+ DW_TAG_Formal_Parameter : constant := 16#05#;
+ DW_TAG_Imported_Declaration : constant := 16#08#;
+ DW_TAG_Label : constant := 16#0a#;
+ DW_TAG_Lexical_Block : constant := 16#0b#;
+ DW_TAG_Member : constant := 16#0d#;
+ DW_TAG_Pointer_Type : constant := 16#0f#;
+ DW_TAG_Reference_Type : constant := 16#10#;
+ DW_TAG_Compile_Unit : constant := 16#11#;
+ DW_TAG_String_Type : constant := 16#12#;
+ DW_TAG_Structure_Type : constant := 16#13#;
+ DW_TAG_Subroutine_Type : constant := 16#15#;
+ DW_TAG_Typedef : constant := 16#16#;
+ DW_TAG_Union_Type : constant := 16#17#;
+ DW_TAG_Unspecified_Parameters : constant := 16#18#;
+ DW_TAG_Variant : constant := 16#19#;
+ DW_TAG_Common_Block : constant := 16#1a#;
+ DW_TAG_Common_Inclusion : constant := 16#1b#;
+ DW_TAG_Inheritance : constant := 16#1c#;
+ DW_TAG_Inlined_Subroutine : constant := 16#1d#;
+ DW_TAG_Module : constant := 16#1e#;
+ DW_TAG_Ptr_To_Member_Type : constant := 16#1f#;
+ DW_TAG_Set_Type : constant := 16#20#;
+ DW_TAG_Subrange_Type : constant := 16#21#;
+ DW_TAG_With_Stmt : constant := 16#22#;
+ DW_TAG_Access_Declaration : constant := 16#23#;
+ DW_TAG_Base_Type : constant := 16#24#;
+ DW_TAG_Catch_Block : constant := 16#25#;
+ DW_TAG_Const_Type : constant := 16#26#;
+ DW_TAG_Constant : constant := 16#27#;
+ DW_TAG_Enumerator : constant := 16#28#;
+ DW_TAG_File_Type : constant := 16#29#;
+ DW_TAG_Friend : constant := 16#2a#;
+ DW_TAG_Namelist : constant := 16#2b#;
+ DW_TAG_Namelist_Item : constant := 16#2c#;
+ DW_TAG_Packed_Type : constant := 16#2d#;
+ DW_TAG_Subprogram : constant := 16#2e#;
+ DW_TAG_Template_Type_Parameter : constant := 16#2f#;
+ DW_TAG_Template_Value_Parameter : constant := 16#30#;
+ DW_TAG_Thrown_Type : constant := 16#31#;
+ DW_TAG_Try_Block : constant := 16#32#;
+ DW_TAG_Variant_Part : constant := 16#33#;
+ DW_TAG_Variable : constant := 16#34#;
+ DW_TAG_Volatile_Type : constant := 16#35#;
+ DW_TAG_Dwarf_Procedure : constant := 16#36#;
+ DW_TAG_Restrict_Type : constant := 16#37#;
+ DW_TAG_Interface_Type : constant := 16#38#;
+ DW_TAG_Namespace : constant := 16#39#;
+ DW_TAG_Imported_Module : constant := 16#3a#;
+ DW_TAG_Unspecified_Type : constant := 16#3b#;
+ DW_TAG_Partial_Unit : constant := 16#3c#;
+ DW_TAG_Imported_Unit : constant := 16#3d#;
+ DW_TAG_Mutable_Type : constant := 16#3e#;
+ DW_TAG_Lo_User : constant := 16#4080#;
+ DW_TAG_Hi_User : constant := 16#Ffff#;
+
+ DW_CHILDREN_No : constant := 16#0#;
+ DW_CHILDREN_Yes : constant := 16#1#;
+
+ DW_AT_Sibling : constant := 16#01#; -- reference
+ DW_AT_Location : constant := 16#02#; -- block, loclistptr
+ DW_AT_Name : constant := 16#03#; -- string
+ DW_AT_Ordering : constant := 16#09#; -- constant
+ DW_AT_Byte_Size : constant := 16#0b#; -- block, constant, ref
+ DW_AT_Bit_Offset : constant := 16#0c#; -- block, constant, ref
+ DW_AT_Bit_Size : constant := 16#0d#; -- block, constant, ref
+ DW_AT_Stmt_List : constant := 16#10#; -- lineptr
+ DW_AT_Low_Pc : constant := 16#11#; -- address
+ DW_AT_High_Pc : constant := 16#12#; -- address
+ DW_AT_Language : constant := 16#13#; -- constant
+ DW_AT_Discr : constant := 16#15#; -- reference
+ DW_AT_Discr_Value : constant := 16#16#; -- constant
+ DW_AT_Visibility : constant := 16#17#; -- constant
+ DW_AT_Import : constant := 16#18#; -- reference
+ DW_AT_String_Length : constant := 16#19#; -- block, loclistptr
+ DW_AT_Common_Reference : constant := 16#1a#; -- reference
+ DW_AT_Comp_Dir : constant := 16#1b#; -- string
+ DW_AT_Const_Value : constant := 16#1c#; -- block, constant, string
+ DW_AT_Containing_Type : constant := 16#1d#; -- reference
+ DW_AT_Default_Value : constant := 16#1e#; -- reference
+ DW_AT_Inline : constant := 16#20#; -- constant
+ DW_AT_Is_Optional : constant := 16#21#; -- flag
+ DW_AT_Lower_Bound : constant := 16#22#; -- block, constant, ref
+ DW_AT_Producer : constant := 16#25#; -- string
+ DW_AT_Prototyped : constant := 16#27#; -- flag
+ DW_AT_Return_Addr : constant := 16#2a#; -- block, loclistptr
+ DW_AT_Start_Scope : constant := 16#2c#; -- constant
+ DW_AT_Stride_Size : constant := 16#2e#; -- constant
+ DW_AT_Upper_Bound : constant := 16#2f#; -- block, constant, ref
+ DW_AT_Abstract_Origin : constant := 16#31#; -- reference
+ DW_AT_Accessibility : constant := 16#32#; -- constant
+ DW_AT_Address_Class : constant := 16#33#; -- constant
+ DW_AT_Artificial : constant := 16#34#; -- flag
+ DW_AT_Base_Types : constant := 16#35#; -- reference
+ DW_AT_Calling_Convention : constant := 16#36#; -- constant
+ DW_AT_Count : constant := 16#37#; -- block, constant, ref
+ DW_AT_Data_Member_Location : constant := 16#38#; -- block, const, loclistptr
+ DW_AT_Decl_Column : constant := 16#39#; -- constant
+ DW_AT_Decl_File : constant := 16#3a#; -- constant
+ DW_AT_Decl_Line : constant := 16#3b#; -- constant
+ DW_AT_Declaration : constant := 16#3c#; -- flag
+ DW_AT_Discr_List : constant := 16#3d#; -- block
+ DW_AT_Encoding : constant := 16#3e#; -- constant
+ DW_AT_External : constant := 16#3f#; -- flag
+ DW_AT_Frame_Base : constant := 16#40#; -- block, loclistptr
+ DW_AT_Friend : constant := 16#41#; -- reference
+ DW_AT_Identifier_Case : constant := 16#42#; -- constant
+ DW_AT_Macro_Info : constant := 16#43#; -- macptr
+ DW_AT_Namelist_Item : constant := 16#44#; -- block
+ DW_AT_Priority : constant := 16#45#; -- reference
+ DW_AT_Segment : constant := 16#46#; -- block, constant
+ DW_AT_Specification : constant := 16#47#; -- reference
+ DW_AT_Static_Link : constant := 16#48#; -- block, loclistptr
+ DW_AT_Type : constant := 16#49#; -- reference
+ DW_AT_Use_Location : constant := 16#4a#; -- block, loclistptr
+ DW_AT_Variable_Parameter : constant := 16#4b#; -- flag
+ DW_AT_Virtuality : constant := 16#4c#; -- constant
+ DW_AT_Vtable_Elem_Location : constant := 16#4d#; -- block, loclistptr
+ DW_AT_Allocated : constant := 16#4e#; -- block, constant, ref
+ DW_AT_Associated : constant := 16#4f#; -- block, constant, ref
+ DW_AT_Data_Location : constant := 16#50#; -- x50block
+ DW_AT_Stride : constant := 16#51#; -- block, constant, ref
+ DW_AT_Entry_Pc : constant := 16#52#; -- address
+ DW_AT_Use_UTF8 : constant := 16#53#; -- flag
+ DW_AT_Extension : constant := 16#04#; -- reference
+ DW_AT_Ranges : constant := 16#55#; -- rangelistptr
+ DW_AT_Trampoline : constant := 16#56#; -- address, flag, ref, str
+ DW_AT_Call_Column : constant := 16#57#; -- constant
+ DW_AT_Call_File : constant := 16#58#; -- constant
+ DW_AT_Call_Line : constant := 16#59#; -- constant
+ DW_AT_Description : constant := 16#5a#; -- string
+ DW_AT_Lo_User : constant := 16#2000#; -- ---
+ DW_AT_Hi_User : constant := 16#3fff#; -- ---
+
+ DW_FORM_Addr : constant := 16#01#; -- address
+ DW_FORM_Block2 : constant := 16#03#; -- block
+ DW_FORM_Block4 : constant := 16#04#; -- block
+ DW_FORM_Data2 : constant := 16#05#; -- constant
+ DW_FORM_Data4 : constant := 16#06#; -- constant, lineptr, loclistptr...
+ DW_FORM_Data8 : constant := 16#07#; -- ... macptr, rangelistptr
+ DW_FORM_String : constant := 16#08#; -- string
+ DW_FORM_Block : constant := 16#09#; -- block
+ DW_FORM_Block1 : constant := 16#0a#; -- block
+ DW_FORM_Data1 : constant := 16#0b#; -- constant
+ DW_FORM_Flag : constant := 16#0c#; -- flag
+ DW_FORM_Sdata : constant := 16#0d#; -- constant
+ DW_FORM_Strp : constant := 16#0e#; -- string
+ DW_FORM_Udata : constant := 16#0f#; -- constant
+ DW_FORM_Ref_Addr : constant := 16#10#; -- reference
+ DW_FORM_Ref1 : constant := 16#11#; -- reference
+ DW_FORM_Ref2 : constant := 16#12#; -- reference
+ DW_FORM_Ref4 : constant := 16#13#; -- reference
+ DW_FORM_Ref8 : constant := 16#14#; -- reference
+ DW_FORM_Ref_Udata : constant := 16#15#; -- reference
+ DW_FORM_Indirect : constant := 16#16#; -- (see Section 7.5.3)
+
+
+ DW_OP_Addr : constant := 16#03#; -- 1 constant address (target spec)
+ DW_OP_Deref : constant := 16#06#; -- 0
+ DW_OP_Const1u : constant := 16#08#; -- 1 1-byte constant
+ DW_OP_Const1s : constant := 16#09#; -- 1 1-byte constant
+ DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant
+ DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant
+ DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant
+ DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant
+ DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant
+ DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant
+ DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant
+ DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant
+ DW_OP_Dup : constant := 16#12#; -- 0
+ DW_OP_Drop : constant := 16#13#; -- 0
+ DW_OP_Over : constant := 16#14#; -- 0
+ DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index
+ DW_OP_Swap : constant := 16#16#; -- 0
+ DW_OP_Rot : constant := 16#17#; -- 0
+ DW_OP_Xderef : constant := 16#18#; -- 0
+ DW_OP_Abs : constant := 16#19#; -- 0
+ DW_OP_And : constant := 16#1a#; -- 0
+ DW_OP_Div : constant := 16#1b#; -- 0
+ DW_OP_Minus : constant := 16#1c#; -- 0
+ DW_OP_Mod : constant := 16#1d#; -- 0
+ DW_OP_Mul : constant := 16#1e#; -- 0
+ DW_OP_Neg : constant := 16#1f#; -- 0
+ DW_OP_Not : constant := 16#20#; -- 0
+ DW_OP_Or : constant := 16#21#; -- 0
+ DW_OP_Plus : constant := 16#22#; -- 0
+ DW_OP_Plus_Uconst : constant := 16#23#; -- 1 ULEB128 addend
+ DW_OP_Shl : constant := 16#24#; -- 0
+ DW_OP_Shr : constant := 16#25#; -- 0
+ DW_OP_Shra : constant := 16#26#; -- 0
+ DW_OP_Xor : constant := 16#27#; -- 0
+ DW_OP_Skip : constant := 16#2f#; -- 1 signed 2-byte constant
+ DW_OP_Bra : constant := 16#28#; -- 1 signed 2-byte constant
+ DW_OP_Eq : constant := 16#29#; -- 0
+ DW_OP_Ge : constant := 16#2a#; -- 0
+ DW_OP_Gt : constant := 16#2b#; -- 0
+ DW_OP_Le : constant := 16#2c#; -- 0
+ DW_OP_Lt : constant := 16#2d#; -- 0
+ DW_OP_Ne : constant := 16#2e#; -- 0
+ DW_OP_Lit0 : constant := 16#30#; -- 0
+ DW_OP_Lit1 : constant := 16#31#; -- 0
+ DW_OP_Lit2 : constant := 16#32#; -- 0
+ DW_OP_Lit3 : constant := 16#33#; -- 0
+ DW_OP_Lit4 : constant := 16#34#; -- 0
+ DW_OP_Lit5 : constant := 16#35#; -- 0
+ DW_OP_Lit6 : constant := 16#36#; -- 0
+ DW_OP_Lit7 : constant := 16#37#; -- 0
+ DW_OP_Lit8 : constant := 16#38#; -- 0
+ DW_OP_Lit9 : constant := 16#39#; -- 0
+ DW_OP_Lit10 : constant := 16#3a#; -- 0
+ DW_OP_Lit11 : constant := 16#3b#; -- 0
+ DW_OP_Lit12 : constant := 16#3c#; -- 0
+ DW_OP_Lit13 : constant := 16#3d#; -- 0
+ DW_OP_Lit14 : constant := 16#3e#; -- 0
+ DW_OP_Lit15 : constant := 16#3f#; -- 0
+ DW_OP_Lit16 : constant := 16#40#; -- 0
+ DW_OP_Lit17 : constant := 16#41#; -- 0
+ DW_OP_Lit18 : constant := 16#42#; -- 0
+ DW_OP_Lit19 : constant := 16#43#; -- 0
+ DW_OP_Lit20 : constant := 16#44#; -- 0
+ DW_OP_Lit21 : constant := 16#45#; -- 0
+ DW_OP_Lit22 : constant := 16#46#; -- 0
+ DW_OP_Lit23 : constant := 16#47#; -- 0
+ DW_OP_Lit24 : constant := 16#48#; -- 0
+ DW_OP_Lit25 : constant := 16#49#; -- 0
+ DW_OP_Lit26 : constant := 16#4a#; -- 0
+ DW_OP_Lit27 : constant := 16#4b#; -- 0
+ DW_OP_Lit28 : constant := 16#4c#; -- 0
+ DW_OP_Lit29 : constant := 16#4d#; -- 0
+ DW_OP_Lit30 : constant := 16#4e#; -- 0
+ DW_OP_Lit31 : constant := 16#4f#; -- 0
+ DW_OP_Reg0 : constant := 16#50#; -- 0
+ DW_OP_Reg1 : constant := 16#51#; -- 0
+ DW_OP_Reg2 : constant := 16#52#; -- 0
+ DW_OP_Reg3 : constant := 16#53#; -- 0
+ DW_OP_Reg4 : constant := 16#54#; -- 0
+ DW_OP_Reg5 : constant := 16#55#; -- 0
+ DW_OP_Reg6 : constant := 16#56#; -- 0
+ DW_OP_Reg7 : constant := 16#57#; -- 0
+ DW_OP_Reg8 : constant := 16#58#; -- 0
+ DW_OP_Reg9 : constant := 16#59#; -- 0
+ DW_OP_Reg10 : constant := 16#5a#; -- 0
+ DW_OP_Reg11 : constant := 16#5b#; -- 0
+ DW_OP_Reg12 : constant := 16#5c#; -- 0
+ DW_OP_Reg13 : constant := 16#5d#; -- 0
+ DW_OP_Reg14 : constant := 16#5e#; -- 0
+ DW_OP_Reg15 : constant := 16#5f#; -- 0
+ DW_OP_Reg16 : constant := 16#60#; -- 0
+ DW_OP_Reg17 : constant := 16#61#; -- 0
+ DW_OP_Reg18 : constant := 16#62#; -- 0
+ DW_OP_Reg19 : constant := 16#63#; -- 0
+ DW_OP_Reg20 : constant := 16#64#; -- 0
+ DW_OP_Reg21 : constant := 16#65#; -- 0
+ DW_OP_Reg22 : constant := 16#66#; -- 0
+ DW_OP_Reg23 : constant := 16#67#; -- 0
+ DW_OP_Reg24 : constant := 16#68#; -- 0
+ DW_OP_Reg25 : constant := 16#69#; -- 0
+ DW_OP_Reg26 : constant := 16#6a#; -- 0
+ DW_OP_Reg27 : constant := 16#6b#; -- 0
+ DW_OP_Reg28 : constant := 16#6c#; -- 0
+ DW_OP_Reg29 : constant := 16#6d#; -- 0
+ DW_OP_Reg30 : constant := 16#6e#; -- 0
+ DW_OP_Reg31 : constant := 16#6f#; -- 0 reg 0..31
+ DW_OP_Breg0 : constant := 16#70#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg1 : constant := 16#71#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg2 : constant := 16#72#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg3 : constant := 16#73#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg4 : constant := 16#74#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg5 : constant := 16#75#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg6 : constant := 16#76#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg7 : constant := 16#77#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg8 : constant := 16#78#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg9 : constant := 16#79#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg10 : constant := 16#7a#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg11 : constant := 16#7b#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg12 : constant := 16#7c#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg13 : constant := 16#7d#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg14 : constant := 16#7e#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg15 : constant := 16#7f#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg16 : constant := 16#80#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg17 : constant := 16#81#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg18 : constant := 16#82#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg19 : constant := 16#83#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg20 : constant := 16#84#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg21 : constant := 16#85#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg22 : constant := 16#86#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg23 : constant := 16#87#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg24 : constant := 16#88#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg25 : constant := 16#89#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg26 : constant := 16#8a#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg27 : constant := 16#8b#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg28 : constant := 16#8c#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg29 : constant := 16#8d#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg30 : constant := 16#8e#; -- 1 SLEB128 offset base reg
+ DW_OP_Breg31 : constant := 16#8f#; -- 1 SLEB128 offset base reg 0..31
+ DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register
+ DW_OP_Fbreg : constant := 16#91#; -- 1 SLEB128 offset
+ DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset
+ DW_OP_Piece : constant := 16#93#; -- 1 ULEB128 size of piece addressed
+ DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved
+ DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved
+ DW_OP_Nop : constant := 16#96#; -- 0
+ DW_OP_Push_Object_Address : constant := 16#97#; -- 0
+ DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE
+ DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE
+ DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE
+ DW_OP_Lo_User : constant := 16#E0#; --
+ DW_OP_Hi_User : constant := 16#ff#; --
+
+ DW_ATE_Address : constant := 16#1#;
+ DW_ATE_Boolean : constant := 16#2#;
+ DW_ATE_Complex_Float : constant := 16#3#;
+ DW_ATE_Float : constant := 16#4#;
+ DW_ATE_Signed : constant := 16#5#;
+ DW_ATE_Signed_Char : constant := 16#6#;
+ DW_ATE_Unsigned : constant := 16#7#;
+ DW_ATE_Unsigned_Char : constant := 16#8#;
+ DW_ATE_Imaginary_Float : constant := 16#9#;
+ DW_ATE_Lo_User : constant := 16#80#;
+ DW_ATE_Hi_User : constant := 16#ff#;
+
+ DW_ACCESS_Public : constant := 1;
+ DW_ACCESS_Protected : constant := 2;
+ DW_ACCESS_Private : constant := 3;
+
+ DW_LANG_C89 : constant := 16#0001#;
+ DW_LANG_C : constant := 16#0002#;
+ DW_LANG_Ada83 : constant := 16#0003#;
+ DW_LANG_C_Plus_Plus : constant := 16#0004#;
+ DW_LANG_Cobol74 : constant := 16#0005#;
+ DW_LANG_Cobol85 : constant := 16#0006#;
+ DW_LANG_Fortran77 : constant := 16#0007#;
+ DW_LANG_Fortran90 : constant := 16#0008#;
+ DW_LANG_Pascal83 : constant := 16#0009#;
+ DW_LANG_Modula2 : constant := 16#000a#;
+ DW_LANG_Java : constant := 16#000b#;
+ DW_LANG_C99 : constant := 16#000c#;
+ DW_LANG_Ada95 : constant := 16#000d#;
+ DW_LANG_Fortran95 : constant := 16#000e#;
+ DW_LANG_PLI : constant := 16#000f#;
+ DW_LANG_Lo_User : constant := 16#8000#;
+ DW_LANG_Hi_User : constant := 16#ffff#;
+
+ DW_ID_Case_Sensitive : constant := 0;
+ DW_ID_Up_Case : constant := 1;
+ DW_ID_Down_Case : constant := 2;
+ DW_ID_Case_Insensitive : constant := 3;
+
+ DW_CC_Normal : constant := 16#1#;
+ DW_CC_Program : constant := 16#2#;
+ DW_CC_Nocall : constant := 16#3#;
+ DW_CC_Lo_User : constant := 16#40#;
+ DW_CC_Hi_User : constant := 16#Ff#;
+
+ DW_INL_Not_Inlined : constant := 0;
+ DW_INL_Inlined : constant := 1;
+ DW_INL_Declared_Not_Inlined : constant := 2;
+ DW_INL_Declared_Inlined : constant := 3;
+
+ -- Line number information.
+ -- Line number standard opcode.
+ DW_LNS_Copy : constant Unsigned_8 := 1;
+ DW_LNS_Advance_Pc : constant Unsigned_8 := 2;
+ DW_LNS_Advance_Line : constant Unsigned_8 := 3;
+ DW_LNS_Set_File : constant Unsigned_8 := 4;
+ DW_LNS_Set_Column : constant Unsigned_8 := 5;
+ DW_LNS_Negate_Stmt : constant Unsigned_8 := 6;
+ DW_LNS_Set_Basic_Block : constant Unsigned_8 := 7;
+ DW_LNS_Const_Add_Pc : constant Unsigned_8 := 8;
+ DW_LNS_Fixed_Advance_Pc : constant Unsigned_8 := 9;
+ DW_LNS_Set_Prologue_End : constant Unsigned_8 := 10;
+ DW_LNS_Set_Epilogue_Begin : constant Unsigned_8 := 11;
+ DW_LNS_Set_Isa : constant Unsigned_8 := 12;
+
+ -- Line number extended opcode.
+ DW_LNE_End_Sequence : constant Unsigned_8 := 1;
+ DW_LNE_Set_Address : constant Unsigned_8 := 2;
+ DW_LNE_Define_File : constant Unsigned_8 := 3;
+ DW_LNE_Lo_User : constant Unsigned_8 := 128;
+ DW_LNE_Hi_User : constant Unsigned_8 := 255;
+
+ DW_CFA_Advance_Loc : constant Unsigned_8 := 16#40#;
+ DW_CFA_Advance_Loc_Min : constant Unsigned_8 := 16#40#;
+ DW_CFA_Advance_Loc_Max : constant Unsigned_8 := 16#7f#;
+ DW_CFA_Offset : constant Unsigned_8 := 16#80#;
+ DW_CFA_Offset_Min : constant Unsigned_8 := 16#80#;
+ DW_CFA_Offset_Max : constant Unsigned_8 := 16#Bf#;
+ DW_CFA_Restore : constant Unsigned_8 := 16#C0#;
+ DW_CFA_Restore_Min : constant Unsigned_8 := 16#C0#;
+ DW_CFA_Restore_Max : constant Unsigned_8 := 16#FF#;
+ DW_CFA_Nop : constant Unsigned_8 := 16#00#;
+ DW_CFA_Set_Loc : constant Unsigned_8 := 16#01#;
+ DW_CFA_Advance_Loc1 : constant Unsigned_8 := 16#02#;
+ DW_CFA_Advance_Loc2 : constant Unsigned_8 := 16#03#;
+ DW_CFA_Advance_Loc4 : constant Unsigned_8 := 16#04#;
+ DW_CFA_Offset_Extended : constant Unsigned_8 := 16#05#;
+ DW_CFA_Restore_Extended : constant Unsigned_8 := 16#06#;
+ DW_CFA_Undefined : constant Unsigned_8 := 16#07#;
+ DW_CFA_Same_Value : constant Unsigned_8 := 16#08#;
+ DW_CFA_Register : constant Unsigned_8 := 16#09#;
+ DW_CFA_Remember_State : constant Unsigned_8 := 16#0a#;
+ DW_CFA_Restore_State : constant Unsigned_8 := 16#0b#;
+ DW_CFA_Def_Cfa : constant Unsigned_8 := 16#0c#;
+ DW_CFA_Def_Cfa_Register : constant Unsigned_8 := 16#0d#;
+ DW_CFA_Def_Cfa_Offset : constant Unsigned_8 := 16#0e#;
+ DW_CFA_Def_Cfa_Expression : constant Unsigned_8 := 16#0f#;
+
+ DW_EH_PE_Omit : constant Unsigned_8 := 16#Ff#;
+ DW_EH_PE_Uleb128 : constant Unsigned_8 := 16#01#;
+ DW_EH_PE_Udata2 : constant Unsigned_8 := 16#02#;
+ DW_EH_PE_Udata4 : constant Unsigned_8 := 16#03#;
+ DW_EH_PE_Udata8 : constant Unsigned_8 := 16#04#;
+ DW_EH_PE_Sleb128 : constant Unsigned_8 := 16#09#;
+ DW_EH_PE_Sdata2 : constant Unsigned_8 := 16#0A#;
+ DW_EH_PE_Sdata4 : constant Unsigned_8 := 16#0B#;
+ DW_EH_PE_Sdata8 : constant Unsigned_8 := 16#0C#;
+ DW_EH_PE_Absptr : constant Unsigned_8 := 16#00#;
+ DW_EH_PE_Pcrel : constant Unsigned_8 := 16#10#;
+ DW_EH_PE_Datarel : constant Unsigned_8 := 16#30#;
+ DW_EH_PE_Format_Mask : constant Unsigned_8 := 16#0f#;
+end Dwarf;
+
+
diff --git a/src/ortho/mcode/elf32.adb b/src/ortho/mcode/elf32.adb
new file mode 100644
index 000000000..ef58fe64b
--- /dev/null
+++ b/src/ortho/mcode/elf32.adb
@@ -0,0 +1,48 @@
+-- ELF32 definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Elf32 is
+ function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar is
+ begin
+ return Shift_Right (Info, 4);
+ end Elf32_St_Bind;
+
+ function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar is
+ begin
+ return Info and 16#0F#;
+ end Elf32_St_Type;
+
+ function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar is
+ begin
+ return Shift_Left (B, 4) or T;
+ end Elf32_St_Info;
+
+ function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is
+ begin
+ return Shift_Right (I, 8);
+ end Elf32_R_Sym;
+
+ function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is
+ begin
+ return I and 16#Ff#;
+ end Elf32_R_Type;
+
+ function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is
+ begin
+ return Shift_Left (S, 8) or T;
+ end Elf32_R_Info;
+end Elf32;
diff --git a/src/ortho/mcode/elf32.ads b/src/ortho/mcode/elf32.ads
new file mode 100644
index 000000000..5afd317f6
--- /dev/null
+++ b/src/ortho/mcode/elf32.ads
@@ -0,0 +1,124 @@
+-- ELF32 definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with System;
+with Elf_Common; use Elf_Common;
+
+package Elf32 is
+ subtype Elf32_Addr is Unsigned_32;
+ subtype Elf32_Half is Unsigned_16;
+ subtype Elf32_Off is Unsigned_32;
+ subtype Elf32_Sword is Integer_32;
+ subtype Elf32_Word is Unsigned_32;
+ subtype Elf32_Uchar is Unsigned_8;
+
+ type Elf32_Ehdr is record
+ E_Ident : E_Ident_Type;
+ E_Type : Elf32_Half;
+ E_Machine : Elf32_Half;
+ E_Version : Elf32_Word;
+ E_Entry : Elf32_Addr;
+ E_Phoff : Elf32_Off;
+ E_Shoff : Elf32_Off;
+ E_Flags : Elf32_Word;
+ E_Ehsize : Elf32_Half;
+ E_Phentsize : Elf32_Half;
+ E_Phnum : Elf32_Half;
+ E_Shentsize : Elf32_Half;
+ E_Shnum : Elf32_Half;
+ E_Shstrndx : Elf32_Half;
+ end record;
+
+ Elf32_Ehdr_Size : constant Natural := Elf32_Ehdr'Size / System.Storage_Unit;
+
+ type Elf32_Shdr is record
+ Sh_Name : Elf32_Word;
+ Sh_Type : Elf32_Word;
+ Sh_Flags : Elf32_Word;
+ Sh_Addr : Elf32_Addr;
+ Sh_Offset : Elf32_Off;
+ Sh_Size : Elf32_Word;
+ Sh_Link : Elf32_Word;
+ Sh_Info : Elf32_Word;
+ Sh_Addralign : Elf32_Word;
+ Sh_Entsize : Elf32_Word;
+ end record;
+ Elf32_Shdr_Size : constant Natural := Elf32_Shdr'Size / System.Storage_Unit;
+
+ -- Symbol table.
+ type Elf32_Sym is record
+ St_Name : Elf32_Word;
+ St_Value : Elf32_Addr;
+ St_Size : Elf32_Word;
+ St_Info : Elf32_Uchar;
+ St_Other : Elf32_Uchar;
+ St_Shndx : Elf32_Half;
+ end record;
+ Elf32_Sym_Size : constant Natural := Elf32_Sym'Size / System.Storage_Unit;
+
+ function Elf32_St_Bind (Info : Elf32_Uchar) return Elf32_Uchar;
+ function Elf32_St_Type (Info : Elf32_Uchar) return Elf32_Uchar;
+ function Elf32_St_Info (B, T : Elf32_Uchar) return Elf32_Uchar;
+ pragma Inline (Elf32_St_Bind);
+ pragma Inline (Elf32_St_Type);
+ pragma Inline (Elf32_St_Info);
+
+ -- Relocation.
+ type Elf32_Rel is record
+ R_Offset : Elf32_Addr;
+ R_Info : Elf32_Word;
+ end record;
+ Elf32_Rel_Size : constant Natural := Elf32_Rel'Size / System.Storage_Unit;
+
+ type Elf32_Rela is record
+ R_Offset : Elf32_Addr;
+ R_Info : Elf32_Word;
+ R_Addend : Elf32_Sword;
+ end record;
+ Elf32_Rela_Size : constant Natural := Elf32_Rela'Size / System.Storage_Unit;
+
+ function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word;
+ function Elf32_R_Type (I : Elf32_Word) return Elf32_Word;
+ function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word;
+
+ -- For i386
+ R_386_NONE : constant Elf32_Word := 0; -- none none
+ R_386_32 : constant Elf32_Word := 1; -- word32 S+A
+ R_386_PC32 : constant Elf32_Word := 2; -- word32 S+A-P
+
+ -- For sparc
+ R_SPARC_NONE : constant Elf32_Word := 0; -- none
+ R_SPARC_32 : constant Elf32_Word := 3; -- (S + A)
+ R_SPARC_WDISP30 : constant Elf32_Word := 7; -- (S + A - P) >> 2
+ R_SPARC_WDISP22 : constant Elf32_Word := 8; -- (S + A - P) >> 2
+ R_SPARC_HI22 : constant Elf32_Word := 9; -- (S + A) >> 10
+ R_SPARC_LO10 : constant Elf32_Word := 12; -- (S + A) & 0x3ff
+ R_SPARC_UA32 : constant Elf32_Word := 23; -- (S + A)
+
+ type Elf32_Phdr is record
+ P_Type : Elf32_Word;
+ P_Offset : Elf32_Off;
+ P_Vaddr : Elf32_Addr;
+ P_Paddr : Elf32_Addr;
+ P_Filesz : Elf32_Word;
+ P_Memsz : Elf32_Word;
+ P_Flags : Elf32_Word;
+ P_Align : Elf32_Word;
+ end record;
+ Elf32_Phdr_Size : constant Natural := Elf32_Phdr'Size / System.Storage_Unit;
+end Elf32;
diff --git a/src/ortho/mcode/elf64.ads b/src/ortho/mcode/elf64.ads
new file mode 100644
index 000000000..217e5557a
--- /dev/null
+++ b/src/ortho/mcode/elf64.ads
@@ -0,0 +1,105 @@
+-- ELF64 definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with System;
+with Elf_Common; use Elf_Common;
+
+package Elf64 is
+ subtype Elf64_Addr is Unsigned_64;
+ subtype Elf64_Off is Unsigned_64;
+ subtype Elf64_Uchar is Unsigned_8;
+ subtype Elf64_Half is Unsigned_16;
+ subtype Elf64_Sword is Integer_32;
+ subtype Elf64_Word is Unsigned_32;
+ subtype Elf64_Xword is Unsigned_64;
+ subtype Elf64_Sxword is Integer_64;
+
+ type Elf64_Ehdr is record
+ E_Ident : E_Ident_Type;
+ E_Type : Elf64_Half;
+ E_Machine : Elf64_Half;
+ E_Version : Elf64_Word;
+ E_Entry : Elf64_Addr;
+ E_Phoff : Elf64_Off;
+ E_Shoff : Elf64_Off;
+ E_Flags : Elf64_Word;
+ E_Ehsize : Elf64_Half;
+ E_Phentsize : Elf64_Half;
+ E_Phnum : Elf64_Half;
+ E_Shentsize : Elf64_Half;
+ E_Shnum : Elf64_Half;
+ E_Shstrndx : Elf64_Half;
+ end record;
+
+ Elf64_Ehdr_Size : constant Natural := Elf64_Ehdr'Size / System.Storage_Unit;
+
+ type Elf64_Shdr is record
+ Sh_Name : Elf64_Word;
+ Sh_Type : Elf64_Word;
+ Sh_Flags : Elf64_Xword;
+ Sh_Addr : Elf64_Addr;
+ Sh_Offset : Elf64_Off;
+ Sh_Size : Elf64_Xword;
+ Sh_Link : Elf64_Word;
+ Sh_Info : Elf64_Word;
+ Sh_Addralign : Elf64_Xword;
+ Sh_Entsize : Elf64_Xword;
+ end record;
+ Elf64_Shdr_Size : constant Natural := Elf64_Shdr'Size / System.Storage_Unit;
+
+ -- Symbol table.
+ type Elf64_Sym is record
+ St_Name : Elf64_Word;
+ St_Info : Elf64_Uchar;
+ St_Other : Elf64_Uchar;
+ St_Shndx : Elf64_Half;
+ St_Value : Elf64_Addr;
+ St_Size : Elf64_Xword;
+ end record;
+ Elf64_Sym_Size : constant Natural := Elf64_Sym'Size / System.Storage_Unit;
+
+ -- Relocation.
+ type Elf64_Rel is record
+ R_Offset : Elf64_Addr;
+ R_Info : Elf64_Xword;
+ end record;
+ Elf64_Rel_Size : constant Natural := Elf64_Rel'Size / System.Storage_Unit;
+
+ type Elf64_Rela is record
+ R_Offset : Elf64_Addr;
+ R_Info : Elf64_Xword;
+ R_Addend : Elf64_Sxword;
+ end record;
+ Elf64_Rela_Size : constant Natural := Elf64_Rela'Size / System.Storage_Unit;
+
+-- function Elf64_R_Sym (I : Elf64_Word) return Elf64_Word;
+-- function Elf64_R_Type (I : Elf64_Word) return Elf64_Word;
+-- function Elf64_R_Info (S, T : Elf64_Word) return Elf64_Word;
+
+ type Elf64_Phdr is record
+ P_Type : Elf64_Word;
+ P_Flags : Elf64_Word;
+ P_Offset : Elf64_Off;
+ P_Vaddr : Elf64_Addr;
+ P_Paddr : Elf64_Addr;
+ P_Filesz : Elf64_Xword;
+ P_Memsz : Elf64_Xword;
+ P_Align : Elf64_Xword;
+ end record;
+ Elf64_Phdr_Size : constant Natural := Elf64_Phdr'Size / System.Storage_Unit;
+end Elf64;
diff --git a/src/ortho/mcode/elf_arch.ads b/src/ortho/mcode/elf_arch.ads
new file mode 100644
index 000000000..325c4e5e3
--- /dev/null
+++ b/src/ortho/mcode/elf_arch.ads
@@ -0,0 +1,2 @@
+with Elf_Arch32;
+package Elf_Arch renames Elf_Arch32;
diff --git a/src/ortho/mcode/elf_arch32.ads b/src/ortho/mcode/elf_arch32.ads
new file mode 100644
index 000000000..5e987b1e6
--- /dev/null
+++ b/src/ortho/mcode/elf_arch32.ads
@@ -0,0 +1,37 @@
+-- ELF32 view of ELF.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Elf_Common; use Elf_Common;
+with Elf32; use Elf32;
+
+package Elf_Arch32 is
+ subtype Elf_Ehdr is Elf32_Ehdr;
+ subtype Elf_Shdr is Elf32_Shdr;
+ subtype Elf_Sym is Elf32_Sym;
+ subtype Elf_Rel is Elf32_Rel;
+ subtype Elf_Rela is Elf32_Rela;
+ subtype Elf_Phdr is Elf32_Phdr;
+
+ subtype Elf_Off is Elf32_Off;
+ subtype Elf_Size is Elf32_Word;
+ Elf_Ehdr_Size : constant Natural := Elf32_Ehdr_Size;
+ Elf_Shdr_Size : constant Natural := Elf32_Shdr_Size;
+ Elf_Phdr_Size : constant Natural := Elf32_Phdr_Size;
+ Elf_Sym_Size : constant Natural := Elf32_Sym_Size;
+
+ Elf_Arch_Class : constant Elf_Uchar := ELFCLASS32;
+end Elf_Arch32;
diff --git a/src/ortho/mcode/elf_arch64.ads b/src/ortho/mcode/elf_arch64.ads
new file mode 100644
index 000000000..504cd66b3
--- /dev/null
+++ b/src/ortho/mcode/elf_arch64.ads
@@ -0,0 +1,37 @@
+-- ELF64 view of ELF.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Elf_Common; use Elf_Common;
+with Elf64; use Elf64;
+
+package Elf_Arch64 is
+ subtype Elf_Ehdr is Elf64_Ehdr;
+ subtype Elf_Shdr is Elf64_Shdr;
+ subtype Elf_Sym is Elf64_Sym;
+ subtype Elf_Rel is Elf64_Rel;
+ subtype Elf_Rela is Elf64_Rela;
+ subtype Elf_Phdr is Elf64_Phdr;
+
+ subtype Elf_Off is Elf64_Off;
+ subtype Elf_Size is Elf64_Xword;
+ Elf_Ehdr_Size : constant Natural := Elf64_Ehdr_Size;
+ Elf_Shdr_Size : constant Natural := Elf64_Shdr_Size;
+ Elf_Phdr_Size : constant Natural := Elf64_Phdr_Size;
+ Elf_Sym_Size : constant Natural := Elf64_Sym_Size;
+
+ Elf_Arch_Class : constant Elf_Uchar := ELFCLASS64;
+end Elf_Arch64;
diff --git a/src/ortho/mcode/elf_common.adb b/src/ortho/mcode/elf_common.adb
new file mode 100644
index 000000000..5d05a2dc7
--- /dev/null
+++ b/src/ortho/mcode/elf_common.adb
@@ -0,0 +1,48 @@
+-- ELF definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Elf_Common is
+ function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar is
+ begin
+ return Shift_Right (Info, 4);
+ end Elf_St_Bind;
+
+ function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar is
+ begin
+ return Info and 16#0F#;
+ end Elf_St_Type;
+
+ function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar is
+ begin
+ return Shift_Left (B, 4) or T;
+ end Elf_St_Info;
+
+-- function Elf32_R_Sym (I : Elf32_Word) return Elf32_Word is
+-- begin
+-- return Shift_Right (I, 8);
+-- end Elf32_R_Sym;
+
+-- function Elf32_R_Type (I : Elf32_Word) return Elf32_Word is
+-- begin
+-- return I and 16#Ff#;
+-- end Elf32_R_Type;
+
+-- function Elf32_R_Info (S, T : Elf32_Word) return Elf32_Word is
+-- begin
+-- return Shift_Left (S, 8) or T;
+-- end Elf32_R_Info;
+end Elf_Common;
diff --git a/src/ortho/mcode/elf_common.ads b/src/ortho/mcode/elf_common.ads
new file mode 100644
index 000000000..28186d094
--- /dev/null
+++ b/src/ortho/mcode/elf_common.ads
@@ -0,0 +1,250 @@
+-- ELF definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Elf_Common is
+ subtype Elf_Half is Unsigned_16;
+ subtype Elf_Sword is Integer_32;
+ subtype Elf_Word is Unsigned_32;
+ subtype Elf_Uchar is Unsigned_8;
+
+ EI_NIDENT : constant Natural := 16;
+ type E_Ident_Type is array (Natural range 0 .. EI_NIDENT - 1)
+ of Elf_Uchar;
+
+ -- e_type values.
+ ET_NONE : constant Elf_Half := 0; -- No file type
+ ET_REL : constant Elf_Half := 1; -- Relocatable file
+ ET_EXEC : constant Elf_Half := 2; -- Executable file
+ ET_DYN : constant Elf_Half := 3; -- Shared object file
+ ET_CORE : constant Elf_Half := 4; -- Core file
+ ET_LOPROC : constant Elf_Half := 16#Ff00#; -- Processor-specific
+ ET_HIPROC : constant Elf_Half := 16#Ffff#; -- Processor-specific
+
+ -- e_machine values.
+ EM_NONE : constant Elf_Half := 0; -- No machine
+ EM_M32 : constant Elf_Half := 1; -- AT&T WE 32100
+ EM_SPARC : constant Elf_Half := 2; -- SPARC
+ EM_386 : constant Elf_Half := 3; -- Intel Architecture
+ EM_68K : constant Elf_Half := 4; -- Motorola 68000
+ EM_88K : constant Elf_Half := 5; -- Motorola 88000
+ EM_860 : constant Elf_Half := 7; -- Intel 80860
+ EM_MIPS : constant Elf_Half := 8; -- MIPS RS3000 Big-Endian
+ EM_MIPS_RS4_BE : constant Elf_Half := 10; -- MIPS RS4000 Big-Endian
+ -- RESERVED : constant Elf_Half := 11; -- -16 Reserved for future use
+
+ -- e_version
+ EV_NONE : constant Elf_Uchar := 0; -- Invalid versionn
+ EV_CURRENT : constant Elf_Uchar := 1; -- Current version
+
+ -- e_ident identification indexes.
+ EI_MAG0 : constant Natural := 0; -- File identification
+ EI_MAG1 : constant Natural := 1; -- File identification
+ EI_MAG2 : constant Natural := 2; -- File identification
+ EI_MAG3 : constant Natural := 3; -- File identification
+ EI_CLASS : constant Natural := 4; -- File class
+ EI_DATA : constant Natural := 5; -- Data encoding
+ EI_VERSION : constant Natural := 6; -- File version
+ EI_PAD : constant Natural := 7; -- Start of padding bytes
+ --EI_NIDENT : constant Natural := 16; -- Size of e_ident[]
+
+ -- Magic values.
+ ELFMAG0 : constant Elf_Uchar := 16#7f#; -- e_ident[EI_MAG0]
+ ELFMAG1 : constant Elf_Uchar := Character'Pos ('E'); -- e_ident[EI_MAG1]
+ ELFMAG2 : constant Elf_Uchar := Character'Pos ('L'); -- e_ident[EI_MAG2]
+ ELFMAG3 : constant Elf_Uchar := Character'Pos ('F'); -- e_ident[EI_MAG3]
+
+ ELFCLASSNONE : constant Elf_Uchar := 0; -- Invalid class
+ ELFCLASS32 : constant Elf_Uchar := 1; -- 32-bit objects
+ ELFCLASS64 : constant Elf_Uchar := 2; -- 64-bit objects
+
+ ELFDATANONE : constant Elf_Uchar := 0; -- Invalid data encoding
+ ELFDATA2LSB : constant Elf_Uchar := 1; -- See below
+ ELFDATA2MSB : constant Elf_Uchar := 2; -- See below
+
+ SHN_UNDEF : constant Elf_Half := 0; --
+ SHN_LORESERVE : constant Elf_Half := 16#Ff00#; --
+ SHN_LOPROC : constant Elf_Half := 16#ff00#; --
+ SHN_HIPROC : constant Elf_Half := 16#ff1f#; --
+ SHN_ABS : constant Elf_Half := 16#fff1#; --
+ SHN_COMMON : constant Elf_Half := 16#fff2#; --
+ SHN_HIRESERVE : constant Elf_Half := 16#ffff#; --
+
+ -- Sh_type.
+ SHT_NULL : constant Elf_Word := 0;
+ SHT_PROGBITS : constant Elf_Word := 1;
+ SHT_SYMTAB : constant Elf_Word := 2;
+ SHT_STRTAB : constant Elf_Word := 3;
+ SHT_RELA : constant Elf_Word := 4;
+ SHT_HASH : constant Elf_Word := 5;
+ SHT_DYNAMIC : constant Elf_Word := 6;
+ SHT_NOTE : constant Elf_Word := 7;
+ SHT_NOBITS : constant Elf_Word := 8;
+ SHT_REL : constant Elf_Word := 9;
+ SHT_SHLIB : constant Elf_Word := 10;
+ SHT_DYNSYM : constant Elf_Word := 11;
+ SHT_INIT_ARRAY : constant Elf_Word := 14;
+ SHT_FINI_ARRAY : constant Elf_Word := 15;
+ SHT_PREINIT_ARRAY : constant Elf_Word := 16;
+ SHT_GROUP : constant Elf_Word := 17;
+ SHT_SYMTAB_SHNDX : constant Elf_Word := 18;
+ SHT_NUM : constant Elf_Word := 19;
+ SHT_LOOS : constant Elf_Word := 16#60000000#;
+ SHT_GNU_LIBLIST : constant Elf_Word := 16#6ffffff7#;
+ SHT_CHECKSUM : constant Elf_Word := 16#6ffffff8#;
+ SHT_LOSUNW : constant Elf_Word := 16#6ffffffa#;
+ SHT_SUNW_Move : constant Elf_Word := 16#6ffffffa#;
+ SHT_SUNW_COMDAT : constant Elf_Word := 16#6ffffffb#;
+ SHT_SUNW_Syminfo : constant Elf_Word := 16#6ffffffc#;
+ SHT_GNU_Verdef : constant Elf_Word := 16#6ffffffd#;
+ SHT_GNU_Verneed : constant Elf_Word := 16#6ffffffe#;
+ SHT_GNU_Versym : constant Elf_Word := 16#6fffffff#;
+ SHT_HISUNW : constant Elf_Word := 16#6fffffff#;
+ SHT_HIOS : constant Elf_Word := 16#6fffffff#;
+ SHT_LOPROC : constant Elf_Word := 16#70000000#;
+ SHT_HIPROC : constant Elf_Word := 16#7fffffff#;
+ SHT_LOUSER : constant Elf_Word := 16#80000000#;
+ SHT_HIUSER : constant Elf_Word := 16#ffffffff#;
+
+
+ SHF_WRITE : constant := 16#1#;
+ SHF_ALLOC : constant := 16#2#;
+ SHF_EXECINSTR : constant := 16#4#;
+ SHF_MASKPROC : constant := 16#F0000000#;
+
+ function Elf_St_Bind (Info : Elf_Uchar) return Elf_Uchar;
+ function Elf_St_Type (Info : Elf_Uchar) return Elf_Uchar;
+ function Elf_St_Info (B, T : Elf_Uchar) return Elf_Uchar;
+ pragma Inline (Elf_St_Bind);
+ pragma Inline (Elf_St_Type);
+ pragma Inline (Elf_St_Info);
+
+ -- Symbol binding.
+ STB_LOCAL : constant Elf_Uchar := 0;
+ STB_GLOBAL : constant Elf_Uchar := 1;
+ STB_WEAK : constant Elf_Uchar := 2;
+ STB_LOPROC : constant Elf_Uchar := 13;
+ STB_HIPROC : constant Elf_Uchar := 15;
+
+ -- Symbol types.
+ STT_NOTYPE : constant Elf_Uchar := 0;
+ STT_OBJECT : constant Elf_Uchar := 1;
+ STT_FUNC : constant Elf_Uchar := 2;
+ STT_SECTION : constant Elf_Uchar := 3;
+ STT_FILE : constant Elf_Uchar := 4;
+ STT_LOPROC : constant Elf_Uchar := 13;
+ STT_HIPROC : constant Elf_Uchar := 15;
+
+
+ PT_NULL : constant Elf_Word := 0;
+ PT_LOAD : constant Elf_Word := 1;
+ PT_DYNAMIC : constant Elf_Word := 2;
+ PT_INTERP : constant Elf_Word := 3;
+ PT_NOTE : constant Elf_Word := 4;
+ PT_SHLIB : constant Elf_Word := 5;
+ PT_PHDR : constant Elf_Word := 6;
+ PT_TLS : constant Elf_Word := 7;
+ PT_NUM : constant Elf_Word := 8;
+ PT_LOOS : constant Elf_Word := 16#60000000#;
+ PT_GNU_EH_FRAME : constant Elf_Word := 16#6474e550#;
+ PT_LOSUNW : constant Elf_Word := 16#6ffffffa#;
+ PT_SUNWBSS : constant Elf_Word := 16#6ffffffa#;
+ PT_SUNWSTACK : constant Elf_Word := 16#6ffffffb#;
+ PT_HISUNW : constant Elf_Word := 16#6fffffff#;
+ PT_HIOS : constant Elf_Word := 16#6fffffff#;
+ PT_LOPROC : constant Elf_Word := 16#70000000#;
+ PT_HIPROC : constant Elf_Word := 16#7fffffff#;
+
+ PF_X : constant Elf_Word := 1;
+ PF_W : constant Elf_Word := 2;
+ PF_R : constant Elf_Word := 4;
+
+ DT_NULL : constant Elf_Word := 0;
+ DT_NEEDED : constant Elf_Word := 1;
+ DT_PLTRELSZ : constant Elf_Word := 2;
+ DT_PLTGOT : constant Elf_Word := 3;
+ DT_HASH : constant Elf_Word := 4;
+ DT_STRTAB : constant Elf_Word := 5;
+ DT_SYMTAB : constant Elf_Word := 6;
+ DT_RELA : constant Elf_Word := 7;
+ DT_RELASZ : constant Elf_Word := 8;
+ DT_RELAENT : constant Elf_Word := 9;
+ DT_STRSZ : constant Elf_Word := 10;
+ DT_SYMENT : constant Elf_Word := 11;
+ DT_INIT : constant Elf_Word := 12;
+ DT_FINI : constant Elf_Word := 13;
+ DT_SONAME : constant Elf_Word := 14;
+ DT_RPATH : constant Elf_Word := 15;
+ DT_SYMBOLIC : constant Elf_Word := 16;
+ DT_REL : constant Elf_Word := 17;
+ DT_RELSZ : constant Elf_Word := 18;
+ DT_RELENT : constant Elf_Word := 19;
+ DT_PLTREL : constant Elf_Word := 20;
+ DT_DEBUG : constant Elf_Word := 21;
+ DT_TEXTREL : constant Elf_Word := 22;
+ DT_JMPREL : constant Elf_Word := 23;
+ DT_BIND_NOW : constant Elf_Word := 24;
+ DT_INIT_ARRAY : constant Elf_Word := 25;
+ DT_FINI_ARRAY : constant Elf_Word := 26;
+ DT_INIT_ARRAYSZ : constant Elf_Word := 27;
+ DT_FINI_ARRAYSZ : constant Elf_Word := 28;
+ DT_RUNPATH : constant Elf_Word := 29;
+ DT_FLAGS : constant Elf_Word := 30;
+ DT_ENCODING : constant Elf_Word := 32;
+ DT_PREINIT_ARRAY : constant Elf_Word := 32;
+ DT_PREINIT_ARRAYSZ : constant Elf_Word := 33;
+ DT_NUM : constant Elf_Word := 34;
+ DT_LOOS : constant Elf_Word := 16#60000000#;
+ DT_HIOS : constant Elf_Word := 16#6fffffff#;
+ DT_LOPROC : constant Elf_Word := 16#70000000#;
+ DT_HIPROC : constant Elf_Word := 16#7fffffff#;
+ DT_VALRNGLO : constant Elf_Word := 16#6ffffd00#;
+ DT_GNU_PRELINKED : constant Elf_Word := 16#6ffffdf5#;
+ DT_GNU_CONFLICTSZ : constant Elf_Word := 16#6ffffdf6#;
+ DT_GNU_LIBLISTSZ : constant Elf_Word := 16#6ffffdf7#;
+ DT_CHECKSUM : constant Elf_Word := 16#6ffffdf8#;
+ DT_PLTPADSZ : constant Elf_Word := 16#6ffffdf9#;
+ DT_MOVEENT : constant Elf_Word := 16#6ffffdfa#;
+ DT_MOVESZ : constant Elf_Word := 16#6ffffdfb#;
+ DT_FEATURE_1 : constant Elf_Word := 16#6ffffdfc#;
+ DT_POSFLAG_1 : constant Elf_Word := 16#6ffffdfd#;
+ DT_SYMINSZ : constant Elf_Word := 16#6ffffdfe#;
+ DT_SYMINENT : constant Elf_Word := 16#6ffffdff#;
+ DT_VALRNGHI : constant Elf_Word := 16#6ffffdff#;
+ DT_ADDRRNGLO : constant Elf_Word := 16#6ffffe00#;
+ DT_GNU_CONFLICT : constant Elf_Word := 16#6ffffef8#;
+ DT_GNU_LIBLIST : constant Elf_Word := 16#6ffffef9#;
+ DT_CONFIG : constant Elf_Word := 16#6ffffefa#;
+ DT_DEPAUDIT : constant Elf_Word := 16#6ffffefb#;
+ DT_AUDIT : constant Elf_Word := 16#6ffffefc#;
+ DT_PLTPAD : constant Elf_Word := 16#6ffffefd#;
+ DT_MOVETAB : constant Elf_Word := 16#6ffffefe#;
+ DT_SYMINFO : constant Elf_Word := 16#6ffffeff#;
+ DT_ADDRRNGHI : constant Elf_Word := 16#6ffffeff#;
+ DT_VERSYM : constant Elf_Word := 16#6ffffff0#;
+ DT_RELACOUNT : constant Elf_Word := 16#6ffffff9#;
+ DT_RELCOUNT : constant Elf_Word := 16#6ffffffa#;
+ DT_FLAGS_1 : constant Elf_Word := 16#6ffffffb#;
+ DT_VERDEF : constant Elf_Word := 16#6ffffffc#;
+ DT_VERDEFNUM : constant Elf_Word := 16#6ffffffd#;
+ DT_VERNEED : constant Elf_Word := 16#6ffffffe#;
+ DT_VERNEEDNUM : constant Elf_Word := 16#6fffffff#;
+ DT_AUXILIARY : constant Elf_Word := 16#7ffffffd#;
+ DT_FILTER : constant Elf_Word := 16#7fffffff#;
+
+end Elf_Common;
diff --git a/src/ortho/mcode/elfdump.adb b/src/ortho/mcode/elfdump.adb
new file mode 100644
index 000000000..d49275912
--- /dev/null
+++ b/src/ortho/mcode/elfdump.adb
@@ -0,0 +1,267 @@
+-- ELF dumper (main program).
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO; use Ada.Text_IO;
+with Elf_Common; use Elf_Common;
+with Ada.Command_Line; use Ada.Command_Line;
+with Hex_Images; use Hex_Images;
+with Interfaces; use Interfaces;
+with Elfdumper; use Elfdumper;
+
+procedure Elfdump is
+ Flag_Ehdr : Boolean := False;
+ Flag_Shdr : Boolean := False;
+ Flag_Strtab : Boolean := False;
+ Flag_Symtab : Boolean := False;
+ Flag_Dwarf_Info : Boolean := False;
+ Flag_Dwarf_Abbrev : Boolean := False;
+ Flag_Dwarf_Pubnames : Boolean := False;
+ Flag_Dwarf_Aranges : Boolean := False;
+ Flag_Dwarf_Line : Boolean := False;
+ Flag_Dwarf_Frame : Boolean := False;
+ Flag_Eh_Frame_Hdr : Boolean := False;
+ Flag_Long_Shdr : Boolean := False;
+ Flag_Phdr : Boolean := False;
+ Flag_Note : Boolean := False;
+ Flag_Dynamic : Boolean := False;
+
+ procedure Disp_Max_Len (Str : String; Len : Natural)
+ is
+ begin
+ if Str'Length > Len then
+ Put (Str (Str'First .. Str'First + Len - 1));
+ else
+ Put (Str);
+ Put ((Str'Length + 1 .. Len => ' '));
+ end if;
+ end Disp_Max_Len;
+
+ procedure Disp_Section_Header (File : Elf_File; Index : Elf_Half) is
+ begin
+ Put ("Section " & Hex_Image (Index));
+ Put (" ");
+ Put (Get_Section_Name (File, Index));
+ New_Line;
+ end Disp_Section_Header;
+
+ procedure Disp_Elf_File (Filename : String)
+ is
+ File : Elf_File;
+ Ehdr : Elf_Ehdr_Acc;
+ Shdr : Elf_Shdr_Acc;
+ Phdr : Elf_Phdr_Acc;
+ Sh_Strtab : Strtab_Type;
+ begin
+ Open_File (File, Filename);
+ if Get_Status (File) /= Status_Ok then
+ Put_Line ("cannot open elf file '" & Filename & "': " &
+ Elf_File_Status'Image (Get_Status (File)));
+ return;
+ end if;
+
+ Ehdr := Get_Ehdr (File);
+
+ if Flag_Ehdr then
+ Disp_Ehdr (Ehdr.all);
+ end if;
+
+ Load_Shdr (File);
+ Sh_Strtab := Get_Sh_Strtab (File);
+
+ if Flag_Long_Shdr then
+ if Ehdr.E_Shnum = 0 then
+ Put ("no section");
+ else
+ for I in 0 .. Ehdr.E_Shnum - 1 loop
+ Put ("Section " & Hex_Image (I));
+ New_Line;
+ Disp_Shdr (Get_Shdr (File, I).all, Sh_Strtab);
+ end loop;
+ end if;
+ end if;
+ if Flag_Shdr then
+ if Ehdr.E_Shnum = 0 then
+ Put ("no section");
+ else
+ Put ("Num Name Type ");
+ Put ("Offset Size Link Info Al Es");
+ New_Line;
+ for I in 0 .. Ehdr.E_Shnum - 1 loop
+ declare
+ Shdr : Elf_Shdr_Acc := Get_Shdr (File, I);
+ begin
+ Put (Hex_Image (I));
+ Put (" ");
+ Disp_Max_Len (Get_Section_Name (File, I), 20);
+ Put (" ");
+ Disp_Max_Len (Get_Shdr_Type_Name (Shdr.Sh_Type), 10);
+ Put (" ");
+ Put (Hex_Image (Shdr.Sh_Offset));
+ Put (" ");
+ Put (Hex_Image (Shdr.Sh_Size));
+ Put (" ");
+ Put (Hex_Image (Unsigned_16 (Shdr.Sh_Link and 16#Ffff#)));
+ Put (" ");
+ Put (Hex_Image (Unsigned_16 (Shdr.Sh_Info and 16#Ffff#)));
+ Put (" ");
+ Put (Hex_Image (Unsigned_8 (Shdr.Sh_Addralign and 16#ff#)));
+ Put (" ");
+ Put (Hex_Image (Unsigned_8 (Shdr.Sh_Entsize and 16#ff#)));
+ New_Line;
+ end;
+ end loop;
+ end if;
+ end if;
+
+ if Flag_Phdr then
+ Load_Phdr (File);
+ if Ehdr.E_Phnum = 0 then
+ Put ("no program segment");
+ else
+ for I in 0 .. Ehdr.E_Phnum - 1 loop
+ Put ("segment " & Hex_Image (I));
+ New_Line;
+ Disp_Phdr (Get_Phdr (File, I).all);
+ end loop;
+ end if;
+ end if;
+
+ -- Dump each section.
+ if Ehdr.E_Shnum > 0 then
+ for I in 0 .. Ehdr.E_Shnum - 1 loop
+ Shdr := Get_Shdr (File, I);
+ case Shdr.Sh_Type is
+ when SHT_SYMTAB =>
+ if Flag_Symtab then
+ Disp_Section_Header (File, I);
+ Disp_Symtab (File, I);
+ end if;
+ when SHT_STRTAB =>
+ if Flag_Strtab then
+ Disp_Section_Header (File, I);
+ Disp_Strtab (File, I);
+ end if;
+ when SHT_PROGBITS =>
+ declare
+ Name : String := Get_Section_Name (File, I);
+ begin
+ if Flag_Dwarf_Abbrev and then Name = ".debug_abbrev" then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Abbrev (File, I);
+ elsif Flag_Dwarf_Info and then Name = ".debug_info" then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Info (File, I);
+ elsif Flag_Dwarf_Line and then Name = ".debug_line" then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Line (File, I);
+ elsif Flag_Dwarf_Frame and then Name = ".debug_frame" then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Frame (File, I);
+ elsif Flag_Dwarf_Pubnames
+ and then Name = ".debug_pubnames"
+ then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Pubnames (File, I);
+ elsif Flag_Eh_Frame_Hdr and then Name = ".eh_frame_hdr"
+ then
+ Disp_Section_Header (File, I);
+ Disp_Eh_Frame_Hdr (File, I);
+ elsif Flag_Dwarf_Aranges
+ and then Name = ".debug_aranges"
+ then
+ Disp_Section_Header (File, I);
+ Disp_Debug_Aranges (File, I);
+ end if;
+ end;
+ when SHT_NOTE =>
+ if Flag_Note then
+ Disp_Section_Header (File, I);
+ Disp_Section_Note (File, I);
+ end if;
+ when SHT_DYNAMIC =>
+ if Flag_Dynamic then
+ Disp_Section_Header (File, I);
+ Disp_Dynamic (File, I);
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ elsif Ehdr.E_Phnum > 0 then
+ Load_Phdr (File);
+ for I in 0 .. Ehdr.E_Phnum - 1 loop
+ Phdr := Get_Phdr (File, I);
+ case Phdr.P_Type is
+ when PT_NOTE =>
+ if Flag_Note then
+ Disp_Segment_Note (File, I);
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end if;
+ end Disp_Elf_File;
+
+begin
+ for I in 1 .. Argument_Count loop
+ declare
+ Arg : String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ -- An option.
+ if Arg = "-e" then
+ Flag_Ehdr := True;
+ elsif Arg = "-t" then
+ Flag_Strtab := True;
+ elsif Arg = "-S" then
+ Flag_Symtab := True;
+ elsif Arg = "-s" then
+ Flag_Shdr := True;
+ elsif Arg = "-p" then
+ Flag_Phdr := True;
+ elsif Arg = "-n" then
+ Flag_Note := True;
+ elsif Arg = "-d" then
+ Flag_Dynamic := True;
+ elsif Arg = "--dwarf-info" then
+ Flag_Dwarf_Info := True;
+ elsif Arg = "--dwarf-abbrev" then
+ Flag_Dwarf_Abbrev := True;
+ elsif Arg = "--dwarf-line" then
+ Flag_Dwarf_Line := True;
+ elsif Arg = "--dwarf-frame" then
+ Flag_Dwarf_Frame := True;
+ elsif Arg = "--dwarf-pubnames" then
+ Flag_Dwarf_Pubnames := True;
+ elsif Arg = "--dwarf-aranges" then
+ Flag_Dwarf_Aranges := True;
+ elsif Arg = "--eh-frame-hdr" then
+ Flag_Eh_Frame_Hdr := True;
+ elsif Arg = "--long-shdr" then
+ Flag_Long_Shdr := True;
+ else
+ Put_Line ("unknown option '" & Arg & "'");
+ return;
+ end if;
+ else
+ Disp_Elf_File (Arg);
+ end if;
+ end;
+ end loop;
+end Elfdump;
+
diff --git a/src/ortho/mcode/elfdumper.adb b/src/ortho/mcode/elfdumper.adb
new file mode 100644
index 000000000..b3a3b70f2
--- /dev/null
+++ b/src/ortho/mcode/elfdumper.adb
@@ -0,0 +1,2818 @@
+-- ELF dumper (library).
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System.Storage_Elements; use System.Storage_Elements;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+with GNAT.OS_Lib;
+with Interfaces; use Interfaces;
+with Hex_Images; use Hex_Images;
+with Elf_Common; use Elf_Common;
+with Dwarf;
+
+package body Elfdumper is
+ function Get_String (Strtab : Strtab_Type; N : Elf_Size) return String
+ is
+ E : Elf_Size;
+ begin
+ E := N;
+ while Strtab.Base (E) /= Nul loop
+ E := E + 1;
+ end loop;
+ if E = N then
+ return "";
+ else
+ return String (Strtab.Base (N .. E - 1));
+ end if;
+ end Get_String;
+
+ procedure Disp_Ehdr (Ehdr : Elf_Ehdr) is
+ begin
+ Put ("File class: ");
+ case Ehdr.E_Ident (EI_CLASS) is
+ when ELFCLASSNONE =>
+ Put ("none");
+ when ELFCLASS32 =>
+ Put ("class_32");
+ when ELFCLASS64 =>
+ Put ("class_64");
+ when others =>
+ Put ("others");
+ end case;
+ New_Line;
+
+ Put ("encoding : ");
+ case Ehdr.E_Ident (EI_DATA) is
+ when ELFDATANONE =>
+ Put ("none");
+ when ELFDATA2LSB =>
+ Put ("LSB byte order");
+ when ELFDATA2MSB =>
+ Put ("MSB byte order");
+ when others =>
+ Put ("unknown");
+ end case;
+ New_Line;
+
+ Put ("version : ");
+ case Ehdr.E_Ident (EI_VERSION) is
+ when EV_NONE =>
+ Put ("none");
+ when EV_CURRENT =>
+ Put ("current (1)");
+ when others =>
+ Put ("future");
+ end case;
+ New_Line;
+
+ if Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class
+-- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB
+ or Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT
+ then
+ Put_Line ("bad class/data encoding/version");
+ return;
+ end if;
+
+ Put ("File type : ");
+ case Ehdr.E_Type is
+ when ET_NONE =>
+ Put ("no file type");
+ when ET_REL =>
+ Put ("relocatable file");
+ when ET_EXEC =>
+ Put ("executable file");
+ when ET_CORE =>
+ Put ("core file");
+ when ET_LOPROC .. ET_HIPROC =>
+ Put ("processor-specific");
+ when others =>
+ Put ("unknown");
+ end case;
+ New_Line;
+
+ Put ("machine : ");
+ case Ehdr.E_Machine is
+ when EM_NONE =>
+ Put ("no machine");
+ when EM_M32 =>
+ Put ("AT&T WE 32100");
+ when EM_SPARC =>
+ Put ("SPARC");
+ when EM_386 =>
+ Put ("Intel architecture");
+ when EM_68K =>
+ Put ("Motorola 68000");
+ when EM_88K =>
+ Put ("Motorola 88000");
+ when EM_860 =>
+ Put ("Intel 80860");
+ when EM_MIPS =>
+ Put ("MIPS RS3000 Big-Endian");
+ when EM_MIPS_RS4_BE =>
+ Put ("MIPS RS4000 Big-Endian");
+ when others =>
+ Put ("unknown");
+ end case;
+ New_Line;
+
+ Put_Line ("Version : " & Hex_Image (Ehdr.E_Version));
+ Put_Line ("Phoff : " & Hex_Image (Ehdr.E_Phoff));
+ Put_Line ("Shoff : " & Hex_Image (Ehdr.E_Shoff));
+ Put_Line ("flags : " & Hex_Image (Ehdr.E_Flags));
+ Put_Line ("phentsize : " & Hex_Image (Ehdr.E_Ehsize));
+ Put_Line ("phnum : " & Hex_Image (Ehdr.E_Phentsize));
+ Put_Line ("shentsize : " & Hex_Image (Ehdr.E_Shentsize));
+ Put_Line ("shnum : " & Hex_Image (Ehdr.E_Shnum));
+ Put_Line ("shstrndx : " & Hex_Image (Ehdr.E_Shstrndx));
+ end Disp_Ehdr;
+
+ function Get_Shdr_Type_Name (Stype : Elf_Word) return String is
+ begin
+ case Stype is
+ when SHT_NULL =>
+ return "NULL";
+ when SHT_PROGBITS =>
+ return "PROGBITS";
+ when SHT_SYMTAB =>
+ return "SYMTAB";
+ when SHT_STRTAB =>
+ return "STRTAB";
+ when SHT_RELA =>
+ return "RELA";
+ when SHT_HASH =>
+ return "HASH";
+ when SHT_DYNAMIC =>
+ return "DYNAMIC";
+ when SHT_NOTE =>
+ return "NOTE";
+ when SHT_NOBITS =>
+ return "NOBITS";
+ when SHT_REL =>
+ return "REL";
+ when SHT_SHLIB =>
+ return "SHLIB";
+ when SHT_DYNSYM =>
+ return "DYNSYM";
+ when SHT_INIT_ARRAY =>
+ return "INIT_ARRAY";
+ when SHT_FINI_ARRAY =>
+ return "FINI_ARRAY";
+ when SHT_PREINIT_ARRAY =>
+ return "PREINIT_ARRAY";
+ when SHT_GROUP =>
+ return "GROUP";
+ when SHT_SYMTAB_SHNDX =>
+ return "SYMTAB_SHNDX";
+ when SHT_NUM =>
+ return "NUM";
+ when SHT_LOOS =>
+ return "LOOS";
+ when SHT_GNU_LIBLIST =>
+ return "GNU_LIBLIST";
+ when SHT_CHECKSUM =>
+ return "CHECKSUM";
+ when SHT_SUNW_Move =>
+ return "SUNW_move";
+ when SHT_SUNW_COMDAT =>
+ return "SUNW_COMDAT";
+ when SHT_SUNW_Syminfo =>
+ return "SUNW_syminfo";
+ when SHT_GNU_Verdef =>
+ return "GNU_verdef";
+ when SHT_GNU_Verneed =>
+ return "GNU_verneed";
+ when SHT_GNU_Versym =>
+ return "GNU_versym";
+ when SHT_LOPROC .. SHT_HIPROC =>
+ return "Processor dependant";
+ when SHT_LOUSER .. SHT_HIUSER =>
+ return "User dependant";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Shdr_Type_Name;
+
+ procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type)
+ is
+ begin
+ Put_Line ("name : " & Hex_Image (Shdr.Sh_Name) & " """
+ & Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) & """");
+ Put ("type : " & Hex_Image (Shdr.Sh_Type) & " ");
+ Put (Get_Shdr_Type_Name (Shdr.Sh_Type));
+ New_Line;
+ Put ("flags : " & Hex_Image (Shdr.Sh_Flags));
+ if (Shdr.Sh_Flags and SHF_WRITE) /= 0 then
+ Put (" WRITE");
+ end if;
+ if (Shdr.Sh_Flags and SHF_ALLOC) /= 0 then
+ Put (" ALLOC");
+ end if;
+ if (Shdr.Sh_Flags and SHF_EXECINSTR) /= 0 then
+ Put (" EXEC");
+ end if;
+ New_Line;
+ Put ("addr : " & Hex_Image (Shdr.Sh_Addr));
+ Put (" offset : " & Hex_Image (Shdr.Sh_Offset));
+ Put (" size : " & Hex_Image (Shdr.Sh_Size));
+ New_Line;
+ Put ("link : " & Hex_Image (Shdr.Sh_Link));
+ Put (" info : " & Hex_Image (Shdr.Sh_Info));
+ Put (" addralign : " & Hex_Image (Shdr.Sh_Addralign));
+ Put (" entsize : " & Hex_Image (Shdr.Sh_Entsize));
+ New_Line;
+ end Disp_Shdr;
+
+ procedure Disp_Sym (File : Elf_File;
+ Sym : Elf_Sym;
+ Strtab : Strtab_Type)
+ is
+ begin
+ Put (Hex_Image (Sym.St_Value));
+ Put (" " & Hex_Image (Sym.St_Size));
+ Put (' ');
+ --Put (" info:" & Hex_Image (Sym.St_Info) & " ");
+ case Elf_St_Bind (Sym.St_Info) is
+ when STB_LOCAL =>
+ Put ("loc ");
+ when STB_GLOBAL =>
+ Put ("glob");
+ when STB_WEAK =>
+ Put ("weak");
+ when others =>
+ Put ("? ");
+ end case;
+ Put (' ');
+ case Elf_St_Type (Sym.St_Info) is
+ when STT_NOTYPE =>
+ Put ("none");
+ when STT_OBJECT =>
+ Put ("obj ");
+ when STT_FUNC =>
+ Put ("func");
+ when STT_SECTION =>
+ Put ("sect");
+ when STT_FILE =>
+ Put ("file");
+ when others =>
+ Put ("? ");
+ end case;
+ --Put (" other:" & Hex_Image (Sym.St_Other));
+ Put (' ');
+ case Sym.St_Shndx is
+ when SHN_UNDEF =>
+ Put ("UNDEF ");
+ when 1 .. SHN_LORESERVE - 1 =>
+ declare
+ S : String := Get_Section_Name (File, Sym.St_Shndx);
+ Max : constant Natural := 8;
+ begin
+ if S'Length <= Max then
+ Put (S);
+ for I in S'Length + 1 .. Max loop
+ Put (' ');
+ end loop;
+ else
+ Put (S (S'First .. S'First + Max - 1));
+ end if;
+ end;
+ when SHN_LOPROC .. SHN_HIPROC =>
+ Put ("*proc* ");
+ when SHN_ABS =>
+ Put ("*ABS* ");
+ when SHN_COMMON =>
+ Put ("*COMMON*");
+ when others =>
+ Put ("?? ");
+ end case;
+ --Put (" sect:" & Hex_Image (Sym.St_Shndx));
+ Put (' ');
+ Put_Line (Get_String (Strtab, Elf_Size (Sym.St_Name)));
+ end Disp_Sym;
+
+ function Get_Offset (File : Elf_File; Off : Elf_Off; Size : Elf_Size)
+ return Address
+ is
+ begin
+ if Off > File.Length or Off + Size > File.Length then
+ return Null_Address;
+ end if;
+ return File.Base + Storage_Offset (Off);
+ end Get_Offset;
+
+ function Get_Section_Base (File : Elf_File; Shdr : Elf_Shdr)
+ return Address
+ is
+ begin
+ return Get_Offset (File, Shdr.Sh_Offset, Shdr.Sh_Size);
+ end Get_Section_Base;
+
+ function Get_Section_Base (File : Elf_File; Index : Elf_Half)
+ return Address
+ is
+ Shdr : Elf_Shdr_Acc;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ return Get_Section_Base (File, Shdr.all);
+ end Get_Section_Base;
+
+ function Get_Segment_Base (File : Elf_File; Phdr : Elf_Phdr)
+ return Address
+ is
+ begin
+ return Get_Offset (File, Phdr.P_Offset, Phdr.P_Filesz);
+ end Get_Segment_Base;
+
+ function Get_Segment_Base (File : Elf_File; Index : Elf_Half)
+ return Address
+ is
+ Phdr : Elf_Phdr_Acc;
+ begin
+ Phdr := Get_Phdr (File, Index);
+ return Get_Segment_Base (File, Phdr.all);
+ end Get_Segment_Base;
+
+ procedure Open_File (File : out Elf_File; Filename : String)
+ is
+ function Malloc (Size : Integer) return Address;
+ pragma Import (C, Malloc);
+
+ use GNAT.OS_Lib;
+ Length : Long_Integer;
+ Len : Integer;
+ Fd : File_Descriptor;
+ begin
+ File := (Filename => new String'(Filename),
+ Status => Status_Ok,
+ Length => 0,
+ Base => Null_Address,
+ Ehdr => null,
+ Shdr_Base => Null_Address,
+ Sh_Strtab => (null, 0),
+ Phdr_Base => Null_Address);
+
+ -- Open the file.
+ Fd := Open_Read (Filename, Binary);
+ if Fd = Invalid_FD then
+ File.Status := Status_Open_Failure;
+ return;
+ end if;
+
+ -- Get length.
+ Length := File_Length (Fd);
+ Len := Integer (Length);
+ if Len < Elf_Ehdr_Size then
+ File.Status := Status_Bad_File;
+ Close (Fd);
+ return;
+ end if;
+
+ File.Length := Elf_Off (Len);
+
+ -- Allocate memory for the file.
+ File.Base := Malloc (Len);
+ if File.Base = Null_Address then
+ File.Status := Status_Memory;
+ Close (Fd);
+ return;
+ end if;
+
+ -- Read the whole file.
+ if Read (Fd, File.Base, Integer (Length)) /= Integer (Length) then
+ File.Status := Status_Read_Error;
+ Close (Fd);
+ return;
+ end if;
+
+ Close (Fd);
+
+ File.Ehdr := To_Elf_Ehdr_Acc (File.Base);
+
+ if File.Ehdr.E_Ident (EI_MAG0) /= ELFMAG0
+ or File.Ehdr.E_Ident (EI_MAG1) /= ELFMAG1
+ or File.Ehdr.E_Ident (EI_MAG2) /= ELFMAG2
+ or File.Ehdr.E_Ident (EI_MAG3) /= ELFMAG3
+ then
+ File.Status := Status_Bad_Magic;
+ return;
+ end if;
+
+ if File.Ehdr.E_Ident (EI_CLASS) /= Elf_Arch_Class
+-- or Ehdr.E_Ident (EI_DATA) /= ELFDATA2LSB
+ or File.Ehdr.E_Ident (EI_VERSION) /= EV_CURRENT
+ then
+ File.Status := Status_Bad_Class;
+ return;
+ end if;
+ end Open_File;
+
+ function Get_Status (File : Elf_File) return Elf_File_Status is
+ begin
+ return File.Status;
+ end Get_Status;
+
+ function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc is
+ begin
+ return File.Ehdr;
+ end Get_Ehdr;
+
+ function Get_Shdr (File : Elf_File; Index : Elf_Half)
+ return Elf_Shdr_Acc
+ is
+ begin
+ if Index >= File.Ehdr.E_Shnum then
+ raise Constraint_Error;
+ end if;
+ return To_Elf_Shdr_Acc
+ (File.Shdr_Base
+ + Storage_Offset (Index * Elf_Half (Elf_Shdr_Size)));
+ end Get_Shdr;
+
+ procedure Load_Phdr (File : in out Elf_File)
+ is
+ begin
+ if Get_Ehdr (File).E_Phentsize /= Elf_Half (Elf_Phdr_Size) then
+ return;
+ end if;
+
+ File.Phdr_Base :=
+ Get_Offset (File, Get_Ehdr (File).E_Phoff,
+ Elf_Size (Get_Ehdr (File).E_Phnum
+ * Elf_Half (Elf_Phdr_Size)));
+ end Load_Phdr;
+
+ function Get_Phdr (File : Elf_File; Index : Elf_Half)
+ return Elf_Phdr_Acc
+ is
+ begin
+ if Index >= File.Ehdr.E_Phnum then
+ raise Constraint_Error;
+ end if;
+ return To_Elf_Phdr_Acc
+ (File.Phdr_Base
+ + Storage_Offset (Index * Elf_Half (Elf_Phdr_Size)));
+ end Get_Phdr;
+
+ function Get_Strtab (File : Elf_File; Index : Elf_Half)
+ return Strtab_Type
+ is
+ Shdr : Elf_Shdr_Acc;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ if Shdr = null or Shdr.Sh_Type /= SHT_STRTAB then
+ return Null_Strtab;
+ end if;
+ return (Base => To_Strtab_Fat_Acc (Get_Section_Base (File, Shdr.all)),
+ Length => Shdr.Sh_Size);
+ end Get_Strtab;
+
+ procedure Load_Shdr (File : in out Elf_File)
+ is
+ begin
+ if Get_Ehdr (File).E_Shentsize /= Elf_Half (Elf_Shdr_Size) then
+ return;
+ end if;
+
+ File.Shdr_Base :=
+ Get_Offset (File, Get_Ehdr (File).E_Shoff,
+ Elf_Size (Get_Ehdr (File).E_Shnum
+ * Elf_Half (Elf_Shdr_Size)));
+ File.Sh_Strtab := Get_Strtab (File, Get_Ehdr (File).E_Shstrndx);
+ end Load_Shdr;
+
+ function Get_Sh_Strtab (File : Elf_File) return Strtab_Type is
+ begin
+ return File.Sh_Strtab;
+ end Get_Sh_Strtab;
+
+ function Get_Section_Name (File : Elf_File; Index : Elf_Half)
+ return String
+ is
+ begin
+ return Get_String (Get_Sh_Strtab (File),
+ Elf_Size (Get_Shdr (File, Index).Sh_Name));
+ end Get_Section_Name;
+
+ function Get_Section_By_Name (File : Elf_File; Name : String)
+ return Elf_Half
+ is
+ Ehdr : Elf_Ehdr_Acc;
+ Shdr : Elf_Shdr_Acc;
+ Sh_Strtab : Strtab_Type;
+ begin
+ Ehdr := Get_Ehdr (File);
+ Sh_Strtab := Get_Sh_Strtab (File);
+ for I in 1 .. Ehdr.E_Shnum - 1 loop
+ Shdr := Get_Shdr (File, I);
+ if Get_String (Sh_Strtab, Elf_Size (Shdr.Sh_Name)) = Name then
+ return I;
+ end if;
+ end loop;
+ return 0;
+ end Get_Section_By_Name;
+
+ procedure Disp_Symtab (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ S_Strtab : Strtab_Type;
+ Base : Address;
+ Off : Storage_Offset;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ if Shdr.Sh_Entsize /= Elf_Size (Elf_Sym_Size) then
+ return;
+ end if;
+ S_Strtab := Get_Strtab (File, Elf_Half (Shdr.Sh_Link));
+ Base := Get_Section_Base (File, Shdr.all);
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Disp_Sym (File, To_Elf_Sym_Acc (Base + Off).all, S_Strtab);
+ Off := Off + Storage_Offset (Elf_Sym_Size);
+ end loop;
+ end Disp_Symtab;
+
+ procedure Disp_Strtab (File : Elf_File; Index : Elf_Half)
+ is
+ Strtab : Strtab_Type;
+ S, E : Elf_Size;
+ begin
+ Strtab := Get_Strtab (File, Index);
+ S := 1;
+ while S < Strtab.Length loop
+ E := S;
+ while Strtab.Base (E) /= Nul loop
+ E := E + 1;
+ end loop;
+ Put_Line (Hex_Image (S) & ": "
+ & String (Strtab.Base (S .. E - 1)));
+ S := E + 1;
+ end loop;
+ end Disp_Strtab;
+
+ function Read_Byte (Addr : Address) return Unsigned_8
+ is
+ type Unsigned_8_Acc is access all Unsigned_8;
+ function To_Unsigned_8_Acc is new Ada.Unchecked_Conversion
+ (Address, Unsigned_8_Acc);
+ begin
+ return To_Unsigned_8_Acc (Addr).all;
+ end Read_Byte;
+
+ procedure Read_ULEB128 (Base : Address;
+ Off : in out Storage_Offset;
+ Res : out Unsigned_32)
+ is
+ B : Unsigned_8;
+ Shift : Integer;
+ begin
+ Res := 0;
+ Shift := 0;
+ loop
+ B := Read_Byte (Base + Off);
+ Off := Off + 1;
+ Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift);
+ exit when (B and 16#80#) = 0;
+ Shift := Shift + 7;
+ end loop;
+ end Read_ULEB128;
+
+ procedure Read_SLEB128 (Base : Address;
+ Off : in out Storage_Offset;
+ Res : out Unsigned_32)
+ is
+ B : Unsigned_8;
+ Shift : Integer;
+ begin
+ Res := 0;
+ Shift := 0;
+ loop
+ B := Read_Byte (Base + Off);
+ Off := Off + 1;
+ Res := Res or Shift_Left (Unsigned_32 (B and 16#7f#), Shift);
+ Shift := Shift + 7;
+ exit when (B and 16#80#) = 0;
+ end loop;
+ if Shift < 32 and (Res and Shift_Left (1, Shift - 1)) /= 0 then
+ Res := Res or Shift_Left (-1, Shift);
+ end if;
+ end Read_SLEB128;
+
+ procedure Read_Word4 (Base : Address;
+ Off : in out Storage_Offset;
+ Res : out Unsigned_32)
+ is
+ B0, B1, B2, B3 : Unsigned_8;
+ begin
+ B0 := Read_Byte (Base + Off + 0);
+ B1 := Read_Byte (Base + Off + 1);
+ B2 := Read_Byte (Base + Off + 2);
+ B3 := Read_Byte (Base + Off + 3);
+ Res := Shift_Left (Unsigned_32 (B3), 24)
+ or Shift_Left (Unsigned_32 (B2), 16)
+ or Shift_Left (Unsigned_32 (B1), 8)
+ or Shift_Left (Unsigned_32 (B0), 0);
+ Off := Off + 4;
+ end Read_Word4;
+
+ procedure Read_Word2 (Base : Address;
+ Off : in out Storage_Offset;
+ Res : out Unsigned_16)
+ is
+ B0, B1 : Unsigned_8;
+ begin
+ B0 := Read_Byte (Base + Off + 0);
+ B1 := Read_Byte (Base + Off + 1);
+ Res := Shift_Left (Unsigned_16 (B1), 8)
+ or Shift_Left (Unsigned_16 (B0), 0);
+ Off := Off + 2;
+ end Read_Word2;
+
+ procedure Read_Byte (Base : Address;
+ Off : in out Storage_Offset;
+ Res : out Unsigned_8)
+ is
+ begin
+ Res := Read_Byte (Base + Off);
+ Off := Off + 1;
+ end Read_Byte;
+
+ procedure Disp_Note (Base : Address; Size : Storage_Offset)
+ is
+ Off : Storage_Offset;
+ Namesz : Unsigned_32;
+ Descsz : Unsigned_32;
+ Ntype : Unsigned_32;
+ B : Unsigned_8;
+ Is_Full : Boolean;
+ begin
+ Off := 0;
+ while Off < Size loop
+ Read_Word4 (Base, Off, Namesz);
+ Read_Word4 (Base, Off, Descsz);
+ Read_Word4 (Base, Off, Ntype);
+ Put ("type : ");
+ Put (Hex_Image (Ntype));
+ New_Line;
+ Put ("name : ");
+ Put (Hex_Image (Namesz));
+ Put (" ");
+ for I in 1 .. Namesz loop
+ Read_Byte (Base, Off, B);
+ if B /= 0 then
+ Put (Character'Val (B));
+ end if;
+ end loop;
+ if Namesz mod 4 /= 0 then
+ for I in (Namesz mod 4) .. 3 loop
+ Read_Byte (Base, Off, B);
+ end loop;
+ end if;
+ New_Line;
+ Put ("desc : ");
+ Put (Hex_Image (Descsz));
+ Put (" ");
+ Is_Full := Descsz >= 20;
+ for I in 1 .. Descsz loop
+ if Is_Full and (I mod 16) = 1 then
+ New_Line;
+ end if;
+ Read_Byte (Base, Off, B);
+ Put (' ');
+ Put (Hex_Image (B));
+ end loop;
+ if Descsz mod 4 /= 0 then
+ for I in (Descsz mod 4) .. 3 loop
+ Read_Byte (Base, Off, B);
+ end loop;
+ end if;
+ New_Line;
+ end loop;
+ end Disp_Note;
+
+ procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+ Disp_Note (Base, Storage_Offset (Shdr.Sh_Size));
+ end Disp_Section_Note;
+
+ procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half)
+ is
+ Phdr : Elf_Phdr_Acc;
+ Base : Address;
+ begin
+ Phdr := Get_Phdr (File, Index);
+ Base := Get_Segment_Base (File, Phdr.all);
+ Disp_Note (Base, Storage_Offset (Phdr.P_Filesz));
+ end Disp_Segment_Note;
+
+
+ function Get_Dt_Name (Name : Elf_Word) return String is
+ begin
+ case Name is
+ when DT_NULL =>
+ return "NULL";
+ when DT_NEEDED =>
+ return "NEEDED";
+ when DT_PLTRELSZ =>
+ return "PLTRELSZ";
+ when DT_PLTGOT =>
+ return "PLTGOT";
+ when DT_HASH =>
+ return "HASH";
+ when DT_STRTAB =>
+ return "STRTAB";
+ when DT_SYMTAB =>
+ return "SYMTAB";
+ when DT_RELA =>
+ return "RELA";
+ when DT_RELASZ =>
+ return "RELASZ";
+ when DT_RELAENT =>
+ return "RELAENT";
+ when DT_STRSZ =>
+ return "STRSZ";
+ when DT_SYMENT =>
+ return "SYMENT";
+ when DT_INIT =>
+ return "INIT";
+ when DT_FINI =>
+ return "FINI";
+ when DT_SONAME =>
+ return "SONAME";
+ when DT_RPATH =>
+ return "RPATH";
+ when DT_SYMBOLIC =>
+ return "SYMBOLIC";
+ when DT_REL =>
+ return "REL";
+ when DT_RELSZ =>
+ return "RELSZ";
+ when DT_RELENT =>
+ return "RELENT";
+ when DT_PLTREL =>
+ return "PLTREL";
+ when DT_DEBUG =>
+ return "DEBUG";
+ when DT_TEXTREL =>
+ return "TEXTREL";
+ when DT_JMPREL =>
+ return "JMPREL";
+ when DT_BIND_NOW =>
+ return "BIND_NOW";
+ when DT_INIT_ARRAY =>
+ return "INIT_ARRAY";
+ when DT_FINI_ARRAY =>
+ return "FINI_ARRAY";
+ when DT_INIT_ARRAYSZ =>
+ return "INIT_ARRAYSZ";
+ when DT_FINI_ARRAYSZ =>
+ return "FINI_ARRAYSZ";
+ when DT_RUNPATH =>
+ return "RUNPATH";
+ when DT_FLAGS =>
+ return "FLAGS";
+-- when DT_ENCODING =>
+-- return "ENCODING";
+ when DT_PREINIT_ARRAY =>
+ return "PREINIT_ARRAY";
+ when DT_PREINIT_ARRAYSZ =>
+ return "PREINIT_ARRAYSZ";
+ when DT_NUM =>
+ return "NUM";
+ when DT_LOOS =>
+ return "LOOS";
+-- when DT_HIOS =>
+-- return "HIOS";
+ when DT_LOPROC =>
+ return "LOPROC";
+-- when DT_HIPROC =>
+-- return "HIPROC";
+ when DT_VALRNGLO =>
+ return "VALRNGLO";
+ when DT_GNU_PRELINKED =>
+ return "GNU_PRELINKED";
+ when DT_GNU_CONFLICTSZ =>
+ return "GNU_CONFLICTSZ";
+ when DT_GNU_LIBLISTSZ =>
+ return "GNU_LIBLISTSZ";
+ when DT_CHECKSUM =>
+ return "CHECKSUM";
+ when DT_PLTPADSZ =>
+ return "PLTPADSZ";
+ when DT_MOVEENT =>
+ return "MOVEENT";
+ when DT_MOVESZ =>
+ return "MOVESZ";
+ when DT_FEATURE_1 =>
+ return "FEATURE_1";
+ when DT_POSFLAG_1 =>
+ return "POSFLAG_1";
+ when DT_SYMINSZ =>
+ return "SYMINSZ";
+ when DT_SYMINENT =>
+ return "SYMINENT";
+-- when DT_VALRNGHI =>
+-- return "VALRNGHI";
+ when DT_ADDRRNGLO =>
+ return "ADDRRNGLO";
+ when DT_GNU_CONFLICT =>
+ return "GNU_CONFLICT";
+ when DT_GNU_LIBLIST =>
+ return "GNU_LIBLIST";
+ when DT_CONFIG =>
+ return "CONFIG";
+ when DT_DEPAUDIT =>
+ return "DEPAUDIT";
+ when DT_AUDIT =>
+ return "AUDIT";
+ when DT_PLTPAD =>
+ return "PLTPAD";
+ when DT_MOVETAB =>
+ return "MOVETAB";
+ when DT_SYMINFO =>
+ return "SYMINFO";
+-- when DT_ADDRRNGHI =>
+-- return "ADDRRNGHI";
+ when DT_VERSYM =>
+ return "VERSYM";
+ when DT_RELACOUNT =>
+ return "RELACOUNT";
+ when DT_RELCOUNT =>
+ return "RELCOUNT";
+ when DT_FLAGS_1 =>
+ return "FLAGS_1";
+ when DT_VERDEF =>
+ return "VERDEF";
+ when DT_VERDEFNUM =>
+ return "VERDEFNUM";
+ when DT_VERNEED =>
+ return "VERNEED";
+ when DT_VERNEEDNUM =>
+ return "VERNEEDNUM";
+ when DT_AUXILIARY =>
+ return "AUXILIARY";
+ when DT_FILTER =>
+ return "FILTER";
+ when others =>
+ return "?unknown?";
+ end case;
+ end Get_Dt_Name;
+
+ procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+ Tag : Unsigned_32;
+ Val : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Word4 (Base, Off, Tag);
+ Read_Word4 (Base, Off, Val);
+ Put ("tag : ");
+ Put (Hex_Image (Tag));
+ Put (" (");
+ Put (Get_Dt_Name (Tag));
+ Put (")");
+ Set_Col (34);
+ Put ("val : ");
+ Put (Hex_Image (Val));
+ New_Line;
+ end loop;
+ end Disp_Dynamic;
+
+ function Get_Dwarf_Form_Name (Name : Unsigned_32) return String
+ is
+ use Dwarf;
+ begin
+ case Name is
+ when DW_FORM_Addr =>
+ return "addr";
+ when DW_FORM_Block2 =>
+ return "block2";
+ when DW_FORM_Block4 =>
+ return "block4";
+ when DW_FORM_Data2 =>
+ return "data2";
+ when DW_FORM_Data4 =>
+ return "data4";
+ when DW_FORM_Data8 =>
+ return "data8";
+ when DW_FORM_String =>
+ return "string";
+ when DW_FORM_Block =>
+ return "block";
+ when DW_FORM_Block1 =>
+ return "block1";
+ when DW_FORM_Data1 =>
+ return "data1";
+ when DW_FORM_Flag =>
+ return "flag";
+ when DW_FORM_Sdata =>
+ return "sdata";
+ when DW_FORM_Strp =>
+ return "strp";
+ when DW_FORM_Udata =>
+ return "udata";
+ when DW_FORM_Ref_Addr =>
+ return "ref_addr";
+ when DW_FORM_Ref1 =>
+ return "ref1";
+ when DW_FORM_Ref2 =>
+ return "ref2";
+ when DW_FORM_Ref4 =>
+ return "ref4";
+ when DW_FORM_Ref8 =>
+ return "ref8";
+ when DW_FORM_Ref_Udata =>
+ return "ref_udata";
+ when DW_FORM_Indirect =>
+ return "indirect";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Dwarf_Form_Name;
+
+ function Get_Dwarf_Tag_Name (Tag : Unsigned_32) return String
+ is
+ use Dwarf;
+ begin
+ case Tag is
+ when DW_TAG_Array_Type =>
+ return "array_type";
+ when DW_TAG_Class_Type =>
+ return "class_type";
+ when DW_TAG_Entry_Point =>
+ return "entry_point";
+ when DW_TAG_Enumeration_Type =>
+ return "enumeration_type";
+ when DW_TAG_Formal_Parameter =>
+ return "formal_parameter";
+ when DW_TAG_Imported_Declaration =>
+ return "imported_declaration";
+ when DW_TAG_Label =>
+ return "label";
+ when DW_TAG_Lexical_Block =>
+ return "lexical_block";
+ when DW_TAG_Member =>
+ return "member";
+ when DW_TAG_Pointer_Type =>
+ return "pointer_type";
+ when DW_TAG_Reference_Type =>
+ return "reference_type";
+ when DW_TAG_Compile_Unit =>
+ return "compile_unit";
+ when DW_TAG_String_Type =>
+ return "string_type";
+ when DW_TAG_Structure_Type =>
+ return "structure_type";
+ when DW_TAG_Subroutine_Type =>
+ return "subroutine_type";
+ when DW_TAG_Typedef =>
+ return "typedef";
+ when DW_TAG_Union_Type =>
+ return "union_type";
+ when DW_TAG_Unspecified_Parameters =>
+ return "unspecified_parameters";
+ when DW_TAG_Variant =>
+ return "variant";
+ when DW_TAG_Common_Block =>
+ return "common_block";
+ when DW_TAG_Common_Inclusion =>
+ return "common_inclusion";
+ when DW_TAG_Inheritance =>
+ return "inheritance";
+ when DW_TAG_Inlined_Subroutine =>
+ return "inlined_subroutine";
+ when DW_TAG_Module =>
+ return "module";
+ when DW_TAG_Ptr_To_Member_Type =>
+ return "ptr_to_member_type";
+ when DW_TAG_Set_Type =>
+ return "set_type";
+ when DW_TAG_Subrange_Type =>
+ return "subrange_type";
+ when DW_TAG_With_Stmt =>
+ return "with_stmt";
+ when DW_TAG_Access_Declaration =>
+ return "access_declaration";
+ when DW_TAG_Base_Type =>
+ return "base_type";
+ when DW_TAG_Catch_Block =>
+ return "catch_block";
+ when DW_TAG_Const_Type =>
+ return "const_type";
+ when DW_TAG_Constant =>
+ return "constant";
+ when DW_TAG_Enumerator =>
+ return "enumerator";
+ when DW_TAG_File_Type =>
+ return "file_type";
+ when DW_TAG_Friend =>
+ return "friend";
+ when DW_TAG_Namelist =>
+ return "namelist";
+ when DW_TAG_Namelist_Item =>
+ return "namelist_item";
+ when DW_TAG_Packed_Type =>
+ return "packed_type";
+ when DW_TAG_Subprogram =>
+ return "subprogram";
+ when DW_TAG_Template_Type_Parameter =>
+ return "template_type_parameter";
+ when DW_TAG_Template_Value_Parameter =>
+ return "template_value_parameter";
+ when DW_TAG_Thrown_Type =>
+ return "thrown_type";
+ when DW_TAG_Try_Block =>
+ return "try_block";
+ when DW_TAG_Variant_Part =>
+ return "variant_part";
+ when DW_TAG_Variable =>
+ return "variable";
+ when DW_TAG_Volatile_Type =>
+ return "volatile_type";
+ when DW_TAG_Dwarf_Procedure =>
+ return "dwarf_procedure";
+ when DW_TAG_Restrict_Type =>
+ return "restrict_type";
+ when DW_TAG_Interface_Type =>
+ return "interface_type";
+ when DW_TAG_Namespace =>
+ return "namespace";
+ when DW_TAG_Imported_Module =>
+ return "imported_module";
+ when DW_TAG_Unspecified_Type =>
+ return "unspecified_type";
+ when DW_TAG_Partial_Unit =>
+ return "partial_unit";
+ when DW_TAG_Imported_Unit =>
+ return "imported_unit";
+ when DW_TAG_Mutable_Type =>
+ return "mutable_type";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Dwarf_Tag_Name;
+
+ function Get_Dwarf_At_Name (Attr : Unsigned_32) return String
+ is
+ use Dwarf;
+ begin
+ case Attr is
+ when DW_AT_Sibling =>
+ return "sibling";
+ when DW_AT_Location =>
+ return "location";
+ when DW_AT_Name =>
+ return "name";
+ when DW_AT_Ordering =>
+ return "ordering";
+ when DW_AT_Byte_Size =>
+ return "byte_size";
+ when DW_AT_Bit_Offset =>
+ return "bit_offset";
+ when DW_AT_Bit_Size =>
+ return "bit_size";
+ when DW_AT_Stmt_List =>
+ return "stmt_list";
+ when DW_AT_Low_Pc =>
+ return "low_pc";
+ when DW_AT_High_Pc =>
+ return "high_pc";
+ when DW_AT_Language =>
+ return "language";
+ when DW_AT_Discr =>
+ return "discr";
+ when DW_AT_Discr_Value =>
+ return "discr_value";
+ when DW_AT_Visibility =>
+ return "visibility";
+ when DW_AT_Import =>
+ return "import";
+ when DW_AT_String_Length =>
+ return "string_length";
+ when DW_AT_Common_Reference =>
+ return "common_reference";
+ when DW_AT_Comp_Dir =>
+ return "comp_dir";
+ when DW_AT_Const_Value =>
+ return "const_value";
+ when DW_AT_Containing_Type =>
+ return "containing_type";
+ when DW_AT_Default_Value =>
+ return "default_value";
+ when DW_AT_Inline =>
+ return "inline";
+ when DW_AT_Is_Optional =>
+ return "is_optional";
+ when DW_AT_Lower_Bound =>
+ return "lower_bound";
+ when DW_AT_Producer =>
+ return "producer";
+ when DW_AT_Prototyped =>
+ return "prototyped";
+ when DW_AT_Return_Addr =>
+ return "return_addr";
+ when DW_AT_Start_Scope =>
+ return "start_scope";
+ when DW_AT_Stride_Size =>
+ return "stride_size";
+ when DW_AT_Upper_Bound =>
+ return "upper_bound";
+ when DW_AT_Abstract_Origin =>
+ return "abstract_origin";
+ when DW_AT_Accessibility =>
+ return "accessibility";
+ when DW_AT_Address_Class =>
+ return "address_class";
+ when DW_AT_Artificial =>
+ return "artificial";
+ when DW_AT_Base_Types =>
+ return "base_types";
+ when DW_AT_Calling_Convention =>
+ return "calling_convention";
+ when DW_AT_Count =>
+ return "count";
+ when DW_AT_Data_Member_Location =>
+ return "data_member_location";
+ when DW_AT_Decl_Column =>
+ return "decl_column";
+ when DW_AT_Decl_File =>
+ return "decl_file";
+ when DW_AT_Decl_Line =>
+ return "decl_line";
+ when DW_AT_Declaration =>
+ return "declaration";
+ when DW_AT_Discr_List =>
+ return "discr_list";
+ when DW_AT_Encoding =>
+ return "encoding";
+ when DW_AT_External =>
+ return "external";
+ when DW_AT_Frame_Base =>
+ return "frame_base";
+ when DW_AT_Friend =>
+ return "friend";
+ when DW_AT_Identifier_Case =>
+ return "identifier_case";
+ when DW_AT_Macro_Info =>
+ return "macro_info";
+ when DW_AT_Namelist_Item =>
+ return "namelist_item";
+ when DW_AT_Priority =>
+ return "priority";
+ when DW_AT_Segment =>
+ return "segment";
+ when DW_AT_Specification =>
+ return "specification";
+ when DW_AT_Static_Link =>
+ return "static_link";
+ when DW_AT_Type =>
+ return "type";
+ when DW_AT_Use_Location =>
+ return "use_location";
+ when DW_AT_Variable_Parameter =>
+ return "variable_parameter";
+ when DW_AT_Virtuality =>
+ return "virtuality";
+ when DW_AT_Vtable_Elem_Location =>
+ return "vtable_elem_location";
+ when DW_AT_Allocated =>
+ return "allocated";
+ when DW_AT_Associated =>
+ return "associated";
+ when DW_AT_Data_Location =>
+ return "data_location";
+ when DW_AT_Stride =>
+ return "stride";
+ when DW_AT_Entry_Pc =>
+ return "entry_pc";
+ when DW_AT_Use_UTF8 =>
+ return "use_utf8";
+ when DW_AT_Extension =>
+ return "extension";
+ when DW_AT_Ranges =>
+ return "ranges";
+ when DW_AT_Trampoline =>
+ return "trampoline";
+ when DW_AT_Call_Column =>
+ return "call_column";
+ when DW_AT_Call_File =>
+ return "call_file";
+ when DW_AT_Call_Line =>
+ return "call_line";
+ when DW_AT_Description =>
+ return "description";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Dwarf_At_Name;
+
+ procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Old_Off : Storage_Offset;
+ Off : Storage_Offset;
+ V : Unsigned_32;
+ Tag : Unsigned_32;
+ Name : Unsigned_32;
+ Form : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Old_Off := Off;
+ Read_ULEB128 (Base, Off, V);
+ Put_Line ("abbrev #" & Hex_Image (V) & " at "
+ & Hex_Image (Unsigned_32 (Old_Off)) & ':');
+ if V = 0 then
+ Put_Line ("pad");
+ goto Again;
+ end if;
+ Read_ULEB128 (Base, Off, Tag);
+ Put (" tag: " & Hex_Image (Tag));
+ Put (" (");
+ Put (Get_Dwarf_Tag_Name (Tag));
+ Put ("), children: " & Hex_Image (Read_Byte (Base + Off)));
+ New_Line;
+ Off := Off + 1;
+ loop
+ Read_ULEB128 (Base, Off, Name);
+ Read_ULEB128 (Base, Off, Form);
+ Put (" name: " & Hex_Image (Name));
+ Put (" (");
+ Put (Get_Dwarf_At_Name (Name));
+ Put (")");
+ Set_Col (42);
+ Put ("form: " & Hex_Image (Form));
+ Put (" (");
+ Put (Get_Dwarf_Form_Name (Form));
+ Put (")");
+ New_Line;
+ exit when Name = 0 and Form = 0;
+ end loop;
+ << Again >> null;
+ end loop;
+ end Disp_Debug_Abbrev;
+
+ type Abbrev_Map_Type is array (Unsigned_32 range <>) of Address;
+ type Abbrev_Map_Acc is access Abbrev_Map_Type;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Abbrev_Map_Type, Abbrev_Map_Acc);
+
+ procedure Build_Abbrev_Map (Base : Address; Res : out Abbrev_Map_Acc)
+ is
+ Max : Unsigned_32;
+ Off : Storage_Offset;
+ V : Unsigned_32;
+ V1 : Unsigned_32;
+ N_Res : Abbrev_Map_Acc;
+ begin
+ Off := 0;
+ Max := 0;
+ Res := new Abbrev_Map_Type (0 .. 128);
+ Res.all := (others => Null_Address);
+ loop
+ Read_ULEB128 (Base, Off, V);
+ if V > Max then
+ Max := V;
+ end if;
+ exit when V = 0;
+ if Max > Res.all'Last then
+ N_Res := new Abbrev_Map_Type (0 .. 2 * Max);
+ N_Res (Res'Range) := Res.all;
+ N_Res (Res'Last + 1 .. N_Res'Last) := (others => Null_Address);
+ Unchecked_Deallocation (Res);
+ Res := N_Res;
+ end if;
+ if Res (V) /= Null_Address then
+ Put_Line ("!! abbrev override !!");
+ return;
+ end if;
+ Res (V) := Base + Off;
+ Read_ULEB128 (Base, Off, V);
+ -- Skip child flag.
+ Off := Off + 1;
+ loop
+ Read_ULEB128 (Base, Off, V);
+ Read_ULEB128 (Base, Off, V1);
+ exit when V = 0 and V1 = 0;
+ end loop;
+ end loop;
+ end Build_Abbrev_Map;
+
+ procedure Disp_Block (Base : Address;
+ Off : in out Storage_Offset;
+ Cnt : Unsigned_32)
+ is
+ begin
+ for I in 1 .. Cnt loop
+ Put (" ");
+ Put (Hex_Image (Read_Byte (Base + Off + Storage_Offset (I - 1))));
+ end loop;
+ Off := Off + Storage_Offset (Cnt);
+ end Disp_Block;
+
+ procedure Disp_Dwarf_Form (Base : Address;
+ Off : in out Storage_Offset;
+ Form : Unsigned_32)
+ is
+ use Dwarf;
+ begin
+ case Form is
+ when DW_FORM_Addr =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (Base, Off, V);
+ Put ("address: " & Hex_Image (V));
+ end;
+ when DW_FORM_Flag =>
+ declare
+ V : Unsigned_8;
+ begin
+ Read_Byte (Base, Off, V);
+ Put ("flag: " & Hex_Image (V));
+ end;
+ when DW_FORM_Block1 =>
+ declare
+ V : Unsigned_8;
+ begin
+ Read_Byte (Base, Off, V);
+ Put ("block1: " & Hex_Image (V));
+ Disp_Block (Base, Off, Unsigned_32 (V));
+ end;
+ when DW_FORM_Data1 =>
+ declare
+ V : Unsigned_8;
+ begin
+ Read_Byte (Base, Off, V);
+ Put ("data1: " & Hex_Image (V));
+ end;
+ when DW_FORM_Data2 =>
+ declare
+ V : Unsigned_16;
+ begin
+ Read_Word2 (Base, Off, V);
+ Put ("data2: " & Hex_Image (V));
+ end;
+ when DW_FORM_Data4 =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (Base, Off, V);
+ Put ("data4: " & Hex_Image (V));
+ end;
+ when DW_FORM_Sdata =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_SLEB128 (Base, Off, V);
+ Put ("sdata: " & Hex_Image (V));
+ end;
+ when DW_FORM_Udata =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_ULEB128 (Base, Off, V);
+ Put ("udata: " & Hex_Image (V));
+ end;
+ when DW_FORM_Ref4 =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (Base, Off, V);
+ Put ("ref4: " & Hex_Image (V));
+ end;
+ when DW_FORM_Strp =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (Base, Off, V);
+ Put ("strp: " & Hex_Image (V));
+ end;
+ when DW_FORM_String =>
+ declare
+ C : Unsigned_8;
+ begin
+ Put ("string: ");
+ loop
+ Read_Byte (Base, Off, C);
+ exit when C = 0;
+ Put (Character'Val (C));
+ end loop;
+ end;
+ when others =>
+ Put ("???");
+ raise Program_Error;
+ end case;
+ end Disp_Dwarf_Form;
+
+ function Get_Dwarf_ATE_Name (Val : Unsigned_32) return String
+ is
+ use Dwarf;
+ begin
+ case Val is
+ when DW_ATE_Address =>
+ return "address";
+ when DW_ATE_Boolean =>
+ return "boolean";
+ when DW_ATE_Complex_Float =>
+ return "complex_float";
+ when DW_ATE_Float =>
+ return "float";
+ when DW_ATE_Signed =>
+ return "signed";
+ when DW_ATE_Signed_Char =>
+ return "signed_char";
+ when DW_ATE_Unsigned =>
+ return "unsigned";
+ when DW_ATE_Unsigned_Char =>
+ return "unsigned_char";
+ when DW_ATE_Imaginary_Float =>
+ return "imaginary_float";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Dwarf_ATE_Name;
+
+ procedure Read_Dwarf_Constant (Base : Address;
+ Off : in out Storage_Offset;
+ Form : Unsigned_32;
+ Res : out Unsigned_32)
+ is
+ use Dwarf;
+ begin
+ case Form is
+ when DW_FORM_Data1 =>
+ declare
+ V : Unsigned_8;
+ begin
+ Read_Byte (Base, Off, V);
+ Res := Unsigned_32 (V);
+ end;
+ when DW_FORM_Data2 =>
+ declare
+ V : Unsigned_16;
+ begin
+ Read_Word2 (Base, Off, V);
+ Res := Unsigned_32 (V);
+ end;
+ when DW_FORM_Data4 =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (Base, Off, V);
+ Res := V;
+ end;
+ when DW_FORM_Sdata =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_SLEB128 (Base, Off, V);
+ Res := V;
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Read_Dwarf_Constant;
+
+ procedure Disp_Dwarf_Encoding
+ (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32)
+ is
+ Val : Unsigned_32;
+ begin
+ Read_Dwarf_Constant (Base, Off, Form, Val);
+ Put (Get_Dwarf_ATE_Name (Val));
+ end Disp_Dwarf_Encoding;
+
+ function Get_Dwarf_Lang_Name (Lang : Unsigned_32) return String
+ is
+ use Dwarf;
+ begin
+ case Lang is
+ when DW_LANG_C89 =>
+ return "C89";
+ when DW_LANG_C =>
+ return "C";
+ when DW_LANG_Ada83 =>
+ return "Ada83";
+ when DW_LANG_C_Plus_Plus =>
+ return "C_Plus_Plus";
+ when DW_LANG_Cobol74 =>
+ return "Cobol74";
+ when DW_LANG_Cobol85 =>
+ return "Cobol85";
+ when DW_LANG_Fortran77 =>
+ return "Fortran77";
+ when DW_LANG_Fortran90 =>
+ return "Fortran90";
+ when DW_LANG_Pascal83 =>
+ return "Pascal83";
+ when DW_LANG_Modula2 =>
+ return "Modula2";
+ when DW_LANG_Java =>
+ return "Java";
+ when DW_LANG_C99 =>
+ return "C99";
+ when DW_LANG_Ada95 =>
+ return "Ada95";
+ when DW_LANG_Fortran95 =>
+ return "Fortran95";
+ when DW_LANG_PLI =>
+ return "PLI";
+ when others =>
+ return "?unknown?";
+ end case;
+ end Get_Dwarf_Lang_Name;
+
+ procedure Disp_Dwarf_Language
+ (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32)
+ is
+ Val : Unsigned_32;
+ begin
+ Read_Dwarf_Constant (Base, Off, Form, Val);
+ Put (Get_Dwarf_Lang_Name (Val));
+ end Disp_Dwarf_Language;
+
+ function Get_Dwarf_Op_Name (Op : Unsigned_8) return String
+ is
+ use Dwarf;
+ begin
+ case Op is
+ when DW_OP_Addr =>
+ return "addr";
+ when DW_OP_Deref =>
+ return "deref";
+ when DW_OP_Const1u =>
+ return "const1u";
+ when DW_OP_Const1s =>
+ return "const1s";
+ when DW_OP_Const2u =>
+ return "const2u";
+ when DW_OP_Const2s =>
+ return "const2s";
+ when DW_OP_Const4u =>
+ return "const4u";
+ when DW_OP_Const4s =>
+ return "const4s";
+ when DW_OP_Const8u =>
+ return "const8u";
+ when DW_OP_Const8s =>
+ return "const8s";
+ when DW_OP_Constu =>
+ return "constu";
+ when DW_OP_Consts =>
+ return "consts";
+ when DW_OP_Dup =>
+ return "dup";
+ when DW_OP_Drop =>
+ return "drop";
+ when DW_OP_Over =>
+ return "over";
+ when DW_OP_Pick =>
+ return "pick";
+ when DW_OP_Swap =>
+ return "swap";
+ when DW_OP_Rot =>
+ return "rot";
+ when DW_OP_Xderef =>
+ return "xderef";
+ when DW_OP_Abs =>
+ return "abs";
+ when DW_OP_And =>
+ return "and";
+ when DW_OP_Div =>
+ return "div";
+ when DW_OP_Minus =>
+ return "minus";
+ when DW_OP_Mod =>
+ return "mod";
+ when DW_OP_Mul =>
+ return "mul";
+ when DW_OP_Neg =>
+ return "neg";
+ when DW_OP_Not =>
+ return "not";
+ when DW_OP_Or =>
+ return "or";
+ when DW_OP_Plus =>
+ return "plus";
+ when DW_OP_Plus_Uconst =>
+ return "plus_uconst";
+ when DW_OP_Shl =>
+ return "shl";
+ when DW_OP_Shr =>
+ return "shr";
+ when DW_OP_Shra =>
+ return "shra";
+ when DW_OP_Xor =>
+ return "xor";
+ when DW_OP_Skip =>
+ return "skip";
+ when DW_OP_Bra =>
+ return "bra";
+ when DW_OP_Eq =>
+ return "eq";
+ when DW_OP_Ge =>
+ return "ge";
+ when DW_OP_Gt =>
+ return "gt";
+ when DW_OP_Le =>
+ return "le";
+ when DW_OP_Lt =>
+ return "lt";
+ when DW_OP_Ne =>
+ return "ne";
+ when DW_OP_Lit0 =>
+ return "lit0";
+ when DW_OP_Lit1 =>
+ return "lit1";
+ when DW_OP_Lit2 =>
+ return "lit2";
+ when DW_OP_Lit3 =>
+ return "lit3";
+ when DW_OP_Lit4 =>
+ return "lit4";
+ when DW_OP_Lit5 =>
+ return "lit5";
+ when DW_OP_Lit6 =>
+ return "lit6";
+ when DW_OP_Lit7 =>
+ return "lit7";
+ when DW_OP_Lit8 =>
+ return "lit8";
+ when DW_OP_Lit9 =>
+ return "lit9";
+ when DW_OP_Lit10 =>
+ return "lit10";
+ when DW_OP_Lit11 =>
+ return "lit11";
+ when DW_OP_Lit12 =>
+ return "lit12";
+ when DW_OP_Lit13 =>
+ return "lit13";
+ when DW_OP_Lit14 =>
+ return "lit14";
+ when DW_OP_Lit15 =>
+ return "lit15";
+ when DW_OP_Lit16 =>
+ return "lit16";
+ when DW_OP_Lit17 =>
+ return "lit17";
+ when DW_OP_Lit18 =>
+ return "lit18";
+ when DW_OP_Lit19 =>
+ return "lit19";
+ when DW_OP_Lit20 =>
+ return "lit20";
+ when DW_OP_Lit21 =>
+ return "lit21";
+ when DW_OP_Lit22 =>
+ return "lit22";
+ when DW_OP_Lit23 =>
+ return "lit23";
+ when DW_OP_Lit24 =>
+ return "lit24";
+ when DW_OP_Lit25 =>
+ return "lit25";
+ when DW_OP_Lit26 =>
+ return "lit26";
+ when DW_OP_Lit27 =>
+ return "lit27";
+ when DW_OP_Lit28 =>
+ return "lit28";
+ when DW_OP_Lit29 =>
+ return "lit29";
+ when DW_OP_Lit30 =>
+ return "lit30";
+ when DW_OP_Lit31 =>
+ return "lit31";
+ when DW_OP_Reg0 =>
+ return "reg0";
+ when DW_OP_Reg1 =>
+ return "reg1";
+ when DW_OP_Reg2 =>
+ return "reg2";
+ when DW_OP_Reg3 =>
+ return "reg3";
+ when DW_OP_Reg4 =>
+ return "reg4";
+ when DW_OP_Reg5 =>
+ return "reg5";
+ when DW_OP_Reg6 =>
+ return "reg6";
+ when DW_OP_Reg7 =>
+ return "reg7";
+ when DW_OP_Reg8 =>
+ return "reg8";
+ when DW_OP_Reg9 =>
+ return "reg9";
+ when DW_OP_Reg10 =>
+ return "reg10";
+ when DW_OP_Reg11 =>
+ return "reg11";
+ when DW_OP_Reg12 =>
+ return "reg12";
+ when DW_OP_Reg13 =>
+ return "reg13";
+ when DW_OP_Reg14 =>
+ return "reg14";
+ when DW_OP_Reg15 =>
+ return "reg15";
+ when DW_OP_Reg16 =>
+ return "reg16";
+ when DW_OP_Reg17 =>
+ return "reg17";
+ when DW_OP_Reg18 =>
+ return "reg18";
+ when DW_OP_Reg19 =>
+ return "reg19";
+ when DW_OP_Reg20 =>
+ return "reg20";
+ when DW_OP_Reg21 =>
+ return "reg21";
+ when DW_OP_Reg22 =>
+ return "reg22";
+ when DW_OP_Reg23 =>
+ return "reg23";
+ when DW_OP_Reg24 =>
+ return "reg24";
+ when DW_OP_Reg25 =>
+ return "reg25";
+ when DW_OP_Reg26 =>
+ return "reg26";
+ when DW_OP_Reg27 =>
+ return "reg27";
+ when DW_OP_Reg28 =>
+ return "reg28";
+ when DW_OP_Reg29 =>
+ return "reg29";
+ when DW_OP_Reg30 =>
+ return "reg30";
+ when DW_OP_Reg31 =>
+ return "reg31";
+ when DW_OP_Breg0 =>
+ return "breg0";
+ when DW_OP_Breg1 =>
+ return "breg1";
+ when DW_OP_Breg2 =>
+ return "breg2";
+ when DW_OP_Breg3 =>
+ return "breg3";
+ when DW_OP_Breg4 =>
+ return "breg4";
+ when DW_OP_Breg5 =>
+ return "breg5";
+ when DW_OP_Breg6 =>
+ return "breg6";
+ when DW_OP_Breg7 =>
+ return "breg7";
+ when DW_OP_Breg8 =>
+ return "breg8";
+ when DW_OP_Breg9 =>
+ return "breg9";
+ when DW_OP_Breg10 =>
+ return "breg10";
+ when DW_OP_Breg11 =>
+ return "breg11";
+ when DW_OP_Breg12 =>
+ return "breg12";
+ when DW_OP_Breg13 =>
+ return "breg13";
+ when DW_OP_Breg14 =>
+ return "breg14";
+ when DW_OP_Breg15 =>
+ return "breg15";
+ when DW_OP_Breg16 =>
+ return "breg16";
+ when DW_OP_Breg17 =>
+ return "breg17";
+ when DW_OP_Breg18 =>
+ return "breg18";
+ when DW_OP_Breg19 =>
+ return "breg19";
+ when DW_OP_Breg20 =>
+ return "breg20";
+ when DW_OP_Breg21 =>
+ return "breg21";
+ when DW_OP_Breg22 =>
+ return "breg22";
+ when DW_OP_Breg23 =>
+ return "breg23";
+ when DW_OP_Breg24 =>
+ return "breg24";
+ when DW_OP_Breg25 =>
+ return "breg25";
+ when DW_OP_Breg26 =>
+ return "breg26";
+ when DW_OP_Breg27 =>
+ return "breg27";
+ when DW_OP_Breg28 =>
+ return "breg28";
+ when DW_OP_Breg29 =>
+ return "breg29";
+ when DW_OP_Breg30 =>
+ return "breg30";
+ when DW_OP_Breg31 =>
+ return "breg31";
+ when DW_OP_Regx =>
+ return "regx";
+ when DW_OP_Fbreg =>
+ return "fbreg";
+ when DW_OP_Bregx =>
+ return "bregx";
+ when DW_OP_Piece =>
+ return "piece";
+ when DW_OP_Deref_Size =>
+ return "deref_size";
+ when DW_OP_Xderef_Size =>
+ return "xderef_size";
+ when DW_OP_Nop =>
+ return "nop";
+ when DW_OP_Push_Object_Address =>
+ return "push_object_address";
+ when DW_OP_Call2 =>
+ return "call2";
+ when DW_OP_Call4 =>
+ return "call4";
+ when DW_OP_Call_Ref =>
+ return "call_ref";
+ when others =>
+ return "unknown";
+ end case;
+ end Get_Dwarf_Op_Name;
+
+ procedure Read_Dwarf_Block (Base : Address;
+ Off : in out Storage_Offset;
+ Form : Unsigned_32;
+ B : out Address;
+ L : out Unsigned_32)
+ is
+ use Dwarf;
+ begin
+ case Form is
+ when DW_FORM_Block1 =>
+ B := Base + Off + 1;
+ L := Unsigned_32 (Read_Byte (Base + Off));
+ Off := Off + 1;
+ when others =>
+ raise Program_Error;
+ end case;
+ Off := Off + Storage_Offset (L);
+ end Read_Dwarf_Block;
+
+ procedure Disp_Dwarf_Location
+ (Base : Address; Off : in out Storage_Offset; Form : Unsigned_32)
+ is
+ use Dwarf;
+ B : Address;
+ L : Unsigned_32;
+ Op : Unsigned_8;
+ Boff : Storage_Offset;
+ Is_Full : Boolean;
+ begin
+ Read_Dwarf_Block (Base, Off, Form, B, L);
+ if L = 0 then
+ return;
+ end if;
+ Is_Full := L > 6;
+ Boff := 0;
+ while Boff < Storage_Offset (L) loop
+ if Is_Full then
+ New_Line;
+ Put (" ");
+ Put (Hex_Image (Unsigned_32 (Boff)));
+ Put (": ");
+ end if;
+ Op := Read_Byte (B + Boff);
+ Put (' ');
+ Put (Get_Dwarf_Op_Name (Op));
+ Boff := Boff + 1;
+ case Op is
+ when DW_OP_Addr =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_Word4 (B, Boff, V);
+ Put (':');
+ Put (Hex_Image (V));
+ end;
+ when DW_OP_Deref =>
+ null;
+ when DW_OP_Const1u
+ | DW_OP_Const1s =>
+ declare
+ V : Unsigned_8;
+ begin
+ Read_Byte (B, Boff, V);
+ Put (':');
+ Put (Hex_Image (V));
+ end;
+-- DW_OP_Const2u : constant := 16#0a#; -- 1 2-byte constant
+-- DW_OP_Const2s : constant := 16#0b#; -- 1 2-byte constant
+-- DW_OP_Const4u : constant := 16#0c#; -- 1 4-byte constant
+-- DW_OP_Const4s : constant := 16#0d#; -- 1 4-byte constant
+-- DW_OP_Const8u : constant := 16#0e#; -- 1 8-byte constant
+-- DW_OP_Const8s : constant := 16#0f#; -- 1 8-byte constant
+-- DW_OP_Constu : constant := 16#10#; -- 1 ULEB128 constant
+-- DW_OP_Consts : constant := 16#11#; -- 1 SLEB128 constant
+-- DW_OP_Dup : constant := 16#12#; -- 0
+-- DW_OP_Drop : constant := 16#13#; -- 0
+-- DW_OP_Over : constant := 16#14#; -- 0
+-- DW_OP_Pick : constant := 16#15#; -- 1 1-byte stack index
+
+ when DW_OP_Swap
+ | DW_OP_Rot
+ | DW_OP_Xderef
+ | DW_OP_Abs
+ | DW_OP_And
+ | DW_OP_Div
+ | DW_OP_Minus
+ | DW_OP_Mod
+ | DW_OP_Mul
+ | DW_OP_Neg
+ | DW_OP_Not
+ | DW_OP_Or
+ | DW_OP_Plus =>
+ null;
+ when DW_OP_Plus_Uconst
+ | DW_OP_Piece
+ | DW_OP_Regx =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_ULEB128 (B, Boff, V);
+ Put (':');
+ Put (Hex_Image (V));
+ end;
+ when DW_OP_Shl
+ | DW_OP_Shr
+ | DW_OP_Shra
+ | DW_OP_Xor =>
+ null;
+ when DW_OP_Skip
+ | DW_OP_Bra =>
+ declare
+ V : Unsigned_16;
+ begin
+ Read_Word2 (B, Boff, V);
+ Put (':');
+ Put (Hex_Image (V));
+ Put (" (@");
+ -- FIXME: signed
+ Put (Hex_Image (Unsigned_32 (Boff) + Unsigned_32 (V)));
+ Put (")");
+ end;
+ when DW_OP_Eq
+ | DW_OP_Ge
+ | DW_OP_Gt
+ | DW_OP_Le
+ | DW_OP_Lt
+ | DW_OP_Ne =>
+ null;
+ when DW_OP_Lit0 .. DW_OP_Lit31 =>
+ null;
+ when DW_OP_Reg0 .. DW_OP_Reg31 =>
+ null;
+ when DW_OP_Breg0 .. DW_OP_Breg31
+ | DW_OP_Fbreg =>
+ declare
+ V : Unsigned_32;
+ begin
+ Read_SLEB128 (B, Boff, V);
+ Put (':');
+ Put (Hex_Image (V));
+ end;
+
+-- DW_OP_Regx : constant := 16#90#; -- 1 ULEB128 register
+-- DW_OP_Bregx : constant := 16#92#; -- 2 ULEB128 reg + SLEB128 offset
+-- DW_OP_Deref_Size : constant := 16#94#; -- 1 1-byte size of data retrieved
+-- DW_OP_Xderef_Size : constant := 16#95#; -- 1 1-byte size of data retrieved
+ when DW_OP_Nop =>
+ null;
+-- DW_OP_Push_Object_Address : constant := 16#97#; -- 0
+-- DW_OP_Call2 : constant := 16#98#; -- 1 2-byte offset of DIE
+-- DW_OP_Call4 : constant := 16#99#; -- 1 4-byte offset of DIE
+-- DW_OP_Call_Ref : constant := 16#9a#; -- 1 4- or 8-byte offset of DIE
+ when others =>
+ raise Program_Error;
+ end case;
+ end loop;
+ end Disp_Dwarf_Location;
+
+ procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half)
+ is
+ use Dwarf;
+
+ Abbrev_Index : Elf_Half;
+ Abbrev_Base : Address;
+ Map : Abbrev_Map_Acc;
+ Abbrev : Address;
+
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+ Aoff : Storage_Offset;
+ Old_Off : Storage_Offset;
+
+ Len : Unsigned_32;
+ Ver : Unsigned_16;
+ Abbrev_Off : Unsigned_32;
+ Ptr_Sz : Unsigned_8;
+ Last : Storage_Offset;
+ Num : Unsigned_32;
+
+ Tag : Unsigned_32;
+ Name : Unsigned_32;
+ Form : Unsigned_32;
+
+ Level : Unsigned_8;
+ begin
+ Abbrev_Index := Get_Section_By_Name (File, ".debug_abbrev");
+ Abbrev_Base := Get_Section_Base (File, Abbrev_Index);
+ Map := null;
+
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Put_Line ("Compilation unit at #"
+ & Hex_Image (Unsigned_32 (Off)) & ":");
+ Read_Word4 (Base, Off, Len);
+ Last := Off + Storage_Offset (Len);
+ Read_Word2 (Base, Off, Ver);
+ Read_Word4 (Base, Off, Abbrev_Off);
+ Read_Byte (Base, Off, Ptr_Sz);
+ Put (' ');
+ Put ("length: " & Hex_Image (Len));
+ Put (", version: " & Hex_Image (Ver));
+ Put (", abbrev offset: " & Hex_Image (Abbrev_Off));
+ Put (", ptr_sz: " & Hex_Image (Ptr_Sz));
+ New_Line;
+ Level := 0;
+
+ Build_Abbrev_Map (Abbrev_Base + Storage_Offset (Abbrev_Off), Map);
+ loop
+ << Again >> null;
+ exit when Off >= Last;
+ Old_Off := Off;
+ Read_ULEB128 (Base, Off, Num);
+ Put ("<" & Hex_Image (Unsigned_32 (Old_Off)) & ">");
+ Put ("<" & Hex_Image (Level) & ">");
+ Put (" with abbrev #" & Hex_Image (Num));
+ if Num = 0 then
+ Level := Level - 1;
+ New_Line;
+ goto Again;
+ end if;
+ if Num <= Map.all'Last then
+ Abbrev := Map (Num);
+ else
+ Abbrev := Null_Address;
+ end if;
+ if Abbrev = Null_Address then
+ New_Line;
+ Put ("!! abbrev #" & Hex_Image (Num) & " does not exist !!");
+ New_Line;
+ return;
+ end if;
+ Aoff := 0;
+ Read_ULEB128 (Abbrev, Aoff, Tag);
+ if Read_Byte (Abbrev + Aoff) /= 0 then
+ Put (" [has_child]");
+ Level := Level + 1;
+ end if;
+ New_Line;
+
+ -- skip child.
+ Aoff := Aoff + 1;
+ Put (" tag: " & Hex_Image (Tag));
+ Put (" (");
+ Put (Get_Dwarf_Tag_Name (Tag));
+ Put (")");
+ New_Line;
+
+ loop
+ Read_ULEB128 (Abbrev, Aoff, Name);
+ Read_ULEB128 (Abbrev, Aoff, Form);
+ exit when Name = 0 and Form = 0;
+ Put (" ");
+ Put (Get_Dwarf_At_Name (Name));
+ Set_Col (24);
+ Put (": ");
+ Old_Off := Off;
+ Disp_Dwarf_Form (Base, Off, Form);
+ case Name is
+ when DW_AT_Encoding =>
+ Put (": ");
+ Disp_Dwarf_Encoding (Base, Old_Off, Form);
+ when DW_AT_Location
+ | DW_AT_Frame_Base
+ | DW_AT_Data_Member_Location =>
+ Put (":");
+ Disp_Dwarf_Location (Base, Old_Off, Form);
+ when DW_AT_Language =>
+ Put (": ");
+ Disp_Dwarf_Language (Base, Old_Off, Form);
+ when others =>
+ null;
+ end case;
+ New_Line;
+ end loop;
+ end loop;
+ Unchecked_Deallocation (Map);
+ New_Line;
+ end loop;
+ end Disp_Debug_Info;
+
+ function Get_Phdr_Type_Name (Ptype : Elf_Word) return String is
+ begin
+ case Ptype is
+ when PT_NULL =>
+ return "NULL";
+ when PT_LOAD =>
+ return "LOAD";
+ when PT_DYNAMIC =>
+ return "DYNAMIC";
+ when PT_INTERP =>
+ return "INTERP";
+ when PT_NOTE =>
+ return "NOTE";
+ when PT_SHLIB =>
+ return "SHLIB";
+ when PT_PHDR =>
+ return "PHDR";
+ when PT_TLS =>
+ return "TLS";
+ when PT_NUM =>
+ return "NUM";
+ when PT_GNU_EH_FRAME =>
+ return "GNU_EH_FRAME";
+ when PT_SUNWBSS =>
+ return "SUNWBSS";
+ when PT_SUNWSTACK =>
+ return "SUNWSTACK";
+ when others =>
+ return "?unknown?";
+ end case;
+ end Get_Phdr_Type_Name;
+
+ procedure Disp_Phdr (Phdr : Elf_Phdr)
+ is
+ begin
+ Put ("type : " & Hex_Image (Phdr.P_Type));
+ Put (" ");
+ Put (Get_Phdr_Type_Name (Phdr.P_Type));
+ New_Line;
+ Put ("offset: " & Hex_Image (Phdr.P_Offset));
+ Put (" vaddr: " & Hex_Image (Phdr.P_Vaddr));
+ Put (" paddr: " & Hex_Image (Phdr.P_Paddr));
+ New_Line;
+ Put ("filesz: " & Hex_Image (Phdr.P_Filesz));
+ Put (" memsz: " & Hex_Image (Phdr.P_Memsz));
+ Put (" align: " & Hex_Image (Phdr.P_Align));
+ --New_Line;
+ Put (" flags: " & Hex_Image (Phdr.P_Flags));
+ Put (" (");
+ if (Phdr.P_Flags and PF_X) /= 0 then
+ Put ('X');
+ end if;
+ if (Phdr.P_Flags and PF_W) /= 0 then
+ Put ('W');
+ end if;
+ if (Phdr.P_Flags and PF_R) /= 0 then
+ Put ('R');
+ end if;
+ Put (")");
+ New_Line;
+ end Disp_Phdr;
+
+ procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+ B : Unsigned_8;
+
+ Len : Unsigned_32;
+ Ver : Unsigned_16;
+ Info_Off : Unsigned_32;
+ Info_Length : Unsigned_32;
+ Last : Storage_Offset;
+ Ioff : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Word4 (Base, Off, Len);
+ Last := Off + Storage_Offset (Len);
+ Read_Word2 (Base, Off, Ver);
+ Read_Word4 (Base, Off, Info_Off);
+ Read_Word4 (Base, Off, Info_Length);
+ Put ("length: " & Hex_Image (Len));
+ Put (", version: " & Hex_Image (Ver));
+ Put (", offset: " & Hex_Image (Info_Off));
+ Put (", length: " & Hex_Image (Info_Length));
+ New_Line;
+
+ loop
+ Read_Word4 (Base, Off, Ioff);
+ Put (" ");
+ Put (Hex_Image (Ioff));
+ if Ioff /= 0 then
+ Put (": ");
+ loop
+ Read_Byte (Base, Off, B);
+ exit when B = 0;
+ Put (Character'Val (B));
+ end loop;
+ end if;
+ New_Line;
+ exit when Ioff = 0;
+ end loop;
+ end loop;
+ end Disp_Debug_Pubnames;
+
+ procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+
+ Set_Len : Unsigned_32;
+ Ver : Unsigned_16;
+ Info_Off : Unsigned_32;
+ Last : Storage_Offset;
+ Addr_Sz : Unsigned_8;
+ Seg_Sz : Unsigned_8;
+ Pad : Unsigned_32;
+
+ Addr : Unsigned_32;
+ Len : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Word4 (Base, Off, Set_Len);
+ Last := Off + Storage_Offset (Set_Len);
+ Read_Word2 (Base, Off, Ver);
+ Read_Word4 (Base, Off, Info_Off);
+ Read_Byte (Base, Off, Addr_Sz);
+ Read_Byte (Base, Off, Seg_Sz);
+ Read_Word4 (Base, Off, Pad);
+ Put ("length: " & Hex_Image (Set_Len));
+ Put (", version: " & Hex_Image (Ver));
+ Put (", offset: " & Hex_Image (Info_Off));
+ Put (", ptr_sz: " & Hex_Image (Addr_Sz));
+ Put (", seg_sz: " & Hex_Image (Seg_Sz));
+ New_Line;
+
+ loop
+ Read_Word4 (Base, Off, Addr);
+ Read_Word4 (Base, Off, Len);
+ Put (" ");
+ Put (Hex_Image (Addr));
+ Put ('+');
+ Put (Hex_Image (Len));
+ New_Line;
+ exit when Addr = 0 and Len = 0;
+ end loop;
+ end loop;
+ end Disp_Debug_Aranges;
+
+ procedure Disp_String (Base : Address; Off : in out Storage_Offset)
+ is
+ B : Unsigned_8;
+ begin
+ loop
+ B := Read_Byte (Base + Off);
+ Off := Off + 1;
+ exit when B = 0;
+ Put (Character'Val (B));
+ end loop;
+ end Disp_String;
+
+ procedure Read_String (Base : Address; Off : in out Storage_Offset)
+ is
+ B : Unsigned_8;
+ begin
+ loop
+ Read_Byte (Base, Off, B);
+ exit when B = 0;
+ end loop;
+ end Read_String;
+
+ function Get_Dwarf_LNS_Name (Lns : Unsigned_8) return String
+ is
+ use Dwarf;
+ begin
+ case Lns is
+ when DW_LNS_Copy =>
+ return "copy";
+ when DW_LNS_Advance_Pc =>
+ return "advance_pc";
+ when DW_LNS_Advance_Line =>
+ return "advance_line";
+ when DW_LNS_Set_File =>
+ return "set_file";
+ when DW_LNS_Set_Column =>
+ return "set_column";
+ when DW_LNS_Negate_Stmt =>
+ return "negate_stmt";
+ when DW_LNS_Set_Basic_Block =>
+ return "set_basic_block";
+ when DW_LNS_Const_Add_Pc =>
+ return "const_add_pc";
+ when DW_LNS_Fixed_Advance_Pc =>
+ return "fixed_advance_pc";
+ when DW_LNS_Set_Prologue_End =>
+ return "set_prologue_end";
+ when DW_LNS_Set_Epilogue_Begin =>
+ return "set_epilogue_begin";
+ when DW_LNS_Set_Isa =>
+ return "set_isa";
+ when others =>
+ return "?unknown?";
+ end case;
+ end Get_Dwarf_LNS_Name;
+
+ procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half)
+ is
+ use Dwarf;
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+
+ type Opc_Length_Type is array (Unsigned_8 range <>) of Unsigned_8;
+ type Opc_Length_Acc is access Opc_Length_Type;
+ Opc_Length : Opc_Length_Acc;
+
+ Total_Len : Unsigned_32;
+ Version : Unsigned_16;
+ Prolog_Len : Unsigned_32;
+ Min_Insn_Len : Unsigned_8;
+ Dflt_Is_Stmt : Unsigned_8;
+ Line_Base : Unsigned_8;
+ Line_Range : Unsigned_8;
+ Opc_Base : Unsigned_8;
+
+ B : Unsigned_8;
+ Arg : Unsigned_32;
+
+ Old_Off : Storage_Offset;
+ File_Dir : Unsigned_32;
+ File_Time : Unsigned_32;
+ File_Len : Unsigned_32;
+
+ Ext_Len : Unsigned_32;
+ Ext_Opc : Unsigned_8;
+
+ Last : Storage_Offset;
+
+ Pc : Unsigned_32;
+ Line : Unsigned_32;
+ Line_Base2 : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Word4 (Base, Off, Total_Len);
+ Last := Off + Storage_Offset (Total_Len);
+ Read_Word2 (Base, Off, Version);
+ Read_Word4 (Base, Off, Prolog_Len);
+ Read_Byte (Base, Off, Min_Insn_Len);
+ Read_Byte (Base, Off, Dflt_Is_Stmt);
+ Read_Byte (Base, Off, Line_Base);
+ Read_Byte (Base, Off, Line_Range);
+ Read_Byte (Base, Off, Opc_Base);
+
+ Pc := 0;
+ Line := 1;
+
+ Put ("length: " & Hex_Image (Total_Len));
+ Put (", version: " & Hex_Image (Version));
+ Put (", prolog_len: " & Hex_Image (Prolog_Len));
+ New_Line;
+ Put (" minimum_instruction_len: " & Hex_Image (Min_Insn_Len));
+ Put (", default_is_stmt: " & Hex_Image (Dflt_Is_Stmt));
+ New_Line;
+ Put (" line_base: " & Hex_Image (Line_Base));
+ Put (", line_range: " & Hex_Image (Line_Range));
+ Put (", opc_base: " & Hex_Image (Opc_Base));
+ New_Line;
+ Line_Base2 := Unsigned_32 (Line_Base);
+ if (Line_Base and 16#80#) /= 0 then
+ Line_Base2 := Line_Base2 or 16#Ff_Ff_Ff_00#;
+ end if;
+ Put_Line ("standard_opcode_length:");
+ Opc_Length := new Opc_Length_Type (1 .. Opc_Base - 1);
+ for I in 1 .. Opc_Base - 1 loop
+ Read_Byte (Base, Off, B);
+ Put (' ');
+ Put (Hex_Image (I));
+ Put (" => ");
+ Put (Hex_Image (B));
+ Opc_Length (I) := B;
+ New_Line;
+ end loop;
+ Put_Line ("include_directories:");
+ loop
+ B := Read_Byte (Base + Off);
+ exit when B = 0;
+ Put (' ');
+ Disp_String (Base, Off);
+ New_Line;
+ end loop;
+ Off := Off + 1;
+ Put_Line ("file_names:");
+ loop
+ B := Read_Byte (Base + Off);
+ exit when B = 0;
+ Old_Off := Off;
+ Read_String (Base, Off);
+ Read_ULEB128 (Base, Off, File_Dir);
+ Read_ULEB128 (Base, Off, File_Time);
+ Read_ULEB128 (Base, Off, File_Len);
+ Put (' ');
+ Put (Hex_Image (File_Dir));
+ Put (' ');
+ Put (Hex_Image (File_Time));
+ Put (' ');
+ Put (Hex_Image (File_Len));
+ Put (' ');
+ Disp_String (Base, Old_Off);
+ New_Line;
+ end loop;
+ Off := Off + 1;
+
+ while Off < Last loop
+ Put (" ");
+ Read_Byte (Base, Off, B);
+ Put (Hex_Image (B));
+ Old_Off := Off;
+ if B < Opc_Base then
+ case B is
+ when 0 =>
+ Put (" (extended)");
+ Read_ULEB128 (Base, Off, Ext_Len);
+ Put (", len: ");
+ Put (Hex_Image (Ext_Len));
+ Old_Off := Off;
+ Read_Byte (Base, Off, Ext_Opc);
+ Put (" opc:");
+ Put (Hex_Image (Ext_Opc));
+ Off := Old_Off + Storage_Offset (Ext_Len);
+ when others =>
+ Put (" (");
+ Put (Get_Dwarf_LNS_Name (B));
+ Put (")");
+ Set_Col (20);
+ for J in 1 .. Opc_Length (B) loop
+ Read_ULEB128 (Base, Off, Arg);
+ Put (" ");
+ Put (Hex_Image (Arg));
+ end loop;
+ end case;
+ case B is
+ when DW_LNS_Copy =>
+ Put (" pc=");
+ Put (Hex_Image (Pc));
+ Put (", line=");
+ Put (Unsigned_32'Image (Line));
+ when DW_LNS_Advance_Pc =>
+ Read_ULEB128 (Base, Old_Off, Arg);
+ Pc := Pc + Arg * Unsigned_32 (Min_Insn_Len);
+ Put (" pc=");
+ Put (Hex_Image (Pc));
+ when DW_LNS_Advance_Line =>
+ Read_SLEB128 (Base, Old_Off, Arg);
+ Line := Line + Arg;
+ Put (" line=");
+ Put (Unsigned_32'Image (Line));
+ when DW_LNS_Set_File =>
+ null;
+ when DW_LNS_Set_Column =>
+ null;
+ when DW_LNS_Negate_Stmt =>
+ null;
+ when DW_LNS_Set_Basic_Block =>
+ null;
+ when DW_LNS_Const_Add_Pc =>
+ Pc := Pc + Unsigned_32 ((255 - Opc_Base) / Line_Range)
+ * Unsigned_32 (Min_Insn_Len);
+ Put (" pc=");
+ Put (Hex_Image (Pc));
+ when others =>
+ null;
+ end case;
+ New_Line;
+ else
+ B := B - Opc_Base;
+ Pc := Pc + Unsigned_32 (B / Line_Range)
+ * Unsigned_32 (Min_Insn_Len);
+ Line := Line + Line_Base2 + Unsigned_32 (B mod Line_Range);
+ Put (" pc=");
+ Put (Hex_Image (Pc));
+ Put (", line=");
+ Put (Unsigned_32'Image (Line));
+ New_Line;
+ end if;
+ end loop;
+ end loop;
+ end Disp_Debug_Line;
+
+ function Get_Dwarf_Cfi_Name (Cfi : Unsigned_8) return String
+ is
+ use Dwarf;
+ begin
+ case Cfi is
+ when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max =>
+ return "advance_loc";
+ when DW_CFA_Offset_Min .. DW_CFA_Offset_Max =>
+ return "offset";
+ when DW_CFA_Restore_Min .. DW_CFA_Restore_Max =>
+ return "restore";
+ when DW_CFA_Nop =>
+ return "nop";
+ when DW_CFA_Set_Loc =>
+ return "set_loc";
+ when DW_CFA_Advance_Loc1 =>
+ return "advance_loc1";
+ when DW_CFA_Advance_Loc2 =>
+ return "advance_loc2";
+ when DW_CFA_Advance_Loc4 =>
+ return "advance_loc4";
+ when DW_CFA_Offset_Extended =>
+ return "offset_extended";
+ when DW_CFA_Restore_Extended =>
+ return "restore_extended";
+ when DW_CFA_Undefined =>
+ return "undefined";
+ when DW_CFA_Same_Value =>
+ return "same_value";
+ when DW_CFA_Register =>
+ return "register";
+ when DW_CFA_Remember_State =>
+ return "remember_state";
+ when DW_CFA_Restore_State =>
+ return "restore_state";
+ when DW_CFA_Def_Cfa =>
+ return "def_cfa";
+ when DW_CFA_Def_Cfa_Register =>
+ return "def_cfa_register";
+ when DW_CFA_Def_Cfa_Offset =>
+ return "def_cfa_offset";
+ when DW_CFA_Def_Cfa_Expression =>
+ return "def_cfa_expression";
+ when others =>
+ return "?unknown?";
+ end case;
+ end Get_Dwarf_Cfi_Name;
+
+ procedure Disp_Cfi (Base : Address; Length : Storage_Count)
+ is
+ use Dwarf;
+ L : Storage_Offset;
+ Op : Unsigned_8;
+ Off : Unsigned_32;
+ Reg : Unsigned_32;
+ begin
+ L := 0;
+ while L < Length loop
+ Op := Read_Byte (Base + L);
+ Put (" ");
+ Put (Hex_Image (Op));
+ Put (" ");
+ Put (Get_Dwarf_Cfi_Name (Op));
+ Put (" ");
+ L := L + 1;
+ case Op is
+ when DW_CFA_Nop =>
+ null;
+ when DW_CFA_Advance_Loc_Min .. DW_CFA_Advance_Loc_Max =>
+ Put (Hex_Image (Op and 16#3f#));
+ when DW_CFA_Offset_Min .. DW_CFA_Offset_Max =>
+ Read_ULEB128 (Base, L, Off);
+ Put ("reg:");
+ Put (Hex_Image (Op and 16#3f#));
+ Put (", offset:");
+ Put (Hex_Image (Off));
+ when DW_CFA_Def_Cfa =>
+ Read_ULEB128 (Base, L, Reg);
+ Read_ULEB128 (Base, L, Off);
+ Put ("reg:");
+ Put (Hex_Image (Reg));
+ Put (", offset:");
+ Put (Hex_Image (Off));
+ when DW_CFA_Def_Cfa_Offset =>
+ Read_ULEB128 (Base, L, Off);
+ Put (Hex_Image (Off));
+ when DW_CFA_Def_Cfa_Register =>
+ Read_ULEB128 (Base, L, Reg);
+ Put ("reg:");
+ Put (Hex_Image (Reg));
+ when others =>
+ Put ("?unknown?");
+ New_Line;
+ exit;
+ end case;
+ New_Line;
+ end loop;
+ end Disp_Cfi;
+
+ procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+ Old_Off : Storage_Offset;
+
+ Length : Unsigned_32;
+ Cie_Id : Unsigned_32;
+ Version : Unsigned_8;
+ Augmentation : Unsigned_8;
+ Code_Align : Unsigned_32;
+ Data_Align : Unsigned_32;
+ Ret_Addr_Reg : Unsigned_8;
+
+ Init_Loc : Unsigned_32;
+ Addr_Rng : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Word4 (Base, Off, Length);
+ Old_Off := Off;
+
+ Read_Word4 (Base, Off, Cie_Id);
+ if Cie_Id = 16#Ff_Ff_Ff_Ff# then
+ Read_Byte (Base, Off, Version);
+ Read_Byte (Base, Off, Augmentation);
+ Put ("length: ");
+ Put (Hex_Image (Length));
+ Put (", CIE_id: ");
+ Put (Hex_Image (Cie_Id));
+ Put (", version: ");
+ Put (Hex_Image (Version));
+ if Augmentation /= 0 then
+ Put (" +augmentation");
+ New_Line;
+ else
+ New_Line;
+ Read_ULEB128 (Base, Off, Code_Align);
+ Read_SLEB128 (Base, Off, Data_Align);
+ Read_Byte (Base, Off, Ret_Addr_Reg);
+ Put ("code_align: ");
+ Put (Hex_Image (Code_Align));
+ Put (", data_align: ");
+ Put (Hex_Image (Data_Align));
+ Put (", ret_addr_reg: ");
+ Put (Hex_Image (Ret_Addr_Reg));
+ New_Line;
+ Put ("initial instructions:");
+ New_Line;
+ Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off);
+ end if;
+ else
+ Read_Word4 (Base, Off, Init_Loc);
+ Read_Word4 (Base, Off, Addr_Rng);
+ Put ("length: ");
+ Put (Hex_Image (Length));
+ Put (", CIE_pointer: ");
+ Put (Hex_Image (Cie_Id));
+ Put (", address_range: ");
+ Put (Hex_Image (Init_Loc));
+ Put ("-");
+ Put (Hex_Image (Init_Loc + Addr_Rng));
+ New_Line;
+ Put ("instructions:");
+ New_Line;
+ Disp_Cfi (Base + Off, Old_Off + Storage_Offset (Length) - Off);
+ end if;
+ Off := Old_Off + Storage_Offset (Length);
+ end loop;
+ end Disp_Debug_Frame;
+
+ procedure Read_Coded (Base : Address;
+ Offset : in out Storage_Offset;
+ Code : Unsigned_8;
+ Val : out Unsigned_32)
+ is
+ use Dwarf;
+
+ V2 : Unsigned_16;
+ begin
+ if Code = DW_EH_PE_Omit then
+ return;
+ end if;
+ case Code and DW_EH_PE_Format_Mask is
+ when DW_EH_PE_Uleb128 =>
+ Read_ULEB128 (Base, Offset, Val);
+ when DW_EH_PE_Udata2 =>
+ Read_Word2 (Base, Offset, V2);
+ Val := Unsigned_32 (V2);
+ when DW_EH_PE_Udata4 =>
+ Read_Word4 (Base, Offset, Val);
+ when DW_EH_PE_Sleb128 =>
+ Read_SLEB128 (Base, Offset, Val);
+ when DW_EH_PE_Sdata2 =>
+ Read_Word2 (Base, Offset, V2);
+ Val := Unsigned_32 (V2);
+ if (V2 and 16#80_00#) /= 0 then
+ Val := Val or 16#Ff_Ff_00_00#;
+ end if;
+ when DW_EH_PE_Sdata4 =>
+ Read_Word4 (Base, Offset, Val);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Read_Coded;
+
+ procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half)
+ is
+ Shdr : Elf_Shdr_Acc;
+ Base : Address;
+ Off : Storage_Offset;
+
+ Version : Unsigned_8;
+ Eh_Frame_Ptr_Enc : Unsigned_8;
+ Fde_Count_Enc : Unsigned_8;
+ Table_Enc : Unsigned_8;
+
+ Eh_Frame_Ptr : Unsigned_32;
+ Fde_Count : Unsigned_32;
+
+ Loc : Unsigned_32;
+ Addr : Unsigned_32;
+ begin
+ Shdr := Get_Shdr (File, Index);
+ Base := Get_Section_Base (File, Shdr.all);
+
+ Off := 0;
+ while Off < Storage_Offset (Shdr.Sh_Size) loop
+ Read_Byte (Base, Off, Version);
+ Read_Byte (Base, Off, Eh_Frame_Ptr_Enc);
+ Read_Byte (Base, Off, Fde_Count_Enc);
+ Read_Byte (Base, Off, Table_Enc);
+ Put ("version: ");
+ Put (Hex_Image (Version));
+ Put (", encodings: ptr:");
+ Put (Hex_Image (Eh_Frame_Ptr_Enc));
+ Put (" count:");
+ Put (Hex_Image (Fde_Count_Enc));
+ Put (" table:");
+ Put (Hex_Image (Table_Enc));
+ New_Line;
+ Read_Coded (Base, Off, Eh_Frame_Ptr_Enc, Eh_Frame_Ptr);
+ Read_Coded (Base, Off, Fde_Count_Enc, Fde_Count);
+ Put ("eh_frame_ptr: ");
+ Put (Hex_Image (Eh_Frame_Ptr));
+ Put (", fde_count: ");
+ Put (Hex_Image (Fde_Count));
+ New_Line;
+ for I in 1 .. Fde_Count loop
+ Read_Coded (Base, Off, Table_Enc, Loc);
+ Read_Coded (Base, Off, Table_Enc, Addr);
+ Put (" init loc: ");
+ Put (Hex_Image (Loc));
+ Put (", addr : ");
+ Put (Hex_Image (Addr));
+ New_Line;
+ end loop;
+ end loop;
+ end Disp_Eh_Frame_Hdr;
+end Elfdumper;
diff --git a/src/ortho/mcode/elfdumper.ads b/src/ortho/mcode/elfdumper.ads
new file mode 100644
index 000000000..0227f0f41
--- /dev/null
+++ b/src/ortho/mcode/elfdumper.ads
@@ -0,0 +1,164 @@
+-- ELF dumper (library).
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System; use System;
+with Elf_Common; use Elf_Common;
+with Elf_Arch; use Elf_Arch;
+with Ada.Unchecked_Conversion;
+
+package Elfdumper is
+ procedure Disp_Ehdr (Ehdr : Elf_Ehdr);
+
+ type Strtab_Fat_Type is array (Elf_Size) of Character;
+ type Strtab_Fat_Acc is access all Strtab_Fat_Type;
+
+ type Strtab_Type is record
+ Base : Strtab_Fat_Acc;
+ Length : Elf_Size;
+ end record;
+
+ Null_Strtab : constant Strtab_Type := (null, 0);
+
+ Nul : constant Character := Character'Val (0);
+
+ function Get_String (Strtab : Strtab_Type; N : Elf_Size)
+ return String;
+
+ procedure Disp_Shdr (Shdr : Elf_Shdr; Sh_Strtab : Strtab_Type);
+
+ type Elf_Shdr_Array is array (Elf_Half range <>) of Elf_Shdr;
+
+ type Elf_File is limited private;
+ type Elf_File_Status is
+ (
+ -- No error.
+ Status_Ok,
+
+ -- Cannot open file.
+ Status_Open_Failure,
+
+ Status_Bad_File,
+ Status_Memory,
+ Status_Read_Error,
+ Status_Bad_Magic,
+ Status_Bad_Class
+ );
+
+ procedure Open_File (File : out Elf_File; Filename : String);
+
+ function Get_Status (File : Elf_File) return Elf_File_Status;
+
+ type Elf_Ehdr_Acc is access all Elf_Ehdr;
+
+ function Get_Ehdr (File : Elf_File) return Elf_Ehdr_Acc;
+
+ procedure Load_Shdr (File : in out Elf_File);
+
+ type Elf_Shdr_Acc is access all Elf_Shdr;
+
+ function Get_Shdr (File : Elf_File; Index : Elf_Half)
+ return Elf_Shdr_Acc;
+
+ function Get_Shdr_Type_Name (Stype : Elf_Word) return String;
+
+ procedure Load_Phdr (File : in out Elf_File);
+
+ type Elf_Phdr_Acc is access all Elf_Phdr;
+
+ function Get_Phdr (File : Elf_File; Index : Elf_Half)
+ return Elf_Phdr_Acc;
+
+ function Get_Segment_Base (File : Elf_File; Index : Elf_Half)
+ return Address;
+
+ function Get_Sh_Strtab (File : Elf_File) return Strtab_Type;
+
+ procedure Disp_Sym (File : Elf_File;
+ Sym : Elf_Sym;
+ Strtab : Strtab_Type);
+
+ procedure Disp_Symtab (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Strtab (File : Elf_File; Index : Elf_Half);
+
+ function Get_Section_Name (File : Elf_File; Index : Elf_Half)
+ return String;
+
+ function Get_Section_By_Name (File : Elf_File; Name : String)
+ return Elf_Half;
+
+ procedure Disp_Debug_Abbrev (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Debug_Info (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Debug_Pubnames (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Debug_Aranges (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Debug_Line (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Debug_Frame (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Eh_Frame_Hdr (File : Elf_File; Index : Elf_Half);
+
+ procedure Disp_Phdr (Phdr : Elf_Phdr);
+
+ procedure Disp_Segment_Note (File : Elf_File; Index : Elf_Half);
+ procedure Disp_Section_Note (File : Elf_File; Index : Elf_Half);
+
+ procedure Disp_Dynamic (File : Elf_File; Index : Elf_Half);
+private
+ use System;
+
+ function To_Strtab_Fat_Acc is new Ada.Unchecked_Conversion
+ (Address, Strtab_Fat_Acc);
+
+ type String_Acc is access String;
+
+ function To_Elf_Ehdr_Acc is new Ada.Unchecked_Conversion
+ (Address, Elf_Ehdr_Acc);
+
+ function To_Elf_Phdr_Acc is new Ada.Unchecked_Conversion
+ (Address, Elf_Phdr_Acc);
+
+ function To_Elf_Shdr_Acc is new Ada.Unchecked_Conversion
+ (Address, Elf_Shdr_Acc);
+
+ type Elf_Sym_Acc is access all Elf_Sym;
+ function To_Elf_Sym_Acc is new Ada.Unchecked_Conversion
+ (Address, Elf_Sym_Acc);
+
+ type Elf_Shdr_Arr is array (Elf_Half) of Elf_Shdr;
+
+ type Elf_Shdr_Arr_Acc is access all Elf_Shdr_Arr;
+ function To_Elf_Shdr_Arr_Acc is new Ada.Unchecked_Conversion
+ (Address, Elf_Shdr_Arr_Acc);
+
+ type Elf_File is record
+ -- Name of the file.
+ Filename : String_Acc;
+
+ -- Status, used to report errors.
+ Status : Elf_File_Status;
+
+ -- Length of the file.
+ Length : Elf_Off;
+
+ -- File contents.
+ Base : Address;
+
+ Ehdr : Elf_Ehdr_Acc;
+
+ Shdr_Base : Address;
+ Sh_Strtab : Strtab_Type;
+
+ Phdr_Base : Address;
+ end record;
+end Elfdumper;
diff --git a/src/ortho/mcode/hex_images.adb b/src/ortho/mcode/hex_images.adb
new file mode 100644
index 000000000..a9dca324d
--- /dev/null
+++ b/src/ortho/mcode/hex_images.adb
@@ -0,0 +1,71 @@
+-- To hexadecimal conversions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+
+package body Hex_Images is
+ type Hex_Str_Type is array (0 .. 15) of Character;
+ Hexdigits : constant Hex_Str_Type := "0123456789abcdef";
+
+ function Hex_Image (B : Unsigned_8) return String is
+ Res : String (1 .. 2);
+ begin
+ for I in 1 .. 2 loop
+ Res (I) := Hexdigits
+ (Natural (Shift_Right (B, 8 - 4 * I) and 16#0f#));
+ end loop;
+ return Res;
+ end Hex_Image;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Integer_32, Target => Unsigned_32);
+
+ function Hex_Image (W : Unsigned_32) return String is
+ Res : String (1 .. 8);
+ begin
+ for I in 1 .. 8 loop
+ Res (I) := Hexdigits
+ (Natural (Shift_Right (W, 32 - 4 * I) and 16#0f#));
+ end loop;
+ return Res;
+ end Hex_Image;
+
+ function Hex_Image (W : Unsigned_64) return String is
+ Res : String (1 .. 16);
+ begin
+ for I in 1 .. 16 loop
+ Res (I) := Hexdigits
+ (Natural (Shift_Right (W, 64 - 4 * I) and 16#0f#));
+ end loop;
+ return Res;
+ end Hex_Image;
+
+ function Hex_Image (W : Unsigned_16) return String is
+ Res : String (1 .. 4);
+ begin
+ for I in 1 .. 4 loop
+ Res (I) := Hexdigits
+ (Natural (Shift_Right (W, 16 - 4 * I) and 16#0f#));
+ end loop;
+ return Res;
+ end Hex_Image;
+
+ function Hex_Image (W : Integer_32) return String is
+ begin
+ return Hex_Image (Conv (W));
+ end Hex_Image;
+end Hex_Images;
diff --git a/src/ortho/mcode/hex_images.ads b/src/ortho/mcode/hex_images.ads
new file mode 100644
index 000000000..830d2ec43
--- /dev/null
+++ b/src/ortho/mcode/hex_images.ads
@@ -0,0 +1,26 @@
+-- To hexadecimal conversions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Hex_Images is
+ function Hex_Image (W : Integer_32) return String;
+ function Hex_Image (W : Unsigned_32) return String;
+ function Hex_Image (B : Unsigned_8) return String;
+ function Hex_Image (W : Unsigned_16) return String;
+ function Hex_Image (W : Unsigned_64) return String;
+end Hex_Images;
diff --git a/src/ortho/mcode/memsegs.ads b/src/ortho/mcode/memsegs.ads
new file mode 100644
index 000000000..ff7f8947e
--- /dev/null
+++ b/src/ortho/mcode/memsegs.ads
@@ -0,0 +1,3 @@
+with Memsegs_Mmap;
+package Memsegs renames Memsegs_Mmap;
+
diff --git a/src/ortho/mcode/memsegs_c.c b/src/ortho/mcode/memsegs_c.c
new file mode 100644
index 000000000..f0a0e27d5
--- /dev/null
+++ b/src/ortho/mcode/memsegs_c.c
@@ -0,0 +1,133 @@
+/* Memory segment handling.
+ Copyright (C) 2006 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+#ifndef WINNT
+
+#define _GNU_SOURCE
+#include <sys/mman.h>
+#include <stddef.h>
+/* #include <stdio.h> */
+
+/* TODO: init (get pagesize)
+ round size,
+ set rights.
+*/
+
+#ifdef __APPLE__
+#define MAP_ANONYMOUS MAP_ANON
+#else
+#define HAVE_MREMAP
+#endif
+
+#ifndef HAVE_MREMAP
+#include <string.h>
+#endif
+
+void *
+mmap_malloc (int size)
+{
+ void *res;
+ res = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ /* printf ("mmap (%d) = %p\n", size, res); */
+ if (res == MAP_FAILED)
+ return NULL;
+ return res;
+}
+
+void *
+mmap_realloc (void *ptr, int old_size, int size)
+{
+ void *res;
+#ifdef HAVE_MREMAP
+ res = mremap (ptr, old_size, size, MREMAP_MAYMOVE);
+#else
+ res = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ if (res == MAP_FAILED)
+ return NULL;
+ memcpy (res, ptr, old_size);
+ munmap (ptr, old_size);
+#endif
+ /* printf ("mremap (%p, %d, %d) = %p\n", ptr, old_size, size, res); */
+#if 0
+ if (res == MAP_FAILED)
+ return NULL;
+#endif
+ return res;
+}
+
+void
+mmap_free (void * ptr, int size)
+{
+ munmap (ptr, size);
+}
+
+void
+mmap_rx (void *ptr, int size)
+{
+ mprotect (ptr, size, PROT_READ | PROT_EXEC);
+}
+
+#else
+#include <windows.h>
+
+void *
+mmap_malloc (int size)
+{
+ void *res;
+ res = VirtualAlloc (NULL, size,
+ MEM_COMMIT | MEM_RESERVE,
+ PAGE_READWRITE);
+ return res;
+}
+
+void *
+mmap_realloc (void *ptr, int old_size, int size)
+{
+ void *res;
+
+ res = VirtualAlloc (NULL, size,
+ MEM_COMMIT | MEM_RESERVE,
+ PAGE_READWRITE);
+
+ if (ptr != NULL)
+ {
+ CopyMemory (res, ptr, size > old_size ? old_size : size);
+ VirtualFree (ptr, old_size, MEM_RELEASE);
+ }
+
+ return res;
+}
+
+void
+mmap_free (void * ptr, int size)
+{
+ VirtualFree (ptr, size, MEM_RELEASE);
+}
+
+void
+mmap_rx (void *ptr, int size)
+{
+ DWORD old;
+
+ /* This is not supported on every version.
+ In case of failure, this should still work. */
+ VirtualProtect (ptr, size, PAGE_EXECUTE_READ, &old);
+}
+#endif
diff --git a/src/ortho/mcode/memsegs_mmap.adb b/src/ortho/mcode/memsegs_mmap.adb
new file mode 100644
index 000000000..1ee8e7bcf
--- /dev/null
+++ b/src/ortho/mcode/memsegs_mmap.adb
@@ -0,0 +1,64 @@
+-- Memory segments.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Memsegs_Mmap is
+ function Mmap_Malloc (Size : Natural) return Address;
+ pragma Import (C, Mmap_Malloc, "mmap_malloc");
+
+ function Mmap_Realloc (Ptr : Address; Old_Size : Natural; Size : Natural)
+ return Address;
+ pragma Import (C, Mmap_Realloc, "mmap_realloc");
+
+ procedure Mmap_Free (Ptr : Address; Size : Natural);
+ pragma Import (C, Mmap_Free, "mmap_free");
+
+ procedure Mmap_Rx (Ptr : Address; Size : Natural);
+ pragma Import (C, Mmap_Rx, "mmap_rx");
+
+ function Create return Memseg_Type is
+ begin
+ return (Base => Null_Address, Size => 0);
+ end Create;
+
+ procedure Resize (Seg : in out Memseg_Type; Size : Natural) is
+ begin
+ if Seg.Size = 0 then
+ Seg.Base := Mmap_Malloc (Size);
+ else
+ Seg.Base := Mmap_Realloc (Seg.Base, Seg.Size, Size);
+ end if;
+ Seg.Size := Size;
+ end Resize;
+
+ function Get_Address (Seg : Memseg_Type) return Address is
+ begin
+ return Seg.Base;
+ end Get_Address;
+
+ procedure Delete (Seg : in out Memseg_Type) is
+ begin
+ Mmap_Free (Seg.Base, Seg.Size);
+ Seg.Base := Null_Address;
+ Seg.Size := 0;
+ end Delete;
+
+ procedure Set_Rx (Seg : in out Memseg_Type) is
+ begin
+ Mmap_Rx (Seg.Base, Seg.Size);
+ end Set_Rx;
+end Memsegs_Mmap;
+
diff --git a/src/ortho/mcode/memsegs_mmap.ads b/src/ortho/mcode/memsegs_mmap.ads
new file mode 100644
index 000000000..ba7d76618
--- /dev/null
+++ b/src/ortho/mcode/memsegs_mmap.ads
@@ -0,0 +1,49 @@
+-- Memory segments.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System; use System;
+
+package Memsegs_Mmap is
+ -- A memseg is a growable memory space. It can be resized with Resize.
+ -- After each operation the base address can change and must be get
+ -- with Get_Address.
+ type Memseg_Type is private;
+
+ -- Create a new memseg.
+ function Create return Memseg_Type;
+
+ -- Resize the memseg.
+ procedure Resize (Seg : in out Memseg_Type; Size : Natural);
+
+ -- Get the base address.
+ function Get_Address (Seg : Memseg_Type) return Address;
+
+ -- Free all the memory and initialize the memseg.
+ procedure Delete (Seg : in out Memseg_Type);
+
+ -- Set the protection to read+execute.
+ procedure Set_Rx (Seg : in out Memseg_Type);
+
+ pragma Inline (Create);
+ pragma Inline (Get_Address);
+private
+ type Memseg_Type is record
+ Base : Address := Null_Address;
+ Size : Natural := 0;
+ end record;
+end Memsegs_Mmap;
+
diff --git a/src/ortho/mcode/ortho_code-abi.ads b/src/ortho/mcode/ortho_code-abi.ads
new file mode 100644
index 000000000..e75b08509
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-abi.ads
@@ -0,0 +1,3 @@
+with Ortho_Code.X86.Abi;
+
+package Ortho_Code.Abi renames Ortho_Code.X86.Abi;
diff --git a/src/ortho/mcode/ortho_code-binary.adb b/src/ortho/mcode/ortho_code-binary.adb
new file mode 100644
index 000000000..7bb6bdd28
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-binary.adb
@@ -0,0 +1,37 @@
+-- Interface with binary writer for mcode.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Decls;
+with Ortho_Code.Exprs;
+
+package body Ortho_Code.Binary is
+ function Get_Decl_Symbol (Decl : O_Dnode) return Symbol
+ is
+ begin
+ return To_Symbol (Decls.Get_Decl_Info (Decl));
+ end Get_Decl_Symbol;
+
+ function Get_Label_Symbol (Label : O_Enode) return Symbol is
+ begin
+ return To_Symbol (Exprs.Get_Label_Info (Label));
+ end Get_Label_Symbol;
+
+ procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol) is
+ begin
+ Exprs.Set_Label_Info (Label, To_Int32 (Sym));
+ end Set_Label_Symbol;
+end Ortho_Code.Binary;
diff --git a/src/ortho/mcode/ortho_code-binary.ads b/src/ortho/mcode/ortho_code-binary.ads
new file mode 100644
index 000000000..58c79d3b2
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-binary.ads
@@ -0,0 +1,31 @@
+-- Interface with binary writer for mcode.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Binary_File; use Binary_File;
+
+package Ortho_Code.Binary is
+ function To_Symbol is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => Symbol);
+
+ function To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Symbol, Target => Int32);
+
+ function Get_Decl_Symbol (Decl : O_Dnode) return Symbol;
+ function Get_Label_Symbol (Label : O_Enode) return Symbol;
+ procedure Set_Label_Symbol (Label : O_Enode; Sym : Symbol);
+end Ortho_Code.Binary;
+
diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb
new file mode 100644
index 000000000..d09a13c34
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-consts.adb
@@ -0,0 +1,559 @@
+-- Mcode back-end for ortho - Constants handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+with GNAT.Table;
+with Ada.Text_IO;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Debug;
+
+package body Ortho_Code.Consts is
+ type Cnode_Common is record
+ Kind : OC_Kind;
+ Lit_Type : O_Tnode;
+ end record;
+ for Cnode_Common use record
+ Kind at 0 range 0 .. 31;
+ Lit_Type at 4 range 0 .. 31;
+ end record;
+ for Cnode_Common'Size use 64;
+
+ type Cnode_Signed is record
+ Val : Integer_64;
+ end record;
+ for Cnode_Signed'Size use 64;
+
+ type Cnode_Unsigned is record
+ Val : Unsigned_64;
+ end record;
+ for Cnode_Unsigned'Size use 64;
+
+ type Cnode_Float is record
+ Val : IEEE_Float_64;
+ end record;
+ for Cnode_Float'Size use 64;
+
+ type Cnode_Enum is record
+ Id : O_Ident;
+ Val : Uns32;
+ end record;
+ for Cnode_Enum'Size use 64;
+
+ type Cnode_Addr is record
+ Decl : O_Dnode;
+ Pad : Int32;
+ end record;
+ for Cnode_Addr'Size use 64;
+
+ type Cnode_Aggr is record
+ Els : Int32;
+ Nbr : Int32;
+ end record;
+ for Cnode_Aggr'Size use 64;
+
+ type Cnode_Sizeof is record
+ Atype : O_Tnode;
+ Pad : Int32;
+ end record;
+ for Cnode_Sizeof'Size use 64;
+
+ type Cnode_Union is record
+ El : O_Cnode;
+ Field : O_Fnode;
+ end record;
+ for Cnode_Union'Size use 64;
+
+ package Cnodes is new GNAT.Table
+ (Table_Component_Type => Cnode_Common,
+ Table_Index_Type => O_Cnode,
+ Table_Low_Bound => 2,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is
+ begin
+ return Cnodes.Table (Cst).Kind;
+ end Get_Const_Kind;
+
+ function Get_Const_Type (Cst : O_Cnode) return O_Tnode is
+ begin
+ return Cnodes.Table (Cst).Lit_Type;
+ end Get_Const_Type;
+
+ function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64
+ is
+ function To_Cnode_Unsigned is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Unsigned);
+ begin
+ return To_Cnode_Unsigned (Cnodes.Table (Cst + 1)).Val;
+ end Get_Const_U64;
+
+ function Get_Const_I64 (Cst : O_Cnode) return Integer_64
+ is
+ function To_Cnode_Signed is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Signed);
+ begin
+ return To_Cnode_Signed (Cnodes.Table (Cst + 1)).Val;
+ end Get_Const_I64;
+
+ function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64
+ is
+ function To_Cnode_Float is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Float);
+ begin
+ return To_Cnode_Float (Cnodes.Table (Cst + 1)).Val;
+ end Get_Const_F64;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Signed, Target => Cnode_Common);
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Signed,
+ Lit_Type => Ltype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Signed'(Val => Value)));
+ return Res;
+ end New_Signed_Literal;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Unsigned_64, Target => Cnode_Common);
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Unsigned,
+ Lit_Type => Ltype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Value));
+ return Res;
+ end New_Unsigned_Literal;
+
+-- function Get_Const_Literal (Cst : O_Cnode) return Uns32 is
+-- begin
+-- return Cnodes.Table (Cst).Val;
+-- end Get_Const_Literal;
+
+ function To_Uns64 is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Uns64);
+
+ function Get_Const_U32 (Cst : O_Cnode) return Uns32 is
+ begin
+ return Uns32 (To_Uns64 (Cnodes.Table (Cst + 1)));
+ end Get_Const_U32;
+
+ function Get_Const_R64 (Cst : O_Cnode) return Uns64 is
+ begin
+ return To_Uns64 (Cnodes.Table (Cst + 1));
+ end Get_Const_R64;
+
+ function Get_Const_Low (Cst : O_Cnode) return Uns32
+ is
+ V : Uns64;
+ begin
+ V := Get_Const_R64 (Cst);
+ return Uns32 (V and 16#Ffff_Ffff#);
+ end Get_Const_Low;
+
+ function Get_Const_High (Cst : O_Cnode) return Uns32
+ is
+ V : Uns64;
+ begin
+ V := Get_Const_R64 (Cst);
+ return Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#);
+ end Get_Const_High;
+
+ function Get_Const_Low (Cst : O_Cnode) return Int32
+ is
+ V : Uns64;
+ begin
+ V := Get_Const_R64 (Cst);
+ return To_Int32 (Uns32 (V and 16#Ffff_Ffff#));
+ end Get_Const_Low;
+
+ function Get_Const_High (Cst : O_Cnode) return Int32
+ is
+ V : Uns64;
+ begin
+ V := Get_Const_R64 (Cst);
+ return To_Int32 (Uns32 (Shift_Right (V, 32) and 16#Ffff_Ffff#));
+ end Get_Const_High;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Float, Target => Cnode_Common);
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Float,
+ Lit_Type => Ltype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Float'(Val => Value)));
+ return Res;
+ end New_Float_Literal;
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Null,
+ Lit_Type => Ltype));
+ return Cnodes.Last;
+ end New_Null_Access;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Addr, Target => Cnode_Common);
+
+ function To_Cnode_Addr is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Addr);
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Address,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl,
+ Pad => 0)));
+ return Res;
+ end New_Global_Unchecked_Address;
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Address,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl,
+ Pad => 0)));
+ return Res;
+ end New_Global_Address;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Subprg_Address,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Subprg,
+ Pad => 0)));
+ return Res;
+ end New_Subprogram_Address;
+
+ function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is
+ begin
+ return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl;
+ end Get_Const_Decl;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Enum, Target => Cnode_Common);
+
+ function To_Cnode_Enum is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Enum);
+
+ --function Get_Named_Literal_Id (Lit : O_Cnode) return O_Ident is
+ --begin
+ -- return To_Cnode_Enum (Cnodes.Table (Lit + 1)).Id;
+ --end Get_Named_Literal_Id;
+
+ function New_Named_Literal
+ (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode)
+ return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Cnodes.Append (Cnode_Common'(Kind => OC_Lit,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Enum'(Id => Id,
+ Val => Val)));
+ if Prev /= O_Cnode_Null then
+ if Prev + 2 /= Res then
+ raise Syntax_Error;
+ end if;
+ end if;
+ return Res;
+ end New_Named_Literal;
+
+ function Get_Lit_Ident (L : O_Cnode) return O_Ident is
+ begin
+ return To_Cnode_Enum (Cnodes.Table (L + 1)).Id;
+ end Get_Lit_Ident;
+
+ function Get_Lit_Value (L : O_Cnode) return Uns32 is
+ begin
+ return To_Cnode_Enum (Cnodes.Table (L + 1)).Val;
+ end Get_Lit_Value;
+
+ function Get_Lit_Chain (L : O_Cnode) return O_Cnode is
+ begin
+ return L + 2;
+ end Get_Lit_Chain;
+
+ package Els is new GNAT.Table
+ (Table_Component_Type => O_Cnode,
+ Table_Index_Type => Int32,
+ Table_Low_Bound => 2,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Aggr, Target => Cnode_Common);
+
+ function To_Cnode_Aggr is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Aggr);
+
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode)
+ is
+ Val : Int32;
+ Num : Uns32;
+ begin
+ Num := Get_Type_Record_Nbr_Fields (Atype);
+ Val := Els.Allocate (Integer (Num));
+
+ Cnodes.Append (Cnode_Common'(Kind => OC_Record,
+ Lit_Type => Atype));
+ List := (Res => Cnodes.Last,
+ Rec_Field => Get_Type_Record_Fields (Atype),
+ El => Val);
+ Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val,
+ Nbr => Int32 (Num))));
+ end Start_Record_Aggr;
+
+
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode)
+ is
+ begin
+ Els.Table (List.El) := Value;
+ List.El := List.El + 1;
+ end New_Record_Aggr_El;
+
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode) is
+ begin
+ Res := List.Res;
+ end Finish_Record_Aggr;
+
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
+ is
+ Val : Int32;
+ Num : Uns32;
+ begin
+ Num := Get_Type_Subarray_Length (Atype);
+ Val := Els.Allocate (Integer (Num));
+
+ Cnodes.Append (Cnode_Common'(Kind => OC_Array,
+ Lit_Type => Atype));
+ List := (Res => Cnodes.Last,
+ El => Val);
+ Cnodes.Append (To_Cnode_Common (Cnode_Aggr'(Els => Val,
+ Nbr => Int32 (Num))));
+ end Start_Array_Aggr;
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode)
+ is
+ begin
+ Els.Table (List.El) := Value;
+ List.El := List.El + 1;
+ 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 Get_Const_Aggr_Length (Cst : O_Cnode) return Int32 is
+ begin
+ return To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Nbr;
+ end Get_Const_Aggr_Length;
+
+ function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode
+ is
+ El : Int32;
+ begin
+ El := To_Cnode_Aggr (Cnodes.Table (Cst + 1)).Els;
+ return Els.Table (El + N);
+ end Get_Const_Aggr_Element;
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode
+ is
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Union, Target => Cnode_Common);
+
+ Res : O_Cnode;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Union,
+ Lit_Type => Atype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Union'(El => Value,
+ Field => Field)));
+ return Res;
+ else
+ return Value;
+ end if;
+ end New_Union_Aggr;
+
+ function To_Cnode_Union is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Union);
+
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).Field;
+ end Get_Const_Union_Field;
+
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode is
+ begin
+ return To_Cnode_Union (Cnodes.Table (Cst + 1)).El;
+ end Get_Const_Union_Value;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Sizeof, Target => Cnode_Common);
+
+ Res : O_Cnode;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Sizeof,
+ Lit_Type => Rtype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype,
+ Pad => 0)));
+ return Res;
+ else
+ return New_Unsigned_Literal
+ (Rtype, Unsigned_64 (Get_Type_Size (Atype)));
+ end if;
+ end New_Sizeof;
+
+ function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode
+ is
+ function To_Cnode_Sizeof is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Sizeof);
+ begin
+ return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype;
+ end Get_Sizeof_Type;
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Sizeof, Target => Cnode_Common);
+
+ Res : O_Cnode;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Alignof,
+ Lit_Type => Rtype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype,
+ Pad => 0)));
+ return Res;
+ else
+ return New_Unsigned_Literal
+ (Rtype, Unsigned_64 (Get_Type_Align_Bytes (Atype)));
+ end if;
+ end New_Alignof;
+
+ function Get_Alignof_Type (Cst : O_Cnode) return O_Tnode
+ is
+ function To_Cnode_Sizeof is new Ada.Unchecked_Conversion
+ (Cnode_Common, Cnode_Sizeof);
+ begin
+ return To_Cnode_Sizeof (Cnodes.Table (Cst + 1)).Atype;
+ end Get_Alignof_Type;
+
+ function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ if Get_Field_Parent (Field) /= Rec_Type then
+ raise Syntax_Error;
+ end if;
+ return New_Unsigned_Literal
+ (Rtype, Unsigned_64 (Get_Field_Offset (Field)));
+ end New_Offsetof;
+
+ procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is
+ begin
+ case Get_Const_Kind (Cst) is
+ when OC_Signed
+ | OC_Unsigned
+ | OC_Float =>
+ H := Get_Const_High (Cst);
+ L := Get_Const_Low (Cst);
+ when OC_Null =>
+ H := 0;
+ L := 0;
+ when OC_Lit =>
+ H := 0;
+ L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val;
+ when OC_Array
+ | OC_Record
+ | OC_Union
+ | OC_Sizeof
+ | OC_Alignof
+ | OC_Address
+ | OC_Subprg_Address =>
+ raise Syntax_Error;
+ end case;
+ end Get_Const_Bytes;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Cnode := Cnodes.Last;
+ M.Els := Els.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Cnodes.Set_Last (M.Cnode);
+ Els.Set_Last (M.Els);
+ end Release;
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("Number of Cnodes: " & O_Cnode'Image (Cnodes.Last));
+ Put_Line ("Number of Cnodes-Els: " & Int32'Image (Els.Last));
+ end Disp_Stats;
+
+ procedure Finish is
+ begin
+ Cnodes.Free;
+ Els.Free;
+ end Finish;
+end Ortho_Code.Consts;
diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads
new file mode 100644
index 000000000..0076bc6eb
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-consts.ads
@@ -0,0 +1,158 @@
+-- Mcode back-end for ortho - Constants handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Ortho_Code.Consts is
+ type OC_Kind is (OC_Signed, OC_Unsigned, OC_Float, OC_Lit, OC_Null,
+ OC_Array, OC_Record, OC_Union,
+ OC_Subprg_Address, OC_Address,
+ OC_Sizeof, OC_Alignof);
+
+ function Get_Const_Kind (Cst : O_Cnode) return OC_Kind;
+
+ function Get_Const_Type (Cst : O_Cnode) return O_Tnode;
+
+ -- Get bytes for signed, unsigned, float, lit, null.
+ procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32);
+
+ -- Used to set the length of a constrained type.
+ -- FIXME: check for no overflow.
+ function Get_Const_U32 (Cst : O_Cnode) return Uns32;
+
+ function Get_Const_U64 (Cst : O_Cnode) return Unsigned_64;
+ function Get_Const_I64 (Cst : O_Cnode) return Integer_64;
+
+ function Get_Const_F64 (Cst : O_Cnode) return IEEE_Float_64;
+
+ -- Get the low and high part of a constant.
+ function Get_Const_Low (Cst : O_Cnode) return Uns32;
+ function Get_Const_High (Cst : O_Cnode) return Uns32;
+
+ function Get_Const_Low (Cst : O_Cnode) return Int32;
+ function Get_Const_High (Cst : O_Cnode) return Int32;
+
+ function Get_Const_Aggr_Length (Cst : O_Cnode) return Int32;
+ function Get_Const_Aggr_Element (Cst : O_Cnode; N : Int32) return O_Cnode;
+
+ -- Only available in HLI.
+ function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode;
+ function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode;
+
+ -- Declaration for an address.
+ function Get_Const_Decl (Cst : O_Cnode) return O_Dnode;
+
+ -- Get the type from an OC_Sizeof node.
+ function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode;
+
+ -- Get the type from an OC_Alignof node.
+ function Get_Alignof_Type (Cst : O_Cnode) return O_Tnode;
+
+ -- Get the value of a named literal.
+ --function Get_Const_Literal (Cst : O_Cnode) return Uns32;
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ function New_Named_Literal
+ (Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode)
+ return O_Cnode;
+
+ -- For boolean/enum literals.
+ function Get_Lit_Ident (L : O_Cnode) return O_Ident;
+ function Get_Lit_Chain (L : O_Cnode) return O_Cnode;
+ function Get_Lit_Value (L : O_Cnode) return Uns32;
+
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record REC_TYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Rec_Type : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ procedure Disp_Stats;
+
+ type Mark_Type is limited private;
+ procedure Mark (M : out Mark_Type);
+ procedure Release (M : Mark_Type);
+
+ procedure Finish;
+private
+ type O_Array_Aggr_List is record
+ Res : O_Cnode;
+ El : Int32;
+ end record;
+
+ type O_Record_Aggr_List is record
+ Res : O_Cnode;
+ Rec_Field : O_Fnode;
+ El : Int32;
+ end record;
+
+ type Mark_Type is record
+ Cnode : O_Cnode;
+ Els : Int32;
+ end record;
+
+end Ortho_Code.Consts;
diff --git a/src/ortho/mcode/ortho_code-debug.adb b/src/ortho/mcode/ortho_code-debug.adb
new file mode 100644
index 000000000..0f3e01ab9
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-debug.adb
@@ -0,0 +1,143 @@
+-- Mcode back-end for ortho - Internal debugging.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Flags;
+
+package body Ortho_Code.Debug is
+ procedure Disp_Mode (M : Mode_Type)
+ is
+ use Ada.Text_IO;
+ begin
+ case M is
+ when Mode_U8 =>
+ Put ("U8 ");
+ when Mode_U16 =>
+ Put ("U16");
+ when Mode_U32 =>
+ Put ("U32");
+ when Mode_U64 =>
+ Put ("U64");
+ when Mode_I8 =>
+ Put ("I8 ");
+ when Mode_I16 =>
+ Put ("I16");
+ when Mode_I32 =>
+ Put ("I32");
+ when Mode_I64 =>
+ Put ("I64");
+ when Mode_X1 =>
+ Put ("xxx");
+ when Mode_Nil =>
+ Put ("Nil");
+ when Mode_F32 =>
+ Put ("F32");
+ when Mode_F64 =>
+ Put ("F64");
+ when Mode_B2 =>
+ Put ("B2 ");
+ when Mode_Blk =>
+ Put ("Blk");
+ when Mode_P32 =>
+ Put ("P32");
+ when Mode_P64 =>
+ Put ("P64");
+ end case;
+ end Disp_Mode;
+
+ procedure Set_Debug_Be_Flag (C : Character)
+ is
+ use Ada.Text_IO;
+ begin
+ case C is
+ when 'a' =>
+ Flag_Debug_Asm := True;
+ when 'b' =>
+ Flag_Debug_Body := True;
+ when 'B' =>
+ Flag_Debug_Body2 := True;
+ when 'c' =>
+ Flag_Debug_Code := True;
+ when 'C' =>
+ Flag_Debug_Code2 := True;
+ when 'd' =>
+ Flag_Debug_Dump := True;
+ when 'h' =>
+ Flag_Debug_Hex := True;
+ when 'H' =>
+ Flag_Debug_Hli := True;
+ when 'i' =>
+ Flag_Debug_Insn := True;
+ when 's' =>
+ Flag_Debug_Stat := True;
+ when 'k' =>
+ Flag_Debug_Keep := True;
+ when 't' =>
+ Flags.Flag_Type_Name := True;
+ when others =>
+ Put_Line (Standard_Error, "unknown debug be flag '" & C & "'");
+ end case;
+ end Set_Debug_Be_Flag;
+
+ procedure Set_Be_Flag (Str : String)
+ is
+ use Ada.Text_IO;
+
+ subtype Str_Type is String (1 .. Str'Length);
+ S : Str_Type renames Str;
+ begin
+ if S'Length > 11 and then S (1 .. 11) = "--be-debug=" then
+ for I in 12 .. S'Last loop
+ Set_Debug_Be_Flag (S (I));
+ end loop;
+ elsif S'Length > 10 and then S (1 .. 10) = "--be-dump=" then
+ for I in 11 .. S'Last loop
+ case S (I) is
+ when 'c' =>
+ Flag_Dump_Code := True;
+ when others =>
+ Put_Line (Standard_Error,
+ "unknown back-end dump flag '" & S (I) & "'");
+ end case;
+ end loop;
+ elsif S'Length > 10 and then S (1 .. 10) = "--be-disp=" then
+ for I in 11 .. S'Last loop
+ case S (I) is
+ when 'c' =>
+ Flag_Disp_Code := True;
+ Flags.Flag_Type_Name := True;
+ when others =>
+ Put_Line (Standard_Error,
+ "unknown back-end disp flag '" & S (I) & "'");
+ end case;
+ end loop;
+ elsif S'Length > 9 and then S (1 .. 9) = "--be-opt=" then
+ for I in 10 .. S'Last loop
+ case S (I) is
+ when 'O' =>
+ Flags.Flag_Optimize := True;
+ when 'b' =>
+ Flags.Flag_Opt_BB := True;
+ when others =>
+ Put_Line (Standard_Error,
+ "unknown back-end opt flag '" & S (I) & "'");
+ end case;
+ end loop;
+ else
+ Put_Line (Standard_Error, "unknown back-end option " & Str);
+ end if;
+ end Set_Be_Flag;
+end Ortho_Code.Debug;
diff --git a/src/ortho/mcode/ortho_code-debug.ads b/src/ortho/mcode/ortho_code-debug.ads
new file mode 100644
index 000000000..03f550ac9
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-debug.ads
@@ -0,0 +1,70 @@
+-- Mcode back-end for ortho - Internal debugging.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+
+package Ortho_Code.Debug is
+ package Int32_IO is new Ada.Text_IO.Integer_IO (Ortho_Code.Int32);
+
+ procedure Disp_Mode (M : Mode_Type);
+
+ -- Set a debug flag.
+ procedure Set_Debug_Be_Flag (C : Character);
+
+ -- any '--be-XXX=YY' option.
+ procedure Set_Be_Flag (Str : String);
+
+ -- c: tree created, before any back-end.
+ Flag_Disp_Code : Boolean := False;
+ Flag_Dump_Code : Boolean := False;
+
+ -- a: disp assembly code.
+ Flag_Debug_Asm : Boolean := False;
+
+ -- A: do internal checks (assertions).
+ Flag_Debug_Assert : Boolean := True;
+
+ -- b: disp top-level subprogram body before code generation.
+ Flag_Debug_Body : Boolean := False;
+
+ -- B: disp top-level subprogram body after code generation.
+ Flag_Debug_Body2 : Boolean := False;
+
+ -- c: display generated code.
+ Flag_Debug_Code : Boolean := False;
+
+ -- C: display generated code just before asm.
+ Flag_Debug_Code2 : Boolean := False;
+
+ -- h: disp bytes generated (in hexa).
+ Flag_Debug_Hex : Boolean := False;
+
+ -- H: generate high-level instructions.
+ Flag_Debug_Hli : Boolean := False;
+
+ -- r: raw dump, do not generate code.
+ Flag_Debug_Dump : Boolean := False;
+
+ -- i: disp insns, when generated.
+ Flag_Debug_Insn : Boolean := False;
+
+ -- s: disp stats (number of nodes).
+ Flag_Debug_Stat : Boolean := False;
+
+ -- k: keep all nodes in memory (do not free).
+ Flag_Debug_Keep: Boolean := False;
+end Ortho_Code.Debug;
diff --git a/src/ortho/mcode/ortho_code-decls.adb b/src/ortho/mcode/ortho_code-decls.adb
new file mode 100644
index 000000000..fcbf0b0de
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-decls.adb
@@ -0,0 +1,783 @@
+-- Mcode back-end for ortho - Declarations handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.Table;
+with Ada.Text_IO;
+with Ortho_Ident;
+with Ortho_Code.Debug; use Ortho_Code.Debug;
+with Ortho_Code.Exprs;
+with Ortho_Code.Abi; use Ortho_Code.Abi;
+with Ortho_Code.Flags;
+
+package body Ortho_Code.Decls is
+ -- Common fields:
+ -- kind: 4 bits
+ -- storage: 2 bits
+ -- reg : 8 bits
+ -- depth : 16 bits
+ -- flags: addr + 9
+ -- Additionnal fields:
+ -- OD_Type: Id, dtype
+ -- OD_Var: Id, Dtype, symbol
+ -- OD_Local: Id, Dtype, offset/reg
+ -- OD_Const: Id, Dtype, Val, Symbol?
+ -- OD_Function: Id, Dtype [interfaces follows], Symbol
+ -- OD_Procedure: Id [interfaces follows], Symbol
+ -- OD_Interface: Id, Dtype, offset/reg
+ -- OD_Begin: Last
+ -- OD_Body: Decl, Stmt, Parent
+ type Dnode_Common (Kind : OD_Kind := OD_Type) is record
+ Storage : O_Storage;
+
+ -- True if the address of the declaration is taken.
+ Flag_Addr : Boolean;
+
+ Flag2 : Boolean;
+
+ Reg : O_Reg;
+
+ -- Depth of the declaration.
+ Depth : O_Depth;
+
+ case Kind is
+ when OD_Type
+ | OD_Const
+ | OD_Var
+ | OD_Local
+ | OD_Function
+ | OD_Procedure
+ | OD_Interface =>
+ -- Identifier of this declaration.
+ Id : O_Ident;
+ -- Type of this declaration.
+ Dtype : O_Tnode;
+ -- Symbol or offset.
+ Ref : Int32;
+ -- For const: the value.
+ -- For subprg: size of pushed arguments.
+ Info2 : Int32;
+ when OD_Subprg_Ext =>
+ -- Chain of interfaces.
+ Subprg_Inter : O_Dnode;
+
+ when OD_Block =>
+ -- Last declaration of this block.
+ Last : O_Dnode;
+ -- Max stack offset.
+ Block_Max_Stack : Uns32;
+ -- Infos: may be used to store symbols.
+ Block_Info1 : Int32;
+ Block_Info2 : Int32;
+ when OD_Body =>
+ -- Corresponding declaration (function/procedure).
+ Body_Decl : O_Dnode;
+ -- Entry statement for this body.
+ Body_Stmt : O_Enode;
+ -- Parent (as a body) of this body or null if at top level.
+ Body_Parent : O_Dnode;
+ Body_Info : Int32;
+ when OD_Const_Val =>
+ -- Corresponding declaration.
+ Val_Decl : O_Dnode;
+ -- Value.
+ Val_Val : O_Cnode;
+ end case;
+ end record;
+
+ Use_Subprg_Ext : constant Boolean := False;
+
+ pragma Pack (Dnode_Common);
+
+ package Dnodes is new GNAT.Table
+ (Table_Component_Type => Dnode_Common,
+ Table_Index_Type => O_Dnode,
+ Table_Low_Bound => O_Dnode_First,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ package TDnodes is new GNAT.Table
+ (Table_Component_Type => O_Dnode,
+ Table_Index_Type => O_Tnode,
+ Table_Low_Bound => O_Tnode_First,
+ Table_Initial => 1,
+ Table_Increment => 100);
+
+ Context : O_Dnode := O_Dnode_Null;
+
+ function Get_Decl_Type (Decl : O_Dnode) return O_Tnode is
+ begin
+ return Dnodes.Table (Decl).Dtype;
+ end Get_Decl_Type;
+
+ function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind is
+ begin
+ return Dnodes.Table (Decl).Kind;
+ end Get_Decl_Kind;
+
+ function Get_Decl_Storage (Decl : O_Dnode) return O_Storage is
+ begin
+ return Dnodes.Table (Decl).Storage;
+ end Get_Decl_Storage;
+
+ procedure Set_Decl_Storage (Decl : O_Dnode; Storage : O_Storage) is
+ begin
+ Dnodes.Table (Decl).Storage := Storage;
+ end Set_Decl_Storage;
+
+ function Get_Decl_Reg (Decl : O_Dnode) return O_Reg is
+ begin
+ return Dnodes.Table (Decl).Reg;
+ end Get_Decl_Reg;
+
+ procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg) is
+ begin
+ Dnodes.Table (Decl).Reg := Reg;
+ end Set_Decl_Reg;
+
+ function Get_Decl_Depth (Decl : O_Dnode) return O_Depth is
+ begin
+ return Dnodes.Table (Decl).Depth;
+ end Get_Decl_Depth;
+
+ function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode is
+ begin
+ case Get_Decl_Kind (Decl) is
+ when OD_Block =>
+ return Get_Block_Last (Decl) + 1;
+ when OD_Body =>
+ return Get_Block_Last (Decl + 1) + 1;
+ when OD_Function
+ | OD_Procedure =>
+ if Use_Subprg_Ext then
+ return Decl + 2;
+ else
+ return Decl + 1;
+ end if;
+ when others =>
+ return Decl + 1;
+ end case;
+ end Get_Decl_Chain;
+
+ function Get_Body_Stmt (Bod : O_Dnode) return O_Enode is
+ begin
+ return Dnodes.Table (Bod).Body_Stmt;
+ end Get_Body_Stmt;
+
+ function Get_Body_Decl (Bod : O_Dnode) return O_Dnode is
+ begin
+ return Dnodes.Table (Bod).Body_Decl;
+ end Get_Body_Decl;
+
+ function Get_Body_Parent (Bod : O_Dnode) return O_Dnode is
+ begin
+ return Dnodes.Table (Bod).Body_Parent;
+ end Get_Body_Parent;
+
+ function Get_Body_Info (Bod : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Bod).Body_Info;
+ end Get_Body_Info;
+
+ procedure Set_Body_Info (Bod : O_Dnode; Info : Int32) is
+ begin
+ Dnodes.Table (Bod).Body_Info := Info;
+ end Set_Body_Info;
+
+ function Get_Decl_Ident (Decl : O_Dnode) return O_Ident is
+ begin
+ return Dnodes.Table (Decl).Id;
+ end Get_Decl_Ident;
+
+ function Get_Decl_Last return O_Dnode is
+ begin
+ return Dnodes.Last;
+ end Get_Decl_Last;
+
+ function Get_Block_Last (Blk : O_Dnode) return O_Dnode is
+ begin
+ return Dnodes.Table (Blk).Last;
+ end Get_Block_Last;
+
+ function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32 is
+ begin
+ return Dnodes.Table (Blk).Block_Max_Stack;
+ end Get_Block_Max_Stack;
+
+ procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32) is
+ begin
+ Dnodes.Table (Blk).Block_Max_Stack := Max;
+ end Set_Block_Max_Stack;
+
+ function Get_Block_Info1 (Blk : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Blk).Block_Info1;
+ end Get_Block_Info1;
+
+ procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32) is
+ begin
+ Dnodes.Table (Blk).Block_Info1 := Info;
+ end Set_Block_Info1;
+
+ function Get_Block_Info2 (Blk : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Blk).Block_Info2;
+ end Get_Block_Info2;
+
+ procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32) is
+ begin
+ Dnodes.Table (Blk).Block_Info2 := Info;
+ end Set_Block_Info2;
+
+ function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode
+ is
+ Res : O_Dnode;
+ begin
+ if Use_Subprg_Ext then
+ Res := Decl + 2;
+ else
+ Res := Decl + 1;
+ end if;
+
+ if Get_Decl_Kind (Res) = OD_Interface then
+ return Res;
+ else
+ return O_Dnode_Null;
+ end if;
+ end Get_Subprg_Interfaces;
+
+ function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode
+ is
+ Res : constant O_Dnode := Decl + 1;
+ begin
+ if Get_Decl_Kind (Res) = OD_Interface then
+ return Res;
+ else
+ return O_Dnode_Null;
+ end if;
+ end Get_Interface_Chain;
+
+ function Get_Val_Decl (Decl : O_Dnode) return O_Dnode is
+ begin
+ return Dnodes.Table (Decl).Val_Decl;
+ end Get_Val_Decl;
+
+ function Get_Val_Val (Decl : O_Dnode) return O_Cnode is
+ begin
+ return Dnodes.Table (Decl).Val_Val;
+ end Get_Val_Val;
+
+ Cur_Depth : O_Depth := O_Toplevel;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Type,
+ Storage => O_Storage_Private,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Atype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ if Flags.Flag_Type_Name then
+ declare
+ L : O_Tnode;
+ begin
+ L := TDnodes.Last;
+ if Atype > L then
+ TDnodes.Set_Last (Atype);
+ TDnodes.Table (L + 1 .. Atype) := (others => O_Dnode_Null);
+ end if;
+ end;
+ TDnodes.Table (Atype) := Dnodes.Last;
+ end if;
+ end New_Type_Decl;
+
+ function Get_Type_Decl (Atype : O_Tnode) return O_Dnode is
+ begin
+ if Atype <= TDnodes.Last then
+ return TDnodes.Table (Atype);
+ else
+ return O_Dnode_Null;
+ end if;
+ end Get_Type_Decl;
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Const,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Atype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Res := Dnodes.Last;
+ if not Flag_Debug_Hli then
+ Expand_Const_Decl (Res);
+ end if;
+ end New_Const_Decl;
+
+ procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode) is
+ begin
+ if Dnodes.Table (Cst).Info2 /= 0 then
+ -- Value was already set.
+ raise Syntax_Error;
+ end if;
+ Dnodes.Table (Cst).Info2 := Int32 (Val);
+ if Flag_Debug_Hli then
+ Dnodes.Append (Dnode_Common'(Kind => OD_Const_Val,
+ Storage => O_Storage_Private,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Val_Decl => Cst,
+ Val_Val => Val,
+ others => False));
+ else
+ Expand_Const_Value (Cst, Val);
+ end if;
+ end New_Const_Value;
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ begin
+ if Storage = O_Storage_Local then
+ Dnodes.Append (Dnode_Common'(Kind => OD_Local,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Atype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Res := Dnodes.Last;
+ else
+ Dnodes.Append (Dnode_Common'(Kind => OD_Var,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Atype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Res := Dnodes.Last;
+ if not Flag_Debug_Hli then
+ Expand_Var_Decl (Res);
+ end if;
+ end if;
+ end New_Var_Decl;
+
+ Static_Chain_Id : O_Ident := O_Ident_Nul;
+
+ procedure Add_Static_Chain (Interfaces : in out O_Inter_List)
+ is
+ Res : O_Dnode;
+ begin
+ if Static_Chain_Id = O_Ident_Nul then
+ Static_Chain_Id := Ortho_Ident.Get_Identifier ("STATIC_CHAIN");
+ end if;
+
+ New_Interface_Decl (Interfaces, Res, Static_Chain_Id, O_Tnode_Ptr);
+ end Add_Static_Chain;
+
+ procedure Start_Subprogram_Decl (Interfaces : out O_Inter_List)
+ is
+ Storage : O_Storage;
+ Decl : constant O_Dnode := Dnodes.Last;
+ begin
+ Storage := Get_Decl_Storage (Decl);
+ if Cur_Depth /= O_Toplevel then
+ case Storage is
+ when O_Storage_External
+ | O_Storage_Local =>
+ null;
+ when O_Storage_Public =>
+ raise Syntax_Error;
+ when O_Storage_Private =>
+ Storage := O_Storage_Local;
+ Set_Decl_Storage (Decl, Storage);
+ end case;
+ end if;
+ if Use_Subprg_Ext then
+ Dnodes.Append (Dnode_Common'(Kind => OD_Subprg_Ext,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Subprg_Inter => O_Dnode_Null,
+ others => False));
+ end if;
+
+ Start_Subprogram (Decl, Interfaces.Abi);
+ Interfaces.Decl := Decl;
+ if Storage = O_Storage_Local then
+ Add_Static_Chain (Interfaces);
+ end if;
+ end Start_Subprogram_Decl;
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Function,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Rtype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Start_Subprogram_Decl (Interfaces);
+ end Start_Function_Decl;
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage)
+ is
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Procedure,
+ Storage => Storage,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => O_Tnode_Null,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Start_Subprogram_Decl (Interfaces);
+ 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
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Interface,
+ Storage => O_Storage_Local,
+ Depth => Cur_Depth + 1,
+ Reg => R_Nil,
+ Id => Ident,
+ Dtype => Atype,
+ Ref => 0,
+ Info2 => 0,
+ others => False));
+ Res := Dnodes.Last;
+ New_Interface (Res, Interfaces.Abi);
+ end New_Interface_Decl;
+
+ procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32) is
+ begin
+ Dnodes.Table (Decl).Ref := Off;
+ end Set_Local_Offset;
+
+ function Get_Local_Offset (Decl : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Decl).Ref;
+ end Get_Local_Offset;
+
+ function Get_Inter_Offset (Inter : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Inter).Ref;
+ end Get_Inter_Offset;
+
+ procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32) is
+ begin
+ Dnodes.Table (Decl).Ref := Ref;
+ end Set_Decl_Info;
+
+ function Get_Decl_Info (Decl : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Decl).Ref;
+ end Get_Decl_Info;
+
+ procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32) is
+ begin
+ Dnodes.Table (Decl).Info2 := Val;
+ end Set_Subprg_Stack;
+
+ function Get_Subprg_Stack (Decl : O_Dnode) return Int32 is
+ begin
+ return Dnodes.Table (Decl).Info2;
+ end Get_Subprg_Stack;
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode) is
+ begin
+ Res := Interfaces.Decl;
+ Finish_Subprogram (Res, Interfaces.Abi);
+ end Finish_Subprogram_Decl;
+
+ Cur_Block : O_Dnode := O_Dnode_Null;
+
+ function Start_Declare_Stmt return O_Dnode is
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Block,
+ Storage => O_Storage_Local,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Last => O_Dnode_Null,
+ Block_Max_Stack => 0,
+ Block_Info1 => 0,
+ Block_Info2 => 0,
+ others => False));
+ Cur_Block := Dnodes.Last;
+ return Cur_Block;
+ end Start_Declare_Stmt;
+
+ procedure Finish_Declare_Stmt (Parent : O_Dnode) is
+ begin
+ Dnodes.Table (Cur_Block).Last := Dnodes.Last;
+ Cur_Block := Parent;
+ end Finish_Declare_Stmt;
+
+ function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode)
+ return O_Dnode
+ is
+ Res : O_Dnode;
+ begin
+ Dnodes.Append (Dnode_Common'(Kind => OD_Body,
+ Storage => O_Storage_Local,
+ Depth => Cur_Depth,
+ Reg => R_Nil,
+ Body_Parent => Context,
+ Body_Decl => Decl,
+ Body_Stmt => Stmt,
+ Body_Info => 0,
+ others => False));
+ Res := Dnodes.Last;
+ Context := Res;
+ Cur_Depth := Cur_Depth + 1;
+ return Res;
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body is
+ begin
+ Cur_Depth := Cur_Depth - 1;
+ Context := Get_Body_Parent (Context);
+ end Finish_Subprogram_Body;
+
+
+-- function Image (Decl : O_Dnode) return String is
+-- begin
+-- return O_Dnode'Image (Decl);
+-- end Image;
+
+ procedure Disp_Decl_Name (Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Ident;
+ Id : O_Ident;
+ begin
+ Id := Get_Decl_Ident (Decl);
+ if Is_Equal (Id, O_Ident_Nul) then
+ declare
+ Res : String := O_Dnode'Image (Decl);
+ begin
+ Res (1) := '?';
+ Put (Res);
+ end;
+ else
+ Put (Get_String (Id));
+ end if;
+ end Disp_Decl_Name;
+
+ procedure Disp_Decl_Storage (Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ begin
+ case Get_Decl_Storage (Decl) is
+ when O_Storage_Local =>
+ Put ("local");
+ when O_Storage_External =>
+ Put ("external");
+ when O_Storage_Public =>
+ Put ("public");
+ when O_Storage_Private =>
+ Put ("private");
+ end case;
+ end Disp_Decl_Storage;
+
+ procedure Disp_Decl (Indent : Natural; Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Ident;
+ use Ortho_Code.Debug.Int32_IO;
+ begin
+ Set_Col (Count (Indent));
+ Put (Int32 (Decl), 0);
+ Set_Col (Count (7 + Indent));
+ case Get_Decl_Kind (Decl) is
+ when OD_Type =>
+ Put ("type ");
+ Disp_Decl_Name (Decl);
+ Put (" is ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ when OD_Function =>
+ Disp_Decl_Storage (Decl);
+ Put (" function ");
+ Disp_Decl_Name (Decl);
+ Put (" return ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ when OD_Procedure =>
+ Disp_Decl_Storage (Decl);
+ Put (" procedure ");
+ Disp_Decl_Name (Decl);
+ when OD_Interface =>
+ Put (" interface ");
+ Disp_Decl_Name (Decl);
+ Put (": ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ Put (", offset=");
+ Put (Get_Inter_Offset (Decl), 0);
+ when OD_Const =>
+ Disp_Decl_Storage (Decl);
+ Put (" const ");
+ Disp_Decl_Name (Decl);
+ Put (": ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ when OD_Const_Val =>
+ Put ("constant ");
+ Disp_Decl_Name (Get_Val_Decl (Decl));
+ Put (": ");
+ Put (Int32 (Get_Val_Val (Decl)), 0);
+ when OD_Local =>
+ Put ("local ");
+ Disp_Decl_Name (Decl);
+ Put (": ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ Put (", offset=");
+ Put (Get_Inter_Offset (Decl), 0);
+ when OD_Var =>
+ Disp_Decl_Storage (Decl);
+ Put (" var ");
+ Disp_Decl_Name (Decl);
+ Put (": ");
+ Put (Int32 (Get_Decl_Type (Decl)), 0);
+ when OD_Body =>
+ Put ("body of ");
+ Put (Int32 (Get_Body_Decl (Decl)), 0);
+ Put (", stmt at ");
+ Put (Int32 (Get_Body_Stmt (Decl)), 0);
+ when OD_Block =>
+ Put ("block until ");
+ Put (Int32 (Get_Block_Last (Decl)), 0);
+ when OD_Subprg_Ext =>
+ Put ("Subprg_Ext");
+-- when others =>
+-- Put (OD_Kind'Image (Get_Decl_Kind (Decl)));
+ end case;
+ New_Line;
+ end Disp_Decl;
+
+ procedure Disp_Decls (Indent : Natural; First, Last : O_Dnode)
+ is
+ N : O_Dnode;
+ begin
+ N := First;
+ while N <= Last loop
+ case Get_Decl_Kind (N) is
+ when OD_Body =>
+ Disp_Decl (Indent, N);
+ Ortho_Code.Exprs.Disp_Subprg_Body
+ (Indent + 2, Get_Body_Stmt (N));
+ N := N + 1;
+ when OD_Block =>
+ -- Skip inner bindings.
+ N := Get_Block_Last (N) + 1;
+ when others =>
+ Disp_Decl (Indent, N);
+ N := N + 1;
+ end case;
+ end loop;
+ end Disp_Decls;
+
+ procedure Disp_Block (Indent : Natural; Start : O_Dnode)
+ is
+ Last : O_Dnode;
+ begin
+ if Get_Decl_Kind (Start) /= OD_Block then
+ Disp_Decl (Indent, Start);
+ raise Program_Error;
+ end if;
+ Last := Get_Block_Last (Start);
+ Disp_Decl (Indent, Start);
+ Disp_Decls (Indent, Start + 1, Last);
+ end Disp_Block;
+
+ procedure Disp_All_Decls
+ is
+ begin
+ if False then
+ for I in Dnodes.First .. Dnodes.Last loop
+ Disp_Decl (1, I);
+ end loop;
+ end if;
+
+ Disp_Decls (1, Dnodes.First, Dnodes.Last);
+ end Disp_All_Decls;
+
+ procedure Debug_Decl (Decl : O_Dnode) is
+ begin
+ Disp_Decl (1, Decl);
+ end Debug_Decl;
+
+ pragma Unreferenced (Debug_Decl);
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("Number of Dnodes: " & O_Dnode'Image (Dnodes.Last));
+ Put_Line ("Number of TDnodes: " & O_Tnode'Image (TDnodes.Last));
+ end Disp_Stats;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Dnode := Dnodes.Last;
+ M.TDnode := TDnodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Dnodes.Set_Last (M.Dnode);
+ TDnodes.Set_Last (M.TDnode);
+ end Release;
+
+ procedure Finish is
+ begin
+ Dnodes.Free;
+ TDnodes.Free;
+ end Finish;
+end Ortho_Code.Decls;
diff --git a/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads
new file mode 100644
index 000000000..ad18892fe
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-decls.ads
@@ -0,0 +1,209 @@
+-- Mcode back-end for ortho - Declarations handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Abi;
+
+package Ortho_Code.Decls is
+ -- Kind of a declaration.
+ type OD_Kind is (OD_Type,
+ OD_Const, OD_Const_Val,
+
+ -- Global and local variables.
+ OD_Var, OD_Local,
+
+ -- Subprograms.
+ OD_Function, OD_Procedure,
+
+ -- Additional node for a subprogram. Internal use only.
+ OD_Subprg_Ext,
+
+ OD_Interface,
+ OD_Body,
+ OD_Block);
+
+ -- Return the kind of declaration DECL.
+ function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind;
+
+ -- Return the type of a declaration.
+ function Get_Decl_Type (Decl : O_Dnode) return O_Tnode;
+
+ -- Return the identifier of a declaration.
+ function Get_Decl_Ident (Decl : O_Dnode) return O_Ident;
+
+ -- Return the storage of a declaration.
+ function Get_Decl_Storage (Decl : O_Dnode) return O_Storage;
+
+ -- Return the depth of a declaration.
+ function Get_Decl_Depth (Decl : O_Dnode) return O_Depth;
+
+ -- Register for the declaration.
+ function Get_Decl_Reg (Decl : O_Dnode) return O_Reg;
+ procedure Set_Decl_Reg (Decl : O_Dnode; Reg : O_Reg);
+
+ -- Return the next decl (in the same scope) after DECL.
+ -- This skips declarations in an inner block.
+ function Get_Decl_Chain (Decl : O_Dnode) return O_Dnode;
+
+ -- Get the last declaration.
+ function Get_Decl_Last return O_Dnode;
+
+ -- Return the subprogram declaration correspondig to body BOD.
+ function Get_Body_Decl (Bod : O_Dnode) return O_Dnode;
+
+ -- Return the parent of a body.
+ function Get_Body_Parent (Bod : O_Dnode) return O_Dnode;
+
+ -- Get the entry statement of body DECL.
+ function Get_Body_Stmt (Bod : O_Dnode) return O_Enode;
+
+ -- Get/Set the info field of a body.
+ function Get_Body_Info (Bod : O_Dnode) return Int32;
+ procedure Set_Body_Info (Bod : O_Dnode; Info : Int32);
+
+ -- Get the last declaration of block BLK.
+ function Get_Block_Last (Blk : O_Dnode) return O_Dnode;
+
+ -- Get/Set the block max stack offset.
+ function Get_Block_Max_Stack (Blk : O_Dnode) return Uns32;
+ procedure Set_Block_Max_Stack (Blk : O_Dnode; Max : Uns32);
+
+ -- Info on blocks.
+ function Get_Block_Info1 (Blk : O_Dnode) return Int32;
+ procedure Set_Block_Info1 (Blk : O_Dnode; Info : Int32);
+ function Get_Block_Info2 (Blk : O_Dnode) return Int32;
+ procedure Set_Block_Info2 (Blk : O_Dnode; Info : Int32);
+
+ -- Get the declaration and the value associated with a constant value.
+ function Get_Val_Decl (Decl : O_Dnode) return O_Dnode;
+ function Get_Val_Val (Decl : O_Dnode) return O_Cnode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ -- If Flag_Type_Name is set, a map from type to name is maintained.
+ function Get_Type_Decl (Atype : O_Tnode) return O_Dnode;
+
+ -- Set/Get the offset (or register) of interface or local DECL.
+ -- To be used by ABI.
+ procedure Set_Local_Offset (Decl : O_Dnode; Off : Int32);
+ function Get_Local_Offset (Decl : O_Dnode) return Int32;
+
+ -- Get/Set user info on subprogram, variable, constant declaration.
+ procedure Set_Decl_Info (Decl : O_Dnode; Ref : Int32);
+ function Get_Decl_Info (Decl : O_Dnode) return Int32;
+
+ -- Get/Set the stack size of subprogram arguments.
+ procedure Set_Subprg_Stack (Decl : O_Dnode; Val : Int32);
+ function Get_Subprg_Stack (Decl : O_Dnode) return Int32;
+
+ -- Get the first interface of a subprogram declaration.
+ function Get_Subprg_Interfaces (Decl : O_Dnode) return O_Dnode;
+
+ -- Get the next interface.
+ -- End of interface chain when result is O_Dnode_Null.
+ function Get_Interface_Chain (Decl : O_Dnode) return O_Dnode;
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value to CST.
+ procedure New_Const_Value (Cst : O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ type O_Inter_List is limited private;
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+
+ -- Start subprogram body of DECL. STMT is the corresponding statement.
+ -- Return the declaration for the body.
+ function Start_Subprogram_Body (Decl : O_Dnode; Stmt : O_Enode)
+ return O_Dnode;
+ procedure Finish_Subprogram_Body;
+
+ -- Start a declarative region.
+ function Start_Declare_Stmt return O_Dnode;
+ procedure Finish_Declare_Stmt (Parent : O_Dnode);
+
+ procedure Disp_All_Decls;
+ procedure Disp_Block (Indent : Natural; Start : O_Dnode);
+ procedure Disp_Decl_Name (Decl : O_Dnode);
+ procedure Disp_Decl (Indent : Natural; Decl : O_Dnode);
+ procedure Disp_Stats;
+
+ type Mark_Type is limited private;
+ procedure Mark (M : out Mark_Type);
+ procedure Release (M : Mark_Type);
+
+ procedure Finish;
+private
+ type O_Inter_List is record
+ -- The declaration of the subprogram.
+ Decl : O_Dnode;
+
+ -- Last declared parameter.
+ Last_Param : O_Dnode;
+
+ -- Data for ABI.
+ Abi : Ortho_Code.Abi.O_Abi_Subprg;
+ end record;
+
+ type Mark_Type is record
+ Dnode : O_Dnode;
+ TDnode : O_Tnode;
+ end record;
+
+end Ortho_Code.Decls;
diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb
new file mode 100644
index 000000000..9e8ac1272
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-disps.adb
@@ -0,0 +1,790 @@
+-- Mcode back-end for ortho - Internal tree dumper.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO; use Ada.Text_IO;
+with Ortho_Code.Debug;
+with Ortho_Code.Consts;
+with Ortho_Code.Decls;
+with Ortho_Code.Types;
+with Ortho_Code.Flags;
+with Ortho_Ident;
+with Interfaces;
+
+package body Ortho_Code.Disps is
+ procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode);
+ procedure Disp_Expr (Expr : O_Enode);
+
+ procedure Disp_Indent (Indent : Natural)
+ is
+ begin
+ Put ((1 .. 2 * Indent => ' '));
+ end Disp_Indent;
+
+ procedure Disp_Ident (Id : O_Ident)
+ is
+ use Ortho_Ident;
+ begin
+ Put (Get_String (Id));
+ end Disp_Ident;
+
+ procedure Disp_Storage (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;
+
+ procedure Disp_Label (Label : O_Enode)
+ is
+ N : Int32;
+ begin
+ case Get_Expr_Kind (Label) is
+ when OE_Label =>
+ Put ("label");
+ N := Int32 (Label);
+ when OE_Loop =>
+ Put ("loop");
+ N := Int32 (Label);
+ when OE_BB =>
+ Put ("BB");
+ N := Get_BB_Number (Label);
+ when others =>
+ raise Program_Error;
+ end case;
+ Put (Int32'Image (N));
+ Put (":");
+ end Disp_Label;
+
+ procedure Disp_Call (Call : O_Enode)
+ is
+ Arg : O_Enode;
+ begin
+ Decls.Disp_Decl_Name (Get_Call_Subprg (Call));
+
+ Arg := Get_Arg_Link (Call);
+ if Arg /= O_Enode_Null then
+ Put (" (");
+ loop
+ Disp_Expr (Get_Expr_Operand (Arg));
+ Arg := Get_Arg_Link (Arg);
+ exit when Arg = O_Enode_Null;
+ Put (", ");
+ end loop;
+ Put (")");
+ end if;
+ end Disp_Call;
+
+ procedure Put_Trim (Str : String) is
+ begin
+ if Str (Str'First) = ' ' then
+ Put (Str (Str'First + 1 .. Str'Last));
+ else
+ Put (Str);
+ end if;
+ end Put_Trim;
+
+ procedure Disp_Typed_Lit (Lit : O_Cnode; Val : String)
+ is
+ use Ortho_Code.Consts;
+ begin
+ Disp_Type (Get_Const_Type (Lit));
+ Put ("'[");
+ Put_Trim (Val);
+ Put (']');
+ end Disp_Typed_Lit;
+
+ procedure Disp_Lit (Lit : O_Cnode)
+ is
+ use Interfaces;
+ use Ortho_Code.Consts;
+ begin
+ case Get_Const_Kind (Lit) is
+ when OC_Unsigned =>
+ Disp_Typed_Lit (Lit, Unsigned_64'Image (Get_Const_U64 (Lit)));
+ when OC_Signed =>
+ Disp_Typed_Lit (Lit, Integer_64'Image (Get_Const_I64 (Lit)));
+ when OC_Subprg_Address =>
+ Disp_Type (Get_Const_Type (Lit));
+ Put ("'subprg_addr (");
+ Decls.Disp_Decl_Name (Get_Const_Decl (Lit));
+ Put (")");
+ when OC_Address =>
+ Disp_Type (Get_Const_Type (Lit));
+ Put ("'address (");
+ Decls.Disp_Decl_Name (Get_Const_Decl (Lit));
+ Put (")");
+ when OC_Sizeof =>
+ Disp_Type (Get_Const_Type (Lit));
+ Put ("'sizeof (");
+ Disp_Type (Get_Sizeof_Type (Lit));
+ Put (")");
+ when OC_Null =>
+ Disp_Type (Get_Const_Type (Lit));
+ Put ("'[null]");
+ when OC_Lit =>
+ declare
+ L : O_Cnode;
+ begin
+ L := Types.Get_Type_Enum_Lit
+ (Get_Const_Type (Lit), Get_Lit_Value (Lit));
+ Disp_Typed_Lit
+ (Lit, Ortho_Ident.Get_String (Get_Lit_Ident (L)));
+ end;
+ when OC_Array =>
+ Put ('{');
+ for I in 1 .. Get_Const_Aggr_Length (Lit) loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1));
+ end loop;
+ Put ('}');
+ when OC_Record =>
+ declare
+ use Ortho_Code.Types;
+ F : O_Fnode;
+ begin
+ F := Get_Type_Record_Fields (Get_Const_Type (Lit));
+ Put ('{');
+ for I in 1 .. Get_Const_Aggr_Length (Lit) loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Put ('.');
+ Disp_Ident (Get_Field_Ident (F));
+ Put (" = ");
+ Disp_Lit (Get_Const_Aggr_Element (Lit, I - 1));
+ F := Get_Field_Chain (F);
+ end loop;
+ Put ('}');
+ end;
+ when OC_Union =>
+ Put ('{');
+ Put ('.');
+ Disp_Ident (Types.Get_Field_Ident (Get_Const_Union_Field (Lit)));
+ Put ('=');
+ Disp_Lit (Get_Const_Union_Value (Lit));
+ Put ('}');
+ when others =>
+ Put ("*lit " & OC_Kind'Image (Get_Const_Kind (Lit)) & '*');
+ end case;
+ end Disp_Lit;
+
+ procedure Disp_Expr (Expr : O_Enode)
+ is
+ Kind : OE_Kind;
+ begin
+ Kind := Get_Expr_Kind (Expr);
+ case Kind is
+ when OE_Const =>
+ case Get_Expr_Mode (Expr) is
+ when Mode_I8
+ | Mode_I16
+ | Mode_I32 =>
+ Put_Trim (Int32'Image (To_Int32 (Get_Expr_Low (Expr))));
+ when Mode_U8
+ | Mode_U16
+ | Mode_U32 =>
+ Put_Trim (Uns32'Image (Get_Expr_Low (Expr)));
+ when others =>
+ Put ("const:");
+ Debug.Disp_Mode (Get_Expr_Mode (Expr));
+ end case;
+ when OE_Lit =>
+ Disp_Lit (Get_Expr_Lit (Expr));
+ when OE_Case_Expr =>
+ Put ("{case}");
+ when OE_Kind_Dyadic
+ | OE_Kind_Cmp
+ | OE_Add
+ | OE_Mul
+ | OE_Shl =>
+ Put ("(");
+ Disp_Expr (Get_Expr_Left (Expr));
+ Put (' ');
+ case Kind is
+ when OE_Eq =>
+ Put ('=');
+ when OE_Neq =>
+ Put ("/=");
+ when OE_Lt =>
+ Put ("<");
+ when OE_Gt =>
+ Put (">");
+ when OE_Ge =>
+ Put (">=");
+ when OE_Le =>
+ Put ("<=");
+ when OE_Add =>
+ Put ('+');
+ when OE_Mul =>
+ Put ('*');
+ when OE_Add_Ov =>
+ Put ("+#");
+ when OE_Sub_Ov =>
+ Put ("-#");
+ when OE_Mul_Ov =>
+ Put ("*#");
+ when OE_Shl =>
+ Put ("<<");
+ when OE_And =>
+ Put ("and");
+ when OE_Or =>
+ Put ("or");
+ when others =>
+ Put (OE_Kind'Image (Kind));
+ end case;
+ Put (' ');
+ Disp_Expr (Get_Expr_Right (Expr));
+ Put (")");
+ when OE_Not =>
+ Put ("not ");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ when OE_Neg_Ov =>
+ Put ("neg ");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ when OE_Abs_Ov =>
+ Put ("abs ");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ when OE_Indir =>
+ declare
+ Op : O_Enode;
+ begin
+ Op := Get_Expr_Operand (Expr);
+ case Get_Expr_Kind (Op) is
+ when OE_Addrg
+ | OE_Addrl =>
+ Decls.Disp_Decl_Name (Get_Addr_Object (Op));
+ when others =>
+ --Put ("*");
+ Disp_Expr (Op);
+ end case;
+ end;
+ when OE_Addrl
+ | OE_Addrg =>
+ -- Put ('@');
+ Decls.Disp_Decl_Name (Get_Addr_Object (Expr));
+ when OE_Call =>
+ Disp_Call (Expr);
+ when OE_Alloca =>
+ Put ("alloca (");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put (")");
+ when OE_Conv =>
+ Disp_Type (Get_Conv_Type (Expr));
+ Put ("'conv (");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put (")");
+ when OE_Conv_Ptr =>
+ Disp_Type (Get_Conv_Type (Expr));
+ Put ("'address (");
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put (")");
+ when OE_Typed =>
+ Disp_Type (Get_Conv_Type (Expr));
+ Put ("'");
+ -- Note: there is always parenthesis around comparison.
+ Disp_Expr (Get_Expr_Operand (Expr));
+ when OE_Record_Ref =>
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put (".");
+ Disp_Ident (Types.Get_Field_Ident (Get_Ref_Field (Expr)));
+ when OE_Access_Ref =>
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put (".all");
+ when OE_Index_Ref =>
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put ('[');
+ Disp_Expr (Get_Ref_Index (Expr));
+ Put (']');
+ when OE_Slice_Ref =>
+ Disp_Expr (Get_Expr_Operand (Expr));
+ Put ('[');
+ Disp_Expr (Get_Ref_Index (Expr));
+ Put ("...]");
+ when OE_Get_Stack =>
+ Put ("%sp");
+ when OE_Get_Frame =>
+ Put ("%fp");
+ when others =>
+ Put_Line (Standard_Error, "disps.disp_expr: unknown expr "
+ & OE_Kind'Image (Kind));
+ end case;
+ end Disp_Expr;
+
+ procedure Disp_Fields (Indent : Natural; Atype : O_Tnode)
+ is
+ use Types;
+ Nbr : Uns32;
+ F : O_Fnode;
+ begin
+ Nbr := Get_Type_Record_Nbr_Fields (Atype);
+ F := Get_Type_Record_Fields (Atype);
+ for I in 1 .. Nbr loop
+ Disp_Indent (Indent);
+ Disp_Ident (Get_Field_Ident (F));
+ Put (": ");
+ Disp_Type (Get_Field_Type (F));
+ Put (";");
+ New_Line;
+ F := Get_Field_Chain (F);
+ end loop;
+ end Disp_Fields;
+
+ procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False)
+ is
+ use Types;
+ Kind : OT_Kind;
+ Decl : O_Dnode;
+ begin
+ if not Force then
+ Decl := Decls.Get_Type_Decl (Atype);
+ if Decl /= O_Dnode_Null then
+ Decls.Disp_Decl_Name (Decl);
+ return;
+ end if;
+ end if;
+
+ Kind := Get_Type_Kind (Atype);
+ case Kind is
+ when OT_Signed =>
+ Put ("signed (");
+ Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype)));
+ Put (")");
+ when OT_Unsigned =>
+ Put ("unsigned (");
+ Put_Trim (Uns32'Image (8 * Get_Type_Size (Atype)));
+ Put (")");
+ when OT_Float =>
+ Put ("float");
+ when OT_Access =>
+ Put ("access");
+ declare
+ Acc_Type : O_Tnode;
+ begin
+ Acc_Type := Get_Type_Access_Type (Atype);
+ if Acc_Type /= O_Tnode_Null then
+ Put (' ');
+ Disp_Type (Acc_Type);
+ end if;
+ end;
+ when OT_Ucarray =>
+ Put ("array [");
+ Disp_Type (Get_Type_Ucarray_Index (Atype));
+ Put ("] of ");
+ Disp_Type (Get_Type_Ucarray_Element (Atype));
+ when OT_Subarray =>
+ Put ("subarray ");
+ Disp_Type (Get_Type_Subarray_Base (Atype));
+ Put ("[");
+ Put_Trim (Uns32'Image (Get_Type_Subarray_Length (Atype)));
+ Put ("]");
+ when OT_Record =>
+ Put_Line ("record");
+ Disp_Fields (1, Atype);
+ Put ("end record");
+ when OT_Union =>
+ Put_Line ("union");
+ Disp_Fields (1, Atype);
+ Put ("end union");
+ when OT_Boolean =>
+ declare
+ Lit : O_Cnode;
+ begin
+ Put ("boolean {");
+ Lit := Get_Type_Bool_False (Atype);
+ Disp_Ident (Consts.Get_Lit_Ident (Lit));
+ Put (", ");
+ Lit := Get_Type_Bool_True (Atype);
+ Disp_Ident (Consts.Get_Lit_Ident (Lit));
+ Put ("}");
+ end;
+ when OT_Enum =>
+ declare
+ use Consts;
+ Lit : O_Cnode;
+ begin
+ Put ("enum {");
+ Lit := Get_Type_Enum_Lits (Atype);
+ for I in 1 .. Get_Type_Enum_Nbr_Lits (Atype) loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Ident (Get_Lit_Ident (Lit));
+ Put (" =");
+ Put (Uns32'Image (I - 1));
+ Lit := Get_Lit_Chain (Lit);
+ end loop;
+ Put ('}');
+ end;
+ when OT_Complete =>
+ Put ("-- complete: ");
+ Disp_Type (Get_Type_Complete_Type (Atype));
+ end case;
+ end Disp_Type;
+
+ procedure Disp_Decl_Storage (Decl : O_Dnode) is
+ begin
+ Disp_Storage (Decls.Get_Decl_Storage (Decl));
+ Put (' ');
+ end Disp_Decl_Storage;
+
+ procedure Disp_Subprg_Decl (Indent : Natural; Decl : O_Dnode)
+ is
+ use Decls;
+ Kind : OD_Kind;
+ Inter : O_Dnode;
+ begin
+ Disp_Decl_Storage (Decl);
+ Kind := Get_Decl_Kind (Decl);
+ case Kind is
+ when OD_Function =>
+ Put ("function ");
+ when OD_Procedure =>
+ Put ("procedure ");
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Disp_Decl_Name (Decl);
+ Inter := Get_Subprg_Interfaces (Decl);
+ Put (" (");
+ New_Line;
+ if Inter /= O_Dnode_Null then
+ loop
+ Disp_Indent (Indent + 1);
+ Disp_Decl_Name (Inter);
+ Put (": ");
+ Disp_Type (Get_Decl_Type (Inter));
+ Inter := Get_Interface_Chain (Inter);
+ exit when Inter = O_Dnode_Null;
+ Put (";");
+ New_Line;
+ end loop;
+ else
+ Disp_Indent (Indent + 1);
+ end if;
+ Put (")");
+ if Kind = OD_Function then
+ New_Line;
+ Disp_Indent (Indent + 1);
+ Put ("return ");
+ Disp_Type (Get_Decl_Type (Decl));
+ end if;
+ end Disp_Subprg_Decl;
+
+ procedure Disp_Decl (Indent : Natural;
+ Decl : O_Dnode;
+ Nl : Boolean := False)
+ is
+ use Decls;
+ Kind : OD_Kind;
+ Dtype : O_Tnode;
+ begin
+ Kind := Get_Decl_Kind (Decl);
+ if Kind = OD_Interface then
+ return;
+ end if;
+ Disp_Indent (Indent);
+ case Kind is
+ when OD_Type =>
+ Dtype := Get_Decl_Type (Decl);
+ Put ("type ");
+ Disp_Decl_Name (Decl);
+ Put (" is ");
+ Disp_Type (Dtype, True);
+ Put_Line (";");
+ when OD_Local
+ | OD_Var =>
+ Disp_Decl_Storage (Decl);
+ Put ("var ");
+ Disp_Decl_Name (Decl);
+ Put (" : ");
+ Dtype := Get_Decl_Type (Decl);
+ Disp_Type (Dtype);
+ if True then
+ Put (" {size="
+ & Uns32'Image (Types.Get_Type_Size (Dtype)) & "}");
+ end if;
+ Put_Line (";");
+ when OD_Const =>
+ Disp_Decl_Storage (Decl);
+ Put ("constant ");
+ Disp_Decl_Name (Decl);
+ Put (" : ");
+ Disp_Type (Get_Decl_Type (Decl));
+ Put_Line (";");
+ when OD_Const_Val =>
+ Put ("constant ");
+ Disp_Decl_Name (Get_Val_Decl (Decl));
+ Put (" := ");
+ Disp_Lit (Get_Val_Val (Decl));
+ Put_Line (";");
+ when OD_Function
+ | OD_Procedure =>
+ Disp_Subprg_Decl (Indent, Decl);
+ Put_Line (";");
+ when OD_Interface =>
+ null;
+ when OD_Body =>
+ -- Put ("body ");
+ Disp_Subprg_Decl (Indent, Get_Body_Decl (Decl));
+ -- Disp_Decl_Name (Get_Body_Decl (Decl));
+ New_Line;
+ Disp_Subprg (Indent, Get_Body_Stmt (Decl));
+ when OD_Block | OD_Subprg_Ext =>
+ null;
+ end case;
+ if Nl then
+ New_Line;
+ end if;
+ end Disp_Decl;
+
+ procedure Disp_Stmt (Indent : in out Natural; Stmt : O_Enode)
+ is
+ use Decls;
+ Expr : O_Enode;
+ begin
+ case Get_Expr_Kind (Stmt) is
+ when OE_Beg =>
+ Disp_Indent (Indent);
+ Put_Line ("declare");
+ declare
+ Last : O_Dnode;
+ Decl : O_Dnode;
+ begin
+ Decl := Get_Block_Decls (Stmt);
+ Last := Get_Block_Last (Decl);
+ Decl := Decl + 1;
+ while Decl <= Last loop
+ case Get_Decl_Kind (Decl) is
+ when OD_Block =>
+ Decl := Get_Block_Last (Decl) + 1;
+ when others =>
+ Disp_Decl (Indent + 1, Decl, False);
+ Decl := Decl + 1;
+ end case;
+ end loop;
+ end;
+ Disp_Indent (Indent);
+ Put_Line ("begin");
+ Indent := Indent + 1;
+ when OE_End =>
+ Indent := Indent - 1;
+ Disp_Indent (Indent);
+ Put_Line ("end;");
+ when OE_Line =>
+ Disp_Indent (Indent);
+ Put_Line ("--#" & Int32'Image (Get_Expr_Line_Number (Stmt)));
+ when OE_BB =>
+ Disp_Indent (Indent);
+ Put_Line ("# BB" & Int32'Image (Get_BB_Number (Stmt)));
+ when OE_Asgn =>
+ Disp_Indent (Indent);
+ Disp_Expr (Get_Assign_Target (Stmt));
+ Put (" := ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ Put_Line (";");
+ when OE_Call =>
+ Disp_Indent (Indent);
+ Disp_Call (Stmt);
+ Put_Line (";");
+ when OE_Jump_F =>
+ Disp_Indent (Indent);
+ Put ("jump ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ Put (" if not ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Jump_T =>
+ Disp_Indent (Indent);
+ Put ("jump ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ Put (" if ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Jump =>
+ Disp_Indent (Indent);
+ Put ("jump ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ New_Line;
+ when OE_Label =>
+ Disp_Indent (Indent);
+ Disp_Label (Stmt);
+ New_Line;
+ when OE_Ret =>
+ Disp_Indent (Indent);
+ Put ("return");
+ Expr := Get_Expr_Operand (Stmt);
+ if Expr /= O_Enode_Null then
+ Put (" ");
+ Disp_Expr (Expr);
+ end if;
+ Put_Line (";");
+ when OE_Set_Stack =>
+ Disp_Indent (Indent);
+ Put ("%sp := ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ Put_Line (";");
+ when OE_Leave =>
+ Disp_Indent (Indent);
+ Put_Line ("# leave");
+ when OE_If =>
+ Disp_Indent (Indent);
+ Put ("if ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ Put (" then");
+ New_Line;
+ Indent := Indent + 1;
+ when OE_Else =>
+ Disp_Indent (Indent - 1);
+ Put ("else");
+ New_Line;
+ when OE_Endif =>
+ Indent := Indent - 1;
+ Disp_Indent (Indent);
+ Put_Line ("end if;");
+ when OE_Loop =>
+ Disp_Indent (Indent);
+ Disp_Label (Stmt);
+ New_Line;
+ Indent := Indent + 1;
+ when OE_Exit =>
+ Disp_Indent (Indent);
+ Put ("exit ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ Put (";");
+ New_Line;
+ when OE_Next =>
+ Disp_Indent (Indent);
+ Put ("next ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ Put (";");
+ New_Line;
+ when OE_Eloop =>
+ Indent := Indent - 1;
+ Disp_Indent (Indent);
+ Put_Line ("end loop;");
+ when OE_Case =>
+ Disp_Indent (Indent);
+ Put ("case ");
+ Disp_Expr (Get_Expr_Operand (Stmt));
+ Put (" is");
+ New_Line;
+ if Debug.Flag_Debug_Hli then
+ Indent := Indent + 2;
+ end if;
+ when OE_Case_Branch =>
+ Disp_Indent (Indent - 1);
+ Put ("when ");
+ declare
+ C : O_Enode;
+ L, H : O_Enode;
+ begin
+ C := Get_Case_Branch_Choice (Stmt);
+ loop
+ L := Get_Expr_Left (C);
+ H := Get_Expr_Right (C);
+ if L = O_Enode_Null then
+ Put ("others");
+ else
+ Disp_Expr (L);
+ if H /= O_Enode_Null then
+ Put (" ... ");
+ Disp_Expr (H);
+ end if;
+ end if;
+ C := Get_Case_Choice_Link (C);
+ exit when C = O_Enode_Null;
+ New_Line;
+ Disp_Indent (Indent - 1);
+ Put (" | ");
+ end loop;
+ Put (" =>");
+ New_Line;
+ end;
+ when OE_Case_End =>
+ Indent := Indent - 2;
+ Disp_Indent (Indent);
+ Put ("end case;");
+ New_Line;
+ when others =>
+ Put_Line (Standard_Error, "debug.disp_stmt: unknown statement " &
+ OE_Kind'Image (Get_Expr_Kind (Stmt)));
+ end case;
+ end Disp_Stmt;
+
+ procedure Disp_Subprg (Ident : Natural; S_Entry : O_Enode)
+ is
+ Stmt : O_Enode;
+ N_Ident : Natural := Ident;
+ begin
+ Stmt := S_Entry;
+ loop
+ Stmt := Get_Stmt_Link (Stmt);
+ Disp_Stmt (N_Ident, Stmt);
+ exit when Get_Expr_Kind (Stmt) = OE_Leave;
+ end loop;
+ end Disp_Subprg;
+
+ Last_Decl : O_Dnode := O_Dnode_First;
+
+ procedure Disp_Decls_Until (Last : O_Dnode; Nl : Boolean := False) is
+ begin
+ while Last_Decl <= Last loop
+ Disp_Decl (0, Last_Decl, Nl);
+ Last_Decl := Last_Decl + 1;
+ end loop;
+ end Disp_Decls_Until;
+
+ procedure Disp_Subprg (Subprg : Subprogram_Data_Acc)
+ is
+ use Decls;
+ begin
+ Disp_Decls_Until (Subprg.D_Body, True);
+ if Get_Decl_Kind (Last_Decl) /= OD_Block then
+ raise Program_Error;
+ end if;
+ if Debug.Flag_Debug_Keep then
+ -- If nodes are kept, the next declaration to be displayed (at top
+ -- level) is the one that follow the subprogram block.
+ Last_Decl := Get_Block_Last (Last_Decl) + 1;
+ else
+ -- If nodes are not kept, this subprogram block will be freed, and
+ -- the next declaration is the block itself.
+ Last_Decl := Subprg.D_Body;
+ end if;
+ end Disp_Subprg;
+
+ procedure Init is
+ begin
+ Flags.Flag_Type_Name := True;
+ end Init;
+
+ procedure Finish is
+ begin
+ Disp_Decls_Until (Decls.Get_Decl_Last, True);
+ end Finish;
+
+end Ortho_Code.Disps;
diff --git a/src/ortho/mcode/ortho_code-disps.ads b/src/ortho/mcode/ortho_code-disps.ads
new file mode 100644
index 000000000..5ae4d8697
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-disps.ads
@@ -0,0 +1,25 @@
+-- Mcode back-end for ortho - Internal tree dumper.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+
+package Ortho_Code.Disps is
+ procedure Disp_Subprg (Subprg : Subprogram_Data_Acc);
+ procedure Disp_Type (Atype : O_Tnode; Force : Boolean := False);
+ procedure Init;
+ procedure Finish;
+end Ortho_Code.Disps;
diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb
new file mode 100644
index 000000000..ad67d1ff6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-dwarf.adb
@@ -0,0 +1,1351 @@
+-- Mcode back-end for ortho - Dwarf generator.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.Directory_Operations;
+with GNAT.Table;
+with Interfaces; use Interfaces;
+with Binary_File; use Binary_File;
+with Dwarf; use Dwarf;
+with Ada.Text_IO;
+with Ortho_Code.Decls;
+with Ortho_Code.Types;
+with Ortho_Code.Consts;
+with Ortho_Code.Flags;
+with Ortho_Ident;
+with Ortho_Code.Binary;
+
+package body Ortho_Code.Dwarf is
+ -- Dwarf debugging format.
+ -- Debugging.
+ Line1_Sect : Section_Acc := null;
+ Line_Last : Int32 := 0;
+ Line_Pc : Pc_Type := 0;
+
+ -- Constant.
+ Min_Insn_Len : constant := 1;
+ Line_Base : constant := 1;
+ Line_Range : constant := 4;
+ Line_Opcode_Base : constant := 13;
+ Line_Max_Addr : constant := (255 - Line_Opcode_Base) / Line_Range;
+ -- + Line_Base;
+
+ Cur_File : Natural := 0;
+ Last_File : Natural := 0;
+
+ Orig_Sym : Symbol;
+ End_Sym : Symbol;
+ Abbrev_Sym : Symbol;
+ Info_Sym : Symbol;
+ Line_Sym : Symbol;
+
+ Line_Sect : Section_Acc;
+ Abbrev_Sect : Section_Acc;
+ Info_Sect : Section_Acc;
+ Aranges_Sect : Section_Acc;
+
+ Abbrev_Last : Unsigned_32;
+
+-- procedure Gen_String (Str : String)
+-- is
+-- begin
+-- for I in Str'Range loop
+-- Gen_B8 (Character'Pos (Str (I)));
+-- end loop;
+-- end Gen_String;
+
+ procedure Gen_String_Nul (Str : String)
+ is
+ begin
+ Prealloc (Str'Length + 1);
+ for I in Str'Range loop
+ Gen_B8 (Character'Pos (Str (I)));
+ end loop;
+ Gen_B8 (0);
+ end Gen_String_Nul;
+
+ procedure Gen_Sleb128 (V : Int32)
+ is
+ V1 : Uns32 := To_Uns32 (V);
+ V2 : Uns32;
+ B : Byte;
+ function Shift_Right_Arithmetic (Value : Uns32; Amount : Natural)
+ return Uns32;
+ pragma Import (Intrinsic, Shift_Right_Arithmetic);
+ begin
+ loop
+ B := Byte (V1 and 16#7F#);
+ V2 := Shift_Right_Arithmetic (V1, 7);
+ if (V2 = 0 and (B and 16#40#) = 0)
+ or (V2 = -1 and (B and 16#40#) /= 0)
+ then
+ Gen_B8 (B);
+ exit;
+ else
+ Gen_B8 (B or 16#80#);
+ V1 := V2;
+ end if;
+ end loop;
+ end Gen_Sleb128;
+
+ procedure Gen_Uleb128 (V : Unsigned_32)
+ is
+ V1 : Unsigned_32 := V;
+ B : Byte;
+ begin
+ loop
+ B := Byte (V1 and 16#7f#);
+ V1 := Shift_Right (V1, 7);
+ if V1 /= 0 then
+ Gen_B8 (B or 16#80#);
+ else
+ Gen_B8 (B);
+ exit;
+ end if;
+ end loop;
+ end Gen_Uleb128;
+
+-- procedure New_Debug_Line_Decl (Line : Int32)
+-- is
+-- begin
+-- Line_Last := Line;
+-- end New_Debug_Line_Decl;
+
+ procedure Set_Line_Stmt (Line : Int32)
+ is
+ Pc : Pc_Type;
+ D_Pc : Pc_Type;
+ D_Ln : Int32;
+ begin
+ if Line = Line_Last then
+ return;
+ end if;
+ Pc := Get_Current_Pc;
+
+ D_Pc := (Pc - Line_Pc) / Min_Insn_Len;
+ D_Ln := Line - Line_Last;
+
+ -- Always emit line information, since missing info can distrub the
+ -- user.
+ -- As an optimization, we could try to emit the highest line for the
+ -- same PC, since GDB seems to handle this way.
+ if False and D_Pc = 0 then
+ return;
+ end if;
+
+ Set_Current_Section (Line1_Sect);
+ Prealloc (32);
+
+ if Cur_File /= Last_File then
+ Gen_B8 (Byte (DW_LNS_Set_File));
+ Gen_Uleb128 (Unsigned_32 (Cur_File));
+ Last_File := Cur_File;
+ elsif Cur_File = 0 then
+ return;
+ end if;
+
+ if D_Ln < Line_Base or D_Ln >= (Line_Base + Line_Range) then
+ -- Emit an advance line.
+ Gen_B8 (Byte (DW_LNS_Advance_Line));
+ Gen_Sleb128 (Int32 (D_Ln - Line_Base));
+ D_Ln := Line_Base;
+ end if;
+ if D_Pc >= Line_Max_Addr then
+ -- Emit an advance addr.
+ Gen_B8 (Byte (DW_LNS_Advance_Pc));
+ Gen_Uleb128 (Unsigned_32 (D_Pc));
+ D_Pc := 0;
+ end if;
+ Gen_B8 (Line_Opcode_Base
+ + Byte (D_Pc) * Line_Range
+ + Byte (D_Ln - Line_Base));
+
+ --Set_Current_Section (Text_Sect);
+ Line_Pc := Pc;
+ Line_Last := Line;
+ end Set_Line_Stmt;
+
+
+ type String_Acc is access constant String;
+
+ type Dir_Chain;
+ type Dir_Chain_Acc is access Dir_Chain;
+ type Dir_Chain is record
+ Name : String_Acc;
+ Next : Dir_Chain_Acc;
+ end record;
+
+ type File_Chain;
+ type File_Chain_Acc is access File_Chain;
+ type File_Chain is record
+ Name : String_Acc;
+ Dir : Natural;
+ Next : File_Chain_Acc;
+ end record;
+
+ Dirs : Dir_Chain_Acc := null;
+ Files : File_Chain_Acc := null;
+
+ procedure Set_Filename (Dir : String; File : String)
+ is
+ D : Natural;
+ F : Natural;
+ D_C : Dir_Chain_Acc;
+ F_C : File_Chain_Acc;
+ begin
+ -- Find directory.
+ if Dir = "" then
+ -- Current directory.
+ D := 0;
+ elsif Dirs = null then
+ -- First directory.
+ Dirs := new Dir_Chain'(Name => new String'(Dir),
+ Next => null);
+ D := 1;
+ else
+ -- Find a directory.
+ D_C := Dirs;
+ D := 1;
+ loop
+ exit when D_C.Name.all = Dir;
+ D := D + 1;
+ if D_C.Next = null then
+ D_C.Next := new Dir_Chain'(Name => new String'(Dir),
+ Next => null);
+ exit;
+ else
+ D_C := D_C.Next;
+ end if;
+ end loop;
+ end if;
+
+ -- Find file.
+ F := 1;
+ if Files = null then
+ -- first file.
+ Files := new File_Chain'(Name => new String'(File),
+ Dir => D,
+ Next => null);
+ else
+ F_C := Files;
+ loop
+ exit when F_C.Name.all = File and F_C.Dir = D;
+ F := F + 1;
+ if F_C.Next = null then
+ F_C.Next := new File_Chain'(Name => new String'(File),
+ Dir => D,
+ Next => null);
+ exit;
+ else
+ F_C := F_C.Next;
+ end if;
+ end loop;
+ end if;
+ Cur_File := F;
+ end Set_Filename;
+
+ procedure Gen_Abbrev_Header (Tag : Unsigned_32; Child : Byte) is
+ begin
+ Gen_Uleb128 (Tag);
+ Gen_B8 (Child);
+ end Gen_Abbrev_Header;
+
+ procedure Gen_Abbrev_Tuple (Attr : Unsigned_32; Form : Unsigned_32) is
+ begin
+ Gen_Uleb128 (Attr);
+ Gen_Uleb128 (Form);
+ end Gen_Abbrev_Tuple;
+
+ procedure Init
+ is
+ begin
+ -- Generate type names.
+ Flags.Flag_Type_Name := True;
+
+
+ Orig_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Orig_Sym, False);
+ End_Sym := Create_Local_Symbol;
+
+ Create_Section (Line1_Sect, ".debug_line-1", Section_Debug);
+ Set_Current_Section (Line1_Sect);
+
+ -- Write Address.
+ Gen_B8 (0); -- extended opcode
+ Gen_B8 (5); -- length: 1 + 4
+ Gen_B8 (Byte (DW_LNE_Set_Address));
+ Gen_Ua_32 (Orig_Sym, 0);
+
+ Line_Last := 1;
+
+ Create_Section (Line_Sect, ".debug_line", Section_Debug);
+ Set_Section_Info (Line_Sect, null, 0, 0);
+ Set_Current_Section (Line_Sect);
+ Line_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Line_Sym, False);
+
+ -- Abbrevs.
+ Create_Section (Abbrev_Sect, ".debug_abbrev", Section_Debug);
+ Set_Section_Info (Abbrev_Sect, null, 0, 0);
+ Set_Current_Section (Abbrev_Sect);
+
+ Abbrev_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Abbrev_Sym, False);
+
+ Gen_Uleb128 (1);
+ Gen_Abbrev_Header (DW_TAG_Compile_Unit, DW_CHILDREN_Yes);
+
+ Gen_Abbrev_Tuple (DW_AT_Stmt_List, DW_FORM_Data4);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Producer, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Comp_Dir, DW_FORM_String);
+ Gen_Abbrev_Tuple (0, 0);
+
+ Abbrev_Last := 1;
+
+ -- Info.
+ Create_Section (Info_Sect, ".debug_info", Section_Debug);
+ Set_Section_Info (Info_Sect, null, 0, 0);
+ Set_Current_Section (Info_Sect);
+ Info_Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Info_Sym, False);
+
+ Gen_32 (7); -- Length: to be patched.
+ Gen_16 (2); -- version
+ Gen_Ua_32 (Abbrev_Sym, 0); -- Abbrev offset
+ Gen_B8 (4); -- Ptr size.
+
+ -- Compile_unit.
+ Gen_Uleb128 (1);
+ Gen_Ua_32 (Line_Sym, 0);
+ Gen_Ua_32 (Orig_Sym, 0);
+ Gen_Ua_32 (End_Sym, 0);
+ Gen_String_Nul ("T.Gingold ortho_mcode (2004)");
+ Gen_String_Nul (GNAT.Directory_Operations.Get_Current_Dir);
+ end Init;
+
+ procedure Emit_Decl (Decl : O_Dnode);
+
+ -- Next node to be emitted.
+ Last_Decl : O_Dnode := O_Dnode_First;
+
+ procedure Emit_Decls_Until (Last : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ while Last_Decl < Last loop
+ Emit_Decl (Last_Decl);
+ Last_Decl := Get_Decl_Chain (Last_Decl);
+ end loop;
+ end Emit_Decls_Until;
+
+ procedure Finish
+ is
+ Length : Pc_Type;
+ Last : O_Dnode;
+ begin
+ Set_Symbol_Pc (End_Sym, False);
+ Length := Get_Current_Pc;
+
+ Last := Decls.Get_Decl_Last;
+ Emit_Decls_Until (Last);
+ if Last_Decl <= Last then
+ Emit_Decl (Last);
+ end if;
+
+ -- Finish abbrevs.
+ Set_Current_Section (Abbrev_Sect);
+ Gen_Uleb128 (0);
+
+ -- Emit header.
+ Set_Current_Section (Line_Sect);
+
+ -- Unit_Length (to be patched).
+ Gen_32 (0);
+ -- version
+ Gen_16 (2);
+ -- header_length (to be patched).
+ Gen_32 (5 + 12 + 1);
+ -- minimum_instruction_length.
+ Gen_B8 (Min_Insn_Len);
+ -- default_is_stmt
+ Gen_B8 (1);
+ -- line base
+ Gen_B8 (Line_Base);
+ -- line range
+ Gen_B8 (Line_Range);
+ -- opcode base
+ Gen_B8 (Line_Opcode_Base);
+ -- standard_opcode_length.
+ Gen_B8 (0); -- copy
+ Gen_B8 (1); -- advance pc
+ Gen_B8 (1); -- advance line
+ Gen_B8 (1); -- set file
+ Gen_B8 (1); -- set column
+ Gen_B8 (0); -- negate stmt
+ Gen_B8 (0); -- set basic block
+ Gen_B8 (0); -- const add pc
+ Gen_B8 (1); -- fixed advance pc
+ Gen_B8 (0); -- set prologue end
+ Gen_B8 (0); -- set epilogue begin
+ Gen_B8 (1); -- set isa
+ --if Line_Opcode_Base /= 13 then
+ -- raise Program_Error;
+ --end if;
+
+ -- include directories
+ declare
+ D : Dir_Chain_Acc;
+ begin
+ D := Dirs;
+ while D /= null loop
+ Gen_String_Nul (D.Name.all);
+ D := D.Next;
+ end loop;
+ Gen_B8 (0); -- last entry.
+ end;
+
+ -- file_names.
+ declare
+ F : File_Chain_Acc;
+ begin
+ F := Files;
+ while F /= null loop
+ Gen_String_Nul (F.Name.all);
+ Gen_Uleb128 (Unsigned_32 (F.Dir));
+ Gen_B8 (0); -- time
+ Gen_B8 (0); -- length
+ F := F.Next;
+ end loop;
+ Gen_B8 (0); -- last entry.
+ end;
+
+ -- Set prolog length
+ Patch_32 (6, Unsigned_32 (Get_Current_Pc - 6));
+
+ Merge_Section (Line_Sect, Line1_Sect);
+
+ -- Emit end of sequence.
+ Gen_B8 (0); -- extended opcode
+ Gen_B8 (1); -- length: 1
+ Gen_B8 (Byte (DW_LNE_End_Sequence));
+
+ -- Set total length.
+ Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+ -- Info.
+ Set_Current_Section (Info_Sect);
+ -- Finish child.
+ Gen_Uleb128 (0);
+ -- Set total length.
+ Patch_32 (0, Unsigned_32 (Get_Current_Pc - 4));
+
+ -- Aranges
+ Create_Section (Aranges_Sect, ".debug_aranges", Section_Debug);
+ Set_Section_Info (Aranges_Sect, null, 0, 0);
+ Set_Current_Section (Aranges_Sect);
+
+ Gen_32 (28); -- Length.
+ Gen_16 (2); -- version
+ Gen_Ua_32 (Info_Sym, 0); -- info offset
+ Gen_B8 (4); -- Ptr size.
+ Gen_B8 (0); -- seg desc size.
+ Gen_32 (0); -- pad
+ Gen_Ua_32 (Orig_Sym, 0); -- text offset
+ Gen_32 (Unsigned_32 (Length));
+ Gen_32 (0); -- End
+ Gen_32 (0);
+ end Finish;
+
+ procedure Generate_Abbrev (Abbrev : out Unsigned_32) is
+ begin
+ Abbrev_Last := Abbrev_Last + 1;
+ Abbrev := Abbrev_Last;
+
+ Set_Current_Section (Abbrev_Sect);
+ -- FIXME: should be enough ?
+ Prealloc (128);
+ Gen_Uleb128 (Abbrev);
+ end Generate_Abbrev;
+
+ procedure Gen_Info_Header (Abbrev : Unsigned_32) is
+ begin
+ Set_Current_Section (Info_Sect);
+ Gen_Uleb128 (Abbrev);
+ end Gen_Info_Header;
+
+ function Gen_Info_Sibling return Pc_Type
+ is
+ Pc : Pc_Type;
+ begin
+ Pc := Get_Current_Pc;
+ Gen_32 (0);
+ return Pc;
+ end Gen_Info_Sibling;
+
+ procedure Patch_Info_Sibling (Pc : Pc_Type) is
+ begin
+ Patch_32 (Pc, Unsigned_32 (Get_Current_Pc));
+ end Patch_Info_Sibling;
+
+ Abbrev_Base_Type : Unsigned_32 := 0;
+ Abbrev_Base_Type_Name : Unsigned_32 := 0;
+ Abbrev_Pointer : Unsigned_32 := 0;
+ Abbrev_Pointer_Name : Unsigned_32 := 0;
+ Abbrev_Uncomplete_Pointer : Unsigned_32 := 0;
+ Abbrev_Uncomplete_Pointer_Name : Unsigned_32 := 0;
+ Abbrev_Ucarray : Unsigned_32 := 0;
+ Abbrev_Ucarray_Name : Unsigned_32 := 0;
+ Abbrev_Uc_Subrange : Unsigned_32 := 0;
+ Abbrev_Subarray : Unsigned_32 := 0;
+ Abbrev_Subarray_Name : Unsigned_32 := 0;
+ Abbrev_Subrange : Unsigned_32 := 0;
+ Abbrev_Struct : Unsigned_32 := 0;
+ Abbrev_Struct_Name : Unsigned_32 := 0;
+ Abbrev_Union : Unsigned_32 := 0;
+ Abbrev_Union_Name : Unsigned_32 := 0;
+ Abbrev_Member : Unsigned_32 := 0;
+ Abbrev_Enum : Unsigned_32 := 0;
+ Abbrev_Enum_Name : Unsigned_32 := 0;
+ Abbrev_Enumerator : Unsigned_32 := 0;
+
+ package TOnodes is new GNAT.Table
+ (Table_Component_Type => Pc_Type,
+ Table_Index_Type => O_Tnode,
+ Table_Low_Bound => O_Tnode_First,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ procedure Emit_Type_Ref (Atype : O_Tnode)
+ is
+ Off : Pc_Type;
+ begin
+ Off := TOnodes.Table (Atype);
+ if Off = Null_Pc then
+ raise Program_Error;
+ end if;
+ Gen_32 (Unsigned_32 (Off));
+ end Emit_Type_Ref;
+
+ procedure Emit_Ident (Id : O_Ident)
+ is
+ use Ortho_Ident;
+ L : Natural;
+ begin
+ L := Get_String_Length (Id);
+ Prealloc (Pc_Type (L) + 128);
+ Gen_String_Nul (Get_String (Id));
+ end Emit_Ident;
+
+ procedure Add_Type_Ref (Atype : O_Tnode; Pc : Pc_Type)
+ is
+ Prev : O_Tnode;
+ begin
+ if Atype > TOnodes.Last then
+ -- Expand.
+ Prev := TOnodes.Last;
+ TOnodes.Set_Last (Atype);
+ TOnodes.Table (Prev + 1 .. Atype - 1) := (others => Null_Pc);
+ end if;
+ TOnodes.Table (Atype) := Pc;
+ end Add_Type_Ref;
+
+ procedure Emit_Decl_Ident (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Ident (Get_Decl_Ident (Decl));
+ end Emit_Decl_Ident;
+
+ procedure Emit_Decl_Ident_If_Set (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ if Decl /= O_Dnode_Null then
+ Emit_Ident (Get_Decl_Ident (Decl));
+ end if;
+ end Emit_Decl_Ident_If_Set;
+
+ procedure Emit_Type (Atype : O_Tnode);
+
+ procedure Emit_Base_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Encoding, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Base_Type = 0 then
+ Generate_Abbrev (Abbrev_Base_Type);
+ Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Base_Type);
+ else
+ if Abbrev_Base_Type_Name = 0 then
+ Generate_Abbrev (Abbrev_Base_Type_Name);
+ Gen_Abbrev_Header (DW_TAG_Base_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Base_Type_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+
+ case Get_Type_Kind (Atype) is
+ when OT_Signed =>
+ Gen_B8 (DW_ATE_Signed);
+ when OT_Unsigned =>
+ Gen_B8 (DW_ATE_Unsigned);
+ when OT_Float =>
+ Gen_B8 (DW_ATE_Float);
+ when others =>
+ raise Program_Error;
+ end case;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ end Emit_Base_Type;
+
+ procedure Emit_Access_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ procedure Finish_Gen_Abbrev_Uncomplete is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev_Uncomplete;
+
+ Dtype : O_Tnode;
+ D_Pc : Pc_Type;
+ begin
+ Dtype := Get_Type_Access_Type (Atype);
+
+ if Dtype = O_Tnode_Null then
+ if Decl = O_Dnode_Null then
+ if Abbrev_Uncomplete_Pointer = 0 then
+ Generate_Abbrev (Abbrev_Uncomplete_Pointer);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev_Uncomplete;
+ end if;
+ Gen_Info_Header (Abbrev_Uncomplete_Pointer);
+ else
+ if Abbrev_Uncomplete_Pointer_Name = 0 then
+ Generate_Abbrev (Abbrev_Uncomplete_Pointer_Name);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev_Uncomplete;
+ end if;
+ Gen_Info_Header (Abbrev_Uncomplete_Pointer_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ else
+ if Decl = O_Dnode_Null then
+ if Abbrev_Pointer = 0 then
+ Generate_Abbrev (Abbrev_Pointer);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Pointer);
+ else
+ if Abbrev_Pointer_Name = 0 then
+ Generate_Abbrev (Abbrev_Pointer_Name);
+ Gen_Abbrev_Header (DW_TAG_Pointer_Type, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Pointer_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ -- Break possible loops: generate the access entry...
+ D_Pc := Get_Current_Pc;
+ Gen_32 (0);
+ -- ... generate the designated type ...
+ Emit_Type (Dtype);
+ -- ... and write its reference.
+ Patch_32 (D_Pc, Unsigned_32 (TOnodes.Table (Dtype)));
+ end if;
+ end Emit_Access_Type;
+
+ procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Ucarray = 0 then
+ Generate_Abbrev (Abbrev_Ucarray);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Ucarray);
+ else
+ if Abbrev_Ucarray_Name = 0 then
+ Generate_Abbrev (Abbrev_Ucarray_Name);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Ucarray_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+ Emit_Type_Ref (Get_Type_Ucarray_Element (Atype));
+
+ if Abbrev_Uc_Subrange = 0 then
+ Generate_Abbrev (Abbrev_Uc_Subrange);
+ Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Uc_Subrange);
+ Emit_Type_Ref (Get_Type_Ucarray_Index (Atype));
+
+ Gen_Uleb128 (0);
+ end Emit_Ucarray_Type;
+
+ procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ Base : O_Tnode;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Subarray = 0 then
+ Generate_Abbrev (Abbrev_Subarray);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Subarray);
+ else
+ if Abbrev_Subarray_Name = 0 then
+ Generate_Abbrev (Abbrev_Subarray_Name);
+ Gen_Abbrev_Header (DW_TAG_Array_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Subarray_Name);
+ Emit_Decl_Ident (Decl);
+ end if;
+
+ Base := Get_Type_Subarray_Base (Atype);
+
+ Emit_Type_Ref (Get_Type_Ucarray_Element (Base));
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+ if Abbrev_Subrange = 0 then
+ Generate_Abbrev (Abbrev_Subrange);
+ Gen_Abbrev_Header (DW_TAG_Subrange_Type, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Lower_Bound, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (DW_AT_Count, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Subrange);
+ Emit_Type_Ref (Get_Type_Ucarray_Index (Base));
+ Gen_B8 (0);
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype)));
+
+ Gen_Uleb128 (0);
+ end Emit_Subarray_Type;
+
+ procedure Emit_Members (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ Nbr : Uns32;
+ F : O_Fnode;
+ Loc_Pc : Pc_Type;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Member = 0 then
+ Generate_Abbrev (Abbrev_Member);
+
+ Gen_Abbrev_Header (DW_TAG_Member, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Data_Member_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Set_Current_Section (Info_Sect);
+ Sibling_Pc := Gen_Info_Sibling;
+ Emit_Decl_Ident_If_Set (Decl);
+ Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+
+ Nbr := Get_Type_Record_Nbr_Fields (Atype);
+ F := Get_Type_Record_Fields (Atype);
+ while Nbr > 0 loop
+ Gen_Uleb128 (Abbrev_Member);
+ Emit_Ident (Get_Field_Ident (F));
+ Emit_Type_Ref (Get_Field_Type (F));
+
+ -- Location.
+ Loc_Pc := Get_Current_Pc;
+ Gen_B8 (3);
+ Gen_B8 (DW_OP_Plus_Uconst);
+ Gen_Uleb128 (Unsigned_32 (Get_Field_Offset (F)));
+ Patch_B8 (Loc_Pc, Unsigned_8 (Get_Current_Pc - (Loc_Pc + 1)));
+
+ F := Get_Field_Chain (F);
+ Nbr := Nbr - 1;
+ end loop;
+
+ -- end of children.
+ Gen_Uleb128 (0);
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Members;
+
+ procedure Emit_Record_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Struct = 0 then
+ Generate_Abbrev (Abbrev_Struct);
+
+ Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Struct);
+ else
+ if Abbrev_Struct_Name = 0 then
+ Generate_Abbrev (Abbrev_Struct_Name);
+
+ Gen_Abbrev_Header (DW_TAG_Structure_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Struct_Name);
+ end if;
+ Emit_Members (Atype, Decl);
+ end Emit_Record_Type;
+
+ procedure Emit_Union_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+ begin
+ if Decl = O_Dnode_Null then
+ if Abbrev_Union = 0 then
+ Generate_Abbrev (Abbrev_Union);
+
+ Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Union);
+ else
+ if Abbrev_Union_Name = 0 then
+ Generate_Abbrev (Abbrev_Union_Name);
+
+ Gen_Abbrev_Header (DW_TAG_Union_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Union_Name);
+ end if;
+ Emit_Members (Atype, Decl);
+ end Emit_Union_Type;
+
+ procedure Emit_Enum_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ use Ortho_Code.Consts;
+ procedure Finish_Gen_Abbrev is
+ begin
+ Gen_Abbrev_Tuple (DW_AT_Byte_Size, DW_FORM_Data1);
+ Gen_Abbrev_Tuple (0, 0);
+ end Finish_Gen_Abbrev;
+
+ procedure Emit_Enumerator (L : O_Cnode) is
+ begin
+ Gen_Uleb128 (Abbrev_Enumerator);
+ Emit_Ident (Get_Lit_Ident (L));
+ Gen_Uleb128 (Unsigned_32 (Get_Lit_Value (L)));
+ end Emit_Enumerator;
+
+ Nbr : Uns32;
+ L : O_Cnode;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Enumerator = 0 then
+ Generate_Abbrev (Abbrev_Enumerator);
+
+ Gen_Abbrev_Header (DW_TAG_Enumerator, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Const_Value, DW_FORM_Udata);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ if Decl = O_Dnode_Null then
+ if Abbrev_Enum = 0 then
+ Generate_Abbrev (Abbrev_Enum);
+ Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Enum);
+ else
+ if Abbrev_Enum_Name = 0 then
+ Generate_Abbrev (Abbrev_Enum_Name);
+ Gen_Abbrev_Header (DW_TAG_Enumeration_Type, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Finish_Gen_Abbrev;
+ end if;
+ Gen_Info_Header (Abbrev_Enum_Name);
+ end if;
+
+ Sibling_Pc := Gen_Info_Sibling;
+ Emit_Decl_Ident_If_Set (Decl);
+ Gen_B8 (Byte (Get_Type_Size (Atype)));
+ case Get_Type_Kind (Atype) is
+ when OT_Enum =>
+ Nbr := Get_Type_Enum_Nbr_Lits (Atype);
+ L := Get_Type_Enum_Lits (Atype);
+ while Nbr > 0 loop
+ Emit_Enumerator (L);
+
+ L := Get_Lit_Chain (L);
+ Nbr := Nbr - 1;
+ end loop;
+ when OT_Boolean =>
+ Emit_Enumerator (Get_Type_Bool_False (Atype));
+ Emit_Enumerator (Get_Type_Bool_True (Atype));
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- End of children.
+ Gen_Uleb128 (0);
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Enum_Type;
+
+ procedure Emit_Type (Atype : O_Tnode)
+ is
+ use Ortho_Code.Types;
+ use Ada.Text_IO;
+ Kind : OT_Kind;
+ Decl : O_Dnode;
+ begin
+ -- If already emitted, then return.
+ if Atype <= TOnodes.Last
+ and then TOnodes.Table (Atype) /= Null_Pc
+ then
+ return;
+ end if;
+
+ Kind := Get_Type_Kind (Atype);
+
+ -- First step: emit inner types (if any).
+ case Kind is
+ when OT_Signed
+ | OT_Unsigned
+ | OT_Float
+ | OT_Boolean
+ | OT_Enum =>
+ null;
+ when OT_Access =>
+ null;
+ when OT_Ucarray =>
+ Emit_Type (Get_Type_Ucarray_Index (Atype));
+ Emit_Type (Get_Type_Ucarray_Element (Atype));
+ when OT_Subarray =>
+ Emit_Type (Get_Type_Subarray_Base (Atype));
+ when OT_Record
+ | OT_Union =>
+ declare
+ Nbr : Uns32;
+ F : O_Fnode;
+ begin
+ Nbr := Get_Type_Record_Nbr_Fields (Atype);
+ F := Get_Type_Record_Fields (Atype);
+ while Nbr > 0 loop
+ Emit_Type (Get_Field_Type (F));
+ F := Get_Field_Chain (F);
+ Nbr := Nbr - 1;
+ end loop;
+ end;
+ when OT_Complete =>
+ null;
+ end case;
+
+ Set_Current_Section (Info_Sect);
+ Add_Type_Ref (Atype, Get_Current_Pc);
+
+ Decl := Decls.Get_Type_Decl (Atype);
+
+ -- Second step: emit info.
+ case Kind is
+ when OT_Signed
+ | OT_Unsigned
+ | OT_Float =>
+ Emit_Base_Type (Atype, Decl);
+ -- base types.
+ when OT_Access =>
+ Emit_Access_Type (Atype, Decl);
+ when OT_Ucarray =>
+ Emit_Ucarray_Type (Atype, Decl);
+ when OT_Subarray =>
+ Emit_Subarray_Type (Atype, Decl);
+ when OT_Record =>
+ Emit_Record_Type (Atype, Decl);
+ when OT_Union =>
+ Emit_Union_Type (Atype, Decl);
+ when OT_Enum
+ | OT_Boolean =>
+ Emit_Enum_Type (Atype, Decl);
+ when OT_Complete =>
+ null;
+ end case;
+ end Emit_Type;
+
+ procedure Emit_Decl_Type (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Type_Ref (Get_Decl_Type (Decl));
+ end Emit_Decl_Type;
+
+ Abbrev_Variable : Unsigned_32 := 0;
+ Abbrev_Const : Unsigned_32 := 0;
+
+ procedure Emit_Local_Location (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Pc : Pc_Type;
+ begin
+ Pc := Get_Current_Pc;
+ Gen_B8 (2);
+ Gen_B8 (DW_OP_Fbreg);
+ Gen_Sleb128 (Get_Decl_Info (Decl));
+ Patch_B8 (Pc, Unsigned_8 (Get_Current_Pc - (Pc + 1)));
+ end Emit_Local_Location;
+
+ procedure Emit_Global_Location (Decl : O_Dnode)
+ is
+ use Ortho_Code.Binary;
+ begin
+ Gen_B8 (5);
+ Gen_B8 (DW_OP_Addr);
+ Gen_Ua_32 (Get_Decl_Symbol (Decl), 0);
+ end Emit_Global_Location;
+
+ procedure Emit_Variable (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Dtype : O_Tnode;
+ begin
+ if Get_Decl_Ident (Decl) = O_Ident_Nul then
+ return;
+ end if;
+
+ if Abbrev_Variable = 0 then
+ Generate_Abbrev (Abbrev_Variable);
+ Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Dtype := Get_Decl_Type (Decl);
+ Emit_Type (Dtype);
+
+ Gen_Info_Header (Abbrev_Variable);
+ Emit_Decl_Ident (Decl);
+ Emit_Type_Ref (Dtype);
+ case Get_Decl_Kind (Decl) is
+ when OD_Local =>
+ Emit_Local_Location (Decl);
+ when OD_Var =>
+ Emit_Global_Location (Decl);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Emit_Variable;
+
+ procedure Emit_Const (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Dtype : O_Tnode;
+ begin
+ if Abbrev_Const = 0 then
+ Generate_Abbrev (Abbrev_Const);
+ -- FIXME: should be a TAG_Constant, however, GDB does not support it.
+ -- work-around: could use a const_type.
+ Gen_Abbrev_Header (DW_TAG_Variable, DW_CHILDREN_No);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Dtype := Get_Decl_Type (Decl);
+ Emit_Type (Dtype);
+ Gen_Info_Header (Abbrev_Const);
+ Emit_Decl_Ident (Decl);
+ Emit_Type_Ref (Dtype);
+ Emit_Global_Location (Decl);
+ end Emit_Const;
+
+ procedure Emit_Type_Decl (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ begin
+ Emit_Type (Get_Decl_Type (Decl));
+ end Emit_Type_Decl;
+
+ Subprg_Sym : Symbol;
+
+ Abbrev_Block : Unsigned_32 := 0;
+
+ procedure Emit_Block_Decl (Decl : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Last : O_Dnode;
+ Sdecl : O_Dnode;
+ Sibling_Pc : Pc_Type;
+ begin
+ if Abbrev_Block = 0 then
+ Generate_Abbrev (Abbrev_Block);
+
+ Gen_Abbrev_Header (DW_TAG_Lexical_Block, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ Gen_Info_Header (Abbrev_Block);
+ Sibling_Pc := Gen_Info_Sibling;
+
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info1 (Decl)));
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Block_Info2 (Decl)));
+
+ -- Emit decls for children.
+ Last := Get_Block_Last (Decl);
+ Sdecl := Decl + 1;
+ while Sdecl <= Last loop
+ Emit_Decl (Sdecl);
+ Sdecl := Get_Decl_Chain (Sdecl);
+ end loop;
+
+ -- End of children.
+ Set_Current_Section (Info_Sect);
+ Gen_Uleb128 (0);
+
+ Patch_Info_Sibling (Sibling_Pc);
+ end Emit_Block_Decl;
+
+ Abbrev_Function : Unsigned_32 := 0;
+ Abbrev_Procedure : Unsigned_32 := 0;
+ Abbrev_Interface : Unsigned_32 := 0;
+
+ procedure Emit_Subprg_Body (Bod : O_Dnode)
+ is
+ use Ortho_Code.Decls;
+ Kind : OD_Kind;
+ Decl : O_Dnode;
+ Idecl : O_Dnode;
+ Prev_Subprg_Sym : Symbol;
+ Sibling_Pc : Pc_Type;
+ begin
+ Decl := Get_Body_Decl (Bod);
+ Kind := Get_Decl_Kind (Decl);
+
+ -- Emit interfaces type.
+ Idecl := Get_Subprg_Interfaces (Decl);
+ while Idecl /= O_Dnode_Null loop
+ Emit_Type (Get_Decl_Type (Idecl));
+ Idecl := Get_Interface_Chain (Idecl);
+ end loop;
+
+ if Kind = OD_Function then
+ Emit_Type (Get_Decl_Type (Decl));
+ if Abbrev_Function = 0 then
+ Generate_Abbrev (Abbrev_Function);
+
+ Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+ --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ Gen_Info_Header (Abbrev_Function);
+ else
+ if Abbrev_Procedure = 0 then
+ Generate_Abbrev (Abbrev_Procedure);
+
+ Gen_Abbrev_Header (DW_TAG_Subprogram, DW_CHILDREN_Yes);
+ Gen_Abbrev_Tuple (DW_AT_Sibling, DW_FORM_Ref4);
+
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Low_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_High_Pc, DW_FORM_Addr);
+ Gen_Abbrev_Tuple (DW_AT_Frame_Base, DW_FORM_Block1);
+ --Gen_Abbrev_Tuple (DW_AT_Return_Addr, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+ Gen_Info_Header (Abbrev_Procedure);
+ end if;
+
+ Sibling_Pc := Gen_Info_Sibling;
+
+ if Kind = OD_Function then
+ Emit_Decl_Type (Decl);
+ end if;
+
+ Emit_Decl_Ident (Decl);
+ Prev_Subprg_Sym := Subprg_Sym;
+ Subprg_Sym := Binary.Get_Decl_Symbol (Decl);
+ Gen_Ua_32 (Subprg_Sym, 0);
+ Gen_Ua_32 (Subprg_Sym, Integer_32 (Get_Body_Info (Bod)));
+
+ -- Frame base.
+ Gen_B8 (1);
+ Gen_B8 (DW_OP_Reg5);
+
+ -- Interfaces.
+ Idecl := Get_Subprg_Interfaces (Decl);
+ if Idecl /= O_Dnode_Null then
+ if Abbrev_Interface = 0 then
+ Generate_Abbrev (Abbrev_Interface);
+
+ Gen_Abbrev_Header (DW_TAG_Formal_Parameter, DW_CHILDREN_No);
+ Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
+ Gen_Abbrev_Tuple (DW_AT_Name, DW_FORM_String);
+ Gen_Abbrev_Tuple (DW_AT_Location, DW_FORM_Block1);
+ Gen_Abbrev_Tuple (0, 0);
+ end if;
+
+ loop
+ Gen_Info_Header (Abbrev_Interface);
+ Emit_Decl_Type (Idecl);
+ Emit_Decl_Ident (Idecl);
+
+ Emit_Local_Location (Idecl);
+
+ Idecl := Get_Interface_Chain (Idecl);
+ exit when Idecl = O_Dnode_Null;
+ end loop;
+ end if;
+
+ -- Internal declarations.
+ Emit_Block_Decl (Bod + 1);
+
+ -- End of children.
+ Gen_Uleb128 (0);
+
+ Patch_Info_Sibling (Sibling_Pc);
+
+ Subprg_Sym := Prev_Subprg_Sym;
+ end Emit_Subprg_Body;
+
+ procedure Emit_Decl (Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Decls;
+ begin
+ case Get_Decl_Kind (Decl) is
+ when OD_Type =>
+ Emit_Type_Decl (Decl);
+ when OD_Local
+ | OD_Var =>
+ Emit_Variable (Decl);
+ when OD_Const =>
+ Emit_Const (Decl);
+ when OD_Function
+ | OD_Procedure
+ | OD_Interface =>
+ null;
+ when OD_Body =>
+ Emit_Subprg_Body (Decl);
+ when OD_Block =>
+ Emit_Block_Decl (Decl);
+ when others =>
+ Put_Line ("dwarf.emit_decl: emit "
+ & OD_Kind'Image (Get_Decl_Kind (Decl)));
+ end case;
+ end Emit_Decl;
+
+ procedure Emit_Subprg (Bod : O_Dnode) is
+ begin
+ Emit_Decls_Until (Bod);
+ Emit_Decl (Bod);
+ Last_Decl := Decls.Get_Decl_Chain (Bod);
+ end Emit_Subprg;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Last_Decl := Last_Decl;
+ M.Last_Tnode := TOnodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Last_Decl := M.Last_Decl;
+ TOnodes.Set_Last (M.Last_Tnode);
+ end Release;
+
+end Ortho_Code.Dwarf;
+
diff --git a/src/ortho/mcode/ortho_code-dwarf.ads b/src/ortho/mcode/ortho_code-dwarf.ads
new file mode 100644
index 000000000..c120bcfe1
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-dwarf.ads
@@ -0,0 +1,41 @@
+-- Mcode back-end for ortho - Dwarf generator.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ortho_Code.Dwarf is
+ procedure Init;
+ procedure Finish;
+
+ -- For a body.
+ procedure Emit_Subprg (Bod : O_Dnode);
+
+ -- Emit all debug info until but not including LAST.
+ procedure Emit_Decls_Until (Last : O_Dnode);
+
+ -- For a line in a subprogram.
+ procedure Set_Line_Stmt (Line : Int32);
+ procedure Set_Filename (Dir : String; File : String);
+
+ type Mark_Type is limited private;
+ procedure Mark (M : out Mark_Type);
+ procedure Release (M : Mark_Type);
+
+private
+ type Mark_Type is record
+ Last_Decl : O_Dnode;
+ Last_Tnode : O_Tnode;
+ end record;
+end Ortho_Code.Dwarf;
diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb
new file mode 100644
index 000000000..b2dfa1a67
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-exprs.adb
@@ -0,0 +1,1663 @@
+-- Mcode back-end for ortho - Expressions and control handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+with GNAT.Table;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Debug; use Ortho_Code.Debug;
+with Ortho_Code.Abi; use Ortho_Code.Abi;
+with Ortho_Code.Disps;
+with Ortho_Code.Opts;
+with Ortho_Code.Flags;
+
+package body Ortho_Code.Exprs is
+
+ type Enode_Pad is mod 256;
+
+ type Enode_Common is record
+ Kind : OE_Kind; -- about 1 byte (6 bits)
+ Reg : O_Reg; -- 1 byte
+ Mode : Mode_Type; -- 4 bits
+ Ref : Boolean;
+ Flag1 : Boolean;
+ Flag2 : Boolean;
+ Flag3 : Boolean;
+ Pad : Enode_Pad;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode;
+ Info : Int32;
+ end record;
+ pragma Pack (Enode_Common);
+ for Enode_Common'Size use 4*32;
+ for Enode_Common'Alignment use 4;
+
+ package Enodes is new GNAT.Table
+ (Table_Component_Type => Enode_Common,
+ Table_Index_Type => O_Enode,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ function Get_Expr_Kind (Enode : O_Enode) return OE_Kind is
+ begin
+ return Enodes.Table (Enode).Kind;
+ end Get_Expr_Kind;
+
+ function Get_Expr_Mode (Enode : O_Enode) return Mode_Type is
+ begin
+ return Enodes.Table (Enode).Mode;
+ end Get_Expr_Mode;
+
+ function Get_Enode_Type (Enode : O_Enode) return O_Tnode is
+ begin
+ return O_Tnode (Enodes.Table (Enode).Info);
+ end Get_Enode_Type;
+
+ function Get_Expr_Reg (Enode : O_Enode) return O_Reg is
+ begin
+ return Enodes.Table (Enode).Reg;
+ end Get_Expr_Reg;
+
+ procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg) is
+ begin
+ Enodes.Table (Enode).Reg := Reg;
+ end Set_Expr_Reg;
+
+ function Get_Expr_Operand (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Expr_Operand;
+
+ procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Val;
+ end Set_Expr_Operand;
+
+ function Get_Expr_Left (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Expr_Left;
+
+ function Get_Expr_Right (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Expr_Right;
+
+ procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Val;
+ end Set_Expr_Left;
+
+ procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Val;
+ end Set_Expr_Right;
+
+ function Get_Expr_Low (Cst : O_Enode) return Uns32 is
+ begin
+ return To_Uns32 (Int32 (Enodes.Table (Cst).Arg1));
+ end Get_Expr_Low;
+
+ function Get_Expr_High (Cst : O_Enode) return Uns32 is
+ begin
+ return To_Uns32 (Int32 (Enodes.Table (Cst).Arg2));
+ end Get_Expr_High;
+
+ function Get_Assign_Target (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Assign_Target;
+
+ procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Targ;
+ end Set_Assign_Target;
+
+ function Get_Expr_Lit (Lit : O_Enode) return O_Cnode is
+ begin
+ return O_Cnode (Enodes.Table (Lit).Arg1);
+ end Get_Expr_Lit;
+
+ function Get_Conv_Type (Enode : O_Enode) return O_Tnode is
+ begin
+ return O_Tnode (Enodes.Table (Enode).Arg2);
+ end Get_Conv_Type;
+
+ -- Leave node corresponding to the entry.
+ function Get_Entry_Leave (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg1;
+ end Get_Entry_Leave;
+
+ procedure Set_Entry_Leave (Enode : O_Enode; Leave : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg1 := Leave;
+ end Set_Entry_Leave;
+
+ function Get_Jump_Label (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Jump_Label;
+
+ procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Label;
+ end Set_Jump_Label;
+
+ function Get_Addr_Object (Enode : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Enode).Arg1);
+ end Get_Addr_Object;
+
+ function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Addrl_Frame;
+
+ procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode) is
+ begin
+ Enodes.Table (Enode).Arg2 := Frame;
+ end Set_Addrl_Frame;
+
+ function Get_Call_Subprg (Enode : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Enode).Arg1);
+ end Get_Call_Subprg;
+
+ function Get_Stack_Adjust (Enode : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Enode).Arg1);
+ end Get_Stack_Adjust;
+
+ function Get_Arg_Link (Enode : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Enode).Arg2;
+ end Get_Arg_Link;
+
+ function Get_Block_Decls (Blk : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Blk).Arg2);
+ end Get_Block_Decls;
+
+ function Get_Block_Parent (Blk : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Blk).Arg1;
+ end Get_Block_Parent;
+
+ function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean is
+ begin
+ return Enodes.Table (Blk).Flag1;
+ end Get_Block_Has_Alloca;
+
+ procedure Set_Block_Has_Alloca (Blk : O_Enode; Flag : Boolean) is
+ begin
+ Enodes.Table (Blk).Flag1 := Flag;
+ end Set_Block_Has_Alloca;
+
+ function Get_End_Beg (Blk : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Blk).Arg1;
+ end Get_End_Beg;
+
+ function Get_Label_Info (Label : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Label).Arg2);
+ end Get_Label_Info;
+
+ procedure Set_Label_Info (Label : O_Enode; Info : Int32) is
+ begin
+ Enodes.Table (Label).Arg2 := O_Enode (Info);
+ end Set_Label_Info;
+
+ function Get_Label_Block (Label : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Label).Arg1;
+ end Get_Label_Block;
+
+ function Get_Spill_Info (Spill : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Spill).Arg2);
+ end Get_Spill_Info;
+
+ procedure Set_Spill_Info (Spill : O_Enode; Info : Int32) is
+ begin
+ Enodes.Table (Spill).Arg2 := O_Enode (Info);
+ end Set_Spill_Info;
+
+ -- Get the statement link.
+ function Get_Stmt_Link (Stmt : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Enodes.Table (Stmt).Info);
+ end Get_Stmt_Link;
+
+ procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode) is
+ begin
+ Enodes.Table (Stmt).Info := Int32 (Next);
+ end Set_Stmt_Link;
+
+ function Get_BB_Next (Stmt : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Stmt).Arg1;
+ end Get_BB_Next;
+ pragma Unreferenced (Get_BB_Next);
+
+ procedure Set_BB_Next (Stmt : O_Enode; Next : O_Enode) is
+ begin
+ Enodes.Table (Stmt).Arg1 := Next;
+ end Set_BB_Next;
+
+ function Get_BB_Number (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg2);
+ end Get_BB_Number;
+
+ function Get_Loop_Level (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Loop_Level;
+
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32) is
+ begin
+ Enodes.Table (Stmt).Arg1 := O_Enode (Level);
+ end Set_Loop_Level;
+
+ procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode) is
+ begin
+ Enodes.Table (C).Arg2 := Branch;
+ end Set_Case_Branch;
+
+ procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode) is
+ begin
+ Enodes.Table (Branch).Arg1 := Choice;
+ end Set_Case_Branch_Choice;
+
+ function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Branch).Arg1;
+ end Get_Case_Branch_Choice;
+
+ procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode) is
+ begin
+ Enodes.Table (Choice).Info := Int32 (N_Choice);
+ end Set_Case_Choice_Link;
+
+ function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Enodes.Table (Choice).Info);
+ end Get_Case_Choice_Link;
+
+ function Get_Ref_Field (Ref : O_Enode) return O_Fnode is
+ begin
+ return O_Fnode (Enodes.Table (Ref).Arg2);
+ end Get_Ref_Field;
+
+ function Get_Ref_Index (Ref : O_Enode) return O_Enode is
+ begin
+ return Enodes.Table (Ref).Arg2;
+ end Get_Ref_Index;
+
+ function Get_Expr_Line_Number (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Expr_Line_Number;
+
+ function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32 is
+ begin
+ return Int32 (Enodes.Table (Stmt).Arg1);
+ end Get_Intrinsic_Operation;
+
+ Last_Stmt : O_Enode := O_Enode_Null;
+
+ procedure Link_Stmt (Stmt : O_Enode) is
+ begin
+ if Last_Stmt = O_Enode_Null then
+ raise Program_Error;
+ end if;
+ Set_Stmt_Link (Last_Stmt, Stmt);
+ Last_Stmt := Stmt;
+ end Link_Stmt;
+
+ function New_Enode (Kind : OE_Kind;
+ Rtype : O_Tnode;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode) return O_Enode
+ is
+ Mode : Mode_Type;
+ begin
+ Mode := Get_Type_Mode (Rtype);
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => Int32 (Rtype)));
+ return Enodes.Last;
+ end New_Enode;
+
+ function New_Enode (Kind : OE_Kind;
+ Mode : Mode_Type;
+ Rtype : O_Tnode;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode) return O_Enode
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => Int32 (Rtype)));
+ return Enodes.Last;
+ end New_Enode;
+
+ procedure New_Enode_Stmt (Kind : OE_Kind; Arg1 : O_Enode; Arg2 : O_Enode)
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode_Nil,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => 0));
+ Link_Stmt (Enodes.Last);
+ end New_Enode_Stmt;
+
+ procedure New_Enode_Stmt
+ (Kind : OE_Kind; Mode : Mode_Type; Arg1 : O_Enode; Arg2 : O_Enode)
+ is
+ begin
+ Enodes.Append (Enode_Common'(Kind => Kind,
+ Reg => 0,
+ Mode => Mode,
+ Ref => False,
+ Flag1 => False,
+ Flag2 => False,
+ Flag3 => False,
+ Pad => 0,
+ Arg1 => Arg1,
+ Arg2 => Arg2,
+ Info => 0));
+ Link_Stmt (Enodes.Last);
+ end New_Enode_Stmt;
+
+ Bb_Num : Int32 := 0;
+ Last_Bb : O_Enode := O_Enode_Null;
+
+ procedure Create_BB is
+ begin
+ New_Enode_Stmt (OE_BB, Mode_Nil, O_Enode_Null, O_Enode (Bb_Num));
+ if Last_Bb /= O_Enode_Null then
+ Set_BB_Next (Last_Bb, Enodes.Last);
+ end if;
+ Last_Bb := Enodes.Last;
+ Bb_Num := Bb_Num + 1;
+ end Create_BB;
+
+ procedure Start_BB is
+ begin
+ if Flags.Flag_Opt_BB then
+ Create_BB;
+ end if;
+ end Start_BB;
+ pragma Inline (Start_BB);
+
+ procedure Check_Ref (E : O_Enode) is
+ begin
+ if Enodes.Table (E).Ref then
+ raise Syntax_Error;
+ end if;
+ Enodes.Table (E).Ref := True;
+ end Check_Ref;
+
+ procedure Check_Ref (E : O_Lnode) is
+ begin
+ Check_Ref (O_Enode (E));
+ end Check_Ref;
+
+ procedure Check_Value_Type (Val : O_Enode; Vtype : O_Tnode) is
+ begin
+ if Get_Enode_Type (Val) /= Vtype then
+ raise Syntax_Error;
+ end if;
+ end Check_Value_Type;
+
+ function New_Const_U32 (Val : Uns32; Vtype : O_Tnode) return O_Enode
+ is
+ begin
+ return New_Enode (OE_Const, Vtype,
+ O_Enode (To_Int32 (Val)), O_Enode_Null);
+ end New_Const_U32;
+
+ Last_Decl : O_Dnode := 2;
+ Cur_Block : O_Enode := O_Enode_Null;
+
+ procedure Start_Declare_Stmt
+ is
+ Res : O_Enode;
+ begin
+ New_Enode_Stmt (OE_Beg, Cur_Block, O_Enode_Null);
+ Res := Enodes.Last;
+ Enodes.Table (Res).Arg2 := O_Enode
+ (Ortho_Code.Decls.Start_Declare_Stmt);
+ Cur_Block := Res;
+ end Start_Declare_Stmt;
+
+ function New_Stack (Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Enode (OE_Get_Stack, Rtype, O_Enode_Null, O_Enode_Null);
+ end New_Stack;
+
+ procedure New_Stack_Restore (Blk : O_Enode)
+ is
+ Save_Asgn : O_Enode;
+ Save_Var : O_Dnode;
+ begin
+ Save_Asgn := Get_Stmt_Link (Blk);
+ Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn));
+ New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)),
+ O_Enode_Null);
+ end New_Stack_Restore;
+
+ procedure Finish_Declare_Stmt
+ is
+ Parent : O_Dnode;
+ begin
+ if Get_Block_Has_Alloca (Cur_Block) then
+ New_Stack_Restore (Cur_Block);
+ end if;
+ New_Enode_Stmt (OE_End, Cur_Block, O_Enode_Null);
+ Cur_Block := Get_Block_Parent (Cur_Block);
+ if Cur_Block = O_Enode_Null then
+ Parent := O_Dnode_Null;
+ else
+ Parent := Get_Block_Decls (Cur_Block);
+ end if;
+ Ortho_Code.Decls.Finish_Declare_Stmt (Parent);
+ end Finish_Declare_Stmt;
+
+ function New_Label return O_Enode is
+ begin
+ return New_Enode (OE_Label, Mode_Nil, O_Tnode_Null,
+ Cur_Block, O_Enode_Null);
+ end New_Label;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ Start : O_Enode;
+ D_Body : O_Dnode;
+ Data : Subprogram_Data_Acc;
+ begin
+ if Cur_Subprg = null then
+ Abi.Start_Body (Func);
+ end if;
+
+ Start := New_Enode (OE_Entry, Mode_Nil, O_Tnode_Null,
+ Last_Stmt, O_Enode_Null);
+ D_Body := Decls.Start_Subprogram_Body (Func, Start);
+
+ -- Create the corresponding decl.
+ Enodes.Table (Start).Arg2 := O_Enode (D_Body);
+
+ -- Create the data record.
+ Data := new Subprogram_Data'(Parent => Cur_Subprg,
+ First_Child => null,
+ Last_Child => null,
+ Brother => null,
+ Depth => Get_Decl_Depth (Func),
+ D_Decl => Func,
+ E_Entry => Start,
+ D_Body => D_Body,
+ Exit_Label => O_Enode_Null,
+ Last_Stmt => O_Enode_Null,
+ Stack_Max => 0);
+
+ if not Flag_Debug_Hli then
+ Data.Exit_Label := New_Label;
+ end if;
+
+ -- Link the record.
+ if Cur_Subprg = null then
+ -- A top-level subprogram.
+ if First_Subprg = null then
+ First_Subprg := Data;
+ else
+ Last_Subprg.Brother := Data;
+ end if;
+ Last_Subprg := Data;
+ else
+ -- A nested subprogram.
+ if Cur_Subprg.First_Child = null then
+ Cur_Subprg.First_Child := Data;
+ else
+ Cur_Subprg.Last_Child.Brother := Data;
+ end if;
+ Cur_Subprg.Last_Child := Data;
+
+ -- Also save last_stmt.
+ Cur_Subprg.Last_Stmt := Last_Stmt;
+ end if;
+
+ Cur_Subprg := Data;
+ Last_Stmt := Start;
+
+ Start_Declare_Stmt;
+
+ -- Create a basic block for the beginning of the subprogram.
+ Start_BB;
+
+ -- Disp declarations.
+ if Cur_Subprg.Parent = null then
+ if Ortho_Code.Debug.Flag_Debug_Body
+ or Ortho_Code.Debug.Flag_Debug_Code
+ then
+ while Last_Decl <= D_Body loop
+ case Get_Decl_Kind (Last_Decl) is
+ when OD_Block =>
+ -- Skip blocks.
+ Disp_Decl (1, Last_Decl);
+ Last_Decl := Get_Block_Last (Last_Decl) + 1;
+ when others =>
+ Disp_Decl (1, Last_Decl);
+ Last_Decl := Last_Decl + 1;
+ end case;
+ end loop;
+ end if;
+ end if;
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body
+ is
+ Parent : Subprogram_Data_Acc;
+ begin
+ Finish_Declare_Stmt;
+
+ -- Create a new basic block for the epilog.
+ Start_BB;
+
+ if not Flag_Debug_Hli then
+ Link_Stmt (Cur_Subprg.Exit_Label);
+ end if;
+
+ New_Enode_Stmt (OE_Leave, O_Enode_Null, O_Enode_Null);
+
+ -- Save last statement.
+ Cur_Subprg.Last_Stmt := Enodes.Last;
+ -- Set Leave of Entry.
+ Set_Entry_Leave (Cur_Subprg.E_Entry, Enodes.Last);
+
+ Decls.Finish_Subprogram_Body;
+
+ Parent := Cur_Subprg.Parent;
+
+ if Flags.Flag_Optimize then
+ Opts.Optimize_Subprg (Cur_Subprg);
+ end if;
+
+ if Parent = null then
+ -- This is a top-level subprogram.
+ if Ortho_Code.Debug.Flag_Disp_Code then
+ Disps.Disp_Subprg (Cur_Subprg);
+ end if;
+ if Ortho_Code.Debug.Flag_Dump_Code then
+ Disp_Subprg_Body (1, Cur_Subprg.E_Entry);
+ end if;
+ if not Ortho_Code.Debug.Flag_Debug_Dump then
+ Abi.Finish_Body (Cur_Subprg);
+ end if;
+ end if;
+
+ -- Restore Cur_Subprg.
+ Cur_Subprg := Parent;
+
+ -- Restore Last_Stmt.
+ if Cur_Subprg = null then
+ Last_Stmt := O_Enode_Null;
+ else
+ Last_Stmt := Cur_Subprg.Last_Stmt;
+ end if;
+ end Finish_Subprogram_Body;
+
+ function Get_Inner_Alloca (Label : O_Enode) return O_Enode
+ is
+ Res : O_Enode := O_Enode_Null;
+ Blk : O_Enode;
+ Last_Blk : constant O_Enode := Get_Label_Block (Label);
+ begin
+ Blk := Cur_Block;
+ while Blk /= Last_Blk loop
+ if Get_Block_Has_Alloca (Blk) then
+ Res := Blk;
+ end if;
+ Blk := Get_Block_Parent (Blk);
+ end loop;
+ return Res;
+ end Get_Inner_Alloca;
+
+ procedure Emit_Jmp (Code : OE_Kind; Expr : O_Enode; Label : O_Enode)
+ is
+ begin
+ -- Discard jump after jump.
+ if Code /= OE_Jump or else Get_Expr_Kind (Last_Stmt) /= OE_Jump then
+ New_Enode_Stmt (Code, Expr, Label);
+ end if;
+ end Emit_Jmp;
+
+
+ -- If there is stack allocated memory to be freed, free it.
+ -- Then jump to LABEL.
+ procedure New_Allocb_Jump (Label : O_Enode)
+ is
+ Inner_Alloca : O_Enode;
+ begin
+ Inner_Alloca := Get_Inner_Alloca (Label);
+ if Inner_Alloca /= O_Enode_Null then
+ New_Stack_Restore (Inner_Alloca);
+ end if;
+ Emit_Jmp (OE_Jump, O_Enode_Null, Label);
+ end New_Allocb_Jump;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode
+ is
+ L_Type : O_Tnode;
+ H, L : Uns32;
+ begin
+ L_Type := Get_Const_Type (Lit);
+ if Flag_Debug_Hli then
+ return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null);
+ else
+ case Get_Const_Kind (Lit) is
+ when OC_Signed
+ | OC_Unsigned
+ | OC_Float
+ | OC_Null
+ | OC_Lit =>
+ Get_Const_Bytes (Lit, H, L);
+ return New_Enode
+ (OE_Const, L_Type,
+ O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H)));
+ when OC_Address
+ | OC_Subprg_Address =>
+ return New_Enode (OE_Addrg, L_Type,
+ O_Enode (Get_Const_Decl (Lit)), O_Enode_Null);
+ when OC_Array
+ | OC_Record
+ | OC_Union
+ | OC_Sizeof
+ | OC_Alignof =>
+ raise Syntax_Error;
+ end case;
+ end if;
+ end New_Lit;
+
+ function Get_Static_Chain (Depth : O_Depth) return O_Enode
+ is
+ Cur_Depth : O_Depth := Cur_Subprg.Depth;
+ Subprg : Subprogram_Data_Acc;
+ Res : O_Enode;
+ begin
+ if Depth = Cur_Depth then
+ return New_Enode (OE_Get_Frame, Abi.Mode_Ptr, O_Tnode_Ptr,
+ O_Enode_Null, O_Enode_Null);
+ else
+ Subprg := Cur_Subprg;
+ Res := O_Enode_Null;
+ loop
+ -- The static chain is the first interface of the subprogram.
+ Res := New_Enode (OE_Addrl, Abi.Mode_Ptr, O_Tnode_Ptr,
+ O_Enode (Get_Subprg_Interfaces (Subprg.D_Decl)),
+ Res);
+ Res := New_Enode (OE_Indir, O_Tnode_Ptr, Res, O_Enode_Null);
+ Cur_Depth := Cur_Depth - 1;
+ if Cur_Depth = Depth then
+ return Res;
+ end if;
+ Subprg := Subprg.Parent;
+ end loop;
+ end if;
+ end Get_Static_Chain;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode
+ is
+ O_Type : O_Tnode;
+ Kind : OE_Kind;
+ Chain : O_Enode;
+ Depth : O_Depth;
+ begin
+ O_Type := Get_Decl_Type (Obj);
+ case Get_Decl_Kind (Obj) is
+ when OD_Local
+ | OD_Interface =>
+ Kind := OE_Addrl;
+ -- Local declarations are 1 deeper than their subprogram.
+ Depth := Get_Decl_Depth (Obj) - 1;
+ if Depth /= Cur_Subprg.Depth then
+ Chain := Get_Static_Chain (Depth);
+ else
+ Chain := O_Enode_Null;
+ end if;
+ when OD_Var
+ | OD_Const =>
+ Kind := OE_Addrg;
+ Chain := O_Enode_Null;
+ when others =>
+ raise Program_Error;
+ end case;
+ return O_Lnode (New_Enode (Kind, Abi.Mode_Ptr, O_Type,
+ O_Enode (Obj), Chain));
+ end New_Obj;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ L_Type : O_Tnode;
+ begin
+ L_Type := Get_Enode_Type (Left);
+ if Flag_Debug_Assert then
+ if L_Type /= Get_Enode_Type (Right) then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Mode (L_Type) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ end if;
+
+ return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)),
+ L_Type, Left, Right);
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ O_Type : O_Tnode;
+ begin
+ O_Type := Get_Enode_Type (Operand);
+
+ if Flag_Debug_Assert then
+ if Get_Type_Mode (O_Type) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Operand);
+ end if;
+
+ return New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), O_Type,
+ Operand, O_Enode_Null);
+ 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 Flag_Debug_Assert then
+ if Get_Enode_Type (Left) /= Get_Enode_Type (Right) then
+ raise Syntax_Error;
+ end if;
+ if Get_Expr_Mode (Left) = Mode_Blk then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Kind (Ntype) /= OT_Boolean then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ end if;
+
+ Res := New_Enode (OE_Kind'Val (ON_Op_Kind'Pos (Kind)), Ntype,
+ Left, Right);
+ if Flag_Debug_Hli then
+ return New_Enode (OE_Typed, Ntype, Res, O_Enode (Ntype));
+ else
+ return Res;
+ end if;
+ end New_Compare_Op;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Const_U32 (Get_Type_Size (Atype), Rtype);
+ end New_Sizeof;
+
+ function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return New_Const_U32 (Get_Field_Offset (Field), Rtype);
+ end New_Offsetof;
+
+ function Is_Pow2 (V : Uns32) return Boolean is
+ begin
+ return (V and -V) = V;
+ end Is_Pow2;
+
+ function Extract_Pow2 (V : Uns32) return Uns32 is
+ begin
+ for I in Natural range 0 .. 31 loop
+ if V = Shift_Left (1, I) then
+ return Uns32 (I);
+ end if;
+ end loop;
+ raise Program_Error;
+ end Extract_Pow2;
+
+ function New_Index_Slice_Element
+ (Arr : O_Lnode; Index : O_Enode; Res_Type : O_Tnode)
+ return O_Lnode
+ is
+ El_Type : O_Tnode;
+ In_Type : O_Tnode;
+ Sz : O_Enode;
+ El_Size : Uns32;
+ begin
+ El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr)));
+ In_Type := Get_Enode_Type (Index);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Index);
+ Check_Ref (Arr);
+ end if;
+
+ -- result := arr + index * sizeof (element).
+ El_Size := Get_Type_Size (El_Type);
+ if El_Size = 1 then
+ Sz := Index;
+ elsif Get_Expr_Kind (Index) = OE_Const then
+ -- FIXME: may recycle previous index?
+ Sz := New_Const_U32 (Get_Expr_Low (Index) * El_Size, In_Type);
+ else
+ if Is_Pow2 (El_Size) then
+ Sz := New_Const_U32 (Extract_Pow2 (El_Size), In_Type);
+ Sz := New_Enode (OE_Shl, In_Type, Index, Sz);
+ else
+ Sz := New_Const_U32 (El_Size, In_Type);
+ Sz := New_Enode (OE_Mul, In_Type, Index, Sz);
+ end if;
+ end if;
+ return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Arr), Sz));
+ end New_Index_Slice_Element;
+
+ function New_Hli_Index_Slice
+ (Kind : OE_Kind; Res_Type : O_Tnode; Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Index);
+ Check_Ref (Arr);
+ end if;
+ return O_Lnode (New_Enode (Kind, Res_Type, O_Enode (Arr), Index));
+ end New_Hli_Index_Slice;
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ El_Type : O_Tnode;
+ begin
+ El_Type := Get_Type_Array_Element (Get_Enode_Type (O_Enode (Arr)));
+
+ if Flag_Debug_Hli then
+ return New_Hli_Index_Slice (OE_Index_Ref, El_Type, Arr, Index);
+ else
+ return New_Index_Slice_Element (Arr, Index, El_Type);
+ end if;
+ end New_Indexed_Element;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ begin
+ if Flag_Debug_Hli then
+ return New_Hli_Index_Slice (OE_Slice_Ref, Res_Type, Arr, Index);
+ else
+ return New_Index_Slice_Element (Arr, Index, Res_Type);
+ end if;
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ Offset : Uns32;
+ Off : O_Enode;
+ Res_Type : O_Tnode;
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Rec);
+ end if;
+
+ Res_Type := Get_Field_Type (El);
+ if Flag_Debug_Hli then
+ return O_Lnode (New_Enode (OE_Record_Ref, Res_Type,
+ O_Enode (Rec), O_Enode (El)));
+ else
+ Offset := Get_Field_Offset (El);
+ if Offset = 0 then
+ return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Rec), O_Enode (Res_Type)));
+ else
+ Off := New_Enode (OE_Const, Mode_U32, O_Tnode_Null,
+ O_Enode (Offset), O_Enode_Null);
+
+ return O_Lnode (New_Enode (OE_Add, Abi.Mode_Ptr, Res_Type,
+ O_Enode (Rec), Off));
+ end if;
+ end if;
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ Acc_Type : O_Tnode;
+ Res_Type : O_Tnode;
+ begin
+ Acc_Type := Get_Enode_Type (Acc);
+
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Acc_Type) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Acc);
+ end if;
+
+ Res_Type := Get_Type_Access_Type (Acc_Type);
+ if Flag_Debug_Hli then
+ return O_Lnode (New_Enode (OE_Access_Ref, Abi.Mode_Ptr, Res_Type,
+ Acc, O_Enode_Null));
+ else
+ return O_Lnode (New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Res_Type,
+ Acc, O_Enode (Res_Type)));
+ end if;
+ end New_Access_Element;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Val);
+ end if;
+
+ return New_Enode (OE_Conv, Rtype, Val, O_Enode (Rtype));
+ end New_Convert_Ov;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Atype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype,
+ O_Enode (Lvalue), O_Enode (Atype));
+ end New_Unchecked_Address;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Type_Kind (Atype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue)))
+ /= Get_Base_Type (Get_Type_Access_Type (Atype))
+ then
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Conv_Ptr, Abi.Mode_Ptr, Atype,
+ O_Enode (Lvalue), O_Enode (Atype));
+ end New_Address;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ raise Program_Error;
+ return O_Enode_Null;
+ end New_Subprogram_Address;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (O_Enode (Lvalue));
+
+ if Flag_Debug_Assert then
+ Check_Ref (Lvalue);
+ end if;
+
+ return New_Enode (OE_Indir, V_Type, O_Enode (Lvalue), O_Enode_Null);
+ end New_Value;
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ Save_Var : O_Dnode;
+ Stmt : O_Enode;
+ St_Type : O_Tnode;
+ begin
+ if Flag_Debug_Assert then
+ Check_Ref (Size);
+ if Get_Type_Kind (Rtype) /= OT_Access then
+ raise Syntax_Error;
+ end if;
+ if Get_Type_Kind (Get_Enode_Type (Size)) /= OT_Unsigned then
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ if not Get_Block_Has_Alloca (Cur_Block) then
+ Set_Block_Has_Alloca (Cur_Block, True);
+ if Stack_Ptr_Type /= O_Tnode_Null then
+ St_Type := Stack_Ptr_Type;
+ else
+ St_Type := Rtype;
+ end if;
+ -- Add a decl.
+ New_Var_Decl (Save_Var, O_Ident_Nul, O_Storage_Local, St_Type);
+ -- Add insn to save stack ptr.
+ Stmt := New_Enode (OE_Asgn, St_Type,
+ New_Stack (St_Type),
+ O_Enode (New_Obj (Save_Var)));
+ if Cur_Block = Last_Stmt then
+ Set_Stmt_Link (Last_Stmt, Stmt);
+ Last_Stmt := Stmt;
+ else
+ Set_Stmt_Link (Stmt, Get_Stmt_Link (Cur_Block));
+ Set_Stmt_Link (Cur_Block, Stmt);
+ end if;
+ end if;
+
+ return New_Enode (OE_Alloca, Rtype, Size, O_Enode (Rtype));
+ end New_Alloca;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ Depth : O_Depth;
+ Arg : O_Enode;
+ First_Inter : O_Dnode;
+ begin
+ First_Inter := Get_Subprg_Interfaces (Subprg);
+ if Get_Decl_Storage (Subprg) = O_Storage_Local then
+ Depth := Get_Decl_Depth (Subprg);
+ Arg := New_Enode (OE_Arg, Abi.Mode_Ptr, O_Tnode_Ptr,
+ Get_Static_Chain (Depth - 1), O_Enode_Null);
+ First_Inter := Get_Interface_Chain (First_Inter);
+ else
+ Arg := O_Enode_Null;
+ end if;
+ Assocs := (Subprg => Subprg,
+ First_Arg => Arg,
+ Last_Arg => Arg,
+ Next_Inter => First_Inter);
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode)
+ is
+ V_Type : O_Tnode;
+ Mode : Mode_Type;
+ N_Mode : Mode_Type;
+ Res : O_Enode;
+ begin
+ V_Type := Get_Enode_Type (Val);
+
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter = O_Dnode_Null then
+ -- More assocs than interfaces.
+ raise Syntax_Error;
+ end if;
+ Check_Value_Type (Val, Get_Decl_Type (Assocs.Next_Inter));
+ Check_Ref (Val);
+ end if;
+
+ -- Follow the C convention call: no parameters shorter than int.
+ Mode := Get_Type_Mode (V_Type);
+ case Mode is
+ when Mode_B2
+ | Mode_U8
+ | Mode_U16 =>
+ N_Mode := Mode_U32;
+ when Mode_I8
+ | Mode_I16 =>
+ N_Mode := Mode_I32;
+ when Mode_P32
+ | Mode_U32
+ | Mode_I32
+ | Mode_U64
+ | Mode_I64
+ | Mode_P64
+ | Mode_F32
+ | Mode_F64 =>
+ N_Mode := Mode;
+ when Mode_Blk
+ | Mode_Nil
+ | Mode_X1 =>
+ raise Program_Error;
+ end case;
+ if N_Mode /= Mode and not Flag_Debug_Hli then
+ Res := New_Enode (OE_Conv, N_Mode, V_Type, Val, O_Enode (V_Type));
+ else
+ Res := Val;
+ end if;
+ Res := New_Enode (OE_Arg, N_Mode, V_Type, Res, O_Enode_Null);
+ if Assocs.Last_Arg /= O_Enode_Null then
+ Enodes.Table (Assocs.Last_Arg).Arg2 := Res;
+ else
+ Assocs.First_Arg := Res;
+ end if;
+ Assocs.Last_Arg := Res;
+ Assocs.Next_Inter := Get_Interface_Chain (Assocs.Next_Inter);
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ F_Type : O_Tnode;
+ begin
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter /= O_Dnode_Null then
+ -- Not enough assocs.
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ F_Type := Get_Decl_Type (Assocs.Subprg);
+ return New_Enode (OE_Call, F_Type,
+ O_Enode (Assocs.Subprg), Assocs.First_Arg);
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is
+ begin
+ if Flag_Debug_Assert then
+ if Assocs.Next_Inter /= O_Dnode_Null then
+ -- Not enough assocs.
+ raise Syntax_Error;
+ end if;
+ end if;
+ New_Enode_Stmt (OE_Call, O_Enode (Assocs.Subprg), Assocs.First_Arg);
+ end New_Procedure_Call;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+
+ if Flag_Debug_Assert then
+ Check_Value_Type (Value, Get_Enode_Type (O_Enode (Target)));
+ Check_Ref (Value);
+ Check_Ref (Target);
+ end if;
+
+ New_Enode_Stmt (OE_Asgn, Get_Type_Mode (V_Type),
+ Value, O_Enode (Target));
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt (Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Value);
+ Check_Value_Type (Value, Get_Decl_Type (Cur_Subprg.D_Decl));
+ end if;
+
+ New_Enode_Stmt (OE_Ret, Get_Type_Mode (V_Type), Value, O_Enode_Null);
+ if not Flag_Debug_Hli then
+ New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ end if;
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Decl_Kind (Cur_Subprg.D_Decl) /= OD_Procedure then
+ raise Syntax_Error;
+ end if;
+ end if;
+
+ if not Flag_Debug_Hli then
+ New_Allocb_Jump (Cur_Subprg.Exit_Label);
+ else
+ New_Enode_Stmt (OE_Ret, Mode_Nil, O_Enode_Null, O_Enode_Null);
+ end if;
+ end New_Return_Stmt;
+
+
+ procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode) is
+ begin
+ if Flag_Debug_Assert then
+ if Get_Expr_Mode (Cond) /= Mode_B2 then
+ -- COND must be a boolean.
+ raise Syntax_Error;
+ end if;
+ Check_Ref (Cond);
+ end if;
+
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_If, Cond, O_Enode_Null);
+ Block := (Label_End => O_Enode_Null,
+ Label_Next => Last_Stmt);
+ else
+ Block := (Label_End => O_Enode_Null,
+ Label_Next => New_Label);
+ Emit_Jmp (OE_Jump_F, Cond, Block.Label_Next);
+ Start_BB;
+ end if;
+ end Start_If_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Else, O_Enode_Null, O_Enode_Null);
+ else
+ if Block.Label_End = O_Enode_Null then
+ Block.Label_End := New_Label;
+ end if;
+ Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+ Start_BB;
+ Link_Stmt (Block.Label_Next);
+ Block.Label_Next := O_Enode_Null;
+ end if;
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Endif, O_Enode_Null, O_Enode_Null);
+ else
+ -- Create a badic-block after the IF.
+ Start_BB;
+ if Block.Label_Next /= O_Enode_Null then
+ Link_Stmt (Block.Label_Next);
+ end if;
+ if Block.Label_End /= O_Enode_Null then
+ Link_Stmt (Block.Label_End);
+ end if;
+ end if;
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode) is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Loop, O_Enode_Null, O_Enode_Null);
+ Label := (Label_Start => Last_Stmt,
+ Label_End => O_Enode_Null);
+ else
+ -- Create a basic-block at the beginning of the loop.
+ Start_BB;
+ Label.Label_Start := New_Label;
+ Link_Stmt (Label.Label_Start);
+ Label.Label_End := New_Label;
+ end if;
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode)
+ is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Eloop, Label.Label_Start, O_Enode_Null);
+ else
+ Emit_Jmp (OE_Jump, O_Enode_Null, Label.Label_Start);
+ Start_BB;
+ Link_Stmt (Label.Label_End);
+ end if;
+ end Finish_Loop_Stmt;
+
+ procedure New_Exit_Stmt (L : O_Snode)
+ is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Exit, O_Enode_Null, L.Label_Start);
+ else
+ New_Allocb_Jump (L.Label_End);
+ end if;
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode)
+ is
+ begin
+ if not Flag_Lower_Stmt then
+ New_Enode_Stmt (OE_Next, O_Enode_Null, L.Label_Start);
+ else
+ New_Allocb_Jump (L.Label_Start);
+ end if;
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode)
+ is
+ V_Type : O_Tnode;
+ Mode : Mode_Type;
+ Start : O_Enode;
+ begin
+ V_Type := Get_Enode_Type (Value);
+ Mode := Get_Type_Mode (V_Type);
+
+ if Flag_Debug_Assert then
+ Check_Ref (Value);
+ case Mode is
+ when Mode_U8 .. Mode_U64
+ | Mode_I8 .. Mode_I64
+ | Mode_B2 =>
+ null;
+ when others =>
+ raise Syntax_Error;
+ end case;
+ end if;
+
+ New_Enode_Stmt (OE_Case, Mode, Value, O_Enode_Null);
+ Start := Enodes.Last;
+ if Flag_Debug_Hli then
+ Block := (Expr => Start,
+ Expr_Type => V_Type,
+ Last_Node => O_Enode_Null,
+ Label_End => O_Enode_Null,
+ Label_Branch => Start);
+ else
+ Block := (Expr => Start,
+ Expr_Type => V_Type,
+ Last_Node => Start,
+ Label_End => New_Label,
+ Label_Branch => O_Enode_Null);
+ end if;
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block)
+ is
+ B : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ B := New_Enode (OE_Case_Branch, Mode_Nil, O_Tnode_Null,
+ O_Enode_Null, O_Enode_Null);
+ Link_Stmt (B);
+ -- Link it.
+ Set_Case_Branch (Block.Label_Branch, B);
+ Block.Label_Branch := B;
+ else
+ -- Jump to the end of the case statement.
+ -- If there is already a branch open, this is ok
+ -- (do not fall-through).
+ -- If there is no branch open, then this is the default choice
+ -- (nothing to do).
+ Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+
+ -- Create a label for the code of this branch.
+ Block.Label_Branch := New_Label;
+ end if;
+ end Start_Choice;
+
+ procedure Insert_Choice_Stmt (Block : in out O_Case_Block; Stmt : O_Enode)
+ is
+ Prev : O_Enode;
+ begin
+ Prev := Get_Stmt_Link (Block.Last_Node);
+ Set_Stmt_Link (Block.Last_Node, Stmt);
+ Block.Last_Node := Stmt;
+ if Prev = O_Enode_Null then
+ Last_Stmt := Stmt;
+ else
+ Set_Stmt_Link (Stmt, Prev);
+ end if;
+ end Insert_Choice_Stmt;
+
+ procedure Emit_Choice_Jmp (Block : in out O_Case_Block;
+ Code : OE_Kind; Expr : O_Enode; Label : O_Enode)
+ is
+ Jmp : O_Enode;
+ begin
+ Jmp := New_Enode (Code, Mode_Nil, O_Tnode_Null, Expr, Label);
+ Insert_Choice_Stmt (Block, Jmp);
+ end Emit_Choice_Jmp;
+
+ -- Create a node containing the value of the case expression.
+ function New_Case_Expr (Block : O_Case_Block) return O_Enode is
+ begin
+ return New_Enode (OE_Case_Expr, Block.Expr_Type,
+ Block.Expr, O_Enode_Null);
+ end New_Case_Expr;
+
+ procedure New_Hli_Choice (Block : in out O_Case_Block;
+ Hi, Lo : O_Enode)
+ is
+ Res : O_Enode;
+ begin
+ Res := New_Enode (OE_Case_Choice, Mode_Nil, O_Tnode_Null, Hi, Lo);
+ if Block.Label_End = O_Enode_Null then
+ Set_Case_Branch_Choice (Block.Label_Branch, Res);
+ else
+ Set_Case_Choice_Link (Block.Label_End, Res);
+ end if;
+ Block.Label_End := Res;
+ end New_Hli_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode)
+ is
+ Res : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, New_Lit (Expr), O_Enode_Null);
+ else
+ Res := New_Enode (OE_Eq, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (Expr));
+ Emit_Choice_Jmp (Block, OE_Jump_T, Res, Block.Label_Branch);
+ end if;
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode)
+ is
+ E1 : O_Enode;
+ E2 : O_Enode;
+ Label : O_Enode;
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, New_Lit (Low), New_Lit (High));
+ else
+ -- Internal label.
+ Label := New_Label;
+ E1 := New_Enode (OE_Lt, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (Low));
+ Emit_Choice_Jmp (Block, OE_Jump_T, E1, Label);
+ E2 := New_Enode (OE_Le, Mode_B2, O_Tnode_Null,
+ New_Case_Expr (Block), New_Lit (High));
+ Emit_Choice_Jmp (Block, OE_Jump_T, E2, Block.Label_Branch);
+ Insert_Choice_Stmt (Block, Label);
+ end if;
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Hli_Choice (Block, O_Enode_Null, O_Enode_Null);
+ else
+ -- Jump to the code.
+ Emit_Choice_Jmp (Block, OE_Jump, O_Enode_Null, Block.Label_Branch);
+ end if;
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ Block.Label_End := O_Enode_Null;
+ else
+ -- Put the label of the branch.
+ Start_BB;
+ Link_Stmt (Block.Label_Branch);
+ end if;
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block) is
+ begin
+ if Flag_Debug_Hli then
+ New_Enode_Stmt (OE_Case_End, O_Enode_Null, O_Enode_Null);
+ else
+ -- Jump to the end of the case statement.
+ -- Note: this is not required, since the next instruction is the
+ -- label.
+ -- Emit_Jmp (OE_Jump, O_Enode_Null, Block.Label_End);
+
+ -- Put the label of the end of the case.
+ Start_BB;
+ Link_Stmt (Block.Label_End);
+ Block.Label_End := O_Enode_Null;
+ end if;
+ end Finish_Case_Stmt;
+
+ procedure New_Debug_Line_Stmt (Line : Natural) is
+ begin
+ New_Enode_Stmt (OE_Line, O_Enode (Line), O_Enode_Null);
+ end New_Debug_Line_Stmt;
+
+ procedure Debug_Expr (N : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ Indent : constant Count := Col;
+ begin
+ Put (Int32 (N), 0);
+ Set_Col (Indent + 7);
+ Disp_Mode (Get_Expr_Mode (N));
+ Put (" ");
+ Put (OE_Kind'Image (Get_Expr_Kind (N)));
+ Set_Col (Indent + 28);
+-- Put (Abi.Image_Insn (Get_Expr_Insn (N)));
+-- Put (" ");
+ Put (Abi.Image_Reg (Get_Expr_Reg (N)));
+ Put (" ");
+ Put (Int32 (Enodes.Table (N).Arg1), 7);
+ Put (Int32 (Enodes.Table (N).Arg2), 7);
+ Put (Enodes.Table (N).Info, 7);
+ New_Line;
+ end Debug_Expr;
+
+ procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode)
+ is
+ use Ada.Text_IO;
+ N : O_Enode;
+ N_Indent : Natural;
+ begin
+ N := Subprg;
+ if Get_Expr_Kind (N) /= OE_Entry then
+ raise Program_Error;
+ end if;
+ -- Display the entry.
+ Set_Col (Count (Indent));
+ Debug_Expr (N);
+ -- Display the subprogram, binding.
+ N_Indent := Indent;-- + 1;
+ N := N + 1;
+ loop
+ case Get_Expr_Kind (N) is
+ when OE_Entry =>
+ N := Get_Entry_Leave (N) + 1;
+ when OE_Leave =>
+ Set_Col (Count (Indent));
+ Debug_Expr (N);
+ exit;
+ when others =>
+ Set_Col (Count (N_Indent));
+ Debug_Expr (N);
+ case Get_Expr_Kind (N) is
+ when OE_Beg =>
+ Disp_Block (N_Indent + 2,
+ O_Dnode (Enodes.Table (N).Arg2));
+ N_Indent := N_Indent + 1;
+ when OE_End =>
+ N_Indent := N_Indent - 1;
+ when others =>
+ null;
+ end case;
+ N := N + 1;
+ end case;
+ end loop;
+ end Disp_Subprg_Body;
+
+ procedure Disp_All_Enode is
+ begin
+ for I in Enodes.First .. Enodes.Last loop
+ Debug_Expr (I);
+ end loop;
+ end Disp_All_Enode;
+
+ Max_Enode : O_Enode := O_Enode_Null;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Enode := Enodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last);
+ Enodes.Set_Last (M.Enode);
+ end Release;
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Max_Enode := O_Enode'Max (Max_Enode, Enodes.Last);
+ Put ("Number of Enodes:" & O_Enode'Image (Enodes.Last));
+ Put (", max:" & O_Enode'Image (Max_Enode));
+ New_Line;
+ end Disp_Stats;
+
+ procedure Free_Subprogram_Data (Data : in out Subprogram_Data_Acc)
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Subprogram_Data, Subprogram_Data_Acc);
+ Ch, N_Ch : Subprogram_Data_Acc;
+ begin
+ Ch := Data.First_Child;
+ while Ch /= null loop
+ N_Ch := Ch.Brother;
+ Free_Subprogram_Data (Ch);
+ Ch := N_Ch;
+ end loop;
+ Free (Data);
+ end Free_Subprogram_Data;
+
+ procedure Finish is
+ begin
+ Enodes.Free;
+ Free_Subprogram_Data (First_Subprg);
+ end Finish;
+end Ortho_Code.Exprs;
diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads
new file mode 100644
index 000000000..9bd4596d7
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-exprs.ads
@@ -0,0 +1,600 @@
+-- Mcode back-end for ortho - Expressions and control handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ortho_Code.Exprs is
+ type OE_Kind is
+ (
+ OE_Nil,
+
+ -- Dyadic operations.
+ -- ARG1 is left, ARG2 is right.
+ OE_Add_Ov,
+ OE_Sub_Ov,
+ OE_Mul_Ov,
+ OE_Div_Ov,
+ OE_Rem,
+ OE_Mod,
+
+ OE_And,
+ OE_Or,
+ OE_Xor,
+
+ -- Monadic operations.
+ -- ARG1 is expression.
+ OE_Not,
+ OE_Neg_Ov,
+ OE_Abs_Ov,
+
+ -- Comparaison.
+ -- ARG1 is left, ARG2 is right.
+ OE_Eq,
+ OE_Neq,
+ OE_Le,
+ OE_Lt,
+ OE_Ge,
+ OE_Gt,
+
+ -- Without checks, for addresses.
+ OE_Add,
+ OE_Mul,
+ OE_Shl, -- Left shift
+
+ -- A literal.
+ -- ARG1 is low part, ARG2 is high part.
+ OE_Const,
+
+ -- Address of a local variable/parameter.
+ -- ARG1 is object.
+ -- ARG2 is the frame pointer or O_Enode_Null for current frame pointer.
+ OE_Addrl,
+ -- Address of a global variable.
+ -- ARG1 is object.
+ OE_Addrg,
+
+ -- Pointer dereference.
+ -- ARG1 is operand.
+ OE_Indir,
+
+ -- Conversion.
+ -- ARG1 is expression.
+ -- ARG2: type
+ OE_Conv_Ptr,
+ OE_Conv,
+
+ -- Typed expression.
+ OE_Typed,
+
+ -- Local memory allocation.
+ -- ARG1 is size (in bytes).
+ OE_Alloca,
+
+ -- Statements.
+
+ -- Subrogram entry.
+ -- ARG1 is the corresponding Leave (used to skip inner subprograms).
+ -- ARG2 is unused.
+ OE_Entry,
+ -- Subprogram exit.
+ -- ARG1 and ARG2 are unused.
+ OE_Leave,
+
+ -- Declaration blocks.
+ -- ARG1: parent
+ -- ARG2: corresponding declarations.
+ OE_Beg,
+ -- ARG1: corresponding beg
+ -- ARG2: unsused.
+ OE_End,
+
+ -- Assignment.
+ -- ARG1 is value, ARG2 is target (address).
+ OE_Asgn,
+
+ -- Subprogram calls.
+ -- ARG1 is value
+ -- ARG2 is link to the next argument.
+ OE_Arg,
+ -- ARG1 is subprogram
+ -- ARG2 is arguments.
+ OE_Call,
+ -- ARG1 is intrinsic operation.
+ OE_Intrinsic,
+
+ -- Modify the stack pointer value, to align the stack before pushing
+ -- arguments, or to free the stack.
+ -- ARG1 is the signed offset.
+ OE_Stack_Adjust,
+
+ -- Return ARG1 (if not mode_nil) from current subprogram.
+ -- ARG1: expression.
+ OE_Ret,
+
+ -- Line number (for debugging).
+ -- ARG1: line number
+ OE_Line,
+
+ -- High level instructions.
+
+ -- Basic block.
+ -- ARG1: next BB
+ -- ARG2: number
+ OE_BB,
+
+ -- ARG1 is the literal.
+ OE_Lit,
+ -- ARG1: value
+ -- ARG2: first branch (HLI only).
+ OE_Case,
+ -- ARG1: the corresponding OE_Case
+ OE_Case_Expr,
+ -- ARG1: left bound
+ -- ARG2: right bound
+ -- LINK: choice link
+ OE_Case_Choice,
+ -- ARG1: choice link
+ -- ARG2: next branch
+ OE_Case_Branch,
+ -- End of case.
+ OE_Case_End,
+
+ -- ARG1: the condition
+ -- ARG2: the else/endif
+ OE_If,
+ OE_Else,
+ OE_Endif,
+
+ -- ARG1: loop level.
+ OE_Loop,
+ -- ARG1: loop.
+ OE_Eloop,
+ -- ARG2: loop.
+ OE_Next,
+ OE_Exit,
+
+ -- ARG1: the record
+ -- ARG2: the field
+ OE_Record_Ref,
+
+ -- ARG1: the expression.
+ OE_Access_Ref,
+
+ -- ARG1: the array
+ -- ARG2: the index
+ OE_Index_Ref,
+ OE_Slice_Ref,
+
+ -- Low level instructions.
+
+ -- Label.
+ -- ARG1: current block (used for alloca), only during tree building.
+ -- ARG2: user info (generally used to store symbol).
+ OE_Label,
+
+ -- Jump to ARG2.
+ OE_Jump,
+
+ -- Jump to ARG2 if ARG1 is true/false.
+ OE_Jump_T,
+ OE_Jump_F,
+
+ -- Used internally only.
+ -- ARG2 is info/target, ARG1 is expression (if any).
+ OE_Spill,
+ OE_Reload,
+ OE_Move,
+
+ -- Alloca/allocb handling.
+ OE_Get_Stack,
+ OE_Set_Stack,
+
+ -- Get current frame pointer.
+ OE_Get_Frame,
+
+ -- Additionnal reg
+ OE_Reg
+ );
+ for OE_Kind'Size use 8;
+
+ subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor;
+ subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt;
+
+
+ -- BE representation of an instruction.
+ type O_Insn is mod 256;
+
+ type Subprogram_Data;
+ type Subprogram_Data_Acc is access Subprogram_Data;
+
+ type Subprogram_Data is record
+ -- Parent or null if top-level subprogram.
+ Parent : Subprogram_Data_Acc;
+
+ -- Block in which this subprogram is declared, or o_dnode_null if
+ -- top-level subprogram.
+ --Parent_Block : O_Dnode;
+
+ -- First and last child, or null if no children.
+ First_Child : Subprogram_Data_Acc;
+ Last_Child : Subprogram_Data_Acc;
+
+ -- Next subprogram at the same depth level.
+ Brother : Subprogram_Data_Acc;
+
+ -- Depth of the subprogram.
+ Depth : O_Depth;
+
+ -- Dnode for the declaration.
+ D_Decl : O_Dnode;
+
+ -- Enode for the Entry.
+ E_Entry : O_Enode;
+
+ -- Dnode for the Body.
+ D_Body : O_Dnode;
+
+ -- Label just before leave.
+ Exit_Label : O_Enode;
+
+ -- Last statement of this subprogram.
+ Last_Stmt : O_Enode;
+
+ -- Static maximum stack use.
+ Stack_Max : Uns32;
+ end record;
+
+ -- Data for the current subprogram.
+ Cur_Subprg : Subprogram_Data_Acc := null;
+
+ -- First and last (top-level) subprogram.
+ First_Subprg : Subprogram_Data_Acc := null;
+ Last_Subprg : Subprogram_Data_Acc := null;
+
+ -- Type of the stack pointer - for OE_Get_Stack and OE_Set_Stack.
+ -- Can be set by back-ends.
+ Stack_Ptr_Type : O_Tnode := O_Tnode_Null;
+
+ -- Create a new node.
+ -- Should be used only by back-end to add internal nodes.
+ function New_Enode (Kind : OE_Kind;
+ Mode : Mode_Type;
+ Rtype : O_Tnode;
+ Arg1 : O_Enode;
+ Arg2 : O_Enode) return O_Enode;
+
+ -- Get the kind of ENODE.
+ function Get_Expr_Kind (Enode : O_Enode) return OE_Kind;
+ pragma Inline (Get_Expr_Kind);
+
+ -- Get the mode of ENODE.
+ function Get_Expr_Mode (Enode : O_Enode) return Mode_Type;
+ pragma Inline (Get_Expr_Mode);
+
+ -- Get/Set the register of ENODE.
+ function Get_Expr_Reg (Enode : O_Enode) return O_Reg;
+ procedure Set_Expr_Reg (Enode : O_Enode; Reg : O_Reg);
+ pragma Inline (Get_Expr_Reg);
+ pragma Inline (Set_Expr_Reg);
+
+ -- Get the operand of an unary expression.
+ function Get_Expr_Operand (Enode : O_Enode) return O_Enode;
+ procedure Set_Expr_Operand (Enode : O_Enode; Val : O_Enode);
+
+ -- Get left/right operand of a binary expression.
+ function Get_Expr_Left (Enode : O_Enode) return O_Enode;
+ function Get_Expr_Right (Enode : O_Enode) return O_Enode;
+ procedure Set_Expr_Left (Enode : O_Enode; Val : O_Enode);
+ procedure Set_Expr_Right (Enode : O_Enode; Val : O_Enode);
+
+ -- Get the low and high part of an OE_CONST node.
+ function Get_Expr_Low (Cst : O_Enode) return Uns32;
+ function Get_Expr_High (Cst : O_Enode) return Uns32;
+
+ -- Get target of the assignment.
+ function Get_Assign_Target (Enode : O_Enode) return O_Enode;
+ procedure Set_Assign_Target (Enode : O_Enode; Targ : O_Enode);
+
+ -- For OE_Lit: get the literal.
+ function Get_Expr_Lit (Lit : O_Enode) return O_Cnode;
+
+ -- Type of a OE_Conv/OE_Nop/OE_Typed/OE_Alloca
+ -- Used only for display/debugging purposes.
+ function Get_Conv_Type (Enode : O_Enode) return O_Tnode;
+
+ -- Leave node corresponding to the entry.
+ function Get_Entry_Leave (Enode : O_Enode) return O_Enode;
+
+ -- Get the label of a jump/ret
+ function Get_Jump_Label (Enode : O_Enode) return O_Enode;
+ procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode);
+
+ -- Get the object of addrl,addrp,addrg
+ function Get_Addr_Object (Enode : O_Enode) return O_Dnode;
+
+ -- Get the computed frame for the object.
+ -- If O_Enode_Null, then use current frame.
+ function Get_Addrl_Frame (Enode : O_Enode) return O_Enode;
+ procedure Set_Addrl_Frame (Enode : O_Enode; Frame : O_Enode);
+
+ -- Return the stack adjustment. For positive values, this is the amount of
+ -- bytes to allocate on the stack before pushing arguments, so that the
+ -- stack pointer stays aligned. For negtive values, this is the amount of
+ -- bytes to release on the stack.
+ function Get_Stack_Adjust (Enode : O_Enode) return Int32;
+
+ -- Get the subprogram called by ENODE.
+ function Get_Call_Subprg (Enode : O_Enode) return O_Dnode;
+
+ -- Get the first argument of a call, or the next argument of an arg.
+ function Get_Arg_Link (Enode : O_Enode) return O_Enode;
+
+ -- Get the declaration chain of a Beg statement.
+ function Get_Block_Decls (Blk : O_Enode) return O_Dnode;
+
+ -- Get the parent of the block.
+ function Get_Block_Parent (Blk : O_Enode) return O_Enode;
+
+ -- Get the corresponding beg.
+ function Get_End_Beg (Blk : O_Enode) return O_Enode;
+
+ -- True if the block contains an alloca insn.
+ function Get_Block_Has_Alloca (Blk : O_Enode) return Boolean;
+
+ -- Set the next branch of a case/case_branch.
+ procedure Set_Case_Branch (C : O_Enode; Branch : O_Enode);
+
+ -- Set the first choice of a case branch.
+ procedure Set_Case_Branch_Choice (Branch : O_Enode; Choice : O_Enode);
+ function Get_Case_Branch_Choice (Branch : O_Enode) return O_Enode;
+
+ -- Set the choice link of a case choice.
+ procedure Set_Case_Choice_Link (Choice : O_Enode; N_Choice : O_Enode);
+ function Get_Case_Choice_Link (Choice : O_Enode) return O_Enode;
+
+ -- Get/Set the max stack size for the end block BLKE.
+ --function Get_Block_Max_Stack (Blke : O_Enode) return Int32;
+ --procedure Set_Block_Max_Stack (Blke : O_Enode; Max : Int32);
+
+ -- Get the field of an o_record_ref node.
+ function Get_Ref_Field (Ref : O_Enode) return O_Fnode;
+
+ -- Get the index of an OE_Index_Ref or OE_Slice_Ref node.
+ function Get_Ref_Index (Ref : O_Enode) return O_Enode;
+
+ -- Get/Set the info field of a label.
+ function Get_Label_Info (Label : O_Enode) return Int32;
+ procedure Set_Label_Info (Label : O_Enode; Info : Int32);
+
+ -- Get the info of a spill.
+ function Get_Spill_Info (Spill : O_Enode) return Int32;
+ procedure Set_Spill_Info (Spill : O_Enode; Info : Int32);
+
+ -- Get the statement link.
+ function Get_Stmt_Link (Stmt : O_Enode) return O_Enode;
+ procedure Set_Stmt_Link (Stmt : O_Enode; Next : O_Enode);
+
+ -- Get the line number of an OE_Line statement.
+ function Get_Expr_Line_Number (Stmt : O_Enode) return Int32;
+
+ -- Get the operation of an intrinsic.
+ function Get_Intrinsic_Operation (Stmt : O_Enode) return Int32;
+
+ -- Get the basic block label (uniq number).
+ function Get_BB_Number (Stmt : O_Enode) return Int32;
+
+ -- For OE_Loop, set loop level (an integer).
+ -- Reserved for back-end in HLI mode only.
+ function Get_Loop_Level (Stmt : O_Enode) return Int32;
+ procedure Set_Loop_Level (Stmt : O_Enode; Level : Int32);
+
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+ -- Translate a scalar literal into an expression.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Translate an object (var, const or interface) into an lvalue.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Enode;
+
+ -- Returns the offset of FIELD in its record. The result is a literal
+ -- of unsigned type RTYPE.
+ function New_Offsetof (Field : O_Fnode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ type O_Assoc_List is limited private;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ type O_If_Block is limited private;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ type O_Snode is private;
+ O_Snode_Null : constant O_Snode;
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ type O_Case_Block is limited private;
+ procedure Start_Case_Stmt (Block : out O_Case_Block; Value : O_Enode);
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ procedure Disp_Subprg_Body (Indent : Natural; Subprg : O_Enode);
+ procedure Disp_All_Enode;
+ procedure Disp_Stats;
+
+ type Mark_Type is limited private;
+ procedure Mark (M : out Mark_Type);
+ procedure Release (M : Mark_Type);
+
+ procedure Finish;
+private
+ type O_Assoc_List is record
+ -- Subprogram being called.
+ Subprg : O_Dnode;
+ -- First and last argument statement.
+ First_Arg : O_Enode;
+ Last_Arg : O_Enode;
+ -- Interface for the next association.
+ Next_Inter : O_Dnode;
+ end record;
+
+ type O_Case_Block is record
+ -- Expression for the selection.
+ Expr : O_Enode;
+
+ -- Type of expression.
+ -- Used to perform checks.
+ Expr_Type : O_Tnode;
+
+ -- Choice code and branch code is not mixed (anymore).
+ -- Therefore, code to perform choices is inserted.
+ -- Last node of the choice code.
+ Last_Node : O_Enode;
+
+ -- Label at the end of the case statement.
+ -- used to jump from the end of a branch to the end of the statement.
+ Label_End : O_Enode;
+
+ -- Label of the branch code.
+ Label_Branch : O_Enode;
+ end record;
+
+ type O_If_Block is record
+ Label_End : O_Enode;
+ Label_Next : O_Enode;
+ end record;
+
+ type O_Snode is record
+ Label_Start : O_Enode;
+ Label_End : O_Enode;
+ end record;
+ O_Snode_Null : constant O_Snode := (Label_Start => O_Enode_Null,
+ Label_End => O_Enode_Null);
+
+ type Mark_Type is record
+ Enode : O_Enode;
+ end record;
+end Ortho_Code.Exprs;
diff --git a/src/ortho/mcode/ortho_code-flags.ads b/src/ortho/mcode/ortho_code-flags.ads
new file mode 100644
index 000000000..805f3779b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-flags.ads
@@ -0,0 +1,35 @@
+-- Compile flags for mcode.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ortho_Code.Flags is
+ type Debug_Type is (Debug_None, Debug_Dwarf);
+
+ -- Debugging information generated.
+ Flag_Debug : Debug_Type := Debug_None;
+
+ -- If set, generate a map from type to type declaration.
+ Flag_Type_Name : Boolean := False;
+
+ -- If set, enable optimiztions.
+ Flag_Optimize : Boolean := False;
+
+ -- If set, create basic blocks during tree building.
+ Flag_Opt_BB : Boolean := False;
+
+ -- If set, add profiling calls.
+ Flag_Profile : Boolean := False;
+end Ortho_Code.Flags;
diff --git a/src/ortho/mcode/ortho_code-opts.adb b/src/ortho/mcode/ortho_code-opts.adb
new file mode 100644
index 000000000..0ea6b039b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-opts.adb
@@ -0,0 +1,214 @@
+-- Mcode back-end for ortho - Optimization.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Flags;
+
+package body Ortho_Code.Opts is
+ procedure Relabel_Jump (Jmp : O_Enode)
+ is
+ Label : O_Enode;
+ Bb : O_Enode;
+ begin
+ Label := Get_Jump_Label (Jmp);
+ if Get_Expr_Kind (Label) = OE_Label then
+ Bb := O_Enode (Get_Label_Info (Label));
+ if Bb /= O_Enode_Null then
+ Set_Jump_Label (Jmp, Bb);
+ end if;
+ end if;
+ end Relabel_Jump;
+
+ procedure Jmp_To_Bb (Subprg : Subprogram_Data_Acc)
+ is
+ First : O_Enode;
+ Stmt : O_Enode;
+ Prev : O_Enode;
+ Cur_Bb : O_Enode;
+ begin
+ -- Get first statement after entry.
+ First := Get_Stmt_Link (Subprg.E_Entry);
+
+ -- First loop:
+ -- If a label belongs to a BB (ie, is at the beginning of a BB),
+ -- then link it to the BB.
+ Stmt := First;
+ Cur_Bb := O_Enode_Null;
+ loop
+ case Get_Expr_Kind (Stmt) is
+ when OE_Leave =>
+ exit;
+ when OE_BB =>
+ Cur_Bb := Stmt;
+ when OE_Label =>
+ if Cur_Bb /= O_Enode_Null then
+ Set_Label_Info (Stmt, Int32 (Cur_Bb));
+ end if;
+ when OE_Jump
+ | OE_Jump_T
+ | OE_Jump_F =>
+ -- This handles backward jump.
+ Relabel_Jump (Stmt);
+ when others =>
+ Cur_Bb := O_Enode_Null;
+ end case;
+ Stmt := Get_Stmt_Link (Stmt);
+ end loop;
+
+ -- Second loop:
+ -- Transform jump to label to jump to BB.
+ Stmt := First;
+ Prev := O_Enode_Null;
+ loop
+ case Get_Expr_Kind (Stmt) is
+ when OE_Leave =>
+ exit;
+ when OE_Jump
+ | OE_Jump_T
+ | OE_Jump_F =>
+ -- This handles forward jump.
+ Relabel_Jump (Stmt);
+ -- Update PREV.
+ Prev := Stmt;
+ when OE_Label =>
+ -- Remove the Label.
+ -- Do not update PREV.
+ if Get_Label_Info (Stmt) /= 0 then
+ Set_Stmt_Link (Prev, Get_Stmt_Link (Stmt));
+ end if;
+ when others =>
+ Prev := Stmt;
+ end case;
+ Stmt := Get_Stmt_Link (Stmt);
+ end loop;
+ end Jmp_To_Bb;
+
+ type Oe_Kind_Bool_Array is array (OE_Kind) of Boolean;
+ Is_Passive_Stmt : constant Oe_Kind_Bool_Array :=
+ (OE_Label | OE_BB | OE_End | OE_Beg => True,
+ others => False);
+
+ -- Return the next statement after STMT which really execute instructions.
+ function Get_Fall_Stmt (Stmt : O_Enode) return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ Res := Stmt;
+ loop
+ Res := Get_Stmt_Link (Res);
+ case Get_Expr_Kind (Res) is
+ when OE_Label
+ | OE_BB
+ | OE_End
+ | OE_Beg =>
+ null;
+ when others =>
+ return Res;
+ end case;
+ end loop;
+ end Get_Fall_Stmt;
+ pragma Unreferenced (Get_Fall_Stmt);
+
+ procedure Thread_Jump (Subprg : Subprogram_Data_Acc)
+ is
+ First : O_Enode;
+ Stmt : O_Enode;
+ Prev, Next : O_Enode;
+ Kind : OE_Kind;
+ begin
+ -- Get first statement after entry.
+ First := Get_Stmt_Link (Subprg.E_Entry);
+
+ -- First loop:
+ -- If a label belongs to a BB (ie, is at the beginning of a BB),
+ -- then link it to the BB.
+ Stmt := First;
+ Prev := O_Enode_Null;
+ loop
+ Next := Get_Stmt_Link (Stmt);
+ Kind := Get_Expr_Kind (Stmt);
+ case Kind is
+ when OE_Leave =>
+ exit;
+ when OE_Jump =>
+ -- Remove the jump if followed by the label.
+ -- * For _T/_F: should convert to a ignore value.
+ -- Discard unreachable statements after the jump.
+ declare
+ N_Stmt : O_Enode;
+ P_Stmt : O_Enode;
+ Label : O_Enode;
+ Flag_Discard : Boolean;
+ K_Stmt : OE_Kind;
+ begin
+ N_Stmt := Next;
+ P_Stmt := Stmt;
+ Label := Get_Jump_Label (Stmt);
+ Flag_Discard := True;
+ loop
+ if N_Stmt = Label then
+ -- Remove STMT.
+ Set_Stmt_Link (Prev, Next);
+ exit;
+ end if;
+ K_Stmt := Get_Expr_Kind (N_Stmt);
+ if K_Stmt = OE_Label then
+ -- Do not discard anymore statements, since they are
+ -- now reachable.
+ Flag_Discard := False;
+ end if;
+ if not Is_Passive_Stmt (K_Stmt) then
+ if not Flag_Discard then
+ -- We have found the next statement.
+ -- Keep the jump.
+ Prev := Stmt;
+ exit;
+ else
+ -- Delete insn.
+ N_Stmt := Get_Stmt_Link (N_Stmt);
+ Set_Stmt_Link (P_Stmt, N_Stmt);
+ end if;
+ else
+ -- Iterate.
+ P_Stmt := N_Stmt;
+ N_Stmt := Get_Stmt_Link (N_Stmt);
+ end if;
+ end loop;
+ end;
+ when others =>
+ Prev := Stmt;
+ end case;
+ Stmt := Next;
+ end loop;
+ end Thread_Jump;
+
+ procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc)
+ is
+ begin
+ -- Jump optimisation:
+ -- * discard insns after a OE_JUMP.
+ -- * Remove jump if followed by label
+ -- (through label, BB, comments, end, line)
+ -- * Redirect jump to jump (infinite loop !)
+ -- * Revert jump_t/f if expr is not (XXX)
+ -- * Jmp_t/f L:; jmp L2; L1: -> jmp_f/t L2
+ Thread_Jump (Subprg);
+ if Flags.Flag_Opt_BB then
+ Jmp_To_Bb (Subprg);
+ end if;
+ end Optimize_Subprg;
+end Ortho_Code.Opts;
+
diff --git a/src/ortho/mcode/ortho_code-opts.ads b/src/ortho/mcode/ortho_code-opts.ads
new file mode 100644
index 000000000..27a907c7b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-opts.ads
@@ -0,0 +1,22 @@
+-- Mcode back-end for ortho - Optimization.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+
+package Ortho_Code.Opts is
+ procedure Optimize_Subprg (Subprg : Subprogram_Data_Acc);
+end Ortho_Code.Opts;
diff --git a/src/ortho/mcode/ortho_code-types.adb b/src/ortho/mcode/ortho_code-types.adb
new file mode 100644
index 000000000..e0c070c27
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-types.adb
@@ -0,0 +1,820 @@
+-- Mcode back-end for ortho - type handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ada.Unchecked_Conversion;
+with GNAT.Table;
+with Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Debug;
+with Ortho_Code.Abi; use Ortho_Code.Abi;
+with Ortho_Ident;
+
+package body Ortho_Code.Types is
+ type Bool_Array is array (Natural range <>) of Boolean;
+ pragma Pack (Bool_Array);
+
+ type Tnode_Common is record
+ Kind : OT_Kind; -- 4 bits.
+ Mode : Mode_Type; -- 4 bits.
+ Align : Small_Natural; -- 2 bits.
+ Deferred : Boolean; -- 1 bit (True if the type was incomplete at first)
+ Flag1 : Boolean;
+ Pad0 : Bool_Array (0 .. 19);
+ Size : Uns32;
+ end record;
+ pragma Pack (Tnode_Common);
+ for Tnode_Common'Size use 64;
+
+ type Tnode_Access is record
+ Dtype : O_Tnode;
+ Pad : Uns32;
+ end record;
+
+ type Tnode_Array is record
+ Element_Type : O_Tnode;
+ Index_Type : O_Tnode;
+ end record;
+
+ type Tnode_Subarray is record
+ Base_Type : O_Tnode;
+ Length : Uns32;
+ end record;
+
+ type Tnode_Record is record
+ Fields : O_Fnode;
+ Nbr_Fields : Uns32;
+ end record;
+
+ type Tnode_Enum is record
+ Lits : O_Cnode;
+ Nbr_Lits : Uns32;
+ end record;
+
+ type Tnode_Bool is record
+ Lit_False : O_Cnode;
+ Lit_True : O_Cnode;
+ end record;
+
+ package Tnodes is new GNAT.Table
+ (Table_Component_Type => Tnode_Common,
+ Table_Index_Type => O_Tnode,
+ Table_Low_Bound => O_Tnode_First,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ type Field_Type is record
+ Parent : O_Tnode;
+ Ident : O_Ident;
+ Ftype : O_Tnode;
+ Offset : Uns32;
+ Next : O_Fnode;
+ end record;
+
+ package Fnodes is new GNAT.Table
+ (Table_Component_Type => Field_Type,
+ Table_Index_Type => O_Fnode,
+ Table_Low_Bound => 2,
+ Table_Initial => 64,
+ Table_Increment => 100);
+
+ function Get_Type_Kind (Atype : O_Tnode) return OT_Kind is
+ begin
+ return Tnodes.Table (Atype).Kind;
+ end Get_Type_Kind;
+
+ function Get_Type_Size (Atype : O_Tnode) return Uns32 is
+ begin
+ return Tnodes.Table (Atype).Size;
+ end Get_Type_Size;
+
+ function Get_Type_Align (Atype : O_Tnode) return Small_Natural is
+ begin
+ return Tnodes.Table (Atype).Align;
+ end Get_Type_Align;
+
+ function Get_Type_Align_Bytes (Atype : O_Tnode) return Uns32 is
+ begin
+ return 2 ** Get_Type_Align (Atype);
+ end Get_Type_Align_Bytes;
+
+ function Get_Type_Mode (Atype : O_Tnode) return Mode_Type is
+ begin
+ return Tnodes.Table (Atype).Mode;
+ end Get_Type_Mode;
+
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Deferred;
+ end Get_Type_Deferred;
+
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Flag1;
+ end Get_Type_Flag1;
+
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean) is
+ begin
+ Tnodes.Table (Atype).Flag1 := Flag;
+ end Set_Type_Flag1;
+
+ function To_Tnode_Access is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Access);
+
+ function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode
+ is
+ begin
+ return To_Tnode_Access (Tnodes.Table (Atype + 1)).Dtype;
+ end Get_Type_Access_Type;
+
+
+ function To_Tnode_Array is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Array);
+
+ function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode is
+ begin
+ return To_Tnode_Array (Tnodes.Table (Atype + 1)).Index_Type;
+ end Get_Type_Ucarray_Index;
+
+ function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode is
+ begin
+ return To_Tnode_Array (Tnodes.Table (Atype + 1)).Element_Type;
+ end Get_Type_Ucarray_Element;
+
+
+ function To_Tnode_Subarray is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Subarray);
+
+ function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode is
+ begin
+ return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Base_Type;
+ end Get_Type_Subarray_Base;
+
+ function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32 is
+ begin
+ return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Length;
+ end Get_Type_Subarray_Length;
+
+
+ function To_Tnode_Record is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Record);
+
+ function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode is
+ begin
+ return To_Tnode_Record (Tnodes.Table (Atype + 1)).Fields;
+ end Get_Type_Record_Fields;
+
+ function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32 is
+ begin
+ return To_Tnode_Record (Tnodes.Table (Atype + 1)).Nbr_Fields;
+ end Get_Type_Record_Nbr_Fields;
+
+ function To_Tnode_Enum is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Enum);
+
+ function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode is
+ begin
+ return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Lits;
+ end Get_Type_Enum_Lits;
+
+ function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode
+ is
+ F : O_Cnode;
+ begin
+ F := Get_Type_Enum_Lits (Atype);
+ return F + 2 * O_Cnode (Pos);
+ end Get_Type_Enum_Lit;
+
+ function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32 is
+ begin
+ return To_Tnode_Enum (Tnodes.Table (Atype + 1)).Nbr_Lits;
+ end Get_Type_Enum_Nbr_Lits;
+
+
+ function To_Tnode_Bool is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Bool);
+
+ function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode is
+ begin
+ return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_False;
+ end Get_Type_Bool_False;
+
+ function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode is
+ begin
+ return To_Tnode_Bool (Tnodes.Table (Atype + 1)).Lit_True;
+ end Get_Type_Bool_True;
+
+ function Get_Field_Offset (Field : O_Fnode) return Uns32 is
+ begin
+ return Fnodes.Table (Field).Offset;
+ end Get_Field_Offset;
+
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32) is
+ begin
+ Fnodes.Table (Field).Offset := Offset;
+ end Set_Field_Offset;
+
+ function Get_Field_Parent (Field : O_Fnode) return O_Tnode is
+ begin
+ return Fnodes.Table (Field).Parent;
+ end Get_Field_Parent;
+
+ function Get_Field_Type (Field : O_Fnode) return O_Tnode is
+ begin
+ return Fnodes.Table (Field).Ftype;
+ end Get_Field_Type;
+
+ function Get_Field_Ident (Field : O_Fnode) return O_Ident is
+ begin
+ return Fnodes.Table (Field).Ident;
+ end Get_Field_Ident;
+
+ function Get_Field_Chain (Field : O_Fnode) return O_Fnode is
+ begin
+ return Fnodes.Table (Field).Next;
+ end Get_Field_Chain;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode
+ is
+ Mode : Mode_Type;
+ Sz : Uns32;
+ begin
+ case Size is
+ when 8 =>
+ Mode := Mode_U8;
+ Sz := 1;
+ when 16 =>
+ Mode := Mode_U16;
+ Sz := 2;
+ when 32 =>
+ Mode := Mode_U32;
+ Sz := 4;
+ when 64 =>
+ Mode := Mode_U64;
+ Sz := 8;
+ when others =>
+ raise Program_Error;
+ end case;
+ Tnodes.Append (Tnode_Common'(Kind => OT_Unsigned,
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
+ return Tnodes.Last;
+ end New_Unsigned_Type;
+
+ function New_Signed_Type (Size : Natural) return O_Tnode
+ is
+ Mode : Mode_Type;
+ Sz : Uns32;
+ begin
+ case Size is
+ when 8 =>
+ Mode := Mode_I8;
+ Sz := 1;
+ when 16 =>
+ Mode := Mode_I16;
+ Sz := 2;
+ when 32 =>
+ Mode := Mode_I32;
+ Sz := 4;
+ when 64 =>
+ Mode := Mode_I64;
+ Sz := 8;
+ when others =>
+ raise Program_Error;
+ end case;
+ Tnodes.Append (Tnode_Common'(Kind => OT_Signed,
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
+ return Tnodes.Last;
+ end New_Signed_Type;
+
+ function New_Float_Type return O_Tnode is
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Float,
+ Mode => Mode_F64,
+ Align => Mode_Align (Mode_F64),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 8));
+ return Tnodes.Last;
+ end New_Float_Type;
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Enum, Target => Tnode_Common);
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
+ is
+ Mode : Mode_Type;
+ Sz : Uns32;
+ begin
+ case Size is
+ when 8 =>
+ Mode := Mode_U8;
+ Sz := 1;
+ when 16 =>
+ Mode := Mode_U16;
+ Sz := 2;
+ when 32 =>
+ Mode := Mode_U32;
+ Sz := 4;
+ when 64 =>
+ Mode := Mode_U64;
+ Sz := 8;
+ when others =>
+ raise Program_Error;
+ end case;
+ Tnodes.Append (Tnode_Common'(Kind => OT_Enum,
+ Mode => Mode,
+ Align => Mode_Align (Mode),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Sz));
+ List := (Res => Tnodes.Last,
+ First => O_Cnode_Null,
+ Last => O_Cnode_Null,
+ Nbr => 0);
+ Tnodes.Increment_Last;
+ end Start_Enum_Type;
+
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode)
+ is
+ begin
+ Res := New_Named_Literal (List.Res, Ident, List.Nbr, List.Last);
+ List.Nbr := List.Nbr + 1;
+ if List.Last = O_Cnode_Null then
+ List.First := Res;
+ end if;
+ List.Last := Res;
+ end New_Enum_Literal;
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Res := List.Res;
+ Tnodes.Table (List.Res + 1) := To_Tnode_Common
+ (Tnode_Enum'(Lits => List.First,
+ Nbr_Lits => List.Nbr));
+ end Finish_Enum_Type;
+
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Bool, Target => Tnode_Common);
+
+ 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
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Boolean,
+ Mode => Mode_B2,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 1));
+ Res := Tnodes.Last;
+ False_E := New_Named_Literal (Res, False_Id, 0, O_Cnode_Null);
+ True_E := New_Named_Literal (Res, True_Id, 1, False_E);
+ Tnodes.Append (To_Tnode_Common (Tnode_Bool'(Lit_False => False_E,
+ Lit_True => True_E)));
+ end New_Boolean_Type;
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Array, Target => Tnode_Common);
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode
+ is
+ Res : O_Tnode;
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Ucarray,
+ Mode => Mode_Blk,
+ Align => Get_Type_Align (El_Type),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
+ Res := Tnodes.Last;
+ Tnodes.Append (To_Tnode_Common (Tnode_Array'(Element_Type => El_Type,
+ Index_Type => Index_Type)));
+ return Res;
+ end New_Array_Type;
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Subarray, Target => Tnode_Common);
+
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32)
+ return O_Tnode
+ is
+ Res : O_Tnode;
+ Size : Uns32;
+ begin
+ Size := Get_Type_Size (Get_Type_Array_Element (Atype));
+ Tnodes.Append (Tnode_Common'(Kind => OT_Subarray,
+ Mode => Mode_Blk,
+ Align => Get_Type_Align (Atype),
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => Size * Length));
+ Res := Tnodes.Last;
+ Tnodes.Append (To_Tnode_Common (Tnode_Subarray'(Base_Type => Atype,
+ Length => Length)));
+ return Res;
+ end New_Constrained_Array_Type;
+
+ procedure Create_Completer (Atype : O_Tnode) is
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Complete,
+ Mode => Mode_Nil,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => To_Uns32 (Int32 (Atype))));
+ end Create_Completer;
+
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode is
+ begin
+ return O_Tnode (To_Int32 (Tnodes.Table (Atype).Size));
+ end Get_Type_Complete_Type;
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Access, Target => Tnode_Common);
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode
+ is
+ Res : O_Tnode;
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Access,
+ Mode => Mode_P32,
+ Align => Mode_Align (Mode_P32),
+ Deferred => Dtype = O_Tnode_Null,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 4));
+ Res := Tnodes.Last;
+ Tnodes.Append (To_Tnode_Common (Tnode_Access'(Dtype => Dtype,
+ Pad => 0)));
+ return Res;
+ end New_Access_Type;
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is
+ begin
+ if Get_Type_Access_Type (Atype) /= O_Tnode_Null then
+ raise Program_Error;
+ end if;
+ Tnodes.Table (Atype + 1) :=
+ To_Tnode_Common (Tnode_Access'(Dtype => Dtype,
+ Pad => 0));
+ if Flag_Type_Completer then
+ Create_Completer (Atype);
+ end if;
+ end Finish_Access_Type;
+
+
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Record, Target => Tnode_Common);
+
+ function Create_Record_Type (Deferred : Boolean) return O_Tnode
+ is
+ Res : O_Tnode;
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Record,
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => Deferred,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
+ Res := Tnodes.Last;
+ Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null,
+ Nbr_Fields => 0)));
+ return Res;
+ end Create_Record_Type;
+
+ procedure Start_Record_Type (Elements : out O_Element_List)
+ is
+ begin
+ Elements := (Res => Create_Record_Type (False),
+ First_Field => O_Fnode_Null,
+ Last_Field => O_Fnode_Null,
+ Off => 0,
+ Align => 0,
+ Nbr => 0);
+ end Start_Record_Type;
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
+ begin
+ Res := Create_Record_Type (True);
+ end New_Uncomplete_Record_Type;
+
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List)
+ is
+ begin
+ Elements := (Res => Res,
+ First_Field => O_Fnode_Null,
+ Last_Field => O_Fnode_Null,
+ Off => 0,
+ Align => 0,
+ Nbr => 0);
+ end Start_Uncomplete_Record_Type;
+
+ function Get_Mode_Size (Mode : Mode_Type) return Uns32 is
+ begin
+ case Mode is
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ return 1;
+ when Mode_I16
+ | Mode_U16 =>
+ return 2;
+ when Mode_I32
+ | Mode_U32
+ | Mode_P32
+ | Mode_F32 =>
+ return 4;
+ when Mode_I64
+ | Mode_U64
+ | Mode_P64
+ | Mode_F64 =>
+ return 8;
+ when Mode_X1
+ | Mode_Nil
+ | Mode_Blk =>
+ raise Program_Error;
+ end case;
+ end Get_Mode_Size;
+
+ function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32
+ is
+ Msk : constant Uns32 := Get_Type_Align_Bytes (Atype) - 1;
+ begin
+ -- Align.
+ return (Off + Msk) and (not Msk);
+ end Do_Align;
+
+ function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32
+ is
+ Msk : constant Uns32 := (2 ** Mode_Align (Mode)) - 1;
+ begin
+ -- Align.
+ return (Off + Msk) and (not Msk);
+ end Do_Align;
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode)
+ is
+ begin
+ Elements.Off := Do_Align (Elements.Off, Etype);
+
+ Fnodes.Append (Field_Type'(Parent => Elements.Res,
+ Ident => Ident,
+ Ftype => Etype,
+ Offset => Elements.Off,
+ Next => O_Fnode_Null));
+ El := Fnodes.Last;
+ Elements.Off := Elements.Off + Get_Type_Size (Etype);
+ if Get_Type_Align (Etype) > Elements.Align then
+ Elements.Align := Get_Type_Align (Etype);
+ end if;
+ if Elements.Last_Field /= O_Fnode_Null then
+ Fnodes.Table (Elements.Last_Field).Next := Fnodes.Last;
+ else
+ Elements.First_Field := Fnodes.Last;
+ end if;
+ Elements.Last_Field := Fnodes.Last;
+ Elements.Nbr := Elements.Nbr + 1;
+ end New_Record_Field;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode)
+ is
+ begin
+ Tnodes.Table (Elements.Res).Size := Do_Align (Elements.Off,
+ Elements.Res);
+ Tnodes.Table (Elements.Res).Align := Elements.Align;
+ Tnodes.Table (Elements.Res + 1) := To_Tnode_Common
+ (Tnode_Record'(Fields => Elements.First_Field,
+ Nbr_Fields => Elements.Nbr));
+ Res := Elements.Res;
+ if Flag_Type_Completer
+ and then Tnodes.Table (Elements.Res).Deferred
+ then
+ Create_Completer (Elements.Res);
+ end if;
+ end Finish_Record_Type;
+
+ procedure Start_Union_Type (Elements : out O_Element_List)
+ is
+ begin
+ Tnodes.Append (Tnode_Common'(Kind => OT_Union,
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => False,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
+ Elements := (Res => Tnodes.Last,
+ First_Field => O_Fnode_Null,
+ Last_Field => O_Fnode_Null,
+ Off => 0,
+ Align => 0,
+ Nbr => 0);
+ Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null,
+ Nbr_Fields => 0)));
+ 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
+ Off : Uns32;
+ begin
+ Off := Elements.Off;
+ Elements.Off := 0;
+ New_Record_Field (Elements, El, Ident, Etype);
+ if Off > Elements.Off then
+ Elements.Off := Off;
+ end if;
+ end New_Union_Field;
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode)
+ is
+ begin
+ Finish_Record_Type (Elements, Res);
+ end Finish_Union_Type;
+
+ function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode
+ is
+ Base : O_Tnode;
+ begin
+ case Get_Type_Kind (Atype) is
+ when OT_Ucarray =>
+ Base := Atype;
+ when OT_Subarray =>
+ Base := Get_Type_Subarray_Base (Atype);
+ when others =>
+ raise Program_Error;
+ end case;
+ return Get_Type_Ucarray_Element (Base);
+ end Get_Type_Array_Element;
+
+ procedure Debug_Type (Atype : O_Tnode)
+ is
+ use Ortho_Code.Debug.Int32_IO;
+ use Ada.Text_IO;
+ Kind : OT_Kind;
+ begin
+ Put (Int32 (Atype), 3);
+ Put (" ");
+ Kind := Get_Type_Kind (Atype);
+ Put (OT_Kind'Image (Get_Type_Kind (Atype)));
+ Put (" ");
+ Put (Mode_Type'Image (Get_Type_Mode (Atype)));
+ Put (" D=");
+ Put (Boolean'Image (Get_Type_Deferred (Atype)));
+ Put (" F1=");
+ Put (Boolean'Image (Get_Type_Flag1 (Atype)));
+ New_Line;
+ case Kind is
+ when OT_Boolean =>
+ Put (" false: ");
+ Put (Int32 (Get_Type_Bool_False (Atype)));
+ Put (", true: ");
+ Put (Int32 (Get_Type_Bool_True (Atype)));
+ New_Line;
+ when OT_Access =>
+ Put (" acc_type: ");
+ Put (Int32 (Get_Type_Access_Type (Atype)));
+ New_Line;
+ when OT_Record =>
+ Put (" fields: ");
+ Put (Int32 (Get_Type_Record_Fields (Atype)));
+ Put (", nbr_fields: ");
+ Put (To_Int32 (Get_Type_Record_Nbr_Fields (Atype)));
+ New_Line;
+ when OT_Subarray =>
+ Put (" base type: ");
+ Put (Int32 (Get_Type_Subarray_Base (Atype)));
+ Put (", length: ");
+ Put (To_Int32 (Get_Type_Subarray_Length (Atype)));
+ New_Line;
+ when others =>
+ null;
+ end case;
+ end Debug_Type;
+
+ procedure Debug_Field (Field : O_Fnode)
+ is
+ use Ortho_Code.Debug.Int32_IO;
+ use Ada.Text_IO;
+ begin
+ Put (Int32 (Field), 3);
+ Put (" ");
+ Put (" Offset=");
+ Put (To_Int32 (Get_Field_Offset (Field)), 0);
+ Put (", Ident=");
+ Put (Ortho_Ident.Get_String (Get_Field_Ident (Field)));
+ Put (", Type=");
+ Put (Int32 (Get_Field_Type (Field)), 0);
+ Put (", Chain=");
+ Put (Int32 (Get_Field_Chain (Field)), 0);
+ New_Line;
+ end Debug_Field;
+
+ function Get_Type_Limit return O_Tnode is
+ begin
+ return Tnodes.Last;
+ end Get_Type_Limit;
+
+ function Get_Type_Next (Atype : O_Tnode) return O_Tnode is
+ begin
+ case Tnodes.Table (Atype).Kind is
+ when OT_Unsigned
+ | OT_Signed
+ | OT_Float =>
+ return Atype + 1;
+ when OT_Boolean
+ | OT_Enum
+ | OT_Ucarray
+ | OT_Subarray
+ | OT_Access
+ | OT_Record
+ | OT_Union =>
+ return Atype + 2;
+ when OT_Complete =>
+ return Atype + 1;
+ end case;
+ end Get_Type_Next;
+
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode
+ is
+ begin
+ case Get_Type_Kind (Atype) is
+ when OT_Subarray =>
+ return Get_Type_Subarray_Base (Atype);
+ when others =>
+ return Atype;
+ end case;
+ end Get_Base_Type;
+
+ procedure Mark (M : out Mark_Type) is
+ begin
+ M.Tnode := Tnodes.Last;
+ M.Fnode := Fnodes.Last;
+ end Mark;
+
+ procedure Release (M : Mark_Type) is
+ begin
+ Tnodes.Set_Last (M.Tnode);
+ Fnodes.Set_Last (M.Fnode);
+ end Release;
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("Number of Tnodes: " & O_Tnode'Image (Tnodes.Last));
+ Put_Line ("Number of Fnodes: " & O_Fnode'Image (Fnodes.Last));
+ end Disp_Stats;
+
+ procedure Finish is
+ begin
+ Tnodes.Free;
+ Fnodes.Free;
+ end Finish;
+end Ortho_Code.Types;
diff --git a/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads
new file mode 100644
index 000000000..da6549841
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-types.ads
@@ -0,0 +1,240 @@
+-- Mcode back-end for ortho - type handling.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ortho_Code.Types is
+ type OT_Kind is (OT_Unsigned, OT_Signed, OT_Boolean, OT_Enum, OT_Float,
+ OT_Ucarray, OT_Subarray, OT_Access,
+ OT_Record, OT_Union,
+
+ -- Type completion. Mark the completion of a type.
+ -- Optionnal.
+ OT_Complete);
+
+ -- Kind of ATYPE.
+ function Get_Type_Kind (Atype : O_Tnode) return OT_Kind;
+
+ -- Number of bytes of type ATYPE.
+ function Get_Type_Size (Atype : O_Tnode) return Uns32;
+
+ -- Same as Get_Type_Size but for modes.
+ -- Returns 0 in case of error.
+ function Get_Mode_Size (Mode : Mode_Type) return Uns32;
+
+ -- Alignment for ATYPE, in power of 2.
+ subtype Small_Natural is Natural range 0 .. 3;
+ type Mode_Align_Array is array (Mode_Type) of Small_Natural;
+ function Get_Type_Align (Atype : O_Tnode) return Small_Natural;
+
+ -- Alignment for ATYPE in bytes.
+ function Get_Type_Align_Bytes (Atype : O_Tnode) return Uns32;
+
+ -- Return true is the type was incomplete at creation.
+ -- (it may - or not - have been completed later).
+ function Get_Type_Deferred (Atype : O_Tnode) return Boolean;
+
+ -- A back-end reserved flag.
+ -- Initialized to False.
+ function Get_Type_Flag1 (Atype : O_Tnode) return Boolean;
+ procedure Set_Type_Flag1 (Atype : O_Tnode; Flag : Boolean);
+
+ -- Align OFF on ATYPE.
+ function Do_Align (Off : Uns32; Atype : O_Tnode) return Uns32;
+ function Do_Align (Off : Uns32; Mode : Mode_Type) return Uns32;
+
+ -- Get the mode for ATYPE.
+ function Get_Type_Mode (Atype : O_Tnode) return Mode_Type;
+
+ -- Get the type designated by access type ATYPE.
+ function Get_Type_Access_Type (Atype : O_Tnode) return O_Tnode;
+
+ -- Get the index type of array type ATYPE.
+ function Get_Type_Ucarray_Index (Atype : O_Tnode) return O_Tnode;
+
+ -- Get the element type of array type ATYPE.
+ function Get_Type_Ucarray_Element (Atype : O_Tnode) return O_Tnode;
+
+ -- Get the base type of array type ATYPE.
+ function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode;
+
+ -- Get number of element for array type ATYPE.
+ function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32;
+
+ -- Get the first field of record/union ATYPE.
+ function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode;
+
+ -- Get the number of fields of record/union ATYPE.
+ function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32;
+
+ -- Get the first literal of enum type ATYPE.
+ function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode;
+
+ -- Get the POS th literal of enum type ATYPE.
+ -- The first is when POS = 0.
+ function Get_Type_Enum_Lit (Atype : O_Tnode; Pos : Uns32) return O_Cnode;
+
+ -- Get the number of literals of enum type ATYPE.
+ function Get_Type_Enum_Nbr_Lits (Atype : O_Tnode) return Uns32;
+
+ -- Get the false/true literal of boolean type ATYPE.
+ function Get_Type_Bool_False (Atype : O_Tnode) return O_Cnode;
+ function Get_Type_Bool_True (Atype : O_Tnode) return O_Cnode;
+
+ -- Return the union/record type which contains FIELD.
+ function Get_Field_Parent (Field : O_Fnode) return O_Tnode;
+
+ -- Get the offset of FIELD in its record/union.
+ function Get_Field_Offset (Field : O_Fnode) return Uns32;
+ procedure Set_Field_Offset (Field : O_Fnode; Offset : Uns32);
+
+ -- Get the type of FIELD.
+ function Get_Field_Type (Field : O_Fnode) return O_Tnode;
+
+ -- Get the name of FIELD.
+ function Get_Field_Ident (Field : O_Fnode) return O_Ident;
+
+ -- Get the next field.
+ function Get_Field_Chain (Field : O_Fnode) return O_Fnode;
+
+ -- Get the type that was completed.
+ function Get_Type_Complete_Type (Atype : O_Tnode) return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a boolean 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32)
+ return O_Tnode;
+
+ -- Return the base type of ATYPE: for a subarray this is the uc array,
+ -- otherwise this is the type.
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode;
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Non-primitives.
+
+ -- Type of an element of a ucarray or constrained array.
+ function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode;
+
+ -- Get a type number limit (an O_Tnode is a number).
+ -- There is no type whose number is beyond this limit.
+ -- Note: the limit may not be a type!
+ function Get_Type_Limit return O_Tnode;
+
+ -- Get the type which follows ATYPE.
+ -- User has to check that the result is valid (ie not beyond limit).
+ function Get_Type_Next (Atype : O_Tnode) return O_Tnode;
+
+ procedure Disp_Stats;
+
+ -- Free all the memory used.
+ procedure Finish;
+
+ type Mark_Type is limited private;
+ procedure Mark (M : out Mark_Type);
+ procedure Release (M : Mark_Type);
+
+ procedure Debug_Type (Atype : O_Tnode);
+ procedure Debug_Field (Field : O_Fnode);
+private
+ type O_Enum_List is record
+ Res : O_Tnode;
+ First : O_Cnode;
+ Last : O_Cnode;
+ Nbr : Uns32;
+ end record;
+
+ type O_Element_List is record
+ Res : O_Tnode;
+ Nbr : Uns32;
+ Off : Uns32;
+ Align : Small_Natural;
+ First_Field : O_Fnode;
+ Last_Field : O_Fnode;
+ end record;
+
+ type Mark_Type is record
+ Tnode : O_Tnode;
+ Fnode : O_Fnode;
+ end record;
+
+end Ortho_Code.Types;
+
diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb
new file mode 100644
index 000000000..bb06d51d4
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-abi.adb
@@ -0,0 +1,762 @@
+-- X86 ABI definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+with Ortho_Code.Consts;
+with Ortho_Code.Debug;
+with Ortho_Code.Disps;
+with Ortho_Code.Flags;
+with Ortho_Code.Dwarf;
+with Ortho_Code.X86; use Ortho_Code.X86;
+with Ortho_Code.X86.Insns;
+with Ortho_Code.X86.Emits;
+with Ortho_Code.X86.Flags;
+with Binary_File;
+with Binary_File.Memory;
+with Ada.Text_IO;
+
+package body Ortho_Code.X86.Abi is
+ procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg)
+ is
+ pragma Unreferenced (Subprg);
+ begin
+ -- First argument is at %ebp + 8
+ Abi.Offset := 8;
+ end Start_Subprogram;
+
+ procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg)
+ is
+ Itype : O_Tnode;
+ Size : Uns32;
+ begin
+ Itype := Get_Decl_Type (Inter);
+ Size := Get_Type_Size (Itype);
+ Size := (Size + 3) and not 3;
+ Set_Local_Offset (Inter, Abi.Offset);
+ Abi.Offset := Abi.Offset + Int32 (Size);
+ end New_Interface;
+
+ procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg)
+ is
+ use Binary_File;
+ function To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Symbol, Target => Int32);
+ begin
+ Set_Decl_Info (Subprg,
+ To_Int32 (Create_Symbol (Get_Decl_Ident (Subprg))));
+ -- Offset is 8 biased.
+ Set_Subprg_Stack (Subprg, Abi.Offset - 8);
+ end Finish_Subprogram;
+
+ procedure Link_Stmt (Stmt : O_Enode) is
+ begin
+ Set_Stmt_Link (Last_Link, Stmt);
+ Last_Link := Stmt;
+ end Link_Stmt;
+
+ procedure Disp_Subprg (Subprg : O_Dnode);
+
+
+ Exprs_Mark : Exprs.Mark_Type;
+ Decls_Mark : Decls.Mark_Type;
+ Consts_Mark : Consts.Mark_Type;
+ Types_Mark : Types.Mark_Type;
+ Dwarf_Mark : Dwarf.Mark_Type;
+
+ procedure Start_Body (Subprg : O_Dnode)
+ is
+ pragma Unreferenced (Subprg);
+ begin
+ if not Debug.Flag_Debug_Keep then
+ Mark (Exprs_Mark);
+ Mark (Decls_Mark);
+ Consts.Mark (Consts_Mark);
+ Mark (Types_Mark);
+ end if;
+ end Start_Body;
+
+ procedure Finish_Body (Subprg : Subprogram_Data_Acc)
+ is
+ use Ortho_Code.Flags;
+
+ Child : Subprogram_Data_Acc;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Disps.Disp_Subprg (Subprg);
+ return;
+ end if;
+
+ Insns.Gen_Subprg_Insns (Subprg);
+
+ if Ortho_Code.Debug.Flag_Debug_Body2 then
+ Disp_Subprg_Body (1, Subprg.E_Entry);
+ end if;
+
+ if Ortho_Code.Debug.Flag_Debug_Code then
+ Disp_Subprg (Subprg.D_Body);
+ end if;
+
+ Emits.Emit_Subprg (Subprg);
+
+ if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel
+ and then Flag_Debug = Debug_Dwarf
+ then
+ Dwarf.Emit_Decls_Until (Subprg.D_Body);
+ if not Debug.Flag_Debug_Keep then
+ Dwarf.Mark (Dwarf_Mark);
+ end if;
+ end if;
+
+ -- Recurse on nested subprograms.
+ Child := Subprg.First_Child;
+ while Child /= null loop
+ Finish_Body (Child);
+ Child := Child.Brother;
+ end loop;
+
+ if Get_Decl_Depth (Subprg.D_Decl) = O_Toplevel then
+ if Flag_Debug = Debug_Dwarf then
+ Dwarf.Emit_Subprg (Subprg.D_Body);
+ end if;
+
+ if not Debug.Flag_Debug_Keep then
+ Release (Exprs_Mark);
+ Release (Decls_Mark);
+ Consts.Release (Consts_Mark);
+ Release (Types_Mark);
+ Dwarf.Release (Dwarf_Mark);
+ end if;
+ end if;
+ end Finish_Body;
+
+ procedure Expand_Const_Decl (Decl : O_Dnode) is
+ begin
+ Emits.Emit_Const_Decl (Decl);
+ end Expand_Const_Decl;
+
+ procedure Expand_Var_Decl (Decl : O_Dnode) is
+ begin
+ Emits.Emit_Var_Decl (Decl);
+ end Expand_Var_Decl;
+
+ procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode) is
+ begin
+ Emits.Emit_Const_Value (Decl, Val);
+ end Expand_Const_Value;
+
+ procedure Disp_Label (Label : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ begin
+ Put ("L");
+ Put (Int32 (Label), 0);
+ end Disp_Label;
+
+ procedure Disp_Reg (Reg : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ begin
+ Put ("reg_");
+ Put (Int32 (Reg), 0);
+ Put ("{");
+ Put (Image_Reg (Get_Expr_Reg (Reg)));
+ Put ("}");
+ end Disp_Reg;
+
+ procedure Disp_Local (Stmt : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ Obj : constant O_Dnode := Get_Addr_Object (Stmt);
+ Frame : constant O_Enode := Get_Addrl_Frame (Stmt);
+ begin
+ if Frame = O_Enode_Null then
+ Put ("fp");
+ else
+ Disp_Reg (Frame);
+ end if;
+ Put (",");
+ Put (Get_Local_Offset (Obj), 0);
+ Put (" {");
+ Disp_Decl_Name (Obj);
+ Put ("}");
+ end Disp_Local;
+
+ procedure Disp_Uns32 (Val : Uns32)
+ is
+ use Ada.Text_IO;
+ U2c : constant array (Uns32 range 0 .. 15) of Character
+ := "0123456789abcdef";
+ V : Uns32 := Val;
+ begin
+ for I in 0 .. 7 loop
+ Put (U2c (Shift_Right (V, 28)));
+ V := Shift_Left (V, 4);
+ end loop;
+ end Disp_Uns32;
+
+ procedure Disp_Const (Stmt : O_Enode)
+ is
+ use Ada.Text_IO;
+ begin
+ Put ("[");
+ case Get_Expr_Mode (Stmt) is
+ when Mode_U64
+ | Mode_I64
+ | Mode_F64 =>
+ Disp_Uns32 (Get_Expr_High (Stmt));
+ Put (",");
+ when others =>
+ null;
+ end case;
+ Disp_Uns32 (Get_Expr_Low (Stmt));
+ Put ("]");
+ end Disp_Const;
+
+ procedure Disp_Irm_Code (Stmt : O_Enode)
+ is
+ use Ortho_Code.Debug.Int32_IO;
+ use Ada.Text_IO;
+ Reg : O_Reg;
+ Kind : OE_Kind;
+ begin
+ Reg := Get_Expr_Reg (Stmt);
+ Kind := Get_Expr_Kind (Stmt);
+ case Reg is
+ when R_Mem =>
+ case Kind is
+ when OE_Indir =>
+ Put ('(');
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ Put (')');
+-- when OE_Lit =>
+-- Put ("(&n)");
+ when others =>
+ raise Program_Error;
+ end case;
+ when R_Imm =>
+ case Kind is
+ when OE_Const =>
+ Disp_Const (Stmt);
+ when OE_Addrg =>
+ Put ("&");
+ Disp_Decl_Name (Get_Addr_Object (Stmt));
+ when OE_Add =>
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put ("+");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ when others =>
+ raise Program_Error;
+ end case;
+ when Regs_R32
+ | R_Any32
+ | R_Any8
+ | Regs_R64
+ | R_Any64
+ | Regs_Cc
+ | Regs_Fp
+ | Regs_Xmm =>
+ Disp_Reg (Stmt);
+ when R_Spill =>
+ Disp_Reg (Stmt);
+ --Disp_Irm_Code (Get_Stmt_Link (Stmt));
+ when R_B_Off
+ | R_I_Off
+ | R_B_I
+ | R_Sib =>
+ case Kind is
+ when OE_Addrl =>
+ Disp_Local (Stmt);
+ when OE_Add =>
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (" + ");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ when others =>
+ raise Program_Error;
+ end case;
+ when R_I =>
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (" * ");
+ case Get_Expr_Low (Get_Expr_Right (Stmt)) is
+ when 0 =>
+ Put ('1');
+ when 1 =>
+ Put ('2');
+ when 2 =>
+ Put ('4');
+ when 3 =>
+ Put ('8');
+ when others =>
+ Put ('?');
+ end case;
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("abi.disp_irm_code: unhandled reg=" & Image_Reg (Reg)
+ & ", stmt=" & O_Enode'Image (Stmt));
+ raise Program_Error;
+ end case;
+ end Disp_Irm_Code;
+
+ procedure Disp_Decls (Block : O_Dnode)
+ is
+ Decl : O_Dnode;
+ Last : O_Dnode;
+ begin
+ Last := Get_Block_Last (Block);
+ Disp_Decl (2, Block);
+ Decl := Block + 1;
+ while Decl <= Last loop
+ case Get_Decl_Kind (Decl) is
+ when OD_Local =>
+ Disp_Decl (2, Decl);
+ when OD_Block =>
+ -- Skip internal blocks.
+ Decl := Get_Block_Last (Decl);
+ when others =>
+ Disp_Decl (2, Decl);
+ null;
+ end case;
+ Decl := Decl + 1;
+ end loop;
+ end Disp_Decls;
+
+ procedure Disp_Stmt (Stmt : O_Enode)
+ is
+ use Ada.Text_IO;
+ use Debug.Int32_IO;
+ Kind : OE_Kind;
+ Mode : Mode_Type;
+
+ procedure Disp_Op_Name (Name : String) is
+ begin
+ Put (Name);
+ Put (":");
+ Debug.Disp_Mode (Mode);
+ Put (" ");
+ end Disp_Op_Name;
+
+ procedure Disp_Reg_Op_Name (Name : String) is
+ begin
+ Put (" ");
+ Disp_Reg (Stmt);
+ Put (" = ");
+ Disp_Op_Name (Name);
+ end Disp_Reg_Op_Name;
+
+ begin
+ Kind := Get_Expr_Kind (Stmt);
+ Mode := Get_Expr_Mode (Stmt);
+
+ case Kind is
+ when OE_Beg =>
+ Put (" # block start");
+ if Get_Block_Has_Alloca (Stmt) then
+ Put (" [alloca]");
+ end if;
+ New_Line;
+ Disp_Decls (Get_Block_Decls (Stmt));
+ when OE_End =>
+ Put_Line (" # block end");
+ when OE_Indir =>
+ Disp_Reg_Op_Name ("indir");
+ Put ("(");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ Put_Line (")");
+ when OE_Alloca =>
+ Disp_Reg_Op_Name ("alloca");
+ Put ("(");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ Put_Line (")");
+ when OE_Kind_Cmp
+ | OE_Kind_Dyadic =>
+ Disp_Reg_Op_Name ("op");
+ Put ("{");
+ Put (OE_Kind'Image (Kind));
+ Put ("} ");
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (", ");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ New_Line;
+ when OE_Abs_Ov
+ | OE_Neg_Ov
+ | OE_Not =>
+ Disp_Reg_Op_Name ("op");
+ Put ("{");
+ Put (OE_Kind'Image (Kind));
+ Put ("} ");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Const =>
+ Disp_Reg_Op_Name ("const");
+ Disp_Const (Stmt);
+ New_Line;
+ when OE_Jump_F =>
+ Put (" jump_f ");
+ Disp_Reg (Get_Expr_Operand (Stmt));
+ Put (" ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ New_Line;
+ when OE_Jump_T =>
+ Put (" jump_t ");
+ Disp_Reg (Get_Expr_Operand (Stmt));
+ Put (" ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ New_Line;
+ when OE_Jump =>
+ Put (" jump ");
+ Disp_Label (Get_Jump_Label (Stmt));
+ New_Line;
+ when OE_Label =>
+ Disp_Label (Stmt);
+ Put_Line (":");
+ when OE_Asgn =>
+ Put (" assign:");
+ Debug.Disp_Mode (Mode);
+ Put (" (");
+ Disp_Irm_Code (Get_Assign_Target (Stmt));
+ Put (") <- ");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Set_Stack =>
+ Put (" set_stack");
+ Put (" <- ");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Spill =>
+ Disp_Reg_Op_Name ("spill");
+ Disp_Reg (Get_Expr_Operand (Stmt));
+ Put (", offset=");
+ Put (Int32'Image (Get_Spill_Info (Stmt)));
+ New_Line;
+ when OE_Reload =>
+ Disp_Reg_Op_Name ("reload");
+ Disp_Reg (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Arg =>
+ Put (" push ");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Call =>
+ if Get_Expr_Mode (Stmt) /= Mode_Nil then
+ Disp_Reg_Op_Name ("call");
+ else
+ Put (" ");
+ Disp_Op_Name ("call");
+ Put (" ");
+ end if;
+ Disp_Decl_Name (Get_Call_Subprg (Stmt));
+ New_Line;
+ when OE_Stack_Adjust =>
+ Put (" stack_adjust: ");
+ Put (Int32'Image (Get_Stack_Adjust (Stmt)));
+ New_Line;
+ when OE_Intrinsic =>
+ Disp_Reg_Op_Name ("intrinsic");
+ --Disp_Decl_Name (Get_Call_Subprg (Stmt));
+ New_Line;
+ when OE_Conv =>
+ Disp_Reg_Op_Name ("conv");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Move =>
+ Disp_Reg_Op_Name ("move");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Ret =>
+ Put (" ret");
+ if Get_Expr_Mode (Stmt) /= Mode_Nil then
+ Put (" ");
+ Disp_Reg (Get_Expr_Operand (Stmt));
+ end if;
+ New_Line;
+ when OE_Case =>
+ Disp_Reg_Op_Name ("case");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Case_Expr =>
+ Disp_Reg_Op_Name ("case_expr");
+ Disp_Irm_Code (Get_Expr_Operand (Stmt));
+ New_Line;
+ when OE_Leave =>
+ Put_Line ("leave");
+ when OE_Entry =>
+ Put_Line ("entry");
+ when OE_Line =>
+ Put (" # line #");
+ Put (Get_Expr_Line_Number (Stmt), 0);
+ New_Line;
+ when OE_Addrl =>
+ Disp_Reg_Op_Name ("lea{addrl}");
+ Put ("(");
+ Disp_Local (Stmt);
+ Put (")");
+ New_Line;
+ when OE_Addrg =>
+ Disp_Reg_Op_Name ("lea{addrg}");
+ Put ("&");
+ Disp_Decl_Name (Get_Addr_Object (Stmt));
+ New_Line;
+ when OE_Add =>
+ Disp_Reg_Op_Name ("lea{add}");
+ Put ("(");
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (" + ");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ Put (")");
+ New_Line;
+ when OE_Mul =>
+ Disp_Reg_Op_Name ("mul");
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (", ");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ New_Line;
+ when OE_Shl =>
+ Disp_Reg_Op_Name ("shl");
+ Disp_Irm_Code (Get_Expr_Left (Stmt));
+ Put (", ");
+ Disp_Irm_Code (Get_Expr_Right (Stmt));
+ New_Line;
+ when OE_Reg =>
+ Disp_Reg_Op_Name ("reg");
+ New_Line;
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("abi.disp_stmt: unhandled enode " & OE_Kind'Image (Kind));
+ raise Program_Error;
+ end case;
+ end Disp_Stmt;
+
+ procedure Disp_Subprg_Decl (Decl : O_Dnode)
+ is
+ use Ada.Text_IO;
+ Arg : O_Dnode;
+ begin
+ Put ("subprogram ");
+ Disp_Decl_Name (Decl);
+ Put_Line (":");
+ Arg := Decl + 1;
+ while Get_Decl_Kind (Arg) = OD_Interface loop
+ Disp_Decl (2, Arg);
+ Arg := Arg + 1;
+ end loop;
+ end Disp_Subprg_Decl;
+
+ procedure Disp_Subprg (Subprg : O_Dnode)
+ is
+ use Ada.Text_IO;
+
+ Stmt : O_Enode;
+ begin
+ Disp_Subprg_Decl (Get_Body_Decl (Subprg));
+
+ Stmt := Get_Body_Stmt (Subprg);
+ loop
+ exit when Stmt = O_Enode_Null;
+ Disp_Stmt (Stmt);
+ exit when Get_Expr_Kind (Stmt) = OE_Leave;
+ Stmt := Get_Stmt_Link (Stmt);
+ end loop;
+ end Disp_Subprg;
+
+ procedure New_Debug_Filename_Decl (Filename : String)
+ is
+ use Ortho_Code.Flags;
+ begin
+ if Flag_Debug = Debug_Dwarf then
+ Dwarf.Set_Filename ("", Filename);
+ end if;
+ end New_Debug_Filename_Decl;
+
+ procedure Init
+ is
+ use Ortho_Code.Debug;
+ begin
+ -- Alignment of doubles is platform dependent.
+ Mode_Align (Mode_F64) := X86.Flags.Mode_F64_Align;
+
+ if Flag_Debug_Hli then
+ Disps.Init;
+ else
+ Emits.Init;
+ end if;
+ end Init;
+
+ procedure Finish
+ is
+ use Ortho_Code.Debug;
+ begin
+ if Flag_Debug_Hli then
+ Disps.Finish;
+ else
+ Emits.Finish;
+ end if;
+ end Finish;
+
+-- function Image_Insn (Insn : O_Insn) return String is
+-- begin
+-- case Insn is
+-- when Insn_Nil =>
+-- return "nil";
+-- when Insn_Imm =>
+-- return "imm";
+-- when Insn_Base_Off =>
+-- return "B+O";
+-- when Insn_Loadm =>
+-- return "ldm";
+-- when Insn_Loadi =>
+-- return "ldi";
+-- when Insn_Mem =>
+-- return "mem";
+-- when Insn_Cmp =>
+-- return "cmp";
+-- when Insn_Op =>
+-- return "op ";
+-- when Insn_Rop =>
+-- return "rop";
+-- when Insn_Call =>
+-- return "cal";
+-- when others =>
+-- return "???";
+-- end case;
+-- end Image_Insn;
+
+ function Image_Reg (Reg : O_Reg) return String is
+ begin
+ case Reg is
+ when R_Nil =>
+ return "nil ";
+ when R_None =>
+ return " -- ";
+ when R_Spill =>
+ return "spil";
+ when R_Mem =>
+ return "mem ";
+ when R_Imm =>
+ return "imm ";
+ when R_Irm =>
+ return "irm ";
+ when R_Rm =>
+ return "rm ";
+ when R_Sib =>
+ return "sib ";
+ when R_B_Off =>
+ return "b+o ";
+ when R_B_I =>
+ return "b+i ";
+ when R_I =>
+ return "s*i ";
+ when R_Ir =>
+ return " ir ";
+ when R_I_Off =>
+ return "i+o ";
+ when R_Any32 =>
+ return "r32 ";
+ when R_Any_Cc =>
+ return "cc ";
+ when R_Any8 =>
+ return "r8 ";
+ when R_Any64 =>
+ return "r64 ";
+
+ when R_St0 =>
+ return "st0 ";
+ when R_Ax =>
+ return "ax ";
+ when R_Dx =>
+ return "dx ";
+ when R_Cx =>
+ return "cx ";
+ when R_Bx =>
+ return "bx ";
+ when R_Si =>
+ return "si ";
+ when R_Di =>
+ return "di ";
+ when R_Sp =>
+ return "sp ";
+ when R_Bp =>
+ return "bp ";
+ when R_Edx_Eax =>
+ return "dxax";
+ when R_Ebx_Ecx =>
+ return "bxcx";
+ when R_Esi_Edi =>
+ return "sidi";
+ when R_Eq =>
+ return "eq? ";
+ when R_Ne =>
+ return "ne? ";
+ when R_Uge =>
+ return "uge?";
+ when R_Sge =>
+ return "sge?";
+ when R_Ugt =>
+ return "ugt?";
+ when R_Sgt =>
+ return "sgt?";
+ when R_Ule =>
+ return "ule?";
+ when R_Sle =>
+ return "sle?";
+ when R_Ult =>
+ return "ult?";
+ when R_Slt =>
+ return "slt?";
+ when R_Xmm0 =>
+ return "xmm0";
+ when R_Xmm1 =>
+ return "xmm1";
+ when R_Xmm2 =>
+ return "xmm2";
+ when R_Xmm3 =>
+ return "xmm3";
+ when others =>
+ return "????";
+ end case;
+ end Image_Reg;
+
+ -- From GCC.
+ -- FIXME: these don't handle overflow!
+ function Divdi3 (A, B : Long_Integer) return Long_Integer;
+ pragma Import (C, Divdi3, "__divdi3");
+
+ function Muldi3 (A, B : Long_Integer) return Long_Integer;
+ pragma Import (C, Muldi3, "__muldi3");
+
+ procedure Chkstk (Sz : Integer);
+ pragma Import (C, Chkstk, "__chkstk");
+
+ procedure Link_Intrinsics
+ is
+ begin
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Intrinsics_Symbol
+ (Ortho_Code.X86.Intrinsic_Mul_Ov_I64),
+ Muldi3'Address);
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Intrinsics_Symbol
+ (Ortho_Code.X86.Intrinsic_Div_Ov_I64),
+ Divdi3'Address);
+ if X86.Flags.Flag_Alloca_Call then
+ Binary_File.Memory.Set_Symbol_Address
+ (Ortho_Code.X86.Emits.Chkstk_Symbol, Chkstk'Address);
+ end if;
+ end Link_Intrinsics;
+end Ortho_Code.X86.Abi;
diff --git a/src/ortho/mcode/ortho_code-x86-abi.ads b/src/ortho/mcode/ortho_code-x86-abi.ads
new file mode 100644
index 000000000..7b166dad8
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-abi.ads
@@ -0,0 +1,76 @@
+-- X86 ABI definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Types; use Ortho_Code.Types;
+
+package Ortho_Code.X86.Abi is
+ type O_Abi_Subprg is private;
+
+ procedure Init;
+ procedure Finish;
+
+ Mode_Align : Mode_Align_Array :=
+ (Mode_U8 | Mode_I8 => 0,
+ Mode_U16 | Mode_I16 => 1,
+ Mode_U32 | Mode_I32 | Mode_F32 | Mode_P32 => 2,
+ Mode_U64 | Mode_I64 => 2,
+ Mode_F64 => 2, -- 2 for SVR4-ABI and Darwin, 3 for Windows.
+ Mode_Blk | Mode_X1 | Mode_Nil | Mode_P64 => 0,
+ Mode_B2 => 0);
+
+ Mode_Ptr : constant Mode_Type := Mode_P32;
+
+ Flag_Type_Completer : constant Boolean := False;
+ Flag_Lower_Stmt : constant Boolean := True;
+
+ Flag_Sse2 : Boolean := False;
+
+ -- Procedures to layout a subprogram declaration.
+ procedure Start_Subprogram (Subprg : O_Dnode; Abi : out O_Abi_Subprg);
+ procedure New_Interface (Inter : O_Dnode; Abi : in out O_Abi_Subprg);
+ procedure Finish_Subprogram (Subprg : O_Dnode; Abi : in out O_Abi_Subprg);
+
+ -- Only called for top-level subprograms.
+ procedure Start_Body (Subprg : O_Dnode);
+ -- Finish compilation of a body.
+ procedure Finish_Body (Subprg : Subprogram_Data_Acc);
+
+ procedure Expand_Const_Decl (Decl : O_Dnode);
+ procedure Expand_Var_Decl (Decl : O_Dnode);
+ procedure Expand_Const_Value (Decl : O_Dnode; Val : O_Cnode);
+
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ Last_Link : O_Enode;
+ procedure Link_Stmt (Stmt : O_Enode);
+
+ -- Disp SUBPRG (subprg declaration) as a declaration (name and interfaces).
+ procedure Disp_Subprg_Decl (Decl : O_Dnode);
+
+ procedure Disp_Stmt (Stmt : O_Enode);
+
+ --function Image_Insn (Insn : O_Insn) return String;
+ function Image_Reg (Reg : O_Reg) return String;
+
+ -- Link in memory intrinsics symbols.
+ procedure Link_Intrinsics;
+private
+ type O_Abi_Subprg is record
+ -- For x86: offset of the next argument.
+ Offset : Int32 := 0;
+ end record;
+end Ortho_Code.X86.Abi;
diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb
new file mode 100644
index 000000000..ad1ef559b
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-emits.adb
@@ -0,0 +1,2322 @@
+-- Mcode back-end for ortho - Binary X86 instructions generator.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Abi;
+with Ortho_Code.Decls;
+with Ortho_Code.Types;
+with Ortho_Code.Consts;
+with Ortho_Code.Debug;
+with Ortho_Code.X86.Insns;
+with Ortho_Code.X86.Flags;
+with Ortho_Code.Flags;
+with Ortho_Code.Dwarf;
+with Ortho_Code.Binary; use Ortho_Code.Binary;
+with Ortho_Ident;
+with Ada.Text_IO;
+with Interfaces; use Interfaces;
+
+package body Ortho_Code.X86.Emits is
+ type Insn_Size is (Sz_8, Sz_16, Sz_32l, Sz_32h);
+
+ type Fp_Size is (Fp_32, Fp_64);
+
+ Sect_Text : Binary_File.Section_Acc;
+ Sect_Rodata : Binary_File.Section_Acc;
+ Sect_Bss : Binary_File.Section_Acc;
+
+ Reg_Helper : O_Reg;
+
+ Subprg_Pc : Pc_Type;
+
+ procedure Error_Emit (Msg : String; Insn : O_Enode)
+ is
+ use Ada.Text_IO;
+ begin
+ Put ("error_emit: ");
+ Put (Msg);
+ Put (", insn=");
+ Put (O_Enode'Image (Insn));
+ Put (" (");
+ Put (OE_Kind'Image (Get_Expr_Kind (Insn)));
+ Put (")");
+ New_Line;
+ raise Program_Error;
+ end Error_Emit;
+
+
+ procedure Gen_Insn_Sz (B : Byte; Sz : Insn_Size) is
+ begin
+ case Sz is
+ when Sz_8 =>
+ Gen_B8 (B);
+ when Sz_16 =>
+ Gen_B8 (16#66#);
+ Gen_B8 (B + 1);
+ when Sz_32l
+ | Sz_32h =>
+ Gen_B8 (B + 1);
+ end case;
+ end Gen_Insn_Sz;
+
+ procedure Gen_Insn_Sz_S8 (B : Byte; Sz : Insn_Size) is
+ begin
+ case Sz is
+ when Sz_8 =>
+ Gen_B8 (B);
+ when Sz_16 =>
+ Gen_B8 (16#66#);
+ Gen_B8 (B + 3);
+ when Sz_32l
+ | Sz_32h =>
+ Gen_B8 (B + 3);
+ end case;
+ end Gen_Insn_Sz_S8;
+
+ function Get_Const_Val (C : O_Enode; Sz : Insn_Size) return Uns32 is
+ begin
+ case Sz is
+ when Sz_8
+ | Sz_16
+ | Sz_32l =>
+ return Get_Expr_Low (C);
+ when Sz_32h =>
+ return Get_Expr_High (C);
+ end case;
+ end Get_Const_Val;
+
+ function Is_Imm8 (N : O_Enode; Sz : Insn_Size) return Boolean is
+ begin
+ if Get_Expr_Kind (N) /= OE_Const then
+ return False;
+ end if;
+ return Get_Const_Val (N, Sz) <= 127;
+ end Is_Imm8;
+
+ procedure Gen_Imm8 (N : O_Enode; Sz : Insn_Size) is
+ begin
+ Gen_B8 (Byte (Get_Const_Val (N, Sz)));
+ end Gen_Imm8;
+
+-- procedure Gen_Imm32 (N : O_Enode; Sz : Insn_Size)
+-- is
+-- use Interfaces;
+-- begin
+-- case Get_Expr_Kind (N) is
+-- when OE_Const =>
+-- Gen_Le32 (Unsigned_32 (Get_Const_Val (N, Sz)));
+-- when OE_Addrg =>
+-- Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0);
+-- when others =>
+-- raise Program_Error;
+-- end case;
+-- end Gen_Imm32;
+
+ procedure Gen_Imm (N : O_Enode; Sz : Insn_Size) is
+ begin
+ case Get_Expr_Kind (N) is
+ when OE_Const =>
+ case Sz is
+ when Sz_8 =>
+ Gen_B8 (Byte (Get_Expr_Low (N) and 16#FF#));
+ when Sz_16 =>
+ Gen_Le16 (Unsigned_32 (Get_Expr_Low (N) and 16#FF_FF#));
+ when Sz_32l =>
+ Gen_Le32 (Unsigned_32 (Get_Expr_Low (N)));
+ when Sz_32h =>
+ Gen_Le32 (Unsigned_32 (Get_Expr_High (N)));
+ end case;
+ when OE_Addrg =>
+ if Sz /= Sz_32l then
+ raise Program_Error;
+ end if;
+ Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (N)), 0);
+ when OE_Add =>
+ declare
+ P : O_Enode;
+ L, R : O_Enode;
+ S, C : O_Enode;
+ Off : Int32;
+ begin
+ Off := 0;
+ P := N;
+ if Sz /= Sz_32l then
+ raise Program_Error;
+ end if;
+ loop
+ L := Get_Expr_Left (P);
+ R := Get_Expr_Right (P);
+
+ -- Extract the const node.
+ if Get_Expr_Kind (R) = OE_Const then
+ S := L;
+ C := R;
+ elsif Get_Expr_Kind (L) = OE_Const then
+ S := R;
+ C := L;
+ else
+ raise Program_Error;
+ end if;
+ if Get_Expr_Mode (C) /= Mode_U32 then
+ raise Program_Error;
+ end if;
+ Off := Off + To_Int32 (Get_Expr_Low (C));
+
+ exit when Get_Expr_Kind (S) = OE_Addrg;
+ P := S;
+ if Get_Expr_Kind (P) /= OE_Add then
+ raise Program_Error;
+ end if;
+ end loop;
+ Gen_X86_32 (Get_Decl_Symbol (Get_Addr_Object (S)),
+ Integer_32 (Off));
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Gen_Imm;
+
+ Rm_Base : O_Reg;
+ Rm_Index : O_Reg;
+ Rm_Offset : Int32;
+ Rm_Sym : Symbol;
+ Rm_Scale : Byte;
+
+ procedure Fill_Sib (N : O_Enode)
+ is
+ use Ortho_Code.Decls;
+ Reg : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (N);
+ if Reg in Regs_R32 then
+ if Rm_Base = R_Nil then
+ Rm_Base := Reg;
+ elsif Rm_Index = R_Nil then
+ Rm_Index := Reg;
+ else
+ raise Program_Error;
+ end if;
+ return;
+ end if;
+ case Get_Expr_Kind (N) is
+ when OE_Indir =>
+ Fill_Sib (Get_Expr_Operand (N));
+ when OE_Addrl =>
+ declare
+ Frame : O_Enode;
+ begin
+ Frame := Get_Addrl_Frame (N);
+ if Frame = O_Enode_Null then
+ Rm_Base := R_Bp;
+ else
+ Rm_Base := Get_Expr_Reg (Frame);
+ end if;
+ end;
+ Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N));
+ when OE_Addrg =>
+ if Rm_Sym /= Null_Symbol then
+ raise Program_Error;
+ end if;
+ Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N));
+ when OE_Add =>
+ Fill_Sib (Get_Expr_Left (N));
+ Fill_Sib (Get_Expr_Right (N));
+ when OE_Const =>
+ Rm_Offset := Rm_Offset + To_Int32 (Get_Expr_Low (N));
+ when OE_Shl =>
+ if Rm_Index /= R_Nil then
+ raise Program_Error;
+ end if;
+ Rm_Index := Get_Expr_Reg (Get_Expr_Left (N));
+ Rm_Scale := Byte (Get_Expr_Low (Get_Expr_Right (N)));
+ when others =>
+ Error_Emit ("fill_sib", N);
+ end case;
+ end Fill_Sib;
+
+ function To_Reg32 (R : O_Reg) return Byte is
+ begin
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Ax);
+ end To_Reg32;
+ pragma Inline (To_Reg32);
+
+ function To_Reg_Xmm (R : O_Reg) return Byte is
+ begin
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Xmm0);
+ end To_Reg_Xmm;
+ pragma Inline (To_Reg_Xmm);
+
+ function To_Reg32 (R : O_Reg; Sz : Insn_Size) return Byte is
+ begin
+ case Sz is
+ when Sz_8 =>
+ if R in Regs_R8 then
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Ax);
+ else
+ raise Program_Error;
+ end if;
+ when Sz_16 =>
+ if R in Regs_R32 then
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Ax);
+ else
+ raise Program_Error;
+ end if;
+ when Sz_32l =>
+ case R is
+ when Regs_R32 =>
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Ax);
+ when R_Edx_Eax =>
+ return 2#000#;
+ when R_Ebx_Ecx =>
+ return 2#001#;
+ when R_Esi_Edi =>
+ return 2#111#;
+ when others =>
+ raise Program_Error;
+ end case;
+ when Sz_32h =>
+ case R is
+ when R_Edx_Eax =>
+ return 2#010#;
+ when R_Ebx_Ecx =>
+ return 2#011#;
+ when R_Esi_Edi =>
+ return 2#110#;
+ when others =>
+ raise Program_Error;
+ end case;
+ end case;
+ end To_Reg32;
+
+ function To_Cond (R : O_Reg) return Byte is
+ begin
+ return O_Reg'Pos (R) - O_Reg'Pos (R_Ov);
+ end To_Cond;
+ pragma Inline (To_Cond);
+
+ procedure Gen_Sib is
+ begin
+ if Rm_Base = R_Nil then
+ Gen_B8 (Rm_Scale * 2#1_000_000#
+ + To_Reg32 (Rm_Index) * 2#1_000#
+ + 2#101#);
+ else
+ Gen_B8 (Rm_Scale * 2#1_000_000#
+ + To_Reg32 (Rm_Index) * 2#1_000#
+ + To_Reg32 (Rm_Base));
+ end if;
+ end Gen_Sib;
+
+ -- Generate an R/M (+ SIB) byte.
+ -- R is added to the R/M byte.
+ procedure Gen_Rm_Mem (R : Byte; N : O_Enode; Sz : Insn_Size)
+ is
+ Reg : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (N);
+ Rm_Base := R_Nil;
+ Rm_Index := R_Nil;
+ if Sz = Sz_32h then
+ Rm_Offset := 4;
+ else
+ Rm_Offset := 0;
+ end if;
+ Rm_Scale := 0;
+ Rm_Sym := Null_Symbol;
+ case Reg is
+ when R_Mem
+ | R_Imm
+ | R_Eq
+ | R_B_Off
+ | R_B_I
+ | R_I_Off
+ | R_Sib =>
+ Fill_Sib (N);
+ when Regs_R32 =>
+ Rm_Base := Reg;
+ when R_Spill =>
+ Rm_Base := R_Bp;
+ Rm_Offset := Rm_Offset + Get_Spill_Info (N);
+ when others =>
+ Error_Emit ("gen_rm_mem: unhandled reg", N);
+ end case;
+ if Rm_Index /= R_Nil then
+ -- SIB.
+ if Rm_Base = R_Nil then
+ Gen_B8 (2#00_000_100# + R);
+ Rm_Base := R_Bp;
+ Gen_Sib;
+ Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset));
+ elsif Rm_Sym = Null_Symbol and Rm_Offset = 0 and Rm_Base /= R_Bp then
+ Gen_B8 (2#00_000_100# + R);
+ Gen_Sib;
+ elsif Rm_Sym = Null_Symbol and Rm_Offset <= 127 and Rm_Offset >= -128
+ then
+ Gen_B8 (2#01_000_100# + R);
+ Gen_Sib;
+ Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#));
+ else
+ Gen_B8 (2#10_000_100# + R);
+ Gen_Sib;
+ Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset));
+ end if;
+ return;
+ end if;
+ case Rm_Base is
+ when R_Sp =>
+ raise Program_Error;
+ when R_Nil =>
+ Gen_B8 (2#00_000_101# + R);
+ Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset));
+ when R_Ax
+ | R_Bx
+ | R_Cx
+ | R_Dx
+ | R_Bp
+ | R_Si
+ | R_Di =>
+ if Rm_Offset = 0 and Rm_Sym = Null_Symbol and Rm_Base /= R_Bp then
+ Gen_B8 (2#00_000_000# + R + To_Reg32 (Rm_Base));
+ elsif Rm_Sym = Null_Symbol
+ and Rm_Offset <= 127 and Rm_Offset >= -128
+ then
+ Gen_B8 (2#01_000_000# + R + To_Reg32 (Rm_Base));
+ Gen_B8 (Byte (To_Uns32 (Rm_Offset) and 16#Ff#));
+ else
+ Gen_B8 (2#10_000_000# + R + To_Reg32 (Rm_Base));
+ Gen_X86_32 (Rm_Sym, Integer_32 (Rm_Offset));
+ end if;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Gen_Rm_Mem;
+
+ procedure Gen_Rm (R : Byte; N : O_Enode; Sz : Insn_Size)
+ is
+ Reg : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (N);
+ if Reg in Regs_R32 or Reg in Regs_R64 then
+ Gen_B8 (2#11_000_000# + R + To_Reg32 (Reg, Sz));
+ return;
+ else
+ Gen_Rm_Mem (R, N, Sz);
+ end if;
+ end Gen_Rm;
+
+ procedure Emit_Op (Op : Byte; Stmt : O_Enode; Sz : Insn_Size)
+ is
+ L, R : O_Enode;
+ Lr, Rr : O_Reg;
+ begin
+ L := Get_Expr_Left (Stmt);
+ R := Get_Expr_Right (Stmt);
+ Lr := Get_Expr_Reg (L);
+ Rr := Get_Expr_Reg (R);
+ Start_Insn;
+ case Rr is
+ when R_Imm =>
+ if Is_Imm8 (R, Sz) then
+ Gen_Insn_Sz_S8 (16#80#, Sz);
+ Gen_Rm (Op, L, Sz);
+ Gen_Imm8 (R, Sz);
+ elsif Lr = R_Ax then
+ Gen_Insn_Sz (2#000_000_100# + Op, Sz);
+ Gen_Imm (R, Sz);
+ else
+ Gen_Insn_Sz (16#80#, Sz);
+ Gen_Rm (Op, L, Sz);
+ Gen_Imm (R, Sz);
+ end if;
+ when R_Mem
+ | R_Spill
+ | Regs_R32
+ | Regs_R64 =>
+ Gen_Insn_Sz (2#00_000_010# + Op, Sz);
+ Gen_Rm (To_Reg32 (Lr, Sz) * 8, R, Sz);
+ when others =>
+ Error_Emit ("emit_op", Stmt);
+ end case;
+ End_Insn;
+ end Emit_Op;
+
+ procedure Gen_Into is
+ begin
+ Start_Insn;
+ Gen_B8 (2#1100_1110#);
+ End_Insn;
+ end Gen_Into;
+
+ procedure Gen_Cdq is
+ begin
+ Start_Insn;
+ Gen_B8 (2#1001_1001#);
+ End_Insn;
+ end Gen_Cdq;
+
+ procedure Gen_Mono_Op (Op : Byte; Val : O_Enode; Sz : Insn_Size) is
+ begin
+ Start_Insn;
+ Gen_Insn_Sz (2#1111_011_0#, Sz);
+ Gen_Rm (Op, Val, Sz);
+ End_Insn;
+ end Gen_Mono_Op;
+
+ procedure Emit_Mono_Op_Stmt (Op : Byte; Stmt : O_Enode; Sz : Insn_Size)
+ is
+ begin
+ Gen_Mono_Op (Op, Get_Expr_Operand (Stmt), Sz);
+ end Emit_Mono_Op_Stmt;
+
+ procedure Emit_Load_Imm (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ Tr : O_Reg;
+ begin
+ Tr := Get_Expr_Reg (Stmt);
+ Start_Insn;
+ -- FIXME: handle 0.
+ case Sz is
+ when Sz_8 =>
+ Gen_B8 (2#1011_0_000# + To_Reg32 (Tr, Sz));
+ when Sz_16 =>
+ Gen_B8 (16#66#);
+ Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz));
+ when Sz_32l
+ | Sz_32h =>
+ Gen_B8 (2#1011_1_000# + To_Reg32 (Tr, Sz));
+ end case;
+ Gen_Imm (Stmt, Sz);
+ End_Insn;
+ end Emit_Load_Imm;
+
+ function Fp_Size_To_Mf (Sz : Fp_Size) return Byte is
+ begin
+ case Sz is
+ when Fp_32 =>
+ return 2#00_0#;
+ when Fp_64 =>
+ return 2#10_0#;
+ end case;
+ end Fp_Size_To_Mf;
+
+ procedure Emit_Load_Fp (Stmt : O_Enode; Sz : Fp_Size)
+ is
+ Sym : Symbol;
+ R : O_Reg;
+ begin
+ Set_Current_Section (Sect_Rodata);
+ Gen_Pow_Align (3);
+ Prealloc (8);
+ Sym := Create_Local_Symbol;
+ Set_Symbol_Pc (Sym, False);
+ Gen_Le32 (Unsigned_32 (Get_Expr_Low (Stmt)));
+ if Sz = Fp_64 then
+ Gen_Le32 (Unsigned_32 (Get_Expr_High (Stmt)));
+ end if;
+ Set_Current_Section (Sect_Text);
+
+ R := Get_Expr_Reg (Stmt);
+ case R is
+ when R_St0 =>
+ Start_Insn;
+ Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz));
+ Gen_B8 (2#00_000_101#);
+ Gen_X86_32 (Sym, 0);
+ End_Insn;
+ when Regs_Xmm =>
+ Start_Insn;
+ case Sz is
+ when Fp_32 =>
+ Gen_B8 (16#F3#);
+ when Fp_64 =>
+ Gen_B8 (16#F2#);
+ end case;
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#10#);
+ Gen_B8 (2#00_000_101# + To_Reg_Xmm (R) * 2#1_000#);
+ Gen_X86_32 (Sym, 0);
+ End_Insn;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Emit_Load_Fp;
+
+ procedure Emit_Load_Fp_Mem (Stmt : O_Enode; Sz : Fp_Size)
+ is
+ begin
+ Start_Insn;
+ Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz));
+ Gen_Rm_Mem (2#000_000#, Get_Expr_Operand (Stmt), Sz_32l);
+ End_Insn;
+ end Emit_Load_Fp_Mem;
+
+ procedure Emit_Load_Mem (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ Tr : O_Reg;
+ Val : O_Enode;
+ begin
+ Tr := Get_Expr_Reg (Stmt);
+ Val := Get_Expr_Operand (Stmt);
+ case Tr is
+ when Regs_R32
+ | Regs_R64 =>
+ -- mov REG, OP
+ Start_Insn;
+ Gen_Insn_Sz (2#1000_101_0#, Sz);
+ Gen_Rm_Mem (To_Reg32 (Tr, Sz) * 8, Val, Sz);
+ End_Insn;
+ when R_Eq =>
+ -- Cmp OP, 1
+ Start_Insn;
+ Gen_Insn_Sz_S8 (2#1000_000_0#, Sz);
+ Gen_Rm_Mem (2#111_000#, Val, Sz);
+ Gen_B8 (1);
+ End_Insn;
+ when others =>
+ Error_Emit ("emit_load_mem", Stmt);
+ end case;
+ end Emit_Load_Mem;
+
+
+ procedure Emit_Store (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ T, R : O_Enode;
+ Tr, Rr : O_Reg;
+ B : Byte;
+ begin
+ T := Get_Assign_Target (Stmt);
+ R := Get_Expr_Operand (Stmt);
+ Tr := Get_Expr_Reg (T);
+ Rr := Get_Expr_Reg (R);
+ Start_Insn;
+ case Rr is
+ when R_Imm =>
+ if False and (Tr in Regs_R32 or Tr in Regs_R64) then
+ B := 2#1011_1_000#;
+ case Sz is
+ when Sz_8 =>
+ B := B and not 2#0000_1_000#;
+ when Sz_16 =>
+ Gen_B8 (16#66#);
+ when Sz_32l
+ | Sz_32h =>
+ null;
+ end case;
+ Gen_B8 (B + To_Reg32 (Tr, Sz));
+ else
+ Gen_Insn_Sz (2#1100_011_0#, Sz);
+ Gen_Rm_Mem (16#00#, T, Sz);
+ end if;
+ Gen_Imm (R, Sz);
+ when Regs_R32
+ | Regs_R64 =>
+ Gen_Insn_Sz (2#1000_100_0#, Sz);
+ Gen_Rm_Mem (To_Reg32 (Rr, Sz) * 8, T, Sz);
+ when others =>
+ Error_Emit ("emit_store", Stmt);
+ end case;
+ End_Insn;
+ end Emit_Store;
+
+ procedure Emit_Store_Fp (Stmt : O_Enode; Sz : Fp_Size)
+ is
+ begin
+ -- fstp
+ Start_Insn;
+ Gen_B8 (2#11011_00_1# + Fp_Size_To_Mf (Sz));
+ Gen_Rm_Mem (2#011_000#, Get_Assign_Target (Stmt), Sz_32l);
+ End_Insn;
+ end Emit_Store_Fp;
+
+ procedure Emit_Push_32 (Val : O_Enode; Sz : Insn_Size)
+ is
+ R : O_Reg;
+ begin
+ R := Get_Expr_Reg (Val);
+ Start_Insn;
+ case R is
+ when R_Imm =>
+ if Is_Imm8 (Val, Sz) then
+ Gen_B8 (2#0110_1010#);
+ Gen_Imm8 (Val, Sz);
+ else
+ Gen_B8 (2#0110_1000#);
+ Gen_Imm (Val, Sz);
+ end if;
+ when Regs_R32
+ | Regs_R64 =>
+ Gen_B8 (2#01010_000# + To_Reg32 (R, Sz));
+ when others =>
+ Gen_B8 (2#1111_1111#);
+ Gen_Rm (2#110_000#, Val, Sz);
+ end case;
+ End_Insn;
+ end Emit_Push_32;
+
+ procedure Emit_Pop_32 (Val : O_Enode; Sz : Insn_Size)
+ is
+ R : O_Reg;
+ begin
+ R := Get_Expr_Reg (Val);
+ Start_Insn;
+ case R is
+ when Regs_R32
+ | Regs_R64 =>
+ Gen_B8 (2#01011_000# + To_Reg32 (R, Sz));
+ when others =>
+ Gen_B8 (2#1000_1111#);
+ Gen_Rm (2#000_000#, Val, Sz);
+ end case;
+ End_Insn;
+ end Emit_Pop_32;
+
+ procedure Emit_Push_Fp (Op : O_Enode; Sz : Fp_Size)
+ is
+ pragma Unreferenced (Op);
+ begin
+ Start_Insn;
+ -- subl esp, val
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ case Sz is
+ when Fp_32 =>
+ Gen_B8 (4);
+ when Fp_64 =>
+ Gen_B8 (8);
+ end case;
+ End_Insn;
+ -- fstp st, (esp)
+ Start_Insn;
+ Gen_B8 (2#11011_001# + Fp_Size_To_Mf (Sz));
+ Gen_B8 (2#00_011_100#);
+ Gen_B8 (2#00_100_100#);
+ End_Insn;
+ end Emit_Push_Fp;
+
+ function Prepare_Label (Label : O_Enode) return Symbol
+ is
+ Sym : Symbol;
+ begin
+ Sym := Get_Label_Symbol (Label);
+ if Sym = Null_Symbol then
+ Sym := Create_Local_Symbol;
+ Set_Label_Symbol (Label, Sym);
+ end if;
+ return Sym;
+ end Prepare_Label;
+
+ procedure Emit_Jmp_T (Stmt : O_Enode; Reg : O_Reg)
+ is
+ Sym : Symbol;
+ Val : Pc_Type;
+ Opc : Byte;
+ begin
+ Sym := Prepare_Label (Get_Jump_Label (Stmt));
+ Val := Get_Symbol_Value (Sym);
+ Start_Insn;
+ Opc := To_Cond (Reg);
+ if Val = 0 then
+ -- Assume long jmp.
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#80# + Opc);
+ Gen_X86_Pc32 (Sym);
+ else
+ if Val + 128 < Get_Current_Pc + 4 then
+ -- Long jmp.
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#80# + Opc);
+ Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4)));
+ else
+ -- short jmp.
+ Gen_B8 (16#70# + Opc);
+ Gen_B8 (Byte (Val - (Get_Current_Pc + 1)));
+ end if;
+ end if;
+ End_Insn;
+ end Emit_Jmp_T;
+
+ procedure Emit_Jmp (Stmt : O_Enode)
+ is
+ Sym : Symbol;
+ Val : Pc_Type;
+ begin
+ Sym := Prepare_Label (Get_Jump_Label (Stmt));
+ Val := Get_Symbol_Value (Sym);
+ Start_Insn;
+ if Val = 0 then
+ -- Assume long jmp.
+ Gen_B8 (16#e9#);
+ Gen_X86_Pc32 (Sym);
+ else
+ if Val + 128 < Get_Current_Pc + 4 then
+ -- Long jmp.
+ Gen_B8 (16#e9#);
+ Gen_Le32 (Unsigned_32 (Val - (Get_Current_Pc + 4)));
+ else
+ -- short jmp.
+ Gen_B8 (16#eb#);
+ Gen_B8 (Byte ((Val - (Get_Current_Pc + 1)) and 16#Ff#));
+ end if;
+ end if;
+ End_Insn;
+ end Emit_Jmp;
+
+ procedure Emit_Label (Stmt : O_Enode)
+ is
+ Sym : Symbol;
+ begin
+ Sym := Prepare_Label (Stmt);
+ Set_Symbol_Pc (Sym, False);
+ end Emit_Label;
+
+ procedure Gen_Call (Sym : Symbol) is
+ begin
+ Start_Insn;
+ Gen_B8 (16#E8#);
+ Gen_X86_Pc32 (Sym);
+ End_Insn;
+ end Gen_Call;
+
+ procedure Emit_Setup_Frame (Stmt : O_Enode)
+ is
+ Val : constant Int32 := Get_Stack_Adjust (Stmt);
+ begin
+ if Val > 0 then
+ Start_Insn;
+ -- subl esp, val
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (Byte (Val));
+ End_Insn;
+ elsif Val < 0 then
+ Start_Insn;
+ if -Val <= 127 then
+ -- addl esp, val
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_000_100#);
+ Gen_B8 (Byte (-Val));
+ else
+ -- addl esp, val
+ Gen_B8 (2#100000_01#);
+ Gen_B8 (2#11_000_100#);
+ Gen_Le32 (Unsigned_32 (-Val));
+ end if;
+ End_Insn;
+ end if;
+ end Emit_Setup_Frame;
+
+ procedure Emit_Call (Stmt : O_Enode)
+ is
+ use Ortho_Code.Decls;
+ Subprg : O_Dnode;
+ Sym : Symbol;
+ begin
+ Subprg := Get_Call_Subprg (Stmt);
+ Sym := Get_Decl_Symbol (Subprg);
+ Gen_Call (Sym);
+ end Emit_Call;
+
+ procedure Emit_Intrinsic (Stmt : O_Enode)
+ is
+ Op : Int32;
+ begin
+ Op := Get_Intrinsic_Operation (Stmt);
+ Start_Insn;
+ Gen_B8 (16#E8#);
+ Gen_X86_Pc32 (Intrinsics_Symbol (Op));
+ End_Insn;
+
+ Start_Insn;
+ -- addl esp, val
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_000_100#);
+ Gen_B8 (16);
+ End_Insn;
+ end Emit_Intrinsic;
+
+ procedure Emit_Setcc (Dest : O_Enode; Cond : O_Reg)
+ is
+ begin
+ if Cond not in Regs_Cc then
+ raise Program_Error;
+ end if;
+ Start_Insn;
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#90# + To_Cond (Cond));
+ Gen_Rm (2#000_000#, Dest, Sz_8);
+ End_Insn;
+ end Emit_Setcc;
+
+ procedure Emit_Setcc_Reg (Reg : O_Reg; Cond : O_Reg)
+ is
+ begin
+ if Cond not in Regs_Cc then
+ raise Program_Error;
+ end if;
+ Start_Insn;
+ Gen_B8 (16#0f#);
+ Gen_B8 (16#90# + To_Cond (Cond));
+ Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz_8));
+ End_Insn;
+ end Emit_Setcc_Reg;
+
+ procedure Emit_Tst (Reg : O_Reg; Sz : Insn_Size)
+ is
+ begin
+ Start_Insn;
+ Gen_Insn_Sz (2#1000_0100#, Sz);
+ Gen_B8 (2#11_000_000# + To_Reg32 (Reg, Sz) * 9);
+ End_Insn;
+ end Emit_Tst;
+
+ procedure Gen_Cmp_Imm (Reg : O_Reg; Val : Int32; Sz : Insn_Size)
+ is
+ B : Byte;
+ begin
+ Start_Insn;
+ if Val <= 127 and Val >= -128 then
+ B := 2#10#;
+ else
+ B := 0;
+ end if;
+ Gen_Insn_Sz (2#1000_0000# + B, Sz);
+ Gen_B8 (2#11_111_000# + To_Reg32 (Reg));
+ if B = 0 then
+ Gen_Le32 (Unsigned_32 (To_Uns32 (Val)));
+ else
+ Gen_B8 (Byte (To_Uns32 (Val) and 16#Ff#));
+ end if;
+ End_Insn;
+ end Gen_Cmp_Imm;
+
+ procedure Emit_Spill (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ Reg : O_Reg;
+ Expr : O_Enode;
+ begin
+ Expr := Get_Expr_Operand (Stmt);
+ Reg := Get_Expr_Reg (Expr);
+ if Reg = R_Spill then
+ if Get_Expr_Kind (Expr) = OE_Conv then
+ return;
+ else
+ raise Program_Error;
+ end if;
+ end if;
+ Start_Insn;
+ Gen_Insn_Sz (2#1000_1000#, Sz);
+ Gen_Rm (To_Reg32 (Reg, Sz) * 8, Stmt, Sz);
+ End_Insn;
+ end Emit_Spill;
+
+ procedure Emit_Load (Reg : O_Reg; Val : O_Enode; Sz : Insn_Size)
+ is
+ begin
+ Start_Insn;
+ Gen_Insn_Sz (2#1000_1010#, Sz);
+ Gen_Rm (To_Reg32 (Reg, Sz) * 8, Val, Sz);
+ End_Insn;
+ end Emit_Load;
+
+ procedure Emit_Lea (Stmt : O_Enode)
+ is
+ Reg : O_Reg;
+ begin
+ -- Hack: change the register to use the real address instead of it.
+ Reg := Get_Expr_Reg (Stmt);
+ Set_Expr_Reg (Stmt, R_Mem);
+
+ Start_Insn;
+ Gen_B8 (2#10001101#);
+ Gen_Rm_Mem (To_Reg32 (Reg) * 8, Stmt, Sz_32l);
+ End_Insn;
+ Set_Expr_Reg (Stmt, Reg);
+ end Emit_Lea;
+
+ procedure Gen_Umul (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ begin
+ if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= R_Ax then
+ raise Program_Error;
+ end if;
+ Start_Insn;
+ Gen_Insn_Sz (16#F6#, Sz);
+ Gen_Rm (2#100_000#, Get_Expr_Right (Stmt), Sz);
+ End_Insn;
+ end Gen_Umul;
+
+ procedure Gen_Mul (Stmt : O_Enode; Sz : Insn_Size)
+ is
+ Reg : O_Reg;
+ Right : O_Enode;
+ Reg_R : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (Stmt);
+ Right := Get_Expr_Right (Stmt);
+ if Get_Expr_Reg (Get_Expr_Left (Stmt)) /= Reg
+ or Sz /= Sz_32l
+ then
+ raise Program_Error;
+ end if;
+ Start_Insn;
+ if Reg = R_Ax then
+ Gen_Insn_Sz (16#F6#, Sz);
+ Gen_Rm (2#100_000#, Right, Sz);
+ else
+ Reg_R := Get_Expr_Reg (Right);
+ case Reg_R is
+ when R_Imm =>
+ if Is_Imm8 (Right, Sz) then
+ Gen_B8 (16#6B#);
+ Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#);
+ Gen_Imm8 (Right, Sz);
+ else
+ Gen_B8 (16#69#);
+ Gen_B8 (To_Reg32 (Reg, Sz) * 9 or 2#11_000_000#);
+ Gen_Imm (Right, Sz);
+ end if;
+ when R_Mem
+ | R_Spill
+ | Regs_R32 =>
+ Gen_B8 (16#0F#);
+ Gen_B8 (16#AF#);
+ Gen_Rm (To_Reg32 (Reg, Sz) * 8, Right, Sz);
+ when others =>
+ Error_Emit ("gen_mul", Stmt);
+ end case;
+ end if;
+ End_Insn;
+ end Gen_Mul;
+
+ -- Do not trap if COND is true.
+ procedure Gen_Ov_Check (Cond : O_Reg) is
+ begin
+ -- JXX +2
+ Start_Insn;
+ Gen_B8 (16#70# + To_Cond (Cond));
+ Gen_B8 (16#02#);
+ End_Insn;
+ -- INT 4 (overflow).
+ Start_Insn;
+ Gen_B8 (16#CD#);
+ Gen_B8 (16#04#);
+ End_Insn;
+ end Gen_Ov_Check;
+
+ procedure Emit_Abs (Val : O_Enode; Mode : Mode_Type)
+ is
+ Szh : Insn_Size;
+ Pc_Jmp : Pc_Type;
+ begin
+ case Mode is
+ when Mode_I32 =>
+ Szh := Sz_32l;
+ when Mode_I64 =>
+ Szh := Sz_32h;
+ when others =>
+ raise Program_Error;
+ end case;
+ Emit_Tst (Get_Expr_Reg (Val), Szh);
+ -- JXX +
+ Start_Insn;
+ Gen_B8 (16#70# + To_Cond (R_Sge));
+ Gen_B8 (0);
+ End_Insn;
+ Pc_Jmp := Get_Current_Pc;
+ -- NEG
+ Gen_Mono_Op (2#011_000#, Val, Sz_32l);
+ if Mode = Mode_I64 then
+ -- Propagate carray.
+ -- Adc reg,0
+ -- neg reg
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_Rm (2#010_000#, Val, Sz_32h);
+ Gen_B8 (0);
+ End_Insn;
+ Gen_Mono_Op (2#011_000#, Val, Sz_32h);
+ end if;
+ Gen_Into;
+ Patch_B8 (Pc_Jmp - 1, Unsigned_8 (Get_Current_Pc - Pc_Jmp));
+ end Emit_Abs;
+
+ procedure Gen_Alloca (Stmt : O_Enode)
+ is
+ Reg : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt));
+ if Reg not in Regs_R32 or else Reg /= Get_Expr_Reg (Stmt) then
+ raise Program_Error;
+ end if;
+ -- Align stack on word.
+ -- Add reg, (stack_boundary - 1)
+ Start_Insn;
+ Gen_B8 (2#1000_0011#);
+ Gen_B8 (2#11_000_000# + To_Reg32 (Reg));
+ Gen_B8 (Byte (X86.Flags.Stack_Boundary - 1));
+ End_Insn;
+ -- and reg, ~(stack_boundary - 1)
+ Start_Insn;
+ Gen_B8 (2#1000_0001#);
+ Gen_B8 (2#11_100_000# + To_Reg32 (Reg));
+ Gen_Le32 (not (X86.Flags.Stack_Boundary - 1));
+ End_Insn;
+ if X86.Flags.Flag_Alloca_Call then
+ Gen_Call (Chkstk_Symbol);
+ else
+ -- subl esp, reg
+ Start_Insn;
+ Gen_B8 (2#0001_1011#);
+ Gen_B8 (2#11_100_000# + To_Reg32 (Reg));
+ End_Insn;
+ end if;
+ -- movl reg, esp
+ Start_Insn;
+ Gen_B8 (2#1000_1001#);
+ Gen_B8 (2#11_100_000# + To_Reg32 (Reg));
+ End_Insn;
+ end Gen_Alloca;
+
+ -- Byte/word to long.
+ procedure Gen_Movzx (Reg : Regs_R32; Op : O_Enode; Sz : Insn_Size)
+ is
+ B : Byte;
+ begin
+ Start_Insn;
+ Gen_B8 (16#0f#);
+ case Sz is
+ when Sz_8 =>
+ B := 0;
+ when Sz_16 =>
+ B := 1;
+ when Sz_32l
+ | Sz_32h =>
+ raise Program_Error;
+ end case;
+ Gen_B8 (2#1011_0110# + B);
+ Gen_Rm (To_Reg32 (Reg) * 8, Op, Sz_8);
+ End_Insn;
+ end Gen_Movzx;
+
+ -- Convert U32 to xx.
+ procedure Gen_Conv_U32 (Stmt : O_Enode)
+ is
+ Op : O_Enode;
+ Reg_Op : O_Reg;
+ Reg_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ Reg_Op := Get_Expr_Reg (Op);
+ Reg_Res := Get_Expr_Reg (Stmt);
+ case Get_Expr_Mode (Stmt) is
+ when Mode_I32 =>
+ if Reg_Res not in Regs_R32 then
+ raise Program_Error;
+ end if;
+ if Reg_Op /= Reg_Res then
+ Emit_Load (Reg_Res, Op, Sz_32l);
+ end if;
+ Emit_Tst (Reg_Res, Sz_32l);
+ Gen_Ov_Check (R_Sge);
+ when Mode_U8
+ | Mode_B2 =>
+ if Reg_Res not in Regs_R32 then
+ raise Program_Error;
+ end if;
+ if Reg_Op /= Reg_Res then
+ Emit_Load (Reg_Res, Op, Sz_32l);
+ end if;
+ -- cmpl VAL, 0xff
+ Start_Insn;
+ Gen_B8 (2#1000_0001#);
+ Gen_Rm (2#111_000#, Op, Sz_32l);
+ Gen_Le32 (16#00_00_00_Ff#);
+ End_Insn;
+ Gen_Ov_Check (R_Ule);
+ when others =>
+ Error_Emit ("gen_conv_u32", Stmt);
+ end case;
+ end Gen_Conv_U32;
+
+ -- Convert I32 to xxx
+ procedure Gen_Conv_I32 (Stmt : O_Enode)
+ is
+ Op : O_Enode;
+ Reg_Op : O_Reg;
+ Reg_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ Reg_Op := Get_Expr_Reg (Op);
+ Reg_Res := Get_Expr_Reg (Stmt);
+ case Get_Expr_Mode (Stmt) is
+ when Mode_I64 =>
+ if Reg_Res /= R_Edx_Eax or Reg_Op /= R_Ax then
+ raise Program_Error;
+ end if;
+ Gen_Cdq;
+ when Mode_U32 =>
+ if Reg_Res not in Regs_R32 then
+ raise Program_Error;
+ end if;
+ if Reg_Op /= Reg_Res then
+ Emit_Load (Reg_Res, Op, Sz_32l);
+ end if;
+ Emit_Tst (Reg_Res, Sz_32l);
+ Gen_Ov_Check (R_Sge);
+ when Mode_B2 =>
+ if Reg_Op /= Reg_Res then
+ Emit_Load (Reg_Res, Op, Sz_32l);
+ end if;
+ Gen_Cmp_Imm (Reg_Res, 1, Sz_32l);
+ Gen_Ov_Check (R_Ule);
+ when Mode_U8 =>
+ if Reg_Op /= Reg_Res then
+ Emit_Load (Reg_Res, Op, Sz_32l);
+ end if;
+ Gen_Cmp_Imm (Reg_Res, 16#Ff#, Sz_32l);
+ Gen_Ov_Check (R_Ule);
+ when Mode_F64 =>
+ Emit_Push_32 (Op, Sz_32l);
+ -- fild (%esp)
+ Start_Insn;
+ Gen_B8 (2#11011_011#);
+ Gen_B8 (2#00_000_100#);
+ Gen_B8 (2#00_100_100#);
+ End_Insn;
+ -- addl %esp, 4
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_000_100#);
+ Gen_B8 (4);
+ End_Insn;
+ when others =>
+ Error_Emit ("gen_conv_i32", Stmt);
+ end case;
+ end Gen_Conv_I32;
+
+ -- Convert U8 to xxx
+ procedure Gen_Conv_U8 (Stmt : O_Enode)
+ is
+ Op : O_Enode;
+ Reg_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ Reg_Res := Get_Expr_Reg (Stmt);
+ case Get_Expr_Mode (Stmt) is
+ when Mode_U32
+ | Mode_I32
+ | Mode_U16
+ | Mode_I16 =>
+ if Reg_Res not in Regs_R32 then
+ raise Program_Error;
+ end if;
+ Gen_Movzx (Reg_Res, Op, Sz_8);
+ when others =>
+ Error_Emit ("gen_conv_U8", Stmt);
+ end case;
+ end Gen_Conv_U8;
+
+ -- Convert B2 to xxx
+ procedure Gen_Conv_B2 (Stmt : O_Enode)
+ is
+ Op : O_Enode;
+ Reg_Res : O_Reg;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ Reg_Res := Get_Expr_Reg (Stmt);
+ case Get_Expr_Mode (Stmt) is
+ when Mode_U32
+ | Mode_I32
+ | Mode_U16
+ | Mode_I16 =>
+ Gen_Movzx (Reg_Res, Op, Sz_8);
+ when others =>
+ Error_Emit ("gen_conv_B2", Stmt);
+ end case;
+ end Gen_Conv_B2;
+
+ -- Convert I64 to xxx
+ procedure Gen_Conv_I64 (Stmt : O_Enode)
+ is
+ Op : O_Enode;
+ begin
+ Op := Get_Expr_Operand (Stmt);
+ case Get_Expr_Mode (Stmt) is
+ when Mode_I32 =>
+ -- move dx to reg_helper
+ Start_Insn;
+ Gen_B8 (2#1000_1001#);
+ Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper));
+ End_Insn;
+ Gen_Cdq;
+ -- cmp reg_helper, dx
+ Start_Insn;
+ Gen_B8 (2#0011_1001#);
+ Gen_B8 (2#11_010_000# + To_Reg32 (Reg_Helper));
+ End_Insn;
+ Gen_Ov_Check (R_Eq);
+ when Mode_F64 =>
+ Emit_Push_32 (Op, Sz_32h);
+ Emit_Push_32 (Op, Sz_32l);
+ -- fild (%esp)
+ Start_Insn;
+ Gen_B8 (2#11011_111#);
+ Gen_B8 (2#00_101_100#);
+ Gen_B8 (2#00_100_100#);
+ End_Insn;
+ -- addl %esp, 8
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_000_100#);
+ Gen_B8 (8);
+ End_Insn;
+ when others =>
+ Error_Emit ("gen_conv_I64", Stmt);
+ end case;
+ end Gen_Conv_I64;
+
+ -- Convert FP to xxx.
+ procedure Gen_Conv_Fp (Stmt : O_Enode) is
+ begin
+ case Get_Expr_Mode (Stmt) is
+ when Mode_I32 =>
+ -- subl %esp, 4
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (4);
+ End_Insn;
+ -- fistp (%esp)
+ Start_Insn;
+ Gen_B8 (2#11011_011#);
+ Gen_B8 (2#00_011_100#);
+ Gen_B8 (2#00_100_100#);
+ End_Insn;
+ Emit_Pop_32 (Stmt, Sz_32l);
+ when Mode_I64 =>
+ -- subl %esp, 8
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (8);
+ End_Insn;
+ -- fistp (%esp)
+ Start_Insn;
+ Gen_B8 (2#11011_111#);
+ Gen_B8 (2#00_111_100#);
+ Gen_B8 (2#00_100_100#);
+ End_Insn;
+ Emit_Pop_32 (Stmt, Sz_32l);
+ Emit_Pop_32 (Stmt, Sz_32h);
+ when others =>
+ Error_Emit ("gen_conv_fp", Stmt);
+ end case;
+ end Gen_Conv_Fp;
+
+ procedure Gen_Emit_Op (Stmt : O_Enode; Cl : Byte; Ch : Byte) is
+ begin
+ case Get_Expr_Mode (Stmt) is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Op (Cl, Stmt, Sz_32l);
+ when Mode_I64
+ | Mode_U64 =>
+ Emit_Op (Cl, Stmt, Sz_32l);
+ Emit_Op (Ch, Stmt, Sz_32h);
+ when Mode_B2
+ | Mode_I8
+ | Mode_U8 =>
+ Emit_Op (Cl, Stmt, Sz_8);
+ when others =>
+ Error_Emit ("gen_emit_op", Stmt);
+ end case;
+ end Gen_Emit_Op;
+
+ procedure Gen_Check_Overflow (Mode : Mode_Type) is
+ begin
+ case Mode is
+ when Mode_I32
+ | Mode_I64
+ | Mode_I8 =>
+ Gen_Into;
+ when Mode_U64
+ | Mode_U32
+ | Mode_U8 =>
+ -- FIXME: check no carry.
+ null;
+ when Mode_B2 =>
+ null;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Gen_Check_Overflow;
+
+ procedure Gen_Emit_Fp_Op (Stmt : O_Enode; B_St1 : Byte; B_Mem : Byte)
+ is
+ Right : O_Enode;
+ Reg : O_Reg;
+ B_Size : Byte;
+ begin
+ Right := Get_Expr_Right (Stmt);
+ Reg := Get_Expr_Reg (Right);
+ Start_Insn;
+ case Reg is
+ when R_St0 =>
+ Gen_B8 (2#11011_110#);
+ Gen_B8 (2#11_000_001# or B_St1);
+ when R_Mem =>
+ case Get_Expr_Mode (Stmt) is
+ when Mode_F32 =>
+ B_Size := 0;
+ when Mode_F64 =>
+ B_Size := 2#100#;
+ when others =>
+ raise Program_Error;
+ end case;
+ Gen_B8 (2#11011_000# or B_Size);
+ Gen_Rm_Mem (B_Mem, Right, Sz_32l);
+ when others =>
+ raise Program_Error;
+ end case;
+ End_Insn;
+ end Gen_Emit_Fp_Op;
+
+ procedure Emit_Mod (Stmt : O_Enode)
+ is
+ Right : O_Enode;
+ Pc1, Pc2, Pc3: Pc_Type;
+ begin
+ -- a : EAX
+ -- d : EDX
+ -- b : Rm
+
+ -- d := Rm
+ -- d := d ^ a
+ -- cltd
+ -- if cc < 0 then
+ -- idiv b
+ -- if edx /= 0 then
+ -- edx := edx + b
+ -- end if
+ -- else
+ -- idiv b
+ -- end if
+ Right := Get_Expr_Right (Stmt);
+ -- %edx <- right
+ Emit_Load (R_Dx, Right, Sz_32l);
+ -- xorl %eax -> %edx
+ Start_Insn;
+ Gen_B8 (2#0011_0011#);
+ Gen_B8 (2#11_010_000#);
+ End_Insn;
+ Gen_Cdq;
+ -- js
+ Start_Insn;
+ Gen_B8 (2#0111_1000#);
+ Gen_B8 (0);
+ End_Insn;
+ Pc1 := Get_Current_Pc;
+ -- idiv
+ Gen_Mono_Op (2#111_000#, Right, Sz_32l);
+ -- jmp
+ Start_Insn;
+ Gen_B8 (2#1110_1011#);
+ Gen_B8 (0);
+ End_Insn;
+ Pc2 := Get_Current_Pc;
+ Patch_B8 (Pc1 - 1, Unsigned_8 (Get_Current_Pc - Pc1));
+ -- idiv
+ Gen_Mono_Op (2#111_000#, Right, Sz_32l);
+ -- tstl %edx,%edx
+ Start_Insn;
+ Gen_B8 (2#1000_0101#);
+ Gen_B8 (2#11_010_010#);
+ End_Insn;
+ -- jz
+ Start_Insn;
+ Gen_B8 (2#0111_0100#);
+ Gen_B8 (0);
+ End_Insn;
+ Pc3 := Get_Current_Pc;
+ -- addl b, %edx
+ Start_Insn;
+ Gen_B8 (2#00_000_011#);
+ Gen_Rm (2#010_000#, Right, Sz_32l);
+ End_Insn;
+ Patch_B8 (Pc2 - 1, Unsigned_8 (Get_Current_Pc - Pc2));
+ Patch_B8 (Pc3 - 1, Unsigned_8 (Get_Current_Pc - Pc3));
+ end Emit_Mod;
+
+ procedure Emit_Insn (Stmt : O_Enode)
+ is
+ use Ortho_Code.Flags;
+ Kind : OE_Kind;
+ Mode : Mode_Type;
+ Reg : O_Reg;
+ begin
+ Kind := Get_Expr_Kind (Stmt);
+ Mode := Get_Expr_Mode (Stmt);
+ case Kind is
+ when OE_Beg =>
+ if Flag_Debug /= Debug_None then
+ Decls.Set_Block_Info1 (Get_Block_Decls (Stmt),
+ Int32 (Get_Current_Pc - Subprg_Pc));
+ end if;
+ when OE_End =>
+ if Flag_Debug /= Debug_None then
+ Decls.Set_Block_Info2 (Get_Block_Decls (Get_End_Beg (Stmt)),
+ Int32 (Get_Current_Pc - Subprg_Pc));
+ end if;
+ when OE_Leave =>
+ null;
+ when OE_BB =>
+ null;
+ when OE_Add_Ov =>
+ if Mode in Mode_Fp then
+ Gen_Emit_Fp_Op (Stmt, 2#000_000#, 2#000_000#);
+ else
+ Gen_Emit_Op (Stmt, 2#000_000#, 2#010_000#);
+ Gen_Check_Overflow (Mode);
+ end if;
+ when OE_Or =>
+ Gen_Emit_Op (Stmt, 2#001_000#, 2#001_000#);
+ when OE_And =>
+ Gen_Emit_Op (Stmt, 2#100_000#, 2#100_000#);
+ when OE_Xor =>
+ Gen_Emit_Op (Stmt, 2#110_000#, 2#110_000#);
+ when OE_Sub_Ov =>
+ if Mode in Mode_Fp then
+ Gen_Emit_Fp_Op (Stmt, 2#100_000#, 2#100_000#);
+ else
+ Gen_Emit_Op (Stmt, 2#101_000#, 2#011_000#);
+ Gen_Check_Overflow (Mode);
+ end if;
+ when OE_Mul_Ov
+ | OE_Mul =>
+ case Mode is
+ when Mode_U8 =>
+ Gen_Umul (Stmt, Sz_8);
+ when Mode_U16 =>
+ Gen_Umul (Stmt, Sz_16);
+ when Mode_U32 =>
+ Gen_Mul (Stmt, Sz_32l);
+ when Mode_I32 =>
+ Gen_Mono_Op (2#101_000#, Get_Expr_Right (Stmt), Sz_32l);
+ when Mode_F32
+ | Mode_F64 =>
+ Gen_Emit_Fp_Op (Stmt, 2#001_000#, 2#001_000#);
+ when others =>
+ Error_Emit ("emit_insn: mul_ov", Stmt);
+ end case;
+ when OE_Shl =>
+ declare
+ Right : O_Enode;
+ Sz : Insn_Size;
+ Val : Uns32;
+ begin
+ case Mode is
+ when Mode_U32 =>
+ Sz := Sz_32l;
+ when others =>
+ Error_Emit ("emit_insn: shl", Stmt);
+ end case;
+ Right := Get_Expr_Right (Stmt);
+ if Get_Expr_Kind (Right) = OE_Const then
+ Val := Get_Expr_Low (Right);
+ Start_Insn;
+ if Val = 1 then
+ Gen_Insn_Sz (2#1101000_0#, Sz);
+ Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz);
+ else
+ Gen_Insn_Sz (2#1100000_0#, Sz);
+ Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz);
+ Gen_B8 (Byte (Val and 31));
+ end if;
+ End_Insn;
+ else
+ if Get_Expr_Reg (Right) /= R_Cx then
+ raise Program_Error;
+ end if;
+ Start_Insn;
+ Gen_Insn_Sz (2#1101001_0#, Sz);
+ Gen_Rm (2#100_000#, Get_Expr_Left (Stmt), Sz);
+ End_Insn;
+ end if;
+ end;
+ when OE_Mod
+ | OE_Rem
+ | OE_Div_Ov =>
+ case Mode is
+ when Mode_U32 =>
+ -- Xorl edx, edx
+ Start_Insn;
+ Gen_B8 (2#0011_0001#);
+ Gen_B8 (2#11_010_010#);
+ End_Insn;
+ Gen_Mono_Op (2#110_000#, Get_Expr_Right (Stmt), Sz_32l);
+ when Mode_I32 =>
+ if Kind = OE_Mod then
+ Emit_Mod (Stmt);
+ else
+ Gen_Cdq;
+ Gen_Mono_Op (2#111_000#, Get_Expr_Right (Stmt), Sz_32l);
+ end if;
+ when Mode_F32
+ | Mode_F64 =>
+ if Kind = OE_Div_Ov then
+ Gen_Emit_Fp_Op (Stmt, 2#111_000#, 2#110_000#);
+ else
+ raise Program_Error;
+ end if;
+ when others =>
+ Error_Emit ("emit_insn: mod_ov", Stmt);
+ end case;
+
+ when OE_Not =>
+ case Mode is
+ when Mode_B2 =>
+ -- Xor VAL, $1
+ Start_Insn;
+ Gen_B8 (2#1000_0011#);
+ Gen_Rm (2#110_000#, Stmt, Sz_8);
+ Gen_B8 (16#01#);
+ End_Insn;
+ when Mode_U8 =>
+ Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_8);
+ when Mode_U16 =>
+ Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_16);
+ when Mode_U32 =>
+ Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l);
+ when Mode_U64 =>
+ Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32l);
+ Emit_Mono_Op_Stmt (2#010_000#, Stmt, Sz_32h);
+ when others =>
+ Error_Emit ("emit_insn: not", Stmt);
+ end case;
+
+ when OE_Neg_Ov =>
+ case Mode is
+ when Mode_I8 =>
+ Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_8);
+ --Gen_Into;
+ when Mode_I16 =>
+ Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_16);
+ --Gen_Into;
+ when Mode_I32 =>
+ Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l);
+ --Gen_Into;
+ when Mode_I64 =>
+ Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32l);
+ -- adcl 0, high
+ Start_Insn;
+ Gen_B8 (2#100000_11#);
+ Gen_Rm (2#010_000#, Get_Expr_Operand (Stmt), Sz_32h);
+ Gen_B8 (0);
+ End_Insn;
+ Emit_Mono_Op_Stmt (2#011_000#, Stmt, Sz_32h);
+ --Gen_Into;
+ when Mode_F32
+ | Mode_F64 =>
+ -- fchs
+ Start_Insn;
+ Gen_B8 (2#11011_001#);
+ Gen_B8 (2#1110_0000#);
+ End_Insn;
+ when others =>
+ Error_Emit ("emit_insn: neg_ov", Stmt);
+ end case;
+
+ when OE_Abs_Ov =>
+ case Mode is
+ when Mode_I32
+ | Mode_I64 =>
+ Emit_Abs (Get_Expr_Operand (Stmt), Mode);
+ when Mode_F32
+ | Mode_F64 =>
+ -- fabs
+ Start_Insn;
+ Gen_B8 (2#11011_001#);
+ Gen_B8 (2#1110_0001#);
+ End_Insn;
+ when others =>
+ Error_Emit ("emit_insn: abs_ov", Stmt);
+ end case;
+
+ when OE_Kind_Cmp =>
+ case Get_Expr_Mode (Get_Expr_Left (Stmt)) is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Op (2#111_000#, Stmt, Sz_32l);
+ when Mode_B2
+ | Mode_I8
+ | Mode_U8 =>
+ Emit_Op (2#111_000#, Stmt, Sz_8);
+ when Mode_U64 =>
+ declare
+ Pc : Pc_Type;
+ begin
+ Emit_Op (2#111_000#, Stmt, Sz_32h);
+ -- jne
+ Start_Insn;
+ Gen_B8 (2#0111_0101#);
+ Gen_B8 (0);
+ End_Insn;
+ Pc := Get_Current_Pc;
+ Emit_Op (2#111_000#, Stmt, Sz_32l);
+ Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc));
+ end;
+ when Mode_I64 =>
+ declare
+ Pc : Pc_Type;
+ begin
+ Reg := Get_Expr_Reg (Stmt);
+ Emit_Op (2#111_000#, Stmt, Sz_32h);
+ -- Note: this does not clobber a reg due to care in
+ -- insns.
+ Emit_Setcc_Reg (Reg, Ekind_Signed_To_Cc (Kind));
+ -- jne
+ Start_Insn;
+ Gen_B8 (2#0111_0101#);
+ Gen_B8 (0);
+ End_Insn;
+ Pc := Get_Current_Pc;
+ Emit_Op (2#111_000#, Stmt, Sz_32l);
+ Emit_Setcc_Reg (Reg, Ekind_Unsigned_To_Cc (Kind));
+ Patch_B8 (Pc - 1, Unsigned_8 (Get_Current_Pc - Pc));
+ return;
+ end;
+ when Mode_F32
+ | Mode_F64 =>
+ -- fcomip st, st(1)
+ Start_Insn;
+ Gen_B8 (2#11011_111#);
+ Gen_B8 (2#1111_0001#);
+ End_Insn;
+ -- fstp st, st (0)
+ Start_Insn;
+ Gen_B8 (2#11011_101#);
+ Gen_B8 (2#11_011_000#);
+ End_Insn;
+ when others =>
+ Error_Emit ("emit_insn: cmp", Stmt);
+ end case;
+ Reg := Get_Expr_Reg (Stmt);
+ if Reg not in Regs_Cc then
+ Error_Emit ("emit_insn/cmp: not cc", Stmt);
+ end if;
+ when OE_Const
+ | OE_Addrg =>
+ case Mode is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Load_Imm (Stmt, Sz_32l);
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ Emit_Load_Imm (Stmt, Sz_8);
+ when Mode_I64
+ | Mode_U64 =>
+ Emit_Load_Imm (Stmt, Sz_32l);
+ Emit_Load_Imm (Stmt, Sz_32h);
+ when Mode_F32 =>
+ Emit_Load_Fp (Stmt, Fp_32);
+ when Mode_F64 =>
+ Emit_Load_Fp (Stmt, Fp_64);
+ when others =>
+ Error_Emit ("emit_insn: const", Stmt);
+ end case;
+ when OE_Indir =>
+ case Mode is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Load_Mem (Stmt, Sz_32l);
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ Emit_Load_Mem (Stmt, Sz_8);
+ when Mode_U64
+ | Mode_I64 =>
+ Emit_Load_Mem (Stmt, Sz_32l);
+ Emit_Load_Mem (Stmt, Sz_32h);
+ when Mode_F32 =>
+ Emit_Load_Fp_Mem (Stmt, Fp_32);
+ when Mode_F64 =>
+ Emit_Load_Fp_Mem (Stmt, Fp_64);
+ when others =>
+ Error_Emit ("emit_insn: indir", Stmt);
+ end case;
+
+ when OE_Conv =>
+ case Get_Expr_Mode (Get_Expr_Operand (Stmt)) is
+ when Mode_U32 =>
+ Gen_Conv_U32 (Stmt);
+ when Mode_I32 =>
+ Gen_Conv_I32 (Stmt);
+ when Mode_U8 =>
+ Gen_Conv_U8 (Stmt);
+ when Mode_B2 =>
+ Gen_Conv_B2 (Stmt);
+ when Mode_I64 =>
+ Gen_Conv_I64 (Stmt);
+ when Mode_F32
+ | Mode_F64 =>
+ Gen_Conv_Fp (Stmt);
+ when others =>
+ Error_Emit ("emit_insn: conv", Stmt);
+ end case;
+
+ when OE_Asgn =>
+ case Mode is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Store (Stmt, Sz_32l);
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ Emit_Store (Stmt, Sz_8);
+ when Mode_U64
+ | Mode_I64 =>
+ Emit_Store (Stmt, Sz_32l);
+ Emit_Store (Stmt, Sz_32h);
+ when Mode_F32 =>
+ Emit_Store_Fp (Stmt, Fp_32);
+ when Mode_F64 =>
+ Emit_Store_Fp (Stmt, Fp_64);
+ when others =>
+ Error_Emit ("emit_insn: move", Stmt);
+ end case;
+
+ when OE_Jump_F =>
+ Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt));
+ if Reg not in Regs_Cc then
+ Error_Emit ("emit_insn/jmp_f: not cc", Stmt);
+ end if;
+ Emit_Jmp_T (Stmt, Inverse_Cc (Reg));
+ when OE_Jump_T =>
+ Reg := Get_Expr_Reg (Get_Expr_Operand (Stmt));
+ if Reg not in Regs_Cc then
+ Error_Emit ("emit_insn/jmp_t: not cc", Stmt);
+ end if;
+ Emit_Jmp_T (Stmt, Reg);
+ when OE_Jump =>
+ Emit_Jmp (Stmt);
+ when OE_Label =>
+ Emit_Label (Stmt);
+
+ when OE_Ret =>
+ -- Value already set.
+ null;
+
+ when OE_Arg =>
+ case Mode is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l);
+ when Mode_U64
+ | Mode_I64 =>
+ Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32h);
+ Emit_Push_32 (Get_Expr_Operand (Stmt), Sz_32l);
+ when Mode_F32 =>
+ Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_32);
+ when Mode_F64 =>
+ Emit_Push_Fp (Get_Expr_Operand (Stmt), Fp_64);
+ when others =>
+ Error_Emit ("emit_insn: oe_arg", Stmt);
+ end case;
+ when OE_Stack_Adjust =>
+ Emit_Setup_Frame (Stmt);
+ when OE_Call =>
+ Emit_Call (Stmt);
+ when OE_Intrinsic =>
+ Emit_Intrinsic (Stmt);
+
+ when OE_Move =>
+ declare
+ Operand : O_Enode;
+ Op_Reg : O_Reg;
+ begin
+ Reg := Get_Expr_Reg (Stmt);
+ Operand := Get_Expr_Operand (Stmt);
+ Op_Reg := Get_Expr_Reg (Operand);
+ case Mode is
+ when Mode_B2 =>
+ if Reg in Regs_R32 and then Op_Reg in Regs_Cc then
+ Emit_Setcc (Stmt, Op_Reg);
+ elsif (Reg = R_Eq or Reg = R_Ne)
+ and then Op_Reg in Regs_R32
+ then
+ Emit_Tst (Op_Reg, Sz_8);
+ else
+ Error_Emit ("emit_insn: move/b2", Stmt);
+ end if;
+ when Mode_U32
+ | Mode_I32 =>
+ -- mov REG, OP
+ Start_Insn;
+ Gen_Insn_Sz (2#1000_101_0#, Sz_32l);
+ Gen_Rm (To_Reg32 (Reg, Sz_32l) * 8, Operand, Sz_32l);
+ End_Insn;
+ when others =>
+ Error_Emit ("emit_insn: move", Stmt);
+ end case;
+ end;
+
+ when OE_Alloca =>
+ if Mode /= Mode_P32 then
+ raise Program_Error;
+ end if;
+ Gen_Alloca (Stmt);
+
+ when OE_Set_Stack =>
+ Emit_Load_Mem (Stmt, Sz_32l);
+
+ when OE_Add
+ | OE_Addrl =>
+ case Mode is
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Lea (Stmt);
+ when others =>
+ Error_Emit ("emit_insn: oe_add", Stmt);
+ end case;
+
+ when OE_Spill =>
+ case Mode is
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ Emit_Spill (Stmt, Sz_8);
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Spill (Stmt, Sz_32l);
+ when Mode_U64
+ | Mode_I64 =>
+ Emit_Spill (Stmt, Sz_32l);
+ Emit_Spill (Stmt, Sz_32h);
+ when others =>
+ Error_Emit ("emit_insn: spill", Stmt);
+ end case;
+
+ when OE_Reload =>
+ declare
+ Expr : O_Enode;
+ begin
+ Reg := Get_Expr_Reg (Stmt);
+ Expr := Get_Expr_Operand (Stmt);
+ case Mode is
+ when Mode_B2
+ | Mode_U8
+ | Mode_I8 =>
+ Emit_Load (Reg, Expr, Sz_8);
+ when Mode_U32
+ | Mode_I32
+ | Mode_P32 =>
+ Emit_Load (Reg, Expr, Sz_32l);
+ when Mode_U64
+ | Mode_I64 =>
+ Emit_Load (Reg, Expr, Sz_32l);
+ Emit_Load (Reg, Expr, Sz_32h);
+ when others =>
+ Error_Emit ("emit_insn: reload", Stmt);
+ end case;
+ end;
+
+ when OE_Reg =>
+ Reg_Helper := Get_Expr_Reg (Stmt);
+
+ when OE_Case_Expr
+ | OE_Case =>
+ null;
+
+ when OE_Line =>
+ if Flag_Debug = Debug_Dwarf then
+ Dwarf.Set_Line_Stmt (Get_Expr_Line_Number (Stmt));
+ Set_Current_Section (Sect_Text);
+ end if;
+ when others =>
+ Error_Emit ("cannot handle insn", Stmt);
+ end case;
+ end Emit_Insn;
+
+ procedure Push_Reg_If_Used (Reg : Regs_R32)
+ is
+ use Ortho_Code.X86.Insns;
+ begin
+ if Reg_Used (Reg) then
+ Start_Insn;
+ Gen_B8 (2#01010_000# + To_Reg32 (Reg, Sz_32l));
+ End_Insn;
+ end if;
+ end Push_Reg_If_Used;
+
+ procedure Pop_Reg_If_Used (Reg : Regs_R32)
+ is
+ use Ortho_Code.X86.Insns;
+ begin
+ if Reg_Used (Reg) then
+ Start_Insn;
+ Gen_B8 (2#01011_000# + To_Reg32 (Reg, Sz_32l));
+ End_Insn;
+ end if;
+ end Pop_Reg_If_Used;
+
+ procedure Emit_Prologue (Subprg : Subprogram_Data_Acc)
+ is
+ use Ortho_Code.Decls;
+ use Ortho_Code.Flags;
+ use Ortho_Code.X86.Insns;
+ Sym : Symbol;
+ Subprg_Decl : O_Dnode;
+ Is_Global : Boolean;
+ Frame_Size : Unsigned_32;
+ Saved_Regs_Size : Unsigned_32;
+ begin
+ -- Switch to .text section and align the function (to avoid the nested
+ -- function trick and for performance).
+ Set_Current_Section (Sect_Text);
+ Gen_Pow_Align (2);
+
+ Subprg_Decl := Subprg.D_Decl;
+ Sym := Get_Decl_Symbol (Subprg_Decl);
+ case Get_Decl_Storage (Subprg_Decl) is
+ when O_Storage_Public
+ | O_Storage_External =>
+ -- FIXME: should not accept the external case.
+ Is_Global := True;
+ when others =>
+ Is_Global := False;
+ end case;
+ Set_Symbol_Pc (Sym, Is_Global);
+ Subprg_Pc := Get_Current_Pc;
+
+ Saved_Regs_Size := Boolean'Pos(Reg_Used (R_Di)) * 4
+ + Boolean'Pos(Reg_Used (R_Si)) * 4
+ + Boolean'Pos(Reg_Used (R_Bx)) * 4;
+
+ -- Compute frame size.
+ -- 8 bytes are used by return address and saved frame pointer.
+ Frame_Size := Unsigned_32 (Subprg.Stack_Max) + 8 + Saved_Regs_Size;
+ -- Align.
+ Frame_Size := (Frame_Size + X86.Flags.Stack_Boundary - 1)
+ and not (X86.Flags.Stack_Boundary - 1);
+ -- The 8 bytes are already allocated.
+ Frame_Size := Frame_Size - 8 - Saved_Regs_Size;
+
+ -- Emit prolog.
+ -- push %ebp
+ Start_Insn;
+ Gen_B8 (2#01010_101#);
+ End_Insn;
+ -- movl %esp, %ebp
+ Start_Insn;
+ Gen_B8 (2#1000100_1#);
+ Gen_B8 (2#11_100_101#);
+ End_Insn;
+ -- subl XXX, %esp
+ if Frame_Size /= 0 then
+ if not X86.Flags.Flag_Alloca_Call
+ or else Frame_Size <= 4096
+ then
+ Start_Insn;
+ if Frame_Size < 128 then
+ Gen_B8 (2#100000_11#);
+ Gen_B8 (2#11_101_100#);
+ Gen_B8 (Byte (Frame_Size));
+ else
+ Gen_B8 (2#100000_01#);
+ Gen_B8 (2#11_101_100#);
+ Gen_Le32 (Frame_Size);
+ end if;
+ End_Insn;
+ else
+ -- mov stack_size,%eax
+ Start_Insn;
+ Gen_B8 (2#1011_1_000#);
+ Gen_Le32 (Frame_Size);
+ End_Insn;
+ Gen_Call (Chkstk_Symbol);
+ end if;
+ end if;
+
+ if Flag_Profile then
+ Gen_Call (Mcount_Symbol);
+ end if;
+
+ -- Save registers.
+ Push_Reg_If_Used (R_Di);
+ Push_Reg_If_Used (R_Si);
+ Push_Reg_If_Used (R_Bx);
+ end Emit_Prologue;
+
+ procedure Emit_Epilogue (Subprg : Subprogram_Data_Acc)
+ is
+ use Ortho_Code.Decls;
+ use Ortho_Code.Types;
+ use Ortho_Code.Flags;
+ Decl : O_Dnode;
+ begin
+ -- Restore registers.
+ Pop_Reg_If_Used (R_Bx);
+ Pop_Reg_If_Used (R_Si);
+ Pop_Reg_If_Used (R_Di);
+
+ Decl := Subprg.D_Decl;
+ if Get_Decl_Kind (Decl) = OD_Function then
+ case Get_Type_Mode (Get_Decl_Type (Decl)) is
+ when Mode_U8
+ | Mode_B2 =>
+ -- movzx %al,%eax
+ Start_Insn;
+ Gen_B8 (16#0f#);
+ Gen_B8 (2#1011_0110#);
+ Gen_B8 (2#11_000_000#);
+ End_Insn;
+ when Mode_U32
+ | Mode_I32
+ | Mode_U64
+ | Mode_I64
+ | Mode_F32
+ | Mode_F64
+ | Mode_P32 =>
+ null;
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+
+ -- leave
+ Start_Insn;
+ Gen_B8 (2#1100_1001#);
+ End_Insn;
+
+ -- ret
+ Start_Insn;
+ Gen_B8 (2#1100_0011#);
+ End_Insn;
+
+ if Flag_Debug = Debug_Dwarf then
+ Set_Body_Info (Subprg.D_Body, Int32 (Get_Current_Pc - Subprg_Pc));
+ end if;
+ end Emit_Epilogue;
+
+ procedure Emit_Subprg (Subprg : Subprogram_Data_Acc)
+ is
+ Stmt : O_Enode;
+ begin
+ if Debug.Flag_Debug_Code2 then
+ Abi.Disp_Subprg_Decl (Subprg.D_Decl);
+ end if;
+
+ Emit_Prologue (Subprg);
+
+ Stmt := Subprg.E_Entry;
+ loop
+ Stmt := Get_Stmt_Link (Stmt);
+
+ if Debug.Flag_Debug_Code2 then
+ Abi.Disp_Stmt (Stmt);
+ end if;
+
+ Emit_Insn (Stmt);
+ exit when Get_Expr_Kind (Stmt) = OE_Leave;
+ end loop;
+
+ Emit_Epilogue (Subprg);
+ end Emit_Subprg;
+
+ procedure Emit_Var_Decl (Decl : O_Dnode)
+ is
+ use Decls;
+ use Types;
+ Sym : Symbol;
+ Storage : O_Storage;
+ Dtype : O_Tnode;
+ begin
+ Set_Current_Section (Sect_Bss);
+ Sym := Create_Symbol (Get_Decl_Ident (Decl));
+ Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym)));
+ Storage := Get_Decl_Storage (Decl);
+ Dtype := Get_Decl_Type (Decl);
+ case Storage is
+ when O_Storage_External =>
+ null;
+ when O_Storage_Public
+ | O_Storage_Private =>
+ Gen_Pow_Align (Get_Type_Align (Dtype));
+ Set_Symbol_Pc (Sym, Storage = O_Storage_Public);
+ Gen_Space (Integer_32 (Get_Type_Size (Dtype)));
+ when O_Storage_Local =>
+ raise Program_Error;
+ end case;
+ Set_Current_Section (Sect_Text);
+ end Emit_Var_Decl;
+
+ procedure Emit_Const_Decl (Decl : O_Dnode)
+ is
+ use Decls;
+ use Types;
+ Sym : Symbol;
+ begin
+ Set_Current_Section (Sect_Rodata);
+ Sym := Create_Symbol (Get_Decl_Ident (Decl));
+ Set_Decl_Info (Decl, To_Int32 (Uns32 (Sym)));
+ Set_Current_Section (Sect_Text);
+ end Emit_Const_Decl;
+
+ procedure Emit_Const (Val : O_Cnode)
+ is
+ use Consts;
+ use Types;
+ H, L : Uns32;
+ begin
+ case Get_Const_Kind (Val) is
+ when OC_Signed
+ | OC_Unsigned
+ | OC_Float
+ | OC_Null
+ | OC_Lit =>
+ Get_Const_Bytes (Val, H, L);
+ case Get_Type_Mode (Get_Const_Type (Val)) is
+ when Mode_U8
+ | Mode_I8
+ | Mode_B2 =>
+ Gen_B8 (Byte (L));
+ when Mode_U32
+ | Mode_I32
+ | Mode_F32
+ | Mode_P32 =>
+ Gen_Le32 (Unsigned_32 (L));
+ when Mode_F64
+ | Mode_I64
+ | Mode_U64 =>
+ Gen_Le32 (Unsigned_32 (L));
+ Gen_Le32 (Unsigned_32 (H));
+ when others =>
+ raise Program_Error;
+ end case;
+ when OC_Address
+ | OC_Subprg_Address =>
+ Gen_X86_32 (Get_Decl_Symbol (Get_Const_Decl (Val)), 0);
+ when OC_Array =>
+ for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop
+ Emit_Const (Get_Const_Aggr_Element (Val, I));
+ end loop;
+ when OC_Record =>
+ declare
+ E : O_Cnode;
+ begin
+ for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop
+ E := Get_Const_Aggr_Element (Val, I);
+ Gen_Pow_Align (Get_Type_Align (Get_Const_Type (E)));
+ Emit_Const (E);
+ end loop;
+ end;
+ when OC_Sizeof
+ | OC_Alignof
+ | OC_Union =>
+ raise Program_Error;
+ end case;
+ end Emit_Const;
+
+ procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode)
+ is
+ use Decls;
+ use Types;
+ Sym : Symbol;
+ Dtype : O_Tnode;
+ begin
+ Set_Current_Section (Sect_Rodata);
+ Sym := Get_Decl_Symbol (Decl);
+
+ Dtype := Get_Decl_Type (Decl);
+ Gen_Pow_Align (Get_Type_Align (Dtype));
+ Set_Symbol_Pc (Sym, Get_Decl_Storage (Decl) = O_Storage_Public);
+ Prealloc (Pc_Type (Get_Type_Size (Dtype)));
+ Emit_Const (Val);
+
+ Set_Current_Section (Sect_Text);
+ end Emit_Const_Value;
+
+ procedure Init
+ is
+ use Ortho_Ident;
+ use Ortho_Code.Flags;
+ begin
+ Arch := Arch_X86;
+
+ Create_Section (Sect_Text, ".text", Section_Exec + Section_Read);
+ Create_Section (Sect_Rodata, ".rodata", Section_Read);
+ Create_Section (Sect_Bss, ".bss",
+ Section_Read + Section_Write + Section_Zero);
+
+ Set_Current_Section (Sect_Text);
+
+ if Flag_Profile then
+ Mcount_Symbol := Create_Symbol (Get_Identifier ("mcount"));
+ end if;
+
+ if X86.Flags.Flag_Alloca_Call then
+ Chkstk_Symbol := Create_Symbol (Get_Identifier ("___chkstk"));
+ end if;
+
+ Intrinsics_Symbol (Intrinsic_Mul_Ov_U64) :=
+ Create_Symbol (Get_Identifier ("__muldi3"));
+ Intrinsics_Symbol (Intrinsic_Div_Ov_U64) :=
+ Create_Symbol (Get_Identifier ("__mcode_div_ov_u64"));
+ Intrinsics_Symbol (Intrinsic_Mod_Ov_U64) :=
+ Create_Symbol (Get_Identifier ("__mcode_mod_ov_u64"));
+ Intrinsics_Symbol (Intrinsic_Mul_Ov_I64) :=
+ Create_Symbol (Get_Identifier ("__muldi3"));
+ Intrinsics_Symbol (Intrinsic_Div_Ov_I64) :=
+ Create_Symbol (Get_Identifier ("__divdi3"));
+ Intrinsics_Symbol (Intrinsic_Mod_Ov_I64) :=
+ Create_Symbol (Get_Identifier ("__mcode_mod_ov_i64"));
+ Intrinsics_Symbol (Intrinsic_Rem_Ov_I64) :=
+ Create_Symbol (Get_Identifier ("__mcode_rem_ov_i64"));
+
+ if Debug.Flag_Debug_Asm then
+ Dump_Asm := True;
+ end if;
+ if Debug.Flag_Debug_Hex then
+ Debug_Hex := True;
+ end if;
+
+ if Flag_Debug = Debug_Dwarf then
+ Dwarf.Init;
+ Set_Current_Section (Sect_Text);
+ end if;
+ end Init;
+
+ procedure Finish
+ is
+ use Ortho_Code.Flags;
+ begin
+ if Flag_Debug = Debug_Dwarf then
+ Set_Current_Section (Sect_Text);
+ Dwarf.Finish;
+ end if;
+ end Finish;
+
+end Ortho_Code.X86.Emits;
+
diff --git a/src/ortho/mcode/ortho_code-x86-emits.ads b/src/ortho/mcode/ortho_code-x86-emits.ads
new file mode 100644
index 000000000..9ddb43ee5
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-emits.ads
@@ -0,0 +1,36 @@
+-- Mcode back-end for ortho - Binary X86 instructions generator.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Binary_File; use Binary_File;
+
+package Ortho_Code.X86.Emits is
+ procedure Init;
+ procedure Finish;
+
+ procedure Emit_Subprg (Subprg : Subprogram_Data_Acc);
+
+ procedure Emit_Var_Decl (Decl : O_Dnode);
+ procedure Emit_Const_Decl (Decl : O_Dnode);
+ procedure Emit_Const_Value (Decl : O_Dnode; Val : O_Cnode);
+
+ type Intrinsic_Symbols_Map is array (Intrinsics_X86) of Symbol;
+ Intrinsics_Symbol : Intrinsic_Symbols_Map;
+
+ Mcount_Symbol : Symbol;
+ Chkstk_Symbol : Symbol;
+end Ortho_Code.X86.Emits;
+
diff --git a/src/ortho/mcode/ortho_code-x86-flags_linux.ads b/src/ortho/mcode/ortho_code-x86-flags_linux.ads
new file mode 100644
index 000000000..30bc7f7b3
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_linux.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Ortho_Code.X86.Flags_Linux is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := False;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 3;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 2;
+end Ortho_Code.X86.Flags_Linux;
diff --git a/src/ortho/mcode/ortho_code-x86-flags_macosx.ads b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads
new file mode 100644
index 000000000..a33085294
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_macosx.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Ortho_Code.X86.Flags_Macosx is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := False;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 4;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 2;
+end Ortho_Code.X86.Flags_Macosx;
diff --git a/src/ortho/mcode/ortho_code-x86-flags_windows.ads b/src/ortho/mcode/ortho_code-x86-flags_windows.ads
new file mode 100644
index 000000000..3296aaf2c
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-flags_windows.ads
@@ -0,0 +1,31 @@
+-- X86 ABI flags.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+
+package Ortho_Code.X86.Flags_Windows is
+ -- If true, OE_Alloca calls __chkstk (Windows), otherwise OE_Alloc
+ -- modifies ESP directly.
+ Flag_Alloca_Call : constant Boolean := True;
+
+ -- Prefered stack alignment.
+ -- Must be a power of 2.
+ Stack_Boundary : constant Unsigned_32 := 2 ** 3;
+
+ -- Alignment for double (64 bit float).
+ Mode_F64_Align : constant Natural := 3;
+end Ortho_Code.X86.Flags_Windows;
diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb
new file mode 100644
index 000000000..c218a9ae0
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-insns.adb
@@ -0,0 +1,2068 @@
+-- Mcode back-end for ortho - mcode to X86 instructions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces;
+with Ada.Text_IO;
+with Ortho_Code.Abi;
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Debug;
+with Ortho_Code.X86.Flags;
+
+package body Ortho_Code.X86.Insns is
+ procedure Link_Stmt (Stmt : O_Enode)
+ is
+ use Ortho_Code.Abi;
+ begin
+ Set_Stmt_Link (Last_Link, Stmt);
+ Last_Link := Stmt;
+ if Debug.Flag_Debug_Insn then
+ Disp_Stmt (Stmt);
+ end if;
+ end Link_Stmt;
+
+ function Get_Reg_Any (Mode : Mode_Type) return O_Reg is
+ begin
+ case Mode is
+ when Mode_I16 .. Mode_I32
+ | Mode_U16 .. Mode_U32
+ | Mode_P32 =>
+ return R_Any32;
+ when Mode_I8
+ | Mode_U8
+ | Mode_B2 =>
+ return R_Any8;
+ when Mode_U64
+ | Mode_I64 =>
+ return R_Any64;
+ when Mode_F32
+ | Mode_F64 =>
+ if Abi.Flag_Sse2 then
+ return R_Any_Xmm;
+ else
+ return R_St0;
+ end if;
+ when Mode_P64
+ | Mode_X1
+ | Mode_Nil
+ | Mode_Blk =>
+ raise Program_Error;
+ end case;
+ end Get_Reg_Any;
+
+ function Get_Reg_Any (Stmt : O_Enode) return O_Reg is
+ begin
+ return Get_Reg_Any (Get_Expr_Mode (Stmt));
+ end Get_Reg_Any;
+
+ -- Stack slot management.
+ Stack_Offset : Uns32 := 0;
+ Stack_Max : Uns32 := 0;
+
+ -- Count how many bytes have been pushed on the stack, during a call. This
+ -- is used to correctly align the stack for nested calls.
+ Push_Offset : Uns32 := 0;
+
+ -- STMT is an OE_END statement.
+ -- Swap Stack_Offset with Max_Stack of STMT.
+ procedure Swap_Stack_Offset (Blk : O_Dnode)
+ is
+ Prev_Offset : Uns32;
+ begin
+ Prev_Offset := Get_Block_Max_Stack (Blk);
+ Set_Block_Max_Stack (Blk, Stack_Offset);
+ Stack_Offset := Prev_Offset;
+ end Swap_Stack_Offset;
+
+ procedure Expand_Decls (Block : O_Dnode)
+ is
+ Last : O_Dnode;
+ Decl : O_Dnode;
+ Decl_Type : O_Tnode;
+ begin
+ if Get_Decl_Kind (Block) /= OD_Block then
+ raise Program_Error;
+ end if;
+ Last := Get_Block_Last (Block);
+ Decl := Block + 1;
+ while Decl <= Last loop
+ case Get_Decl_Kind (Decl) is
+ when OD_Local =>
+ Decl_Type := Get_Decl_Type (Decl);
+ Stack_Offset := Do_Align (Stack_Offset, Decl_Type);
+ Stack_Offset := Stack_Offset + Get_Type_Size (Decl_Type);
+ Set_Local_Offset (Decl, -Int32 (Stack_Offset));
+ if Stack_Offset > Stack_Max then
+ Stack_Max := Stack_Offset;
+ end if;
+ when OD_Type
+ | OD_Const
+ | OD_Const_Val
+ | OD_Var
+ | OD_Function
+ | OD_Procedure
+ | OD_Interface
+ | OD_Body
+ | OD_Subprg_Ext =>
+ null;
+ when OD_Block =>
+ Decl := Get_Block_Last (Decl);
+ end case;
+ Decl := Decl + 1;
+ end loop;
+ end Expand_Decls;
+
+ function Ekind_To_Cc (Stmt : O_Enode; Mode : Mode_Type) return O_Reg
+ is
+ Kind : OE_Kind;
+ begin
+ Kind := Get_Expr_Kind (Stmt);
+ case Mode is
+ when Mode_U8 .. Mode_U64
+ | Mode_F32 .. Mode_F64
+ | Mode_P32
+ | Mode_P64
+ | Mode_B2 =>
+ return Ekind_Unsigned_To_Cc (Kind);
+ when Mode_I8 .. Mode_I64 =>
+ return Ekind_Signed_To_Cc (Kind);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Ekind_To_Cc;
+
+ -- CC is the result of A CMP B.
+ -- Returns the condition for B CMP A.
+ function Reverse_Cc (Cc : O_Reg) return O_Reg is
+ begin
+ case Cc is
+ when R_Ult =>
+ return R_Ugt;
+ when R_Uge =>
+ return R_Ule;
+ when R_Eq =>
+ return R_Eq;
+ when R_Ne =>
+ return R_Ne;
+ when R_Ule =>
+ return R_Uge;
+ when R_Ugt =>
+ return R_Ult;
+ when R_Slt =>
+ return R_Sgt;
+ when R_Sge =>
+ return R_Sle;
+ when R_Sle =>
+ return R_Sge;
+ when R_Sgt =>
+ return R_Slt;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Reverse_Cc;
+
+ -- Get the register in which a result of MODE is returned.
+ function Get_Call_Register (Mode : Mode_Type) return O_Reg is
+ begin
+ case Mode is
+ when Mode_U8 .. Mode_U32
+ | Mode_I8 .. Mode_I32
+ | Mode_P32
+ | Mode_B2 =>
+ return R_Ax;
+ when Mode_U64
+ | Mode_I64 =>
+ return R_Edx_Eax;
+ when Mode_F32
+ | Mode_F64 =>
+ if Abi.Flag_Sse2 and True then
+ -- Note: this shouldn't be enabled as the svr4 ABI specifies
+ -- ST0.
+ return R_Xmm0;
+ else
+ return R_St0;
+ end if;
+ when Mode_Nil =>
+ return R_None;
+ when Mode_X1
+ | Mode_Blk
+ | Mode_P64 =>
+ raise Program_Error;
+ end case;
+ end Get_Call_Register;
+
+-- function Ensure_Rm (Stmt : O_Enode) return O_Enode
+-- is
+-- begin
+-- case Get_Expr_Reg (Stmt) is
+-- when R_Mem
+-- | Regs_Any32 =>
+-- return Stmt;
+-- when others =>
+-- raise Program_Error;
+-- end case;
+-- end Ensure_Rm;
+
+-- function Ensure_Ireg (Stmt : O_Enode) return O_Enode
+-- is
+-- Reg : O_Reg;
+-- begin
+-- Reg := Get_Expr_Reg (Stmt);
+-- case Reg is
+-- when Regs_Any32
+-- | R_Imm =>
+-- return Stmt;
+-- when others =>
+-- raise Program_Error;
+-- end case;
+-- end Ensure_Ireg;
+
+ function Insert_Move (Expr : O_Enode; Dest : O_Reg) return O_Enode
+ is
+ N : O_Enode;
+ begin
+ N := New_Enode (OE_Move, Get_Expr_Mode (Expr), O_Tnode_Null,
+ Expr, O_Enode_Null);
+ Set_Expr_Reg (N, Dest);
+ Link_Stmt (N);
+ return N;
+ end Insert_Move;
+
+-- function Insert_Spill (Expr : O_Enode) return O_Enode
+-- is
+-- N : O_Enode;
+-- begin
+-- N := New_Enode (OE_Spill, Get_Expr_Mode (Expr), O_Tnode_Null,
+-- Expr, O_Enode_Null);
+-- Set_Expr_Reg (N, R_Spill);
+-- Link_Stmt (N);
+-- return N;
+-- end Insert_Spill;
+
+ procedure Error_Gen_Insn (Stmt : O_Enode; Reg : O_Reg)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("gen_insn error: cannot match reg " & Abi.Image_Reg (Reg)
+ & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt)));
+ raise Program_Error;
+ end Error_Gen_Insn;
+
+ procedure Error_Gen_Insn (Stmt : O_Enode; Mode : Mode_Type)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("gen_insn error: cannot match mode " & Mode_Type'Image (Mode)
+ & " with stmt " & OE_Kind'Image (Get_Expr_Kind (Stmt))
+ & " of mode " & Mode_Type'Image (Get_Expr_Mode (Stmt)));
+ raise Program_Error;
+ end Error_Gen_Insn;
+
+ pragma No_Return (Error_Gen_Insn);
+
+ Cur_Block : O_Enode;
+
+ type O_Inum is new Int32;
+ O_Free : constant O_Inum := 0;
+ O_Iroot : constant O_Inum := 1;
+
+
+ Insn_Num : O_Inum;
+
+ function Get_Insn_Num return O_Inum is
+ begin
+ Insn_Num := Insn_Num + 1;
+ return Insn_Num;
+ end Get_Insn_Num;
+
+
+ type Reg_Info_Type is record
+ -- Statement number which use this register.
+ -- This is a distance.
+ Num : O_Inum;
+
+ -- Statement which produces this value.
+ -- Used to have more info on this register (such as mode to allocate
+ -- a spill location).
+ Stmt : O_Enode;
+
+ -- If set, this register has been used.
+ -- All callee-saved registers marked must be saved.
+ Used : Boolean;
+ end record;
+
+ Init_Reg_Info : constant Reg_Info_Type := (Num => O_Free,
+ Stmt => O_Enode_Null,
+ Used => False);
+ type Reg32_Info_Array is array (Regs_R32) of Reg_Info_Type;
+ Regs : Reg32_Info_Array := (others => Init_Reg_Info);
+
+ Reg_Cc : Reg_Info_Type := Init_Reg_Info;
+
+ type Fp_Stack_Type is mod 8;
+ type RegFp_Info_Array is array (Fp_Stack_Type) of Reg_Info_Type;
+ Fp_Top : Fp_Stack_Type := 0;
+ Fp_Regs : RegFp_Info_Array;
+
+ type Reg_Xmm_Info_Array is array (Regs_Xmm) of Reg_Info_Type;
+ Info_Regs_Xmm : Reg_Xmm_Info_Array := (others => Init_Reg_Info);
+
+ function Reg_Used (Reg : Regs_R32) return Boolean is
+ begin
+ return Regs (Reg).Used;
+ end Reg_Used;
+
+ procedure Dump_Reg32_Info (Reg : Regs_R32)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ use Abi;
+ begin
+ Put (Image_Reg (Reg));
+ Put (": ");
+ Put (Int32 (Regs (Reg).Stmt), 0);
+ Put (", num: ");
+ Put (Int32 (Regs (Reg).Num), 0);
+ --Put (", twin: ");
+ --Put (Image_Reg (Regs (Reg).Twin_Reg));
+ --Put (", link: ");
+ --Put (Image_Reg (Regs (Reg).Link));
+ New_Line;
+ end Dump_Reg32_Info;
+
+ procedure Dump_Regs
+ is
+ use Ada.Text_IO;
+ use Debug.Int32_IO;
+ begin
+-- Put ("free_regs: ");
+-- Put (Image_Reg (Free_Regs));
+-- Put (", to_free_regs: ");
+-- Put (Image_Reg (To_Free_Regs));
+-- New_Line;
+
+ for I in Regs_R32 loop
+ Dump_Reg32_Info (I);
+ end loop;
+ for I in Fp_Stack_Type loop
+ Put ("fp" & Fp_Stack_Type'Image (I));
+ Put (": ");
+ Put (Int32 (Fp_Regs (I).Stmt), 0);
+ New_Line;
+ end loop;
+ end Dump_Regs;
+
+ pragma Unreferenced (Dump_Regs);
+
+ procedure Error_Reg (Msg : String; Stmt : O_Enode; Reg : O_Reg)
+ is
+ use Ada.Text_IO;
+ use Ortho_Code.Debug.Int32_IO;
+ begin
+ Put ("error reg: ");
+ Put (Msg);
+ New_Line;
+ Put (" stmt: ");
+ Put (Int32 (Stmt), 0);
+ Put (", reg: ");
+ Put (Abi.Image_Reg (Reg));
+ New_Line;
+ --Dump_Regs;
+ raise Program_Error;
+ end Error_Reg;
+ pragma No_Return (Error_Reg);
+
+ -- Free_XX
+ -- Mark a register as unused.
+ procedure Free_R32 (Reg : O_Reg) is
+ begin
+ if Regs (Reg).Num = O_Free then
+ raise Program_Error;
+ end if;
+ Regs (Reg).Num := O_Free;
+ end Free_R32;
+
+ procedure Free_Fp is
+ begin
+ if Fp_Regs (Fp_Top).Stmt = O_Enode_Null then
+ raise Program_Error;
+ end if;
+ Fp_Regs (Fp_Top).Stmt := O_Enode_Null;
+ Fp_Top := Fp_Top + 1;
+ end Free_Fp;
+
+ procedure Free_Cc is
+ begin
+ if Reg_Cc.Num = O_Free then
+ raise Program_Error;
+ end if;
+ Reg_Cc.Num := O_Free;
+ end Free_Cc;
+
+ procedure Free_Xmm (Reg : O_Reg) is
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ raise Program_Error;
+ end if;
+ Info_Regs_Xmm (Reg).Num := O_Free;
+ end Free_Xmm;
+
+ -- Allocate a stack slot for spilling.
+ procedure Alloc_Spill (N : O_Enode)
+ is
+ Mode : Mode_Type;
+ begin
+ Mode := Get_Expr_Mode (N);
+ -- Allocate on the stack.
+ Stack_Offset := Types.Do_Align (Stack_Offset, Mode);
+ Stack_Offset := Stack_Offset + Types.Get_Mode_Size (Mode);
+ if Stack_Offset > Stack_Max then
+ Stack_Max := Stack_Offset;
+ end if;
+ Set_Spill_Info (N, -Int32 (Stack_Offset));
+ end Alloc_Spill;
+
+ -- Insert a spill statement after ORIG: will save register(s) allocated by
+ -- ORIG.
+ -- Return the register(s) spilt (There might be several registers if
+ -- ORIG uses a R64 register).
+ function Insert_Spill (Orig : O_Enode) return O_Reg
+ is
+ N : O_Enode;
+ Mode : Mode_Type;
+ Reg_Orig : O_Reg;
+ begin
+ -- Add a spill statement.
+ Mode := Get_Expr_Mode (Orig);
+ N := New_Enode (OE_Spill, Mode, O_Tnode_Null, Orig, O_Enode_Null);
+ Alloc_Spill (N);
+
+ -- Insert the statement after the one that set the register
+ -- being spilled.
+ -- That's very important to be able to easily find the spill location,
+ -- when it will be reloaded.
+ if Orig = Abi.Last_Link then
+ Link_Stmt (N);
+ else
+ Set_Stmt_Link (N, Get_Stmt_Link (Orig));
+ Set_Stmt_Link (Orig, N);
+ end if;
+ Reg_Orig := Get_Expr_Reg (Orig);
+ Set_Expr_Reg (N, Reg_Orig);
+ Set_Expr_Reg (Orig, R_Spill);
+ return Reg_Orig;
+ end Insert_Spill;
+
+ procedure Spill_R32 (Reg : Regs_R32)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Regs (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Regs (Reg).Stmt);
+
+ -- Free the register.
+ case Reg_Orig is
+ when Regs_R32 =>
+ if Reg_Orig /= Reg then
+ raise Program_Error;
+ end if;
+ Free_R32 (Reg);
+ when Regs_R64 =>
+ Free_R32 (Get_R64_High (Reg_Orig));
+ Free_R32 (Get_R64_Low (Reg_Orig));
+ when others =>
+ raise Program_Error;
+ end case;
+ end Spill_R32;
+
+ procedure Alloc_R32 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is
+ begin
+ if Regs (Reg).Num /= O_Free then
+ Spill_R32 (Reg);
+ end if;
+ Regs (Reg) := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_R32;
+
+ procedure Clobber_R32 (Reg : O_Reg) is
+ begin
+ if Regs (Reg).Num /= O_Free then
+ Spill_R32 (Reg);
+ end if;
+ end Clobber_R32;
+
+ procedure Alloc_Fp (Stmt : O_Enode)
+ is
+ begin
+ Fp_Top := Fp_Top - 1;
+
+ if Fp_Regs (Fp_Top).Stmt /= O_Enode_Null then
+ -- Must spill-out.
+ raise Program_Error;
+ end if;
+ Fp_Regs (Fp_Top).Stmt := Stmt;
+ end Alloc_Fp;
+
+ procedure Alloc_R64 (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum)
+ is
+ Rh, Rl : O_Reg;
+ begin
+ Rl := Get_R64_Low (Reg);
+ Rh := Get_R64_High (Reg);
+ if Regs (Rl).Num /= O_Free
+ or Regs (Rh).Num /= O_Free
+ then
+ Spill_R32 (Rl);
+ end if;
+ Regs (Rh) := (Num => Num, Stmt => Stmt, Used => True);
+ Regs (Rl) := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_R64;
+
+ procedure Alloc_Cc (Stmt : O_Enode; Num : O_Inum) is
+ begin
+ if Reg_Cc.Num /= O_Free then
+ raise Program_Error;
+ end if;
+ Reg_Cc := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_Cc;
+
+ procedure Spill_Xmm (Reg : Regs_Xmm)
+ is
+ Reg_Orig : O_Reg;
+ begin
+ if Info_Regs_Xmm (Reg).Num = O_Free then
+ -- This register was not allocated.
+ raise Program_Error;
+ end if;
+
+ Reg_Orig := Insert_Spill (Info_Regs_Xmm (Reg).Stmt);
+
+ -- Free the register.
+ if Reg_Orig /= Reg then
+ raise Program_Error;
+ end if;
+ Free_Xmm (Reg);
+ end Spill_Xmm;
+
+ procedure Alloc_Xmm (Reg : Regs_Xmm; Stmt : O_Enode; Num : O_Inum) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ Info_Regs_Xmm (Reg) := (Num => Num, Stmt => Stmt, Used => True);
+ end Alloc_Xmm;
+
+ procedure Clobber_Xmm (Reg : Regs_Xmm) is
+ begin
+ if Info_Regs_Xmm (Reg).Num /= O_Free then
+ Spill_Xmm (Reg);
+ end if;
+ end Clobber_Xmm;
+ pragma Unreferenced (Clobber_Xmm);
+
+ function Alloc_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) return O_Reg
+ is
+ Best_Reg : O_Reg;
+ Best_Num : O_Inum;
+ begin
+ case Reg is
+ when Regs_R32 =>
+ Alloc_R32 (Reg, Stmt, Num);
+ return Reg;
+ when Regs_R64 =>
+ Alloc_R64 (Reg, Stmt, Num);
+ return Reg;
+ when R_St0 =>
+ Alloc_Fp (Stmt);
+ return Reg;
+ when Regs_Xmm =>
+ Alloc_Xmm (Reg, Stmt, Num);
+ return Reg;
+ when R_Any32 =>
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_R32 loop
+ if I not in R_Sp .. R_Bp then
+ if Regs (I).Num = O_Free then
+ Alloc_R32 (I, Stmt, Num);
+ return I;
+ elsif Regs (I).Num <= Best_Num then
+ Best_Reg := I;
+ Best_Num := Regs (I).Num;
+ end if;
+ end if;
+ end loop;
+ Alloc_R32 (Best_Reg, Stmt, Num);
+ return Best_Reg;
+ when R_Any8 =>
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_R8 loop
+ if Regs (I).Num = O_Free then
+ Alloc_R32 (I, Stmt, Num);
+ return I;
+ elsif Regs (I).Num <= Best_Num then
+ Best_Reg := I;
+ Best_Num := Regs (I).Num;
+ end if;
+ end loop;
+ Alloc_R32 (Best_Reg, Stmt, Num);
+ return Best_Reg;
+ when R_Any64 =>
+ declare
+ Rh, Rl : O_Reg;
+ begin
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_R64 loop
+ Rh := Get_R64_High (I);
+ Rl := Get_R64_Low (I);
+ if Regs (Rh).Num = O_Free
+ and then Regs (Rl).Num = O_Free
+ then
+ Alloc_R64 (I, Stmt, Num);
+ return I;
+ elsif Regs (Rh).Num <= Best_Num
+ and Regs (Rl).Num <= Best_Num
+ then
+ Best_Reg := I;
+ Best_Num := O_Inum'Max (Regs (Rh).Num,
+ Regs (Rl).Num);
+ end if;
+ end loop;
+ Alloc_R64 (Best_Reg, Stmt, Num);
+ return Best_Reg;
+ end;
+ when R_Any_Xmm =>
+ Best_Num := O_Inum'Last;
+ Best_Reg := R_None;
+ for I in Regs_X86_Xmm loop
+ if Info_Regs_Xmm (I).Num = O_Free then
+ Alloc_Xmm (I, Stmt, Num);
+ return I;
+ elsif Info_Regs_Xmm (I).Num <= Best_Num then
+ Best_Reg := I;
+ Best_Num := Info_Regs_Xmm (I).Num;
+ end if;
+ end loop;
+ Alloc_Xmm (Best_Reg, Stmt, Num);
+ return Best_Reg;
+ when others =>
+ Error_Reg ("alloc_reg: unknown reg", O_Enode_Null, Reg);
+ raise Program_Error;
+ end case;
+ end Alloc_Reg;
+
+ function Gen_Reload (Spill : O_Enode; Reg : O_Reg; Num : O_Inum)
+ return O_Enode
+ is
+ N : O_Enode;
+ Mode : Mode_Type;
+ begin
+ -- Add a reload node.
+ Mode := Get_Expr_Mode (Spill);
+ N := New_Enode (OE_Reload, Mode, O_Tnode_Null, Spill, O_Enode_Null);
+ -- Note: this does not use a just-freed register, since
+ -- this case only occurs at the first call.
+ Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num));
+ Link_Stmt (N);
+ return N;
+ end Gen_Reload;
+
+ function Reload (Expr : O_Enode; Dest : O_Reg; Num : O_Inum) return O_Enode
+ is
+ Reg : O_Reg;
+ Spill : O_Enode;
+ begin
+ Reg := Get_Expr_Reg (Expr);
+ case Reg is
+ when R_Spill =>
+ -- Restore the register between the statement and the spill.
+ Spill := Get_Stmt_Link (Expr);
+ Set_Expr_Reg (Expr, Get_Expr_Reg (Spill));
+ Set_Expr_Reg (Spill, R_Spill);
+ case Dest is
+ when R_Mem
+ | R_Irm
+ | R_Rm =>
+ return Spill;
+ when Regs_R32
+ | R_Any32
+ | Regs_R64
+ | R_Any64
+ | R_Any8 =>
+ return Gen_Reload (Spill, Dest, Num);
+ when R_Sib =>
+ return Gen_Reload (Spill, R_Any32, Num);
+ when R_Ir =>
+ return Gen_Reload (Spill, Get_Reg_Any (Expr), Num);
+ when others =>
+ Error_Reg ("reload: unhandled dest in spill", Expr, Dest);
+ end case;
+ when Regs_R32 =>
+ case Dest is
+ when R_Irm
+ | R_Rm
+ | R_Ir
+ | R_Any32
+ | R_Any8
+ | R_Sib =>
+ return Expr;
+ when Regs_R32 =>
+ if Dest = Reg then
+ return Expr;
+ end if;
+ Free_R32 (Reg);
+ Spill := Insert_Move (Expr, Dest);
+ Alloc_R32 (Dest, Spill, Num);
+ return Spill;
+ when others =>
+ Error_Reg ("reload: unhandled dest in R32", Expr, Dest);
+ end case;
+ when Regs_R64 =>
+ return Expr;
+ when R_St0 =>
+ return Expr;
+ when Regs_Xmm =>
+ return Expr;
+ when R_Mem =>
+ if Get_Expr_Kind (Expr) = OE_Indir then
+ Set_Expr_Operand (Expr,
+ Reload (Get_Expr_Operand (Expr), R_Sib, Num));
+ return Expr;
+ else
+ raise Program_Error;
+ end if;
+ when R_B_Off
+ | R_B_I
+ | R_I_Off
+ | R_Sib =>
+ case Get_Expr_Kind (Expr) is
+ when OE_Add =>
+ Set_Expr_Left
+ (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num));
+ Set_Expr_Right
+ (Expr, Reload (Get_Expr_Right (Expr), R_Any32, Num));
+ return Expr;
+ when OE_Addrl =>
+ Spill := Get_Addrl_Frame (Expr);
+ if Spill /= O_Enode_Null then
+ Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num));
+ end if;
+ return Expr;
+ when others =>
+ Error_Reg ("reload: unhandle expr in b_off", Expr, Dest);
+ end case;
+ when R_I =>
+ Set_Expr_Left (Expr, Reload (Get_Expr_Left (Expr), R_Any32, Num));
+ return Expr;
+ when R_Imm =>
+ return Expr;
+ when others =>
+ Error_Reg ("reload: unhandled reg", Expr, Reg);
+ end case;
+ end Reload;
+
+ procedure Renum_Reg (Reg : O_Reg; Stmt : O_Enode; Num : O_Inum) is
+ begin
+ case Reg is
+ when Regs_R32 =>
+ Regs (Reg).Num := Num;
+ Regs (Reg).Stmt := Stmt;
+ when Regs_Cc =>
+ Reg_Cc.Num := Num;
+ Reg_Cc.Stmt := Stmt;
+ when R_St0 =>
+ null;
+ when Regs_R64 =>
+ declare
+ L, H : O_Reg;
+ begin
+ L := Get_R64_Low (Reg);
+ Regs (L).Num := Num;
+ Regs (L).Stmt := Stmt;
+ H := Get_R64_High (Reg);
+ Regs (H).Num := Num;
+ Regs (H).Stmt := Stmt;
+ end;
+ when others =>
+ Error_Reg ("renum_reg", Stmt, Reg);
+ end case;
+ end Renum_Reg;
+
+ procedure Free_Insn_Regs (Insn : O_Enode)
+ is
+ R : O_Reg;
+ begin
+ R := Get_Expr_Reg (Insn);
+ case R is
+ when R_Ax
+ | R_Bx
+ | R_Cx
+ | R_Dx
+ | R_Si
+ | R_Di =>
+ Free_R32 (R);
+ when R_Sp
+ | R_Bp =>
+ null;
+ when R_St0 =>
+ Free_Fp;
+ when Regs_Xmm =>
+ Free_Xmm (R);
+ when Regs_R64 =>
+ Free_R32 (Get_R64_High (R));
+ Free_R32 (Get_R64_Low (R));
+ when R_Mem =>
+ if Get_Expr_Kind (Insn) = OE_Indir then
+ Free_Insn_Regs (Get_Expr_Operand (Insn));
+ else
+ raise Program_Error;
+ end if;
+ when R_B_Off
+ | R_B_I
+ | R_I_Off
+ | R_Sib =>
+ case Get_Expr_Kind (Insn) is
+ when OE_Add =>
+ Free_Insn_Regs (Get_Expr_Left (Insn));
+ Free_Insn_Regs (Get_Expr_Right (Insn));
+ when OE_Addrl =>
+ if Get_Addrl_Frame (Insn) /= O_Enode_Null then
+ Free_Insn_Regs (Get_Addrl_Frame (Insn));
+ end if;
+ when others =>
+ raise Program_Error;
+ end case;
+ when R_I =>
+ Free_Insn_Regs (Get_Expr_Left (Insn));
+ when R_Imm =>
+ null;
+ when R_Spill =>
+ null;
+ when others =>
+ Error_Reg ("free_insn_regs: unknown reg", Insn, R);
+ end case;
+ end Free_Insn_Regs;
+
+ procedure Insert_Reg (Mode : Mode_Type)
+ is
+ N : O_Enode;
+ Num : O_Inum;
+ begin
+ Num := Get_Insn_Num;
+ N := New_Enode (OE_Reg, Mode, O_Tnode_Null,
+ O_Enode_Null, O_Enode_Null);
+ Set_Expr_Reg (N, Alloc_Reg (Get_Reg_Any (Mode), N, Num));
+ Link_Stmt (N);
+ Free_Insn_Regs (N);
+ end Insert_Reg;
+
+ procedure Insert_Arg (Expr : O_Enode)
+ is
+ N : O_Enode;
+ begin
+ Free_Insn_Regs (Expr);
+ N := New_Enode (OE_Arg, Get_Expr_Mode (Expr), O_Tnode_Null,
+ Expr, O_Enode_Null);
+ Set_Expr_Reg (N, R_None);
+ Link_Stmt (N);
+ end Insert_Arg;
+
+ function Insert_Intrinsic (Stmt : O_Enode; Reg : O_Reg; Num : O_Inum)
+ return O_Enode
+ is
+ N : O_Enode;
+ Op : Int32;
+ Mode : Mode_Type;
+ begin
+ Mode := Get_Expr_Mode (Stmt);
+ case Get_Expr_Kind (Stmt) is
+ when OE_Mul_Ov =>
+ case Mode is
+ when Mode_U64 =>
+ Op := Intrinsic_Mul_Ov_U64;
+ when Mode_I64 =>
+ Op := Intrinsic_Mul_Ov_I64;
+ when others =>
+ raise Program_Error;
+ end case;
+ when OE_Div_Ov =>
+ case Mode is
+ when Mode_U64 =>
+ Op := Intrinsic_Div_Ov_U64;
+ when Mode_I64 =>
+ Op := Intrinsic_Div_Ov_I64;
+ when others =>
+ raise Program_Error;
+ end case;
+ when OE_Mod =>
+ case Mode is
+ when Mode_U64 =>
+ Op := Intrinsic_Mod_Ov_U64;
+ when Mode_I64 =>
+ Op := Intrinsic_Mod_Ov_I64;
+ when others =>
+ raise Program_Error;
+ end case;
+ when OE_Rem =>
+ case Mode is
+ when Mode_U64 =>
+ -- For unsigned, MOD == REM.
+ Op := Intrinsic_Mod_Ov_U64;
+ when Mode_I64 =>
+ Op := Intrinsic_Rem_Ov_I64;
+ when others =>
+ raise Program_Error;
+ end case;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Save caller-saved registers.
+ Clobber_R32 (R_Ax);
+ Clobber_R32 (R_Dx);
+ Clobber_R32 (R_Cx);
+
+ N := New_Enode (OE_Intrinsic, Mode, O_Tnode_Null,
+ O_Enode (Op), O_Enode_Null);
+ Set_Expr_Reg (N, Alloc_Reg (Reg, N, Num));
+ Link_Stmt (N);
+ return N;
+ end Insert_Intrinsic;
+
+ -- REG is mandatory: the result of STMT must satisfy the REG constraint.
+ function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum)
+ return O_Enode;
+
+ function Gen_Conv_From_Fp_Insn (Stmt : O_Enode;
+ Reg : O_Reg;
+ Pnum : O_Inum)
+ return O_Enode
+ is
+ Num : O_Inum;
+ Left : O_Enode;
+ begin
+ Left := Get_Expr_Operand (Stmt);
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_St0, Num);
+ Free_Insn_Regs (Left);
+ Set_Expr_Operand (Stmt, Left);
+ case Reg is
+ when Regs_R32
+ | R_Any32
+ | Regs_R64
+ | R_Any64 =>
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ when R_Rm
+ | R_Irm
+ | R_Ir =>
+ Set_Expr_Reg (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum));
+ when others =>
+ raise Program_Error;
+ end case;
+ Link_Stmt (Stmt);
+ return Stmt;
+-- declare
+-- Spill : O_Enode;
+-- begin
+-- Num := Get_Insn_Num;
+-- Left := Gen_Insn (Left, R_St0, Num);
+-- Set_Expr_Operand (Stmt, Left);
+-- Set_Expr_Reg (Stmt, R_Spill);
+-- Free_Insn_Regs (Left);
+-- Link_Stmt (Stmt);
+-- Spill := Insert_Spill (Stmt);
+-- case Reg is
+-- when R_Any32
+-- | Regs_R32 =>
+-- return Gen_Reload (Spill, Reg, Pnum);
+-- when R_Ir =>
+-- return Gen_Reload (Spill, R_Any32, Pnum);
+-- when R_Rm
+-- | R_Irm =>
+-- return Spill;
+-- when others =>
+-- Error_Reg
+-- ("gen_insn:oe_conv(fp)", Stmt, Reg);
+-- end case;
+-- end;
+ end Gen_Conv_From_Fp_Insn;
+
+ function Gen_Call (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum)
+ return O_Enode
+ is
+ use Interfaces;
+ Left : O_Enode;
+ Reg_Res : O_Reg;
+ Subprg : O_Dnode;
+ Push_Size : Uns32;
+ Pad : Uns32;
+ Res_Stmt : O_Enode;
+ begin
+ -- Emit Setup_Frame (to align stack).
+ Subprg := Get_Call_Subprg (Stmt);
+ Push_Size := Uns32 (Get_Subprg_Stack (Subprg));
+ -- Pad the stack if necessary.
+ Pad := (Push_Size + Push_Offset) and Uns32 (Flags.Stack_Boundary - 1);
+ if Pad /= 0 then
+ Pad := Uns32 (Flags.Stack_Boundary) - Pad;
+ Link_Stmt (New_Enode (OE_Stack_Adjust, Mode_Nil, O_Tnode_Null,
+ O_Enode (Pad), O_Enode_Null));
+ end if;
+ -- The stack has been adjusted by Pad bytes.
+ Push_Offset := Push_Offset + Pad;
+
+ -- Generate code for arguments (if any).
+ Left := Get_Arg_Link (Stmt);
+ if Left /= O_Enode_Null then
+ Left := Gen_Insn (Left, R_None, Pnum);
+ end if;
+
+ -- Clobber registers.
+ Clobber_R32 (R_Ax);
+ Clobber_R32 (R_Dx);
+ Clobber_R32 (R_Cx);
+ -- FIXME: fp regs.
+
+ -- Add the call.
+ Reg_Res := Get_Call_Register (Get_Expr_Mode (Stmt));
+ Set_Expr_Reg (Stmt, Reg_Res);
+ Link_Stmt (Stmt);
+ Res_Stmt := Stmt;
+
+ if Push_Size + Pad /= 0 then
+ Res_Stmt :=
+ New_Enode (OE_Stack_Adjust, Get_Expr_Mode (Stmt), O_Tnode_Null,
+ O_Enode (-Int32 (Push_Size + Pad)), O_Enode_Null);
+ Set_Expr_Reg (Res_Stmt, Reg_Res);
+ Link_Stmt (Res_Stmt);
+ end if;
+
+ -- The stack has been restored (just after the call).
+ Push_Offset := Push_Offset - (Push_Size + Pad);
+
+ case Reg is
+ when R_Any32
+ | R_Any64
+ | R_Any8
+ | R_Irm
+ | R_Rm
+ | R_Ir
+ | R_Sib
+ | R_Ax
+ | R_St0
+ | R_Edx_Eax =>
+ Reg_Res := Alloc_Reg (Reg_Res, Res_Stmt, Pnum);
+ return Res_Stmt;
+ when R_Any_Cc =>
+ -- Move to register.
+ -- (use the 'test' instruction).
+ Alloc_Cc (Res_Stmt, Pnum);
+ return Insert_Move (Res_Stmt, R_Ne);
+ when R_None =>
+ if Reg_Res /= R_None then
+ raise Program_Error;
+ end if;
+ return Res_Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ end Gen_Call;
+
+ function Gen_Insn (Stmt : O_Enode; Reg : O_Reg; Pnum : O_Inum)
+ return O_Enode
+ is
+ Kind : OE_Kind;
+
+ Left : O_Enode;
+ Right : O_Enode;
+
+ Reg1 : O_Reg;
+ -- P_Reg : O_Reg;
+ Reg_L : O_Reg;
+ Reg_Res : O_Reg;
+
+ Num : O_Inum;
+ begin
+ Kind := Get_Expr_Kind (Stmt);
+ case Kind is
+ when OE_Addrl =>
+ Right := Get_Addrl_Frame (Stmt);
+ if Right /= O_Enode_Null then
+ Num := Get_Insn_Num;
+ Right := Gen_Insn (Right, R_Any32, Num);
+ Set_Addrl_Frame (Stmt, Right);
+ else
+ Num := O_Free;
+ end if;
+ case Reg is
+ when R_Sib =>
+ Set_Expr_Reg (Stmt, R_B_Off);
+ return Stmt;
+ when R_Irm
+ | R_Ir =>
+ if Right /= O_Enode_Null then
+ Free_Insn_Regs (Right);
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ when OE_Addrg =>
+ case Reg is
+ when R_Sib
+ | R_Irm
+ | R_Ir =>
+ Set_Expr_Reg (Stmt, R_Imm);
+ return Stmt;
+ when R_Any32
+ | Regs_R32 =>
+ Set_Expr_Reg (Stmt, Reg);
+ Link_Stmt (Stmt);
+ return Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ when OE_Indir =>
+ Left := Get_Expr_Operand (Stmt);
+ case Reg is
+ when R_Irm
+ | R_Rm =>
+ Left := Gen_Insn (Left, R_Sib, Pnum);
+ Set_Expr_Reg (Stmt, R_Mem);
+ Set_Expr_Operand (Stmt, Left);
+ when R_Ir
+ | R_Sib
+ | R_I_Off =>
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Sib, Num);
+ Reg1 := Get_Reg_Any (Stmt);
+ if Reg1 = R_Any64 then
+ Reg1 := Alloc_Reg (Reg1, Stmt, Pnum);
+ Free_Insn_Regs (Left);
+ else
+ Free_Insn_Regs (Left);
+ Reg1 := Alloc_Reg (Reg1, Stmt, Pnum);
+ end if;
+ Set_Expr_Reg (Stmt, Reg1);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Stmt);
+ when Regs_R32
+ | R_Any32
+ | R_Any8
+ | Regs_Fp =>
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Sib, Num);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Stmt);
+ when Regs_R64
+ | R_Any64 =>
+ -- Avoid overwritting:
+ -- Eg: axdx = indir (ax)
+ -- axdx = indir (ax+dx)
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Sib, Num);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ Left := Reload (Left, R_Sib, Num);
+ Free_Insn_Regs (Left);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Stmt);
+ when R_Any_Cc =>
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Sib, Num);
+ -- Generate a cmp $1, XX
+ Set_Expr_Reg (Stmt, R_Eq);
+ Set_Expr_Operand (Stmt, Left);
+ Free_Insn_Regs (Left);
+ Link_Stmt (Stmt);
+ Alloc_Cc (Stmt, Pnum);
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ return Stmt;
+ when OE_Conv_Ptr =>
+ -- Delete nops.
+ return Gen_Insn (Get_Expr_Operand (Stmt), Reg, Pnum);
+ when OE_Const =>
+ case Get_Expr_Mode (Stmt) is
+ when Mode_U8 .. Mode_U32
+ | Mode_I8 .. Mode_I32
+ | Mode_P32
+ | Mode_B2 =>
+ case Reg is
+ when R_Imm
+ | Regs_Imm32 =>
+ Set_Expr_Reg (Stmt, R_Imm);
+ when Regs_R32
+ | R_Any32
+ | R_Any8 =>
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ when R_Rm =>
+ Set_Expr_Reg
+ (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum));
+ Link_Stmt (Stmt);
+ when R_Any_Cc =>
+ Num := Get_Insn_Num;
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_Any8, Stmt, Num));
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Stmt);
+ Right := Insert_Move (Stmt, R_Ne);
+ Alloc_Cc (Right, Pnum);
+ return Right;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ when Mode_F32
+ | Mode_F64 =>
+ case Reg is
+ when R_Ir
+ | R_Irm
+ | R_Rm
+ | R_St0 =>
+ Num := Get_Insn_Num;
+ if Reg = R_St0 or not Abi.Flag_Sse2 then
+ Reg1 := R_St0;
+ else
+ Reg1 := R_Any_Xmm;
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg1, Stmt, Num));
+ Link_Stmt (Stmt);
+ when others =>
+ raise Program_Error;
+ end case;
+ when Mode_U64
+ | Mode_I64 =>
+ case Reg is
+ when R_Irm
+ | R_Ir
+ | R_Rm =>
+ Set_Expr_Reg (Stmt, R_Imm);
+ when R_Mem =>
+ Set_Expr_Reg (Stmt, R_Mem);
+ when Regs_R64
+ | R_Any64 =>
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ when others =>
+ raise Program_Error;
+ end case;
+ when others =>
+ raise Program_Error;
+ end case;
+ return Stmt;
+ when OE_Alloca =>
+ -- Roughly speaking, emited code is: (MASK is a constant).
+ -- VAL := (VAL + MASK) & ~MASK
+ -- SP := SP - VAL
+ -- res <- SP
+ Left := Get_Expr_Operand (Stmt);
+ case Reg is
+ when R_Ir
+ | R_Irm
+ | R_Any32 =>
+ Num := Get_Insn_Num;
+ if X86.Flags.Flag_Alloca_Call then
+ Reg_L := R_Ax;
+ else
+ Reg_L := R_Any32;
+ end if;
+ Left := Gen_Insn (Left, Reg_L, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Left);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_L, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ return Stmt;
+
+ when OE_Kind_Cmp =>
+ -- Return LEFT cmp RIGHT, ie compute RIGHT - LEFT
+ Num := Get_Insn_Num;
+ Left := Get_Expr_Left (Stmt);
+ Reg_L := Get_Reg_Any (Left);
+ Left := Gen_Insn (Left, Reg_L, Num);
+
+ Right := Get_Expr_Right (Stmt);
+ case Get_Expr_Mode (Right) is
+ when Mode_F32
+ | Mode_F64 =>
+ Reg1 := R_St0;
+ when others =>
+ Reg1 := R_Irm;
+ end case;
+ Right := Gen_Insn (Right, Reg1, Num);
+
+ -- FIXME: what about if right was spilled out of FP regs ?
+ -- (it is reloaded in reverse).
+ Left := Reload (Left, Reg_L, Num);
+
+ Set_Expr_Right (Stmt, Right);
+ Set_Expr_Left (Stmt, Left);
+
+ Link_Stmt (Stmt);
+
+ Reg_Res := Ekind_To_Cc (Stmt, Get_Expr_Mode (Left));
+ case Get_Expr_Mode (Left) is
+ when Mode_F32
+ | Mode_F64 =>
+ Reg_Res := Reverse_Cc (Reg_Res);
+ when Mode_I64 =>
+ -- I64 is a little bit special...
+ Reg_Res := Get_R64_High (Get_Expr_Reg (Left));
+ if Reg_Res not in Regs_R8 then
+ Reg_Res := R_Nil;
+ for I in Regs_R8 loop
+ if Regs (I).Num = O_Free then
+ Reg_Res := I;
+ exit;
+ end if;
+ end loop;
+ if Reg_Res = R_Nil then
+ -- FIXME: to be handled.
+ -- Can this happen ?
+ raise Program_Error;
+ end if;
+ end if;
+
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+
+ Set_Expr_Reg (Stmt, Reg_Res);
+ case Reg is
+ when R_Any_Cc =>
+ Right := Insert_Move (Stmt, R_Ne);
+ Alloc_Cc (Right, Pnum);
+ return Right;
+ when R_Any8
+ | Regs_R8
+ | R_Irm
+ | R_Ir
+ | R_Rm =>
+ Reg_Res := Alloc_Reg (Reg_Res, Stmt, Pnum);
+ return Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ when others =>
+ null;
+ end case;
+ Set_Expr_Reg (Stmt, Reg_Res);
+
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+
+ case Reg is
+ when R_Any_Cc =>
+ Alloc_Cc (Stmt, Pnum);
+ return Stmt;
+ when R_Any8
+ | Regs_R8 =>
+ Reg_Res := Alloc_Reg (Reg, Stmt, Pnum);
+ return Insert_Move (Stmt, Reg_Res);
+ when R_Irm
+ | R_Ir
+ | R_Rm =>
+ Reg_Res := Alloc_Reg (R_Any8, Stmt, Pnum);
+ return Insert_Move (Stmt, Reg_Res);
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ when OE_Add =>
+ declare
+ R_L : O_Reg;
+ R_R : O_Reg;
+ begin
+ Left := Gen_Insn (Get_Expr_Left (Stmt), R_Sib, Pnum);
+ Right := Gen_Insn (Get_Expr_Right (Stmt), R_Sib, Pnum);
+ Left := Reload (Left, R_Sib, Pnum);
+ Set_Expr_Right (Stmt, Right);
+ Set_Expr_Left (Stmt, Left);
+ R_L := Get_Expr_Reg (Left);
+ R_R := Get_Expr_Reg (Right);
+ -- Results can be: Reg, R_B_Off, R_Sib, R_Imm, R_B_I
+ case R_L is
+ when R_Any32
+ | Regs_R32 =>
+ case R_R is
+ when R_Imm =>
+ Set_Expr_Reg (Stmt, R_B_Off);
+ when R_B_Off
+ | R_I
+ | R_I_Off =>
+ Set_Expr_Reg (Stmt, R_Sib);
+ when R_Any32
+ | Regs_R32 =>
+ Set_Expr_Reg (Stmt, R_B_I);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ when R_Imm =>
+ case R_R is
+ when R_Imm =>
+ Set_Expr_Reg (Stmt, R_Imm);
+ when R_Any32
+ | Regs_R32
+ | R_B_Off =>
+ Set_Expr_Reg (Stmt, R_B_Off);
+ when R_I
+ | R_I_Off =>
+ Set_Expr_Reg (Stmt, R_I_Off);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ when R_B_Off =>
+ case R_R is
+ when R_Imm =>
+ Set_Expr_Reg (Stmt, R_B_Off);
+ when R_Any32
+ | Regs_R32
+ | R_I =>
+ Set_Expr_Reg (Stmt, R_Sib);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ when R_I_Off =>
+ case R_R is
+ when R_Imm =>
+ Set_Expr_Reg (Stmt, R_I_Off);
+ when R_Any32
+ | Regs_R32 =>
+ Set_Expr_Reg (Stmt, R_Sib);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ when R_I =>
+ case R_R is
+ when R_Imm
+ | Regs_R32
+ | R_B_Off =>
+ Set_Expr_Reg (Stmt, R_Sib);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ when R_Sib
+ | R_B_I =>
+ if R_R = R_Imm then
+ Set_Expr_Reg (Stmt, R_Sib);
+ else
+ Num := Get_Insn_Num;
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Left, Alloc_Reg (R_Any32, Left, Num));
+ Link_Stmt (Left);
+ case R_R is
+ when R_Any32
+ | Regs_R32
+ | R_I =>
+ Set_Expr_Reg (Stmt, R_B_I);
+ when others =>
+ Error_Gen_Insn (Stmt, R_R);
+ end case;
+ end if;
+ when others =>
+ Error_Gen_Insn (Stmt, R_L);
+ end case;
+
+ case Reg is
+ when R_Sib =>
+ null;
+ when R_Ir
+ | R_Irm =>
+ if Get_Expr_Reg (Stmt) /= R_Imm then
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_Any32, Stmt, Pnum));
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+ Link_Stmt (Stmt);
+ end if;
+ when R_Any32
+ | Regs_R32 =>
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ end;
+ return Stmt;
+ when OE_Mul =>
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Get_Expr_Left (Stmt), R_Ax, Num);
+ Set_Expr_Left (Stmt, Left);
+
+ Right := Gen_Insn (Get_Expr_Right (Stmt), R_Any32, Num);
+ if Get_Expr_Kind (Right) /= OE_Const then
+ raise Program_Error;
+ end if;
+ Set_Expr_Right (Stmt, Right);
+
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+ Clobber_R32 (R_Dx);
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_Ax, Stmt, Pnum));
+ case Reg is
+ when R_Sib
+ | R_B_Off =>
+ null;
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ Link_Stmt (Stmt);
+ return Stmt;
+ when OE_Shl =>
+ Num := Get_Insn_Num;
+ Right := Get_Expr_Right (Stmt);
+ if Get_Expr_Kind (Right) /= OE_Const then
+ Right := Gen_Insn (Right, R_Cx, Num);
+ else
+ Right := Gen_Insn (Right, R_Imm, Num);
+ end if;
+ Left := Get_Expr_Left (Stmt);
+ Reg1 := Get_Reg_Any (Stmt);
+ Left := Gen_Insn (Left, Reg1, Pnum);
+ if Get_Expr_Kind (Right) /= OE_Const then
+ Right := Reload (Right, R_Cx, Num);
+ end if;
+ Left := Reload (Left, Reg1, Pnum);
+ Set_Expr_Left (Stmt, Left);
+ Set_Expr_Right (Stmt, Right);
+ if Reg = R_Sib
+ and then Get_Expr_Kind (Right) = OE_Const
+ and then Get_Expr_Low (Right) in 0 .. 3
+ then
+ Set_Expr_Reg (Stmt, R_I);
+ else
+ Link_Stmt (Stmt);
+ Set_Expr_Reg (Stmt, Get_Expr_Reg (Left));
+ Free_Insn_Regs (Right);
+ end if;
+ return Stmt;
+
+ when OE_Add_Ov
+ | OE_Sub_Ov
+ | OE_And
+ | OE_Xor
+ | OE_Or =>
+ -- Accepted is: R with IMM or R/M
+ Num := Get_Insn_Num;
+ Right := Get_Expr_Right (Stmt);
+ Left := Get_Expr_Left (Stmt);
+ case Reg is
+ when R_Irm
+ | R_Rm
+ | R_Ir
+ | R_Sib =>
+ Right := Gen_Insn (Right, R_Irm, Num);
+ Reg1 := Get_Reg_Any (Stmt);
+ Left := Gen_Insn (Left, Reg1, Num);
+ Right := Reload (Right, R_Irm, Num);
+ Left := Reload (Left, Reg1, Num);
+ Reg_Res := Get_Expr_Reg (Left);
+ when R_Any_Cc =>
+ Right := Gen_Insn (Right, R_Irm, Num);
+ Left := Gen_Insn (Left, R_Any8, Num);
+ Reg_Res := R_Ne;
+ Alloc_Cc (Stmt, Num);
+ Free_Insn_Regs (Left);
+ when R_Any32
+ | Regs_R32
+ | R_Any8
+ | R_Any64
+ | Regs_R64
+ | Regs_Fp =>
+ Right := Gen_Insn (Right, R_Irm, Num);
+ Left := Gen_Insn (Left, Reg, Num);
+ Right := Reload (Right, R_Irm, Num);
+ Left := Reload (Left, Reg, Num);
+ Reg_Res := Get_Expr_Reg (Left);
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ Set_Expr_Right (Stmt, Right);
+ Set_Expr_Left (Stmt, Left);
+ Set_Expr_Reg (Stmt, Reg_Res);
+ Renum_Reg (Reg_Res, Stmt, Pnum);
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Right);
+ return Stmt;
+
+ when OE_Mod
+ | OE_Rem
+ | OE_Mul_Ov
+ | OE_Div_Ov =>
+ declare
+ Mode : Mode_Type;
+ begin
+ Num := Get_Insn_Num;
+ Mode := Get_Expr_Mode (Stmt);
+ Left := Get_Expr_Left (Stmt);
+ Right := Get_Expr_Right (Stmt);
+ case Mode is
+ when Mode_I32
+ | Mode_U32
+ | Mode_I16
+ | Mode_U16 =>
+ Left := Gen_Insn (Left, R_Ax, Num);
+ Right := Gen_Insn (Right, R_Rm, Num);
+ Left := Reload (Left, R_Ax, Num);
+ case Kind is
+ when OE_Div_Ov
+ | OE_Rem
+ | OE_Mod =>
+ -- Be sure EDX is free.
+ Reg_Res := Alloc_Reg (R_Dx, Stmt, Pnum);
+ when others =>
+ Reg_Res := R_Nil;
+ end case;
+ Right := Reload (Right, R_Rm, Num);
+ Set_Expr_Right (Stmt, Right);
+ Set_Expr_Left (Stmt, Left);
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+ if Reg_Res /= R_Nil then
+ Free_R32 (Reg_Res);
+ end if;
+ if Kind = OE_Div_Ov or Kind = OE_Mul_Ov then
+ Reg_Res := R_Ax;
+ Clobber_R32 (R_Dx);
+ else
+ Reg_Res := R_Dx;
+ Clobber_R32 (R_Ax);
+ end if;
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Reload (Stmt, Reg, Pnum);
+ when Mode_U64
+ | Mode_I64 =>
+ -- FIXME: align stack
+ Insert_Arg (Gen_Insn (Right, R_Irm, Num));
+ Insert_Arg (Gen_Insn (Left, R_Irm, Num));
+ return Insert_Intrinsic (Stmt, R_Edx_Eax, Pnum);
+ when Mode_F32
+ | Mode_F64 =>
+ Left := Gen_Insn (Left, R_St0, Num);
+ Right := Gen_Insn (Right, R_Rm, Num);
+ Set_Expr_Left (Stmt, Left);
+ Set_Expr_Right (Stmt, Right);
+ Free_Insn_Regs (Right);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (R_St0, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Stmt;
+ when others =>
+ Error_Gen_Insn (Stmt, Mode);
+ end case;
+ end;
+
+ when OE_Not
+ | OE_Abs_Ov
+ | OE_Neg_Ov =>
+ Left := Get_Expr_Operand (Stmt);
+ case Reg is
+ when R_Any32
+ | Regs_R32
+ | R_Any64
+ | Regs_R64
+ | R_Any8
+ | R_St0 =>
+ Reg_Res := Reg;
+ when R_Any_Cc =>
+ if Kind /= OE_Not then
+ raise Program_Error;
+ end if;
+ Left := Gen_Insn (Left, R_Any_Cc, Pnum);
+ Set_Expr_Operand (Stmt, Left);
+ Reg_Res := Inverse_Cc (Get_Expr_Reg (Left));
+ Free_Cc;
+ Set_Expr_Reg (Stmt, Reg_Res);
+ Alloc_Cc (Stmt, Pnum);
+ return Stmt;
+ when R_Irm
+ | R_Rm
+ | R_Ir =>
+ Reg_Res := Get_Reg_Any (Get_Expr_Mode (Left));
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ Left := Gen_Insn (Left, Reg_Res, Pnum);
+ Set_Expr_Operand (Stmt, Left);
+ Reg_Res := Get_Expr_Reg (Left);
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Reg_Res, Stmt, Pnum));
+ Link_Stmt (Stmt);
+ return Stmt;
+ when OE_Conv =>
+ declare
+ O_Mode : Mode_Type; -- Operand mode
+ R_Mode : Mode_Type; -- Result mode
+ begin
+ Left := Get_Expr_Operand (Stmt);
+ O_Mode := Get_Expr_Mode (Left);
+ R_Mode := Get_Expr_Mode (Stmt);
+ -- Simple case: no conversion.
+ -- FIXME: should be handled by EXPR and convert to NOP.
+ if Get_Expr_Mode (Left) = Get_Expr_Mode (Stmt) then
+ -- A no-op.
+ return Gen_Insn (Left, Reg, Pnum);
+ end if;
+ case R_Mode is
+ when Mode_B2 =>
+ case O_Mode is
+ when Mode_U32
+ | Mode_I32 =>
+ -- Detect for bound.
+ null;
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when Mode_U8 =>
+ case O_Mode is
+ when Mode_U16
+ | Mode_U32
+ | Mode_I32 =>
+ -- Detect for bound.
+ null;
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when Mode_U32 =>
+ case O_Mode is
+ when Mode_I32 =>
+ -- Detect for bound.
+ null;
+ when Mode_B2
+ | Mode_U8
+ | Mode_U16 =>
+ -- Zero extend.
+ null;
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when Mode_I32 =>
+ case O_Mode is
+ when Mode_U8
+ | Mode_I8
+ | Mode_B2
+ | Mode_U16
+ | Mode_U32 =>
+ -- Zero extend
+ -- Detect for bound (U32).
+ null;
+ when Mode_I64 =>
+ -- Detect for bound (U32)
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Edx_Eax, Num);
+ Free_Insn_Regs (Left);
+ Set_Expr_Operand (Stmt, Left);
+ case Reg is
+ when R_Ax
+ | R_Any32
+ | R_Rm
+ | R_Irm
+ | R_Ir =>
+ Set_Expr_Reg
+ (Stmt, Alloc_Reg (R_Ax, Stmt, Num));
+ when others =>
+ raise Program_Error;
+ end case;
+ Insert_Reg (Mode_U32);
+ Link_Stmt (Stmt);
+ return Stmt;
+ when Mode_F64
+ | Mode_F32 =>
+ return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum);
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when Mode_I64 =>
+ case O_Mode is
+ when Mode_I32 =>
+ -- Sign extend.
+ Num := Get_Insn_Num;
+ Left := Gen_Insn (Left, R_Ax, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Free_Insn_Regs (Left);
+ case Reg is
+ when R_Edx_Eax
+ | R_Any64
+ | R_Rm
+ | R_Irm
+ | R_Ir =>
+ Set_Expr_Reg
+ (Stmt, Alloc_Reg (R_Edx_Eax, Stmt, Pnum));
+ when others =>
+ raise Program_Error;
+ end case;
+ Link_Stmt (Stmt);
+ return Stmt;
+ when Mode_F64
+ | Mode_F32 =>
+ return Gen_Conv_From_Fp_Insn (Stmt, Reg, Pnum);
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when Mode_F64 =>
+ case O_Mode is
+ when Mode_I32
+ | Mode_I64 =>
+ null;
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ when others =>
+ Error_Gen_Insn (Stmt, O_Mode);
+ end case;
+ Left := Gen_Insn (Left, R_Rm, Pnum);
+ Set_Expr_Operand (Stmt, Left);
+ case Reg is
+ when R_Irm
+ | R_Rm
+ | R_Ir
+ | R_Sib
+ | R_Any32
+ | Regs_R32
+ | R_Any64
+ | R_Any8
+ | Regs_R64
+ | Regs_Fp =>
+ Free_Insn_Regs (Left);
+ Set_Expr_Reg
+ (Stmt, Alloc_Reg (Get_Reg_Any (Stmt), Stmt, Pnum));
+ when others =>
+ Error_Gen_Insn (Stmt, Reg);
+ end case;
+ Link_Stmt (Stmt);
+ return Stmt;
+ end;
+ when OE_Arg =>
+ if Reg /= R_None then
+ raise Program_Error;
+ end if;
+ Left := Get_Arg_Link (Stmt);
+ if Left /= O_Enode_Null then
+ -- Recurse on next argument, so the first argument is pushed
+ -- the last one.
+ Left := Gen_Insn (Left, R_None, Pnum);
+ end if;
+
+ Left := Get_Expr_Operand (Stmt);
+ case Get_Expr_Mode (Left) is
+ when Mode_F32 .. Mode_F64 =>
+ -- fstp instruction.
+ Reg_Res := R_St0;
+ when others =>
+ -- Push instruction.
+ Reg_Res := R_Irm;
+ end case;
+ Left := Gen_Insn (Left, Reg_Res, Pnum);
+ Set_Expr_Operand (Stmt, Left);
+ Push_Offset := Push_Offset +
+ Do_Align (Get_Mode_Size (Get_Expr_Mode (Left)), Mode_U32);
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Left);
+ return Stmt;
+ when OE_Call =>
+ return Gen_Call (Stmt, Reg, Pnum);
+ when OE_Case_Expr =>
+ Left := Get_Expr_Operand (Stmt);
+ Set_Expr_Reg (Stmt, Alloc_Reg (Get_Expr_Reg (Left), Stmt, Pnum));
+ return Stmt;
+ when OE_Get_Stack =>
+ Set_Expr_Reg (Stmt, R_Sp);
+ return Stmt;
+ when OE_Get_Frame =>
+ Set_Expr_Reg (Stmt, R_Bp);
+ return Stmt;
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("gen_insn: unhandled enode " & OE_Kind'Image (Kind));
+ raise Program_Error;
+ end case;
+ end Gen_Insn;
+
+ procedure Assert_Free_Regs (Stmt : O_Enode) is
+ begin
+ for I in Regs_R32 loop
+ if Regs (I).Num /= O_Free then
+ Error_Reg ("gen_insn_stmt: reg is not free", Stmt, I);
+ end if;
+ end loop;
+ for I in Fp_Stack_Type loop
+ if Fp_Regs (I).Stmt /= O_Enode_Null then
+ Error_Reg ("gen_insn_stmt: reg is not free", Stmt, R_St0);
+ end if;
+ end loop;
+ end Assert_Free_Regs;
+
+ procedure Gen_Insn_Stmt (Stmt : O_Enode)
+ is
+ Kind : OE_Kind;
+
+ Left : O_Enode;
+ Right : O_Enode;
+ P_Reg : O_Reg;
+ Num : O_Inum;
+
+ Prev_Stack_Offset : Uns32;
+ begin
+ Insn_Num := O_Iroot;
+ Num := Get_Insn_Num;
+ Prev_Stack_Offset := Stack_Offset;
+
+ Kind := Get_Expr_Kind (Stmt);
+ case Kind is
+ when OE_Asgn =>
+ Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Ir, Num);
+ Right := Gen_Insn (Get_Assign_Target (Stmt), R_Sib, Num);
+ Left := Reload (Left, R_Ir, Num);
+ --Right := Reload (Right, R_Sib, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Set_Assign_Target (Stmt, Right);
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Left);
+ Free_Insn_Regs (Right);
+ when OE_Set_Stack =>
+ Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Rm, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Set_Expr_Reg (Stmt, R_Sp);
+ Link_Stmt (Stmt);
+ when OE_Jump_F
+ | OE_Jump_T =>
+ Left := Gen_Insn (Get_Expr_Operand (Stmt), R_Any_Cc, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Stmt);
+ Free_Cc;
+ when OE_Beg =>
+ declare
+ Block_Decl : O_Dnode;
+ begin
+ Cur_Block := Stmt;
+ Block_Decl := Get_Block_Decls (Cur_Block);
+ Set_Block_Max_Stack (Block_Decl, Stack_Offset);
+ Expand_Decls (Block_Decl);
+ end;
+ Link_Stmt (Stmt);
+ when OE_End =>
+ Swap_Stack_Offset (Get_Block_Decls (Cur_Block));
+ Cur_Block := Get_Block_Parent (Cur_Block);
+ Link_Stmt (Stmt);
+ when OE_Jump
+ | OE_Label =>
+ Link_Stmt (Stmt);
+ when OE_Leave =>
+ Link_Stmt (Stmt);
+ when OE_Call =>
+ Link_Stmt (Gen_Call (Stmt, R_None, Num));
+ when OE_Ret =>
+ Left := Get_Expr_Operand (Stmt);
+ P_Reg := Get_Call_Register (Get_Expr_Mode (Stmt));
+ Left := Gen_Insn (Left, P_Reg, Num);
+ Set_Expr_Operand (Stmt, Left);
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Left);
+ when OE_Case =>
+ Left := Gen_Insn (Get_Expr_Operand (Stmt),
+ Get_Reg_Any (Get_Expr_Mode (Stmt)),
+ Num);
+ Set_Expr_Operand (Stmt, Left);
+ Set_Expr_Reg (Stmt, Get_Expr_Reg (Left));
+ Link_Stmt (Stmt);
+ Free_Insn_Regs (Left);
+ when OE_Line =>
+ Set_Expr_Reg (Stmt, R_None);
+ Link_Stmt (Stmt);
+ when OE_BB =>
+ -- Keep BB.
+ Link_Stmt (Stmt);
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("gen_insn_stmt: unhandled enode " & OE_Kind'Image (Kind));
+ raise Program_Error;
+ end case;
+
+ -- Free any spill stack slots.
+ case Kind is
+ when OE_Beg
+ | OE_End =>
+ null;
+ when others =>
+ Stack_Offset := Prev_Stack_Offset;
+ end case;
+
+ -- Check all registers are free.
+ if Debug.Flag_Debug_Assert then
+ Assert_Free_Regs (Stmt);
+ end if;
+ end Gen_Insn_Stmt;
+
+ procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc)
+ is
+ First : O_Enode;
+ Stmt : O_Enode;
+ N_Stmt : O_Enode;
+ begin
+ if Debug.Flag_Debug_Insn then
+ declare
+ Inter : O_Dnode;
+ begin
+ Disp_Decl (1, Subprg.D_Decl);
+ Inter := Get_Subprg_Interfaces (Subprg.D_Decl);
+ while Inter /= O_Dnode_Null loop
+ Disp_Decl (2, Inter);
+ Inter := Get_Interface_Chain (Inter);
+ end loop;
+ end;
+ end if;
+
+ for I in Regs_R32 loop
+ Regs (I).Used := False;
+ end loop;
+
+ Stack_Max := 0;
+ Stack_Offset := 0;
+ First := Subprg.E_Entry;
+ Expand_Decls (Subprg.D_Body + 1);
+ Abi.Last_Link := First;
+
+ -- Generate instructions.
+ -- Skip OE_Entry.
+ Stmt := Get_Stmt_Link (First);
+ loop
+ N_Stmt := Get_Stmt_Link (Stmt);
+ Gen_Insn_Stmt (Stmt);
+ exit when Get_Expr_Kind (Stmt) = OE_Leave;
+ Stmt := N_Stmt;
+ end loop;
+
+ -- Keep stack depth for this subprogram.
+ Subprg.Stack_Max := Stack_Max;
+
+ -- Sanity check: there must be no remaining pushed bytes.
+ if Push_Offset /= 0 then
+ raise Program_Error with "gen_subprg_insn: push_offset not 0";
+ end if;
+ end Gen_Subprg_Insns;
+
+end Ortho_Code.X86.Insns;
diff --git a/src/ortho/mcode/ortho_code-x86-insns.ads b/src/ortho/mcode/ortho_code-x86-insns.ads
new file mode 100644
index 000000000..9411737a0
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86-insns.ads
@@ -0,0 +1,25 @@
+-- Mcode back-end for ortho - mcode to X86 instructions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ortho_Code.X86.Insns is
+ function Reg_Used (Reg : Regs_R32) return Boolean;
+
+ -- Split enodes of SUBPRG into instructions.
+ procedure Gen_Subprg_Insns (Subprg : Subprogram_Data_Acc);
+
+end Ortho_Code.X86.Insns;
+
diff --git a/src/ortho/mcode/ortho_code-x86.adb b/src/ortho/mcode/ortho_code-x86.adb
new file mode 100644
index 000000000..175dd7e99
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86.adb
@@ -0,0 +1,109 @@
+-- Mcode back-end for ortho - X86 common definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Ortho_Code.X86 is
+ function Inverse_Cc (R : O_Reg) return O_Reg is
+ begin
+ case R is
+ when R_Ult =>
+ return R_Uge;
+ when R_Uge =>
+ return R_Ult;
+ when R_Eq =>
+ return R_Ne;
+ when R_Ne =>
+ return R_Eq;
+ when R_Ule =>
+ return R_Ugt;
+ when R_Ugt =>
+ return R_Ule;
+ when R_Slt =>
+ return R_Sge;
+ when R_Sge =>
+ return R_Slt;
+ when R_Sle =>
+ return R_Sgt;
+ when R_Sgt =>
+ return R_Sle;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Inverse_Cc;
+
+ function Get_R64_High (Reg : Regs_R64) return Regs_R32 is
+ begin
+ case Reg is
+ when R_Edx_Eax =>
+ return R_Dx;
+ when R_Ebx_Ecx =>
+ return R_Bx;
+ when R_Esi_Edi =>
+ return R_Si;
+ end case;
+ end Get_R64_High;
+
+ function Get_R64_Low (Reg : Regs_R64) return Regs_R32 is
+ begin
+ case Reg is
+ when R_Edx_Eax =>
+ return R_Ax;
+ when R_Ebx_Ecx =>
+ return R_Cx;
+ when R_Esi_Edi =>
+ return R_Di;
+ end case;
+ end Get_R64_Low;
+
+ function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is
+ begin
+ case Kind is
+ when OE_Eq =>
+ return R_Eq;
+ when OE_Neq =>
+ return R_Ne;
+ when OE_Lt =>
+ return R_Ult;
+ when OE_Le =>
+ return R_Ule;
+ when OE_Gt =>
+ return R_Ugt;
+ when OE_Ge =>
+ return R_Uge;
+ end case;
+ end Ekind_Unsigned_To_Cc;
+
+ function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg is
+ begin
+ case Kind is
+ when OE_Eq =>
+ return R_Eq;
+ when OE_Neq =>
+ return R_Ne;
+ when OE_Lt =>
+ return R_Slt;
+ when OE_Le =>
+ return R_Sle;
+ when OE_Gt =>
+ return R_Sgt;
+ when OE_Ge =>
+ return R_Sge;
+ end case;
+ end Ekind_Signed_To_Cc;
+
+end Ortho_Code.X86;
+
+
diff --git a/src/ortho/mcode/ortho_code-x86.ads b/src/ortho/mcode/ortho_code-x86.ads
new file mode 100644
index 000000000..24be1eb6c
--- /dev/null
+++ b/src/ortho/mcode/ortho_code-x86.ads
@@ -0,0 +1,160 @@
+-- Mcode back-end for ortho - X86 common definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+
+package Ortho_Code.X86 is
+ -- Registers.
+ R_Nil : constant O_Reg := 0;
+
+ -- Not a value. Used for statements.
+ R_None : constant O_Reg := 1;
+
+ -- Memory.
+ R_Mem : constant O_Reg := 2;
+
+ -- Spilled out.
+ R_Spill : constant O_Reg := 3;
+
+ -- Register or memory.
+ -- THis can only be requested.
+ R_Rm : constant O_Reg := 48;
+
+ -- Immediat
+ R_Imm : constant O_Reg := 49;
+
+ -- Immediat, register or memory.
+ -- This can be requested.
+ R_Irm : constant O_Reg := 50;
+
+ -- Immediat or register.
+ -- This can be requested.
+ R_Ir : constant O_Reg := 51;
+
+ -- BASE + OFFSET
+ R_B_Off : constant O_Reg := 52;
+
+ -- BASE+INDEX*SCALE+OFFSET
+ -- This can be requested.
+ R_Sib : constant O_Reg := 53;
+
+ -- INDEX*SCALE + OFFSET
+ -- This can be requested.
+ R_I_Off : constant O_Reg := 54;
+
+ -- BASE + INDEX*SCALE
+ R_B_I : constant O_Reg := 55;
+
+ -- INDEX*SCALE
+ R_I : constant O_Reg := 56;
+
+ subtype Regs_Imm32 is O_Reg range R_Irm .. R_I_Off;
+
+ R_Any8 : constant O_Reg := 6;
+ R_Any32 : constant O_Reg := 7;
+ R_Ax : constant O_Reg := 8;
+ R_Cx : constant O_Reg := 9;
+ R_Dx : constant O_Reg := 10;
+ R_Bx : constant O_Reg := 11;
+ R_Sp : constant O_Reg := 12;
+ R_Bp : constant O_Reg := 13;
+ R_Si : constant O_Reg := 14;
+ R_Di : constant O_Reg := 15;
+
+ subtype Regs_R8 is O_Reg range R_Ax .. R_Bx;
+ subtype Regs_R32 is O_Reg range R_Ax .. R_Di;
+
+ R_St0 : constant O_Reg := 16;
+ R_St1 : constant O_Reg := 17;
+ R_St2 : constant O_Reg := 18;
+ R_St3 : constant O_Reg := 19;
+ R_St4 : constant O_Reg := 20;
+ R_St5 : constant O_Reg := 21;
+ R_St6 : constant O_Reg := 22;
+ R_St7 : constant O_Reg := 23;
+ --R_Any_Fp : constant O_Reg := 24;
+
+ subtype Regs_Fp is O_Reg range R_St0 .. R_St7;
+
+ -- Any condition register.
+ R_Any_Cc : constant O_Reg := 32;
+ R_Ov : constant O_Reg := 32;
+ R_Ult : constant O_Reg := 34;
+ R_Uge : constant O_Reg := 35;
+ R_Eq : constant O_Reg := 36;
+ R_Ne : constant O_Reg := 37;
+ R_Ule : constant O_Reg := 38;
+ R_Ugt : constant O_Reg := 39;
+ R_Slt : constant O_Reg := 44;
+ R_Sge : constant O_Reg := 45;
+ R_Sle : constant O_Reg := 46;
+ R_Sgt : constant O_Reg := 47;
+
+ subtype Regs_Cc is O_Reg range R_Ov .. R_Sgt;
+
+ R_Edx_Eax : constant O_Reg := 64;
+ R_Ebx_Ecx : constant O_Reg := 65;
+ R_Esi_Edi : constant O_Reg := 66;
+ R_Any64 : constant O_Reg := 67;
+
+ subtype Regs_R64 is O_Reg range R_Edx_Eax .. R_Esi_Edi;
+
+ R_Any_Xmm : constant O_Reg := 79;
+
+ R_Xmm0 : constant O_Reg := 80;
+ R_Xmm1 : constant O_Reg := R_Xmm0 + 1;
+ R_Xmm2 : constant O_Reg := R_Xmm0 + 2;
+ R_Xmm3 : constant O_Reg := R_Xmm0 + 3;
+ R_Xmm4 : constant O_Reg := R_Xmm0 + 4;
+ R_Xmm5 : constant O_Reg := R_Xmm0 + 5;
+ R_Xmm6 : constant O_Reg := R_Xmm0 + 6;
+ R_Xmm7 : constant O_Reg := R_Xmm0 + 7;
+ R_Xmm8 : constant O_Reg := R_Xmm0 + 8;
+ R_Xmm9 : constant O_Reg := R_Xmm0 + 9;
+ R_Xmm10 : constant O_Reg := R_Xmm0 + 10;
+ R_Xmm11 : constant O_Reg := R_Xmm0 + 11;
+ R_Xmm12 : constant O_Reg := R_Xmm0 + 12;
+ R_Xmm13 : constant O_Reg := R_Xmm0 + 13;
+ R_Xmm14 : constant O_Reg := R_Xmm0 + 14;
+ R_Xmm15 : constant O_Reg := R_Xmm0 + 15;
+
+ subtype Regs_X86_64_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+ subtype Regs_X86_Xmm is O_Reg range R_Xmm0 .. R_Xmm7;
+ subtype Regs_Xmm is O_Reg range R_Xmm0 .. R_Xmm15;
+
+ function Get_R64_High (Reg : Regs_R64) return Regs_R32;
+ function Get_R64_Low (Reg : Regs_R64) return Regs_R32;
+
+ function Inverse_Cc (R : O_Reg) return O_Reg;
+
+ -- Intrinsic subprograms.
+ Intrinsic_Mul_Ov_U64 : constant Int32 := 1;
+ Intrinsic_Div_Ov_U64 : constant Int32 := 2;
+ Intrinsic_Mod_Ov_U64 : constant Int32 := 3;
+ Intrinsic_Mul_Ov_I64 : constant Int32 := 4;
+ Intrinsic_Div_Ov_I64 : constant Int32 := 5;
+ Intrinsic_Mod_Ov_I64 : constant Int32 := 6;
+ Intrinsic_Rem_Ov_I64 : constant Int32 := 7;
+
+ subtype Intrinsics_X86 is Int32
+ range Intrinsic_Mul_Ov_U64 .. Intrinsic_Rem_Ov_I64;
+
+ -- Convert a KIND to a reg.
+ function Ekind_Unsigned_To_Cc (Kind : OE_Kind_Cmp) return O_Reg;
+ function Ekind_Signed_To_Cc (Kind : OE_Kind_Cmp) return O_Reg;
+
+end Ortho_Code.X86;
diff --git a/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads
new file mode 100644
index 000000000..0657b07e6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code.ads
@@ -0,0 +1,150 @@
+-- Mcode back-end for ortho - common definitions.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+
+package Ortho_Code is
+ type Int32 is range -(2 ** 31) .. (2 ** 31) - 1;
+
+ type Uns32 is mod 2 ** 32;
+
+ type Uns64 is mod 2 ** 64;
+
+ function Shift_Right (L : Uns64; R : Natural) return Uns64;
+ function Shift_Right (L : Uns32; R : Natural) return Uns32;
+ pragma Import (Intrinsic, Shift_Right);
+
+ function Shift_Right_Arithmetic (L : Uns32; R : Natural) return Uns32;
+ pragma Import (Intrinsic, Shift_Right_Arithmetic);
+
+ function Shift_Left (L : Uns32; R : Natural) return Uns32;
+ pragma Import (Intrinsic, Shift_Left);
+
+ type O_Tnode is new Int32;
+ for O_Tnode'Size use 32;
+ O_Tnode_Null : constant O_Tnode := 0;
+ O_Tnode_First : constant O_Tnode := 2;
+
+ -- A generic pointer.
+ -- This is used by static chains.
+ O_Tnode_Ptr : constant O_Tnode := 2;
+
+ type O_Cnode is new Int32;
+ for O_Cnode'Size use 32;
+ O_Cnode_Null : constant O_Cnode := 0;
+
+ type O_Dnode is new Int32;
+ for O_Dnode'Size use 32;
+ O_Dnode_Null : constant O_Dnode := 0;
+ O_Dnode_First : constant O_Dnode := 2;
+
+ type O_Enode is new Int32;
+ for O_Enode'Size use 32;
+ O_Enode_Null : constant O_Enode := 0;
+ O_Enode_Err : constant O_Enode := 1;
+
+ type O_Fnode is new Int32;
+ for O_Fnode'Size use 32;
+ O_Fnode_Null : constant O_Fnode := 0;
+
+ type O_Lnode is new Int32;
+ for O_Lnode'Size use 32;
+ O_Lnode_Null : constant O_Lnode := 0;
+
+ type O_Ident is new Int32;
+ O_Ident_Nul : constant O_Ident := 0;
+
+ function To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Uns32, Target => Int32);
+
+ function To_Uns32 is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => Uns32);
+
+
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+
+ -- Depth of a declaration.
+ -- 0 for top-level,
+ -- 1 for declared in a top-level subprogram
+ type O_Depth is range 0 .. (2 ** 16) - 1;
+ O_Toplevel : constant O_Depth := 0;
+
+ -- BE representation of a register.
+ type O_Reg is mod 256;
+ R_Nil : constant O_Reg := 0;
+
+ type Mode_Type is (Mode_U8, Mode_U16, Mode_U32, Mode_U64,
+ Mode_I8, Mode_I16, Mode_I32, Mode_I64,
+ Mode_X1, Mode_Nil, Mode_F32, Mode_F64,
+ Mode_B2, Mode_Blk, Mode_P32, Mode_P64);
+
+ subtype Mode_Uns is Mode_Type range Mode_U8 .. Mode_U64;
+ subtype Mode_Int is Mode_Type range Mode_I8 .. Mode_I64;
+ subtype Mode_Fp is Mode_Type range Mode_F32 .. Mode_F64;
+ -- Mode_Ptr : constant Mode_Type := Mode_P32;
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ Syntax_Error : exception;
+end Ortho_Code;
diff --git a/src/ortho/mcode/ortho_code_main.adb b/src/ortho/mcode/ortho_code_main.adb
new file mode 100644
index 000000000..a0e6dc6c6
--- /dev/null
+++ b/src/ortho/mcode/ortho_code_main.adb
@@ -0,0 +1,198 @@
+-- Mcode back-end for ortho - Main subprogram.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Text_IO; use Ada.Text_IO;
+with Binary_File; use Binary_File;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ortho_Code.Debug;
+with Ortho_Mcode; use Ortho_Mcode;
+with Ortho_Front; use Ortho_Front;
+with Ortho_Code.Flags; use Ortho_Code.Flags;
+with Binary_File.Elf;
+with Binary_File.Coff;
+with Binary_File.Memory;
+
+procedure Ortho_Code_Main
+is
+ Output : String_Acc := null;
+ type Format_Type is (Format_Coff, Format_Elf);
+ Format : constant Format_Type := Format_Elf;
+ Fd : File_Descriptor;
+
+ First_File : Natural;
+ Opt : String_Acc;
+ Opt_Arg : String_Acc;
+ Filename : String_Acc;
+ Exec_Func : String_Acc;
+ Res : Natural;
+ I : Natural;
+ Argc : Natural;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+begin
+ First_File := Natural'Last;
+ Exec_Func := null;
+
+ Ortho_Front.Init;
+
+ Argc := Argument_Count;
+ I := 1;
+ while I <= Argc loop
+ declare
+ Arg : constant String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ if Arg'Length > 5 and then Arg (1 .. 5) = "--be-" then
+ Ortho_Code.Debug.Set_Be_Flag (Arg);
+ I := I + 1;
+ elsif Arg = "-o" then
+ if I = Argc then
+ Put_Line (Standard_Error, "error: missing filename to '-o'");
+ return;
+ end if;
+ Output := new String'(Argument (I + 1));
+ I := I + 2;
+ elsif Arg = "-quiet" then
+ -- Skip silently.
+ I := I + 1;
+ elsif Arg = "--exec" then
+ if I = Argc then
+ Put_Line (Standard_Error,
+ "error: missing function name to '--exec'");
+ return;
+ end if;
+ Exec_Func := new String'(Argument (I + 1));
+ I := I + 2;
+ elsif Arg = "-g" then
+ Flag_Debug := Debug_Dwarf;
+ I := I + 1;
+ elsif Arg = "-p" or Arg = "-pg" then
+ Flag_Profile := True;
+ I := I + 1;
+ else
+ -- This is really an argument.
+ Opt := new String'(Arg);
+ if I < Argument_Count then
+ Opt_Arg := new String'(Argument (I + 1));
+ else
+ Opt_Arg := null;
+ end if;
+ Res := Ortho_Front.Decode_Option (Opt, Opt_Arg);
+ case Res is
+ when 0 =>
+ Put_Line (Standard_Error, "unknown option '" & Arg & "'");
+ return;
+ when 1 =>
+ I := I + 1;
+ when 2 =>
+ I := I + 2;
+ when others =>
+ raise Program_Error;
+ end case;
+ Unchecked_Deallocation (Opt);
+ Unchecked_Deallocation (Opt_Arg);
+ end if;
+ else
+ First_File := I;
+ exit;
+ end if;
+ end;
+ end loop;
+
+ Ortho_Mcode.Init;
+
+ Set_Exit_Status (Failure);
+
+ if First_File > Argument_Count then
+ begin
+ if not Parse (null) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ else
+ for I in First_File .. Argument_Count loop
+ Filename := new String'(Argument (First_File));
+ begin
+ if not Parse (Filename) then
+ return;
+ end if;
+ exception
+ when others =>
+ return;
+ end;
+ end loop;
+ end if;
+
+ Ortho_Mcode.Finish;
+
+ if Ortho_Code.Debug.Flag_Debug_Hli then
+ Set_Exit_Status (Success);
+ return;
+ end if;
+
+ if Output /= null then
+ Fd := Create_File (Output.all, Binary);
+ if Fd /= Invalid_FD then
+ case Format is
+ when Format_Elf =>
+ Binary_File.Elf.Write_Elf (Fd);
+ when Format_Coff =>
+ Binary_File.Coff.Write_Coff (Fd);
+ end case;
+ Close (Fd);
+ end if;
+ elsif Exec_Func /= null then
+ declare
+ Sym : Symbol;
+
+ type Func_Acc is access function return Integer;
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Pc_Type, Target => Func_Acc);
+ F : Func_Acc;
+ V : Integer;
+ Err : Boolean;
+ begin
+ Binary_File.Memory.Write_Memory_Init;
+ Binary_File.Memory.Write_Memory_Relocate (Err);
+ if Err then
+ return;
+ end if;
+ Sym := Binary_File.Get_Symbol (Exec_Func.all);
+ if Sym = Null_Symbol then
+ Put_Line (Standard_Error, "no '" & Exec_Func.all & "' symbol");
+ else
+ F := Conv (Get_Symbol_Vaddr (Sym));
+ V := F.all;
+ Put_Line ("Result is " & Integer'Image (V));
+ end if;
+ end;
+ end if;
+
+ Set_Exit_Status (Success);
+exception
+ when others =>
+ Set_Exit_Status (2);
+ raise;
+end Ortho_Code_Main;
+
+
diff --git a/src/ortho/mcode/ortho_ident.adb b/src/ortho/mcode/ortho_ident.adb
new file mode 100644
index 000000000..0893b75dd
--- /dev/null
+++ b/src/ortho/mcode/ortho_ident.adb
@@ -0,0 +1,117 @@
+-- Mcode back-end for ortho.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with GNAT.Table;
+
+package body Ortho_Ident is
+ package Ids is new GNAT.Table
+ (Table_Component_Type => Natural,
+ Table_Index_Type => O_Ident,
+ Table_Low_Bound => 2,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ package Strs is new GNAT.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 2,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ Start : Natural;
+ begin
+ Start := Strs.Allocate (Str'Length + 1);
+ for I in Str'Range loop
+ Strs.Table (Start + I - Str'First) := Str (I);
+ end loop;
+ Strs.Table (Start + Str'Length) := ASCII.Nul;
+ Ids.Append (Start);
+ return Ids.Last;
+ end Get_Identifier;
+
+ function Is_Equal (L, R : O_Ident) return Boolean
+ is
+ begin
+ return L = R;
+ end Is_Equal;
+
+ function Get_String_Length (Id : O_Ident) return Natural
+ is
+ Start : Natural;
+ begin
+ Start := Ids.Table (Id);
+ if Id = Ids.Last then
+ return Strs.Last - Start + 1 - 1;
+ else
+ return Ids.Table (Id + 1) - 1 - Start;
+ end if;
+ end Get_String_Length;
+
+ function Get_String (Id : O_Ident) return String
+ is
+ Res : String (1 .. Get_String_Length (Id));
+ Start : constant Natural := Ids.Table (Id);
+ begin
+ for I in Res'Range loop
+ Res (I) := Strs.Table (Start + I - Res'First);
+ end loop;
+ return Res;
+ end Get_String;
+
+ function Get_Cstring (Id : O_Ident) return System.Address is
+ begin
+ return Strs.Table (Ids.Table (Id))'Address;
+ end Get_Cstring;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean
+ is
+ Start : constant Natural := Ids.Table (Id);
+ Len : constant Natural := Get_String_Length (Id);
+ begin
+ if Len /= Str'Length then
+ return False;
+ end if;
+ for I in Str'Range loop
+ if Str (I) /= Strs.Table (Start + I - Str'First) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Is_Equal;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = O_Ident_Nul;
+ end Is_Nul;
+
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line ("Number of Ident: " & O_Ident'Image (Ids.Last));
+ Put_Line ("Number of Ident-Strs: " & Natural'Image (Strs.Last));
+ end Disp_Stats;
+
+ procedure Finish is
+ begin
+ Ids.Free;
+ Strs.Free;
+ end Finish;
+end Ortho_Ident;
diff --git a/src/ortho/mcode/ortho_ident.ads b/src/ortho/mcode/ortho_ident.ads
new file mode 100644
index 000000000..cdc42fcad
--- /dev/null
+++ b/src/ortho/mcode/ortho_ident.ads
@@ -0,0 +1,38 @@
+-- Mcode back-end for ortho.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Ortho_Code; use Ortho_Code;
+
+package Ortho_Ident is
+ subtype O_Ident is Ortho_Code.O_Ident;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Is_Equal (L, R : O_Ident) return Boolean;
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+ function Get_String (Id : O_Ident) return String;
+ function Get_String_Length (Id : O_Ident) return Natural;
+
+ -- Note: the address is valid until the next call to get_identifier.
+ function Get_Cstring (Id : O_Ident) return System.Address;
+
+ O_Ident_Nul : constant O_Ident := Ortho_Code.O_Ident_Nul;
+
+ procedure Disp_Stats;
+ procedure Finish;
+end Ortho_Ident;
diff --git a/src/ortho/mcode/ortho_jit.adb b/src/ortho/mcode/ortho_jit.adb
new file mode 100644
index 000000000..7aa9724f2
--- /dev/null
+++ b/src/ortho/mcode/ortho_jit.adb
@@ -0,0 +1,125 @@
+-- Ortho JIT implementation for mcode.
+-- 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 GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Text_IO;
+
+with Binary_File; use Binary_File;
+with Binary_File.Memory;
+with Ortho_Mcode; use Ortho_Mcode;
+with Ortho_Mcode.Jit;
+with Ortho_Code.Flags; use Ortho_Code.Flags;
+with Ortho_Code.Debug;
+with Ortho_Code.Abi;
+with Binary_File.Elf;
+
+package body Ortho_Jit is
+ Snap_Filename : GNAT.OS_Lib.String_Access := null;
+
+ -- Initialize the whole engine.
+ procedure Init is
+ begin
+ Ortho_Mcode.Init;
+ Binary_File.Memory.Write_Memory_Init;
+ end Init;
+
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ renames Ortho_Mcode.Jit.Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ renames Ortho_Mcode.Jit.Get_Address;
+
+ -- Do link.
+ procedure Link (Status : out Boolean) is
+ begin
+ if Ortho_Code.Debug.Flag_Debug_Hli then
+ -- Can't generate code in HLI.
+ Status := True;
+ return;
+ end if;
+
+ Ortho_Mcode.Finish;
+
+ Ortho_Code.Abi.Link_Intrinsics;
+
+ Binary_File.Memory.Write_Memory_Relocate (Status);
+ if Status then
+ return;
+ end if;
+
+ if Snap_Filename /= null then
+ declare
+ use Ada.Text_IO;
+ Fd : File_Descriptor;
+ begin
+ Fd := Create_File (Snap_Filename.all, Binary);
+ if Fd = Invalid_FD then
+ Put_Line (Standard_Error,
+ "can't open '" & Snap_Filename.all & "'");
+ Status := False;
+ return;
+ else
+ Binary_File.Elf.Write_Elf (Fd);
+ Close (Fd);
+ end if;
+ end;
+ end if;
+ end Link;
+
+ procedure Finish is
+ begin
+ -- Free all the memory.
+ Ortho_Mcode.Free_All;
+
+ Binary_File.Finish;
+ end Finish;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt = "-g" then
+ Flag_Debug := Debug_Dwarf;
+ return True;
+ elsif Opt'Length > 5 and then Opt (1 .. 5) = "--be-" then
+ Ortho_Code.Debug.Set_Be_Flag (Opt);
+ return True;
+ elsif Opt'Length > 7 and then Opt (1 .. 7) = "--snap=" then
+ Snap_Filename := new String'(Opt (8 .. Opt'Last));
+ return True;
+ else
+ return False;
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Help is
+ use Ada.Text_IO;
+ begin
+ Put_Line (" -g Generate debugging informations");
+ Put_Line (" --debug-be=X Set X internal debugging flags");
+ Put_Line (" --snap=FILE Write memory snapshot to FILE");
+ end Disp_Help;
+
+ function Get_Jit_Name return String is
+ begin
+ return "mcode";
+ end Get_Jit_Name;
+
+end Ortho_Jit;
diff --git a/src/ortho/mcode/ortho_mcode-jit.adb b/src/ortho/mcode/ortho_mcode-jit.adb
new file mode 100644
index 000000000..7e845cc6e
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode-jit.adb
@@ -0,0 +1,28 @@
+with Ada.Unchecked_Conversion;
+
+with Ortho_Code.Binary;
+with Binary_File; use Binary_File;
+with Binary_File.Memory;
+
+package body Ortho_Mcode.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address)
+ is
+ use Ortho_Code.Binary;
+ begin
+ Binary_File.Memory.Set_Symbol_Address
+ (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl)), Addr);
+ end Set_Address;
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address
+ is
+ use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Pc_Type, Target => Address);
+ begin
+ return Conv (Get_Symbol_Vaddr
+ (Get_Decl_Symbol (Ortho_Code.O_Dnode (Decl))));
+ end Get_Address;
+end Ortho_Mcode.Jit;
diff --git a/src/ortho/mcode/ortho_mcode-jit.ads b/src/ortho/mcode/ortho_mcode-jit.ads
new file mode 100644
index 000000000..c689a1e12
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode-jit.ads
@@ -0,0 +1,9 @@
+with System; use System;
+
+package Ortho_Mcode.Jit is
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address);
+
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address;
+end Ortho_Mcode.Jit;
diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb
new file mode 100644
index 000000000..55e890bf3
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.adb
@@ -0,0 +1,738 @@
+-- Mcode back-end for ortho.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ortho_Code.Debug;
+with Ortho_Ident;
+with Ortho_Code.Abi;
+-- with Binary_File;
+
+package body Ortho_Mcode is
+ procedure New_Debug_Comment_Stmt (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Stmt;
+
+ procedure Start_Const_Value (Const : in out O_Dnode)
+ is
+ pragma Unreferenced (Const);
+ begin
+ null;
+ end Start_Const_Value;
+
+ procedure Start_Record_Type (Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Record_Type
+ (Ortho_Code.Types.O_Element_List (Elements));
+ 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
+ Ortho_Code.Types.New_Record_Field
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Fnode (El), Ident, Ortho_Code.O_Tnode (Etype));
+ end New_Record_Field;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Record_Type
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Record_Type;
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res));
+ end New_Uncomplete_Record_Type;
+
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Uncomplete_Record_Type
+ (Ortho_Code.O_Tnode (Res),
+ Ortho_Code.Types.O_Element_List (Elements));
+ end Start_Uncomplete_Record_Type;
+
+ procedure Start_Union_Type (Elements : out O_Element_List) is
+ begin
+ Ortho_Code.Types.Start_Union_Type
+ (Ortho_Code.Types.O_Element_List (Elements));
+ 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
+ Ortho_Code.Types.New_Union_Field
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Fnode (El),
+ Ident,
+ Ortho_Code.O_Tnode (Etype));
+ end New_Union_Field;
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Union_Type
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Union_Type;
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode is
+ begin
+ return O_Tnode
+ (Ortho_Code.Types.New_Access_Type (Ortho_Code.O_Tnode (Dtype)));
+ end New_Access_Type;
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Access_Type (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Dtype));
+ end Finish_Access_Type;
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode)
+ is
+ pragma Warnings (Off, Const);
+ begin
+ New_Const_Value (Ortho_Code.O_Dnode (Const), Ortho_Code.O_Cnode (Val));
+ end Finish_Const_Value;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode is
+ begin
+ return O_Tnode
+ (Ortho_Code.Types.New_Array_Type (Ortho_Code.O_Tnode (El_Type),
+ Ortho_Code.O_Tnode (Index_Type)));
+ end New_Array_Type;
+
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode
+ is
+ Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length);
+ L_Type : Ortho_Code.O_Tnode;
+ begin
+ L_Type := Get_Const_Type (Len);
+ if Get_Type_Kind (L_Type) /= OT_Unsigned then
+ raise Syntax_Error;
+ end if;
+ return O_Tnode (New_Constrained_Array_Type
+ (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len)));
+ end New_Constrained_Array_Type;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Unsigned_Type (Size));
+ end New_Unsigned_Type;
+
+ function New_Signed_Type (Size : Natural) return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Signed_Type (Size));
+ end New_Signed_Type;
+
+ function New_Float_Type return O_Tnode is
+ begin
+ return O_Tnode (Ortho_Code.Types.New_Float_Type);
+ 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
+ begin
+ Ortho_Code.Types.New_Boolean_Type (Ortho_Code.O_Tnode (Res),
+ False_Id,
+ Ortho_Code.O_Cnode (False_E),
+ True_Id,
+ Ortho_Code.O_Cnode (True_E));
+ end New_Boolean_Type;
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) is
+ begin
+ Ortho_Code.Types.Start_Enum_Type (Ortho_Code.Types.O_Enum_List (List),
+ Size);
+ end Start_Enum_Type;
+
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode) is
+ begin
+ Ortho_Code.Types.New_Enum_Literal (Ortho_Code.Types.O_Enum_List (List),
+ Ident, Ortho_Code.O_Cnode (Res));
+ end New_Enum_Literal;
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Enum_Type (Ortho_Code.Types.O_Enum_List (List),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Enum_Type;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ To_Op : constant array (ON_Op_Kind) of Ortho_Code.ON_Op_Kind :=
+ (
+ ON_Nil => ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov => ON_Add_Ov,
+ ON_Sub_Ov => ON_Sub_Ov,
+ ON_Mul_Ov => ON_Mul_Ov,
+ ON_Div_Ov => ON_Div_Ov,
+ ON_Rem_Ov => ON_Rem_Ov,
+ ON_Mod_Ov => ON_Mod_Ov,
+
+ -- Binary operations.
+ ON_And => ON_And,
+ ON_Or => ON_Or,
+ ON_Xor => ON_Xor,
+
+ -- Monadic operations.
+ ON_Not => ON_Not,
+ ON_Neg_Ov => ON_Neg_Ov,
+ ON_Abs_Ov => ON_Abs_Ov,
+
+ -- Comparaisons
+ ON_Eq => ON_Eq,
+ ON_Neq => ON_Neq,
+ ON_Le => ON_Le,
+ ON_Lt => ON_Lt,
+ ON_Ge => ON_Ge,
+ ON_Gt => ON_Gt
+ );
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Signed_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Signed_Literal;
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Unsigned_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Unsigned_Literal;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Float_Literal (Ortho_Code.O_Tnode (Ltype),
+ Value));
+ end New_Float_Literal;
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Null_Access (Ortho_Code.O_Tnode (Ltype)));
+ end New_Null_Access;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Consts.Start_Record_Aggr
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Tnode (Atype));
+ end Start_Record_Aggr;
+
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode) is
+ begin
+ Ortho_Code.Consts.New_Record_Aggr_El
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Cnode (Value));
+ end New_Record_Aggr_El;
+
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode) is
+ begin
+ Ortho_Code.Consts.Finish_Record_Aggr
+ (Ortho_Code.Consts.O_Record_Aggr_List (List),
+ Ortho_Code.O_Cnode (Res));
+ end Finish_Record_Aggr;
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
+ is
+ begin
+ Ortho_Code.Consts.Start_Array_Aggr
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Tnode (Atype));
+ end Start_Array_Aggr;
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode) is
+ begin
+ Ortho_Code.Consts.New_Array_Aggr_El
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Cnode (Value));
+ end New_Array_Aggr_El;
+
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode) is
+ begin
+ Ortho_Code.Consts.Finish_Array_Aggr
+ (Ortho_Code.Consts.O_Array_Aggr_List (List),
+ Ortho_Code.O_Cnode (Res));
+ end Finish_Array_Aggr;
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Union_Aggr (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Fnode (Field),
+ Ortho_Code.O_Cnode (Value)));
+ end New_Union_Aggr;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Sizeof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Sizeof;
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Alignof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Alignof;
+
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Offsetof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Fnode (Field),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Offsetof;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Subprogram_Address
+ (Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype)));
+ end New_Subprogram_Address;
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Global_Address
+ (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ end New_Global_Address;
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Global_Unchecked_Address
+ (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ end New_Global_Unchecked_Address;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit)));
+ end New_Lit;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Dyadic_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Left),
+ Ortho_Code.O_Enode (Right)));
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Monadic_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Operand)));
+ end New_Monadic_Op;
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Compare_Op (To_Op (Kind),
+ Ortho_Code.O_Enode (Left),
+ Ortho_Code.O_Enode (Right),
+ Ortho_Code.O_Tnode (Ntype)));
+ end New_Compare_Op;
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Indexed_Element (Ortho_Code.O_Lnode (Arr),
+ Ortho_Code.O_Enode (Index)));
+ end New_Indexed_Element;
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Slice (Ortho_Code.O_Lnode (Arr),
+ Ortho_Code.O_Tnode (Res_Type),
+ Ortho_Code.O_Enode (Index)));
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Selected_Element (Ortho_Code.O_Lnode (Rec),
+ Ortho_Code.O_Fnode (El)));
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode is
+ begin
+ return O_Lnode
+ (Ortho_Code.Exprs.New_Access_Element (Ortho_Code.O_Enode (Acc)));
+ end New_Access_Element;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Convert_Ov (Ortho_Code.O_Enode (Val),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Convert_Ov;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Address (Ortho_Code.O_Lnode (Lvalue),
+ Ortho_Code.O_Tnode (Atype)));
+ end New_Address;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Unchecked_Address (Ortho_Code.O_Lnode (Lvalue),
+ Ortho_Code.O_Tnode (Atype)));
+ end New_Unchecked_Address;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode is
+ begin
+ return O_Enode
+ (Ortho_Code.Exprs.New_Value (Ortho_Code.O_Lnode (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_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Alloca (Ortho_Code.O_Tnode (Rtype),
+ Ortho_Code.O_Enode (Size)));
+ end New_Alloca;
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String)
+ renames Ortho_Code.Abi.New_Debug_Filename_Decl;
+
+ procedure New_Debug_Line_Decl (Line : Natural)
+ is
+ pragma Unreferenced (Line);
+ begin
+ null;
+ end New_Debug_Line_Decl;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Type_Decl (Ident, Ortho_Code.O_Tnode (Atype));
+ end New_Type_Decl;
+
+ To_Storage : constant array (O_Storage) of Ortho_Code.O_Storage :=
+ (O_Storage_External => O_Storage_External,
+ O_Storage_Public => O_Storage_Public,
+ O_Storage_Private => O_Storage_Private,
+ O_Storage_Local => O_Storage_Local);
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Const_Decl
+ (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage),
+ Ortho_Code.O_Tnode (Atype));
+ end New_Const_Decl;
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.New_Var_Decl
+ (Ortho_Code.O_Dnode (Res), Ident, To_Storage (Storage),
+ Ortho_Code.O_Tnode (Atype));
+ end New_Var_Decl;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode is
+ begin
+ return O_Lnode (Ortho_Code.Exprs.New_Obj (Ortho_Code.O_Dnode (Obj)));
+ end New_Obj;
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode) is
+ begin
+ Ortho_Code.Decls.Start_Function_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ident, To_Storage (Storage), Ortho_Code.O_Tnode (Rtype));
+ end Start_Function_Decl;
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage) is
+ begin
+ Ortho_Code.Decls.Start_Procedure_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ident, To_Storage (Storage));
+ 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
+ begin
+ Ortho_Code.Decls.New_Interface_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces),
+ Ortho_Code.O_Dnode (Res),
+ Ident,
+ Ortho_Code.O_Tnode (Atype));
+ end New_Interface_Decl;
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode) is
+ begin
+ Ortho_Code.Decls.Finish_Subprogram_Decl
+ (Ortho_Code.Decls.O_Inter_List (Interfaces), Ortho_Code.O_Dnode (Res));
+ end Finish_Subprogram_Decl;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode) is
+ begin
+ Ortho_Code.Exprs.Start_Subprogram_Body (Ortho_Code.O_Dnode (Func));
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body
+ renames Ortho_Code.Exprs.Finish_Subprogram_Body;
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural)
+ renames Ortho_Code.Exprs.New_Debug_Line_Stmt;
+
+ procedure New_Debug_Comment_Decl (Comment : String)
+ is
+ pragma Unreferenced (Comment);
+ begin
+ null;
+ end New_Debug_Comment_Decl;
+
+ procedure Start_Declare_Stmt renames
+ Ortho_Code.Exprs.Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt renames
+ Ortho_Code.Exprs.Finish_Declare_Stmt;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) is
+ begin
+ Ortho_Code.Exprs.Start_Association
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Dnode (Subprg));
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Association
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs), Ortho_Code.O_Enode (Val));
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode is
+ begin
+ return O_Enode (Ortho_Code.Exprs.New_Function_Call
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs)));
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List) is
+ begin
+ Ortho_Code.Exprs.New_Procedure_Call
+ (Ortho_Code.Exprs.O_Assoc_List (Assocs));
+ end New_Procedure_Call;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Assign_Stmt (Ortho_Code.O_Lnode (Target),
+ Ortho_Code.O_Enode (Value));
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt (Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.New_Return_Stmt (Ortho_Code.O_Enode (Value));
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt
+ renames Ortho_Code.Exprs.New_Return_Stmt;
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) is
+ begin
+ Ortho_Code.Exprs.Start_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block),
+ Ortho_Code.O_Enode (Cond));
+ end Start_If_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ Ortho_Code.Exprs.New_Else_Stmt (Ortho_Code.Exprs.O_If_Block (Block));
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_If_Stmt (Ortho_Code.Exprs.O_If_Block (Block));
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode) is
+ begin
+ Ortho_Code.Exprs.Start_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label));
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode) is
+ begin
+ Ortho_Code.Exprs.Finish_Loop_Stmt (Ortho_Code.Exprs.O_Snode (Label));
+ end Finish_Loop_Stmt;
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ begin
+ Ortho_Code.Exprs.New_Exit_Stmt (Ortho_Code.Exprs.O_Snode (L));
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ begin
+ Ortho_Code.Exprs.New_Next_Stmt (Ortho_Code.Exprs.O_Snode (L));
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) is
+ begin
+ Ortho_Code.Exprs.Start_Case_Stmt
+ (Ortho_Code.Exprs.O_Case_Block (Block), Ortho_Code.O_Enode (Value));
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Start_Choice (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Start_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) is
+ begin
+ Ortho_Code.Exprs.New_Expr_Choice (Ortho_Code.Exprs.O_Case_Block (Block),
+ Ortho_Code.O_Cnode (Expr));
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode) is
+ begin
+ Ortho_Code.Exprs.New_Range_Choice
+ (Ortho_Code.Exprs.O_Case_Block (Block),
+ Ortho_Code.O_Cnode (Low), Ortho_Code.O_Cnode (High));
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.New_Default_Choice
+ (Ortho_Code.Exprs.O_Case_Block (Block));
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_Choice (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block) is
+ begin
+ Ortho_Code.Exprs.Finish_Case_Stmt
+ (Ortho_Code.Exprs.O_Case_Block (Block));
+ end Finish_Case_Stmt;
+
+ procedure Init is
+ begin
+ -- Create an anonymous pointer type.
+ if New_Access_Type (O_Tnode_Null) /= O_Tnode (O_Tnode_Ptr) then
+ raise Program_Error;
+ end if;
+ -- Do not finish the access, since this creates an infinite recursion
+ -- in gdb (at least for GDB 6.3).
+ --Finish_Access_Type (O_Tnode_Ptr, O_Tnode_Ptr);
+ Ortho_Code.Abi.Init;
+ end Init;
+
+ procedure Finish is
+ begin
+ if False then
+ Ortho_Code.Decls.Disp_All_Decls;
+ --Ortho_Code.Exprs.Disp_All_Enode;
+ end if;
+ Ortho_Code.Abi.Finish;
+ if Debug.Flag_Debug_Stat then
+ Ada.Text_IO.Put_Line ("Statistics:");
+ Ortho_Code.Exprs.Disp_Stats;
+ Ortho_Code.Decls.Disp_Stats;
+ Ortho_Code.Types.Disp_Stats;
+ Ortho_Code.Consts.Disp_Stats;
+ Ortho_Ident.Disp_Stats;
+ -- Binary_File.Disp_Stats;
+ end if;
+ end Finish;
+
+ procedure Free_All is
+ begin
+ Ortho_Code.Types.Finish;
+ Ortho_Code.Exprs.Finish;
+ Ortho_Code.Consts.Finish;
+ Ortho_Code.Decls.Finish;
+ Ortho_Ident.Finish;
+ end Free_All;
+end Ortho_Mcode;
diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads
new file mode 100644
index 000000000..45e803690
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.ads
@@ -0,0 +1,583 @@
+-- DO NOT MODIFY - this file was generated from:
+-- ortho_nodes.common.ads and ortho_mcode.private.ads
+--
+-- Mcode back-end for ortho.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with Ortho_Code; use Ortho_Code;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+
+-- Interface to create nodes.
+package Ortho_Mcode is
+ -- Initialize nodes.
+ procedure Init;
+ procedure Finish;
+
+ procedure Free_All;
+
+-- Start of common part
+
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ type O_Tnode is private;
+ type O_Snode is private;
+ type O_Dnode is private;
+ type O_Fnode is private;
+
+ O_Cnode_Null : constant O_Cnode;
+ O_Dnode_Null : constant O_Dnode;
+ O_Enode_Null : constant O_Enode;
+ O_Fnode_Null : constant O_Fnode;
+ O_Lnode_Null : constant O_Lnode;
+ O_Snode_Null : constant O_Snode;
+ O_Tnode_Null : constant O_Tnode;
+
+ -- True if the code generated supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a boolean 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record ATYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+
+ Type_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- Line number of the next declaration.
+ procedure New_Debug_Line_Decl (Line : Natural);
+
+ -- Add a comment in the declarative region.
+ procedure New_Debug_Comment_Decl (Comment : String);
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value of a non-external constant.
+ procedure Start_Const_Value (Const : in out O_Dnode);
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- Add a comment as a statement.
+ procedure New_Debug_Comment_Stmt (Comment : String);
+
+ -- Start a declarative region.
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+-- End of common part
+private
+ -- MCode supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ type O_Tnode is new Ortho_Code.O_Tnode;
+ type O_Cnode is new Ortho_Code.O_Cnode;
+ type O_Dnode is new Ortho_Code.O_Dnode;
+ type O_Enode is new Ortho_Code.O_Enode;
+ type O_Fnode is new Ortho_Code.O_Fnode;
+ type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Snode is new Ortho_Code.Exprs.O_Snode;
+
+ O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
+ O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null);
+ O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
+
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Dyadic_Op);
+ pragma Inline (New_Monadic_Op);
+ pragma Inline (New_Compare_Op);
+ pragma Inline (New_Signed_Literal);
+ pragma Inline (New_Unsigned_Literal);
+ pragma Inline (New_Float_Literal);
+ pragma Inline (New_Null_Access);
+
+ pragma Inline (Start_Record_Aggr);
+ pragma Inline (New_Record_Aggr_El);
+ pragma Inline (Finish_Record_Aggr);
+
+ pragma Inline (Start_Array_Aggr);
+ pragma Inline (New_Array_Aggr_El);
+ pragma Inline (Finish_Array_Aggr);
+
+ pragma Inline (New_Union_Aggr);
+ pragma Inline (New_Sizeof);
+ pragma Inline (New_Alignof);
+ pragma Inline (New_Offsetof);
+
+ pragma Inline (New_Indexed_Element);
+ pragma Inline (New_Slice);
+ pragma Inline (New_Selected_Element);
+ pragma Inline (New_Access_Element);
+
+ pragma Inline (New_Convert_Ov);
+
+ pragma Inline (New_Address);
+ pragma Inline (New_Global_Address);
+ pragma Inline (New_Unchecked_Address);
+ pragma Inline (New_Global_Unchecked_Address);
+ pragma Inline (New_Subprogram_Address);
+
+ pragma Inline (New_Value);
+ pragma Inline (New_Obj_Value);
+
+ pragma Inline (New_Alloca);
+
+ pragma Inline (New_Debug_Filename_Decl);
+ pragma Inline (New_Debug_Line_Decl);
+ pragma Inline (New_Debug_Comment_Decl);
+
+ pragma Inline (New_Type_Decl);
+ pragma Inline (New_Const_Decl);
+
+ pragma Inline (Start_Const_Value);
+ pragma Inline (Finish_Const_Value);
+ pragma Inline (New_Var_Decl);
+
+ pragma Inline (New_Obj);
+ pragma Inline (Start_Function_Decl);
+ pragma Inline (Start_Procedure_Decl);
+ pragma Inline (New_Interface_Decl);
+ pragma Inline (Finish_Subprogram_Decl);
+ pragma Inline (Start_Subprogram_Body);
+ pragma Inline (Finish_Subprogram_Body);
+
+ pragma Inline (New_Debug_Line_Stmt);
+ pragma Inline (New_Debug_Comment_Stmt);
+
+ pragma Inline (Start_Declare_Stmt);
+ pragma Inline (Finish_Declare_Stmt);
+
+ -- Create a function call or a procedure call.
+ pragma Inline (Start_Association);
+ pragma Inline (New_Association);
+ pragma Inline (New_Function_Call);
+ pragma Inline (New_Procedure_Call);
+
+ pragma Inline (New_Assign_Stmt);
+ pragma Inline (New_Return_Stmt);
+ pragma Inline (Start_If_Stmt);
+ pragma Inline (New_Else_Stmt);
+ pragma Inline (Finish_If_Stmt);
+
+ pragma Inline (Start_Loop_Stmt);
+ pragma Inline (Finish_Loop_Stmt);
+ pragma Inline (New_Exit_Stmt);
+ pragma Inline (New_Next_Stmt);
+
+ pragma Inline (Start_Case_Stmt);
+ pragma Inline (Start_Choice);
+ pragma Inline (New_Expr_Choice);
+ pragma Inline (New_Range_Choice);
+ pragma Inline (New_Default_Choice);
+ pragma Inline (Finish_Choice);
+ pragma Inline (Finish_Case_Stmt);
+end Ortho_Mcode;
diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads
new file mode 100644
index 000000000..1b414773f
--- /dev/null
+++ b/src/ortho/mcode/ortho_mcode.private.ads
@@ -0,0 +1,151 @@
+-- Mcode back-end for ortho.
+-- Copyright (C) 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with Ortho_Code; use Ortho_Code;
+with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Consts; use Ortho_Code.Consts;
+with Ortho_Code.Decls; use Ortho_Code.Decls;
+with Ortho_Code.Exprs; use Ortho_Code.Exprs;
+
+-- Interface to create nodes.
+package Ortho_Mcode is
+ -- Initialize nodes.
+ procedure Init;
+ procedure Finish;
+
+ procedure Free_All;
+
+private
+ -- MCode supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ type O_Tnode is new Ortho_Code.O_Tnode;
+ type O_Cnode is new Ortho_Code.O_Cnode;
+ type O_Dnode is new Ortho_Code.O_Dnode;
+ type O_Enode is new Ortho_Code.O_Enode;
+ type O_Fnode is new Ortho_Code.O_Fnode;
+ type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Snode is new Ortho_Code.Exprs.O_Snode;
+
+ O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
+ O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
+ O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
+ O_Fnode_Null : constant O_Fnode := O_Fnode (Ortho_Code.O_Fnode_Null);
+ O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
+ O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
+
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+
+ pragma Inline (New_Lit);
+ pragma Inline (New_Dyadic_Op);
+ pragma Inline (New_Monadic_Op);
+ pragma Inline (New_Compare_Op);
+ pragma Inline (New_Signed_Literal);
+ pragma Inline (New_Unsigned_Literal);
+ pragma Inline (New_Float_Literal);
+ pragma Inline (New_Null_Access);
+
+ pragma Inline (Start_Record_Aggr);
+ pragma Inline (New_Record_Aggr_El);
+ pragma Inline (Finish_Record_Aggr);
+
+ pragma Inline (Start_Array_Aggr);
+ pragma Inline (New_Array_Aggr_El);
+ pragma Inline (Finish_Array_Aggr);
+
+ pragma Inline (New_Union_Aggr);
+ pragma Inline (New_Sizeof);
+ pragma Inline (New_Alignof);
+ pragma Inline (New_Offsetof);
+
+ pragma Inline (New_Indexed_Element);
+ pragma Inline (New_Slice);
+ pragma Inline (New_Selected_Element);
+ pragma Inline (New_Access_Element);
+
+ pragma Inline (New_Convert_Ov);
+
+ pragma Inline (New_Address);
+ pragma Inline (New_Global_Address);
+ pragma Inline (New_Unchecked_Address);
+ pragma Inline (New_Global_Unchecked_Address);
+ pragma Inline (New_Subprogram_Address);
+
+ pragma Inline (New_Value);
+ pragma Inline (New_Obj_Value);
+
+ pragma Inline (New_Alloca);
+
+ pragma Inline (New_Debug_Filename_Decl);
+ pragma Inline (New_Debug_Line_Decl);
+ pragma Inline (New_Debug_Comment_Decl);
+
+ pragma Inline (New_Type_Decl);
+ pragma Inline (New_Const_Decl);
+
+ pragma Inline (Start_Const_Value);
+ pragma Inline (Finish_Const_Value);
+ pragma Inline (New_Var_Decl);
+
+ pragma Inline (New_Obj);
+ pragma Inline (Start_Function_Decl);
+ pragma Inline (Start_Procedure_Decl);
+ pragma Inline (New_Interface_Decl);
+ pragma Inline (Finish_Subprogram_Decl);
+ pragma Inline (Start_Subprogram_Body);
+ pragma Inline (Finish_Subprogram_Body);
+
+ pragma Inline (New_Debug_Line_Stmt);
+ pragma Inline (New_Debug_Comment_Stmt);
+
+ pragma Inline (Start_Declare_Stmt);
+ pragma Inline (Finish_Declare_Stmt);
+
+ -- Create a function call or a procedure call.
+ pragma Inline (Start_Association);
+ pragma Inline (New_Association);
+ pragma Inline (New_Function_Call);
+ pragma Inline (New_Procedure_Call);
+
+ pragma Inline (New_Assign_Stmt);
+ pragma Inline (New_Return_Stmt);
+ pragma Inline (Start_If_Stmt);
+ pragma Inline (New_Else_Stmt);
+ pragma Inline (Finish_If_Stmt);
+
+ pragma Inline (Start_Loop_Stmt);
+ pragma Inline (Finish_Loop_Stmt);
+ pragma Inline (New_Exit_Stmt);
+ pragma Inline (New_Next_Stmt);
+
+ pragma Inline (Start_Case_Stmt);
+ pragma Inline (Start_Choice);
+ pragma Inline (New_Expr_Choice);
+ pragma Inline (New_Range_Choice);
+ pragma Inline (New_Default_Choice);
+ pragma Inline (Finish_Choice);
+ pragma Inline (Finish_Case_Stmt);
+end Ortho_Mcode;
diff --git a/src/ortho/mcode/ortho_nodes.ads b/src/ortho/mcode/ortho_nodes.ads
new file mode 100644
index 000000000..7a2df3f30
--- /dev/null
+++ b/src/ortho/mcode/ortho_nodes.ads
@@ -0,0 +1,2 @@
+with Ortho_Mcode;
+package Ortho_Nodes renames Ortho_Mcode;
diff --git a/src/ortho/oread/Makefile b/src/ortho/oread/Makefile
new file mode 100644
index 000000000..f94535181
--- /dev/null
+++ b/src/ortho/oread/Makefile
@@ -0,0 +1,43 @@
+# -*- Makefile -*- for the ortho-code compiler.
+# 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 = gcc
+ortho_srcdir=..
+BACK_END=$(ortho_srcdir)/$(BE)
+ortho_exec=oread-$(BE)
+
+all: $(ortho_exec)
+
+test: test.s
+ $(CC) -o $@ $^
+
+test.s: $(ortho_exec)
+ ./$(ortho_exec) test
+
+$(ortho_exec): force
+ $(MAKE) -f $(BACK_END)/Makefile ortho_exec=$(ortho_exec)
+
+clean:
+ $(MAKE) -f $(BACK_END)/Makefile clean
+ $(RM) -f oread-gcc oread-mcode *.o *~
+
+distclean: clean
+ $(MAKE) -f $(BACK_END)/Makefile distclean
+
+force:
+
+.PHONY: force
diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb
new file mode 100644
index 000000000..84bbd1b9d
--- /dev/null
+++ b/src/ortho/oread/ortho_front.adb
@@ -0,0 +1,2677 @@
+-- Ortho code compiler.
+-- 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;
+with Ortho_Nodes; use Ortho_Nodes;
+with Ortho_Ident; use Ortho_Ident;
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Interfaces; use Interfaces;
+with Ada.Exceptions;
+--with GNAT.Debug_Pools;
+
+-- TODO:
+-- uncomplete type: check for type redefinition
+
+package body Ortho_Front is
+ -- If true, emit line number before each statement.
+ -- If flase, keep line number indication in the source file.
+ Flag_Renumber : Boolean := True;
+
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural
+ is
+ pragma Unreferenced (Arg);
+ begin
+ if Opt.all = "-r" or Opt.all = "--ghdl-r" then
+ Flag_Renumber := True;
+ return 1;
+ else
+ return 0;
+ end if;
+ end Decode_Option;
+
+ -- File buffer.
+ File_Name : String_Acc;
+ Buf : String (1 .. 2048 + 1);
+ Buf_Len : Natural;
+ Pos : Natural;
+ Lineno : Natural;
+
+ Fd : File_Descriptor;
+
+ Error : exception;
+
+ procedure Puterr (Msg : String)
+ is
+ L : Integer;
+ pragma Unreferenced (L);
+ begin
+ L := Write (Standerr, Msg'Address, Msg'Length);
+ end Puterr;
+
+ procedure Puterr (N : Natural)
+ is
+ Str : constant String := Natural'Image (N);
+ begin
+ Puterr (Str (Str'First + 1 .. Str'Last));
+ end Puterr;
+
+ procedure Newline_Err is
+ begin
+ Puterr ((1 => LF));
+ end Newline_Err;
+
+ procedure Scan_Error (Msg : String) is
+ begin
+ Puterr (File_Name.all);
+ Puterr (":");
+ Puterr (Lineno);
+ Puterr (": ");
+ Puterr (Msg);
+ Newline_Err;
+ raise Error;
+ end Scan_Error;
+
+ procedure Parse_Error (Msg : String);
+ pragma No_Return (Parse_Error);
+
+ procedure Parse_Error (Msg : String) is
+ begin
+ Puterr (File_Name.all);
+ Puterr (":");
+ Puterr (Lineno);
+ Puterr (": ");
+ Puterr (Msg);
+ Newline_Err;
+ raise Error;
+ end Parse_Error;
+
+
+-- Uniq_Num : Natural := 0;
+
+-- function Get_Uniq_Id return O_Ident
+-- is
+-- Str : String (1 .. 8);
+-- V : Natural;
+-- begin
+-- V := Uniq_Num;
+-- Uniq_Num := Uniq_Num + 1;
+-- Str (1) := 'L';
+-- Str (2) := '.';
+-- for I in reverse 3 .. Str'Last loop
+-- Str (I) := Character'Val ((V mod 10) + Character'Pos('0'));
+-- V := V / 10;
+-- end loop;
+-- return Get_Identifier (Str);
+-- end Get_Uniq_Id;
+
+ -- Get the next character.
+ -- Return NUL on end of file.
+ function Get_Char return Character
+ is
+ Res : Character;
+ begin
+ if Buf (Pos) = NUL then
+ -- Read line.
+ Buf_Len := Read (Fd, Buf'Address, Buf'Length - 1);
+ if Buf_Len = 0 then
+ -- End of file.
+ return NUL;
+ end if;
+ Pos := 1;
+ Buf (Buf_Len + 1) := NUL;
+ end if;
+
+ Res := Buf (Pos);
+ Pos := Pos + 1;
+ return Res;
+ end Get_Char;
+
+ procedure Unget_Char is
+ begin
+ if Pos = Buf'First then
+ raise Program_Error;
+ end if;
+ Pos := Pos - 1;
+ end Unget_Char;
+
+ type Token_Type is
+ (Tok_Eof,
+ Tok_Line_Number, Tok_File_Name, Tok_Comment,
+ Tok_Ident, Tok_Num, Tok_String, Tok_Float_Num,
+ Tok_Plus, Tok_Minus,
+ Tok_Star, Tok_Div, Tok_Mod, Tok_Rem,
+ Tok_Sharp,
+ Tok_Not, Tok_Abs,
+ Tok_Or, Tok_And, Tok_Xor,
+ Tok_Equal, Tok_Not_Equal,
+ Tok_Greater, Tok_Greater_Eq,
+ Tok_Less, Tok_Less_Eq,
+ Tok_Colon, Tok_Semicolon,
+ Tok_Comma, Tok_Dot, Tok_Tick, Tok_Arob, Tok_Elipsis,
+ Tok_Assign,
+ Tok_Left_Paren, Tok_Right_Paren,
+ Tok_Left_Brace, Tok_Right_Brace,
+ Tok_Left_Brack, Tok_Right_Brack,
+ Tok_Unsigned, Tok_Signed, Tok_Float,
+ Tok_Array, Tok_Subarray,
+ Tok_Access, Tok_Record, Tok_Union,
+ Tok_Boolean, Tok_Enum,
+ Tok_If, Tok_Then, Tok_Else, Tok_Elsif,
+ Tok_Loop, Tok_Exit, Tok_Next,
+ Tok_Is, Tok_Of, Tok_All,
+ Tok_Return,
+ Tok_Type,
+ Tok_External, Tok_Private, Tok_Public, Tok_Local,
+ Tok_Procedure, Tok_Function,
+ Tok_Constant, Tok_Var,
+ Tok_Declare, Tok_Begin, Tok_End,
+ Tok_Case, Tok_When, Tok_Default, Tok_Arrow,
+ Tok_Null);
+
+ type Hash_Type is new Unsigned_32;
+
+ type Name_Type;
+ type Name_Acc is access Name_Type;
+
+ -- Symbol table.
+ type Syment_Type;
+ type Syment_Acc is access Syment_Type;
+ type Syment_type is record
+ -- The hash for the symbol.
+ Hash : Hash_Type;
+ -- Identification of the symbol.
+ Ident : O_Ident;
+ -- Next symbol with the same collision.
+ Next : Syment_Acc;
+ -- Meaning of the symbol.
+ Name : Name_Acc;
+ end record;
+
+ -- Well known identifiers (used for attributes).
+ Id_Address : Syment_Acc;
+ Id_Unchecked_Address : Syment_Acc;
+ Id_Subprg_Addr : Syment_Acc;
+ Id_Conv : Syment_Acc;
+ Id_Sizeof : Syment_Acc;
+ Id_Alignof : Syment_Acc;
+ Id_Alloca : Syment_Acc;
+ Id_Offsetof : Syment_Acc;
+
+ Token_Number : Unsigned_64;
+ Token_Float : IEEE_Float_64;
+ Token_Ident : String (1 .. 256);
+ Token_Idlen : Natural;
+ Token_Hash : Hash_Type;
+ Token_Sym : Syment_Acc;
+
+ -- The symbol table.
+ type Syment_Acc_Array is array (Hash_Type range <>) of Syment_Acc;
+ Hash_Max : constant Hash_Type := 511;
+ Symtable : Syment_Acc_Array (0 .. Hash_Max - 1) := (others => null);
+
+ type Node_Kind is (Decl_Keyword, Decl_Type, Decl_Param,
+ Node_Function, Node_Procedure, Node_Object, Node_Field,
+ Node_Lit,
+ Type_Boolean, Type_Enum,
+ Type_Unsigned, Type_Signed, Type_Float,
+ Type_Array, Type_Subarray,
+ Type_Access, Type_Record, Type_Union);
+ subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure;
+
+ type Node (<>);
+ type Node_Acc is access Node;
+ type Node (Kind : Node_Kind) is record
+ case Kind is
+ when Decl_Keyword =>
+ -- Keyword.
+ -- A keyword is not a declaration since the identifier has only
+ -- one meaning (the keyword).
+ Keyword : Token_Type;
+ when Decl_Type
+ | Decl_Param
+ | Node_Function
+ | Node_Procedure
+ | Node_Object
+ | Node_Lit =>
+ -- Declarations
+ -- All declarations but NODE_PROCEDURE have a type.
+ Decl_Dtype : Node_Acc;
+ Decl_Storage : O_Storage;
+ case Kind is
+ when Decl_Type =>
+ -- Type declaration.
+ null;
+ when Decl_Param =>
+ -- Parameter identifier.
+ Param_Name : Syment_Acc;
+ -- Parameter ortho node.
+ Param_Node : O_Dnode;
+ -- Next parameter of the parameters list.
+ Param_Next : Node_Acc;
+ when Node_Procedure
+ | Node_Function =>
+ -- Subprogram symbol name.
+ Subprg_Name : Syment_Acc;
+ -- List of parameters.
+ Subprg_Params : Node_Acc;
+ -- Subprogram ortho node.
+ Subprg_Node : O_Dnode;
+ when Node_Object =>
+ -- Name of the object (constant, variable).
+ Obj_Name : O_Ident;
+ -- Ortho node of the object.
+ Obj_Node : O_Dnode;
+ when Node_Lit =>
+ -- Name of the literal.
+ Lit_Name : O_Ident;
+ -- Enum literal
+ Lit_Cnode : O_Cnode;
+ -- Next literal for the type.
+ Lit_Next : Node_Acc;
+ when others =>
+ null;
+ end case;
+ when Node_Field =>
+ -- Record field.
+ Field_Ident : Syment_Acc;
+ Field_Fnode : O_Fnode;
+ Field_Type : Node_Acc;
+ Field_Next : Node_Acc;
+ when Type_Signed
+ | Type_Unsigned
+ | Type_Float
+ | Type_Array
+ | Type_Subarray
+ | Type_Record
+ | Type_Union
+ | Type_Access
+ | Type_Boolean
+ | Type_Enum =>
+ -- Ortho node type.
+ Type_Onode : O_Tnode;
+ case Kind is
+ when Type_Array =>
+ Array_Index : Node_Acc;
+ Array_Element : Node_Acc;
+ when Type_Subarray =>
+ Subarray_Base : Node_Acc;
+ --Subarray_Length : Natural;
+ when Type_Access =>
+ Access_Dtype : Node_Acc;
+ when Type_Record
+ | Type_Union =>
+ Record_Union_Fields : Node_Acc;
+ when Type_Enum
+ | Type_Boolean =>
+ Enum_Lits : Node_Acc;
+ when Type_Float =>
+ null;
+ when others =>
+ null;
+ end case;
+ end case;
+ end record;
+
+ type Scope_Type;
+ type Scope_Acc is access Scope_Type;
+
+ type Name_Type is record
+ -- Current interpretation of the symbol.
+ Inter : Node_Acc;
+ -- Next declaration in the current scope.
+ Next : Syment_Acc;
+ -- Interpretation in a previous scope.
+ Up : Name_Acc;
+ -- Current scope.
+ Scope : Scope_Acc;
+ end record;
+
+ type Scope_Type is record
+ -- Simply linked list of names.
+ Names : Syment_Acc;
+ -- Previous scope.
+ Prev : Scope_Acc;
+ end record;
+
+ -- Return the current declaration for symbol SYM.
+ function Get_Decl (Sym : Syment_Acc) return Node_Acc;
+ pragma Inline (Get_Decl);
+
+ procedure Scan_Char (C : Character)
+ is
+ R : Character;
+ begin
+
+ if C = '\' then
+ R := Get_Char;
+ case R is
+ when 'n' =>
+ R := LF;
+ when 'r' =>
+ R := CR;
+ when ''' =>
+ R := ''';
+ when '"' => -- "
+ R := '"'; -- "
+ when others =>
+ Scan_Error ("bad character sequence \" & R);
+ end case;
+ else
+ R := C;
+ end if;
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := R;
+ end Scan_Char;
+
+ function Get_Hash (Str : String) return Hash_Type
+ is
+ Res : Hash_Type;
+ begin
+ Res := 0;
+ for I in Str'Range loop
+ Res := Res * 31 + Character'Pos (Str (I));
+ end loop;
+ return Res;
+ end Get_Hash;
+
+ -- Previous token.
+ Tok_Previous : Token_Type;
+
+ function Scan_Number (First_Char : Character) return Token_Type
+ is
+ function To_Digit (C : Character) return Integer is
+ begin
+ case C is
+ when '0' .. '9' =>
+ return Character'Pos (C) - Character'Pos ('0');
+ when 'A' .. 'F' =>
+ return Character'Pos (C) - Character'Pos ('A') + 10;
+ when 'a' .. 'f' =>
+ return Character'Pos (C) - Character'Pos ('a') + 10;
+ when others =>
+ return -1;
+ end case;
+ end To_Digit;
+
+ function Is_Digit (C : Character) return Boolean is
+ begin
+ case C is
+ when '0' .. '9'
+ | 'A' .. 'F'
+ | 'a' .. 'f' =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Digit;
+
+ After_Point : Integer;
+ C : Character;
+ Exp : Integer;
+ Exp_Neg : Boolean;
+ Base : Unsigned_64;
+ begin
+ Token_Number := 0;
+ C := First_Char;
+ loop
+ Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C));
+ C := Get_Char;
+ exit when not Is_Digit (C);
+ end loop;
+ if C = '#' then
+ Base := Token_Number;
+ Token_Number := 0;
+ C := Get_Char;
+ loop
+ Token_Number := Token_Number * Base + Unsigned_64 (To_Digit (C));
+ C := Get_Char;
+ exit when C = '#';
+ end loop;
+ return Tok_Num;
+ end if;
+ if C = '.' then
+ -- A real number.
+ After_Point := 0;
+ Token_Float := IEEE_Float_64 (Token_Number);
+ loop
+ C := Get_Char;
+ exit when C not in '0' .. '9';
+ Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C));
+ After_Point := After_Point + 1;
+ end loop;
+ if C = 'e' or C = 'E' then
+ Exp := 0;
+ C := Get_Char;
+ Exp_Neg := False;
+ if C = '-' then
+ Exp_Neg := True;
+ C := Get_Char;
+ elsif C = '+' then
+ C := Get_Char;
+ elsif not Is_Digit (C) then
+ Scan_Error ("digit expected");
+ end if;
+ while Is_Digit (C) loop
+ Exp := Exp * 10 + To_Digit (C);
+ C := Get_Char;
+ end loop;
+ if Exp_Neg then
+ Exp := -Exp;
+ end if;
+ Exp := Exp - After_Point;
+ else
+ Exp := - After_Point;
+ end if;
+ Unget_Char;
+ Token_Float := Token_Float * 10.0 ** Exp;
+ if Token_Float > IEEE_Float_64'Last then
+ Token_Float := IEEE_Float_64'Last;
+ end if;
+ return Tok_Float_Num;
+ else
+ Unget_Char;
+ return Tok_Num;
+ end if;
+ end Scan_Number;
+
+ procedure Scan_Comment
+ is
+ C : Character;
+ begin
+ Token_Idlen := 0;
+ loop
+ C := Get_Char;
+ exit when C = CR or C = LF;
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := C;
+ end loop;
+ Unget_Char;
+ end Scan_Comment;
+
+ -- Get the next token.
+ function Get_Token return Token_Type
+ is
+ C : Character;
+ begin
+ loop
+
+ C := Get_Char;
+ << Again >> null;
+ case C is
+ when NUL =>
+ return Tok_Eof;
+ when ' ' | HT =>
+ null;
+ when LF =>
+ Lineno := Lineno + 1;
+ C := Get_Char;
+ if C /= CR then
+ goto Again;
+ end if;
+ when CR =>
+ Lineno := Lineno + 1;
+ C := Get_Char;
+ if C /= LF then
+ goto Again;
+ end if;
+ when '+' =>
+ return Tok_Plus;
+ when '-' =>
+ C := Get_Char;
+ if C = '-' then
+ C := Get_Char;
+ if C = '#' then
+ return Tok_Line_Number;
+ elsif C = 'F' then
+ Scan_Comment;
+ return Tok_File_Name;
+ elsif C = ' ' then
+ Scan_Comment;
+ return Tok_Comment;
+ else
+ Scan_Error ("bad comment");
+ end if;
+ else
+ Unget_Char;
+ return Tok_Minus;
+ end if;
+ when '/' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Not_Equal;
+ else
+ Unget_Char;
+ return Tok_Div;
+ end if;
+ when '*' =>
+ return Tok_Star;
+ when '#' =>
+ return Tok_Sharp;
+ when '=' =>
+ C := Get_Char;
+ if C = '>' then
+ return Tok_Arrow;
+ else
+ Unget_Char;
+ return Tok_Equal;
+ end if;
+ when '>' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Greater_Eq;
+ else
+ Unget_Char;
+ return Tok_Greater;
+ end if;
+ when '(' =>
+ return Tok_Left_Paren;
+ when ')' =>
+ return Tok_Right_Paren;
+ when '{' =>
+ return Tok_Left_Brace;
+ when '}' =>
+ return Tok_Right_Brace;
+ when '[' =>
+ return Tok_Left_Brack;
+ when ']' =>
+ return Tok_Right_Brack;
+ when '<' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Less_Eq;
+ else
+ Unget_Char;
+ return Tok_Less;
+ end if;
+ when ':' =>
+ C := Get_Char;
+ if C = '=' then
+ return Tok_Assign;
+ else
+ Unget_Char;
+ return Tok_Colon;
+ end if;
+ when '.' =>
+ C := Get_Char;
+ if C = '.' then
+ C := Get_Char;
+ if C = '.' then
+ return Tok_Elipsis;
+ else
+ Scan_Error ("'...' expected");
+ end if;
+ else
+ Unget_Char;
+ return Tok_Dot;
+ end if;
+ when ';' =>
+ return Tok_Semicolon;
+ when ',' =>
+ return Tok_Comma;
+ when '@' =>
+ return Tok_Arob;
+ when ''' =>
+ if Tok_Previous = Tok_Ident then
+ return Tok_Tick;
+ else
+ Token_Number := Character'Pos (Get_Char);
+ C := Get_Char;
+ if C /= ''' then
+ Scan_Error ("ending single quote expected");
+ end if;
+ return Tok_Num;
+ end if;
+ when '"' => -- "
+ -- Eat double quote.
+ C := Get_Char;
+ Token_Idlen := 0;
+ loop
+ Scan_Char (C);
+ C := Get_Char;
+ exit when C = '"'; -- "
+ end loop;
+ return Tok_String;
+ when '0' .. '9' =>
+ return Scan_Number (C);
+ when 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '_' =>
+ Token_Idlen := 0;
+ Token_Hash := 0;
+ loop
+ Token_Idlen := Token_Idlen + 1;
+ Token_Ident (Token_Idlen) := C;
+ Token_Hash := Token_Hash * 31 + Character'Pos (C);
+ C := Get_Char;
+ exit when (C < 'A' or C > 'Z')
+ and (C < 'a' or C > 'z')
+ and (C < '0' or C > '9')
+ and (C /= '_');
+ end loop;
+ Unget_Char;
+ declare
+ H : Hash_Type;
+ S : Syment_Acc;
+ N : Node_Acc;
+ begin
+ H := Token_Hash mod Hash_Max;
+ S := Symtable (H);
+ while S /= null loop
+ if S.Hash = Token_Hash
+ and then Is_Equal (S.Ident,
+ Token_Ident (1 .. Token_Idlen))
+ then
+ -- This identifier is known.
+ Token_Sym := S;
+
+ -- It may be a keyword.
+ if S.Name /= null then
+ N := Get_Decl (S);
+ if N.Kind = Decl_Keyword then
+ return N.Keyword;
+ end if;
+ end if;
+
+ return Tok_Ident;
+ end if;
+ S := S.Next;
+ end loop;
+ Symtable (H) := new Syment_Type'
+ (Hash => Token_Hash,
+ Ident => Get_Identifier (Token_Ident (1 .. Token_Idlen)),
+ Next => Symtable (H),
+ Name => null);
+ Token_Sym := Symtable (H);
+ return Tok_Ident;
+ end;
+ when others =>
+ Scan_Error ("Bad character:"
+ & Integer'Image (Character'Pos (C))
+ & C);
+ return Tok_Eof;
+ end case;
+ end loop;
+ end Get_Token;
+
+ -- The current token.
+ Tok : Token_Type;
+
+ procedure Next_Token is
+ begin
+ Tok_Previous := Tok;
+ Tok := Get_Token;
+ end Next_Token;
+
+ procedure Expect (T : Token_Type; Msg : String := "") is
+ begin
+ if Tok /= T then
+ if Msg'Length = 0 then
+ case T is
+ when Tok_Left_Brace =>
+ Parse_Error ("'{' expected");
+ when others =>
+ if Tok = Tok_Ident then
+ Parse_Error
+ (Token_Type'Image (T) & " expected, found '" &
+ Token_Ident (1 .. Token_Idlen) & "'");
+ else
+ Parse_Error (Token_Type'Image (T) & " expected, found "
+ & Token_Type'Image (Tok));
+ end if;
+ end case;
+ else
+ Parse_Error (Msg);
+ end if;
+ end if;
+ end Expect;
+
+ procedure Next_Expect (T : Token_Type; Msg : String := "") is
+ begin
+ Next_Token;
+ Expect (T, Msg);
+ end Next_Expect;
+
+ -- Scopes and identifiers.
+
+
+ -- Current scope.
+ Scope : Scope_Acc := null;
+
+ -- Add a declaration for symbol SYM in the current scope.
+ -- INTER defines the meaning of the declaration.
+ -- There must be at most one declaration for a symbol in the current scope,
+ -- i.e. a symbol cannot be redefined.
+ procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc);
+
+ -- Return TRUE iff SYM is already defined in the current scope.
+ function Is_Defined (Sym : Syment_Acc) return Boolean;
+
+ -- Create new scope.
+ procedure Push_Scope;
+
+ -- Close the current scope. Symbols defined in the scope regain their
+ -- previous declaration.
+ procedure Pop_Scope;
+
+
+ procedure Push_Scope
+ is
+ Nscope : Scope_Acc;
+ begin
+ Nscope := new Scope_Type'(Names => null, Prev => Scope);
+ Scope := Nscope;
+ end Push_Scope;
+
+ procedure Pop_Scope
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Name_Type, Name => Name_Acc);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Scope_Type, Name => Scope_Acc);
+
+ Sym : Syment_Acc;
+ N_Sym : Syment_Acc;
+ Name : Name_Acc;
+ Old_Scope : Scope_Acc;
+ begin
+ Sym := Scope.Names;
+ while Sym /= null loop
+ Name := Sym.Name;
+ -- Check.
+ if Name.Scope /= Scope then
+ raise Program_Error;
+ end if;
+
+ -- Set the interpretation of this symbol.
+ Sym.Name := Name.Up;
+
+ N_Sym := Name.Next;
+
+ Free (Name);
+ Sym := N_Sym;
+ end loop;
+
+ -- Free scope.
+ Old_Scope := Scope;
+ Scope := Scope.Prev;
+ Free (Old_Scope);
+ end Pop_Scope;
+
+ function Is_Defined (Sym : Syment_Acc) return Boolean is
+ begin
+ if Sym.Name /= null
+ and then Sym.Name.Scope = Scope
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Defined;
+
+ function New_Symbol (Str : String) return Syment_Acc
+ is
+ Ent : Syment_Acc;
+ H : Hash_Type;
+ begin
+ Ent := new Syment_Type'(Hash => Get_Hash (Str),
+ Ident => Get_Identifier (Str),
+ Next => null,
+ Name => null);
+ H := Ent.Hash mod Hash_Max;
+ Ent.Next := Symtable (H);
+ Symtable (H) := Ent;
+ return Ent;
+ end New_Symbol;
+
+ procedure Add_Keyword (Str : String; Token : Token_Type)
+ is
+ Ent : Syment_Acc;
+ begin
+ Ent := New_Symbol (Str);
+ if Ent.Name /= null
+ or else Scope /= null
+ then
+ -- Redefinition of a keyword.
+ raise Program_Error;
+ end if;
+ Ent.Name := new Name_Type'(Inter => new Node'(Kind => Decl_Keyword,
+ Keyword => Token),
+ Next => null,
+ Up => null,
+ Scope => null);
+ end Add_Keyword;
+
+ procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc)
+ is
+ Name : Name_Acc;
+ Prev : Node_Acc;
+ begin
+ Name := Sym.Name;
+ if Name /= null and then Name.Scope = Scope then
+ Prev := Name.Inter;
+ if Prev.Kind = Inter.Kind
+ and then Prev.Decl_Dtype = Inter.Decl_Dtype
+ and then Prev.Decl_Storage = O_Storage_External
+ and then Inter.Decl_Storage = O_Storage_Public
+ then
+ -- Redefinition
+ Name.Inter := Inter;
+ return;
+ end if;
+ Parse_Error ("redefinition of " & Get_String (Sym.Ident));
+ end if;
+ Name := new Name_Type'(Inter => Inter,
+ Next => Scope.Names,
+ Up => Sym.Name,
+ Scope => Scope);
+ Sym.Name := Name;
+ Scope.Names := Sym;
+ end Add_Decl;
+
+ function Get_Decl (Sym : Syment_Acc) return Node_Acc is
+ begin
+ if Sym.Name = null then
+ Parse_Error ("undefined identifier " & Get_String (Sym.Ident));
+ else
+ return Sym.Name.Inter;
+ end if;
+ end Get_Decl;
+
+ function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode;
+ function Parse_Address (Prefix : Node_Acc) return O_Enode;
+ function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode;
+ procedure Parse_Declaration;
+ procedure Parse_Compound_Statement;
+
+ function Parse_Type return Node_Acc;
+
+ procedure Parse_Fields (Aggr_Type : Node_Acc;
+ Constr : in out O_Element_List)
+ is
+ F_Type : Node_Acc;
+ F : Syment_Acc;
+ Last_Field : Node_Acc;
+ Field : Node_Acc;
+ begin
+ Last_Field := null;
+ loop
+ exit when Tok = Tok_End;
+
+ if Tok /= Tok_Ident then
+ Parse_Error ("field name expected");
+ end if;
+ F := Token_Sym;
+ Next_Expect (Tok_Colon, "':' expected");
+ Next_Token;
+ F_Type := Parse_Type;
+ Field := new Node'(Kind => Node_Field,
+ Field_Ident => F,
+ Field_Fnode => O_Fnode_Null,
+ Field_Type => F_Type,
+ Field_Next => null);
+ case Aggr_Type.Kind is
+ when Type_Record =>
+ New_Record_Field (Constr, Field.Field_Fnode, F.Ident,
+ F_Type.Type_Onode);
+ when Type_Union =>
+ New_Union_Field (Constr, Field.Field_Fnode, F.Ident,
+ F_Type.Type_Onode);
+ when others =>
+ raise Program_Error;
+ end case;
+ if Last_Field = null then
+ Aggr_Type.Record_Union_Fields := Field;
+ else
+ Last_Field.Field_Next := Field;
+ end if;
+ Last_Field := Field;
+ Expect (Tok_Semicolon, "';' expected");
+ Next_Token;
+ end loop;
+ end Parse_Fields;
+
+ procedure Parse_Record_Type (Def : Node_Acc)
+ is
+ Constr : O_Element_List;
+ begin
+ if Def.Type_Onode = O_Tnode_Null then
+ Start_Record_Type (Constr);
+ else
+ Start_Uncomplete_Record_Type (Def.Type_Onode, Constr);
+ end if;
+ Parse_Fields (Def, Constr);
+ Next_Expect (Tok_Record, "end record expected");
+ Finish_Record_Type (Constr, Def.Type_Onode);
+ end Parse_Record_Type;
+
+ procedure Parse_Union_Type (Def : Node_Acc)
+ is
+ Constr : O_Element_List;
+ begin
+ Start_Union_Type (Constr);
+ Parse_Fields (Def, Constr);
+ Next_Expect (Tok_Union, "end union expected");
+ Finish_Union_Type (Constr, Def.Type_Onode);
+ end Parse_Union_Type;
+
+ function Parse_Type return Node_Acc
+ is
+ Res : Node_Acc;
+ T : Token_Type;
+ begin
+ T := Tok;
+ case T is
+ when Tok_Unsigned
+ | Tok_Signed =>
+ Next_Expect (Tok_Left_Paren, "'(' expected");
+ Next_Expect (Tok_Num, "number expected");
+ case T is
+ when Tok_Unsigned =>
+ Res := new Node'
+ (Kind => Type_Unsigned,
+ Type_Onode => New_Unsigned_Type (Natural
+ (Token_Number)));
+ when Tok_Signed =>
+ Res := new Node'
+ (Kind => Type_Signed,
+ Type_Onode => New_Signed_Type (Natural
+ (Token_Number)));
+ when others =>
+ raise Program_Error;
+ end case;
+ Next_Expect (Tok_Right_Paren, "')' expected");
+ when Tok_Float =>
+ Res := new Node'(Kind => Type_Float,
+ Type_Onode => New_Float_Type);
+ when Tok_Array =>
+ declare
+ Index_Node : Node_Acc;
+ El_Node : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Brack, "'[' expected");
+ Next_Token;
+ Index_Node := Parse_Type;
+ Expect (Tok_Right_Brack, "']' expected");
+ Next_Expect (Tok_Of, "'of' expected");
+ Next_Token;
+ El_Node := Parse_Type;
+ Res := new Node'
+ (Kind => Type_Array,
+ Type_Onode => New_Array_Type (El_Node.Type_Onode,
+ Index_Node.Type_Onode),
+ Array_Index => Index_Node,
+ Array_Element => El_Node);
+ end;
+ return Res;
+ when Tok_Subarray =>
+ declare
+ Base_Node : Node_Acc;
+ Res_Type : O_Tnode;
+ begin
+ Next_Token;
+ Base_Node := Parse_Type;
+ Expect (Tok_Left_Brack);
+ Next_Token;
+ Res_Type := New_Constrained_Array_Type
+ (Base_Node.Type_Onode,
+ Parse_Constant_Value (Base_Node.Array_Index));
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ Res := new Node' (Kind => Type_Subarray,
+ Type_Onode => Res_Type,
+ Subarray_Base => Base_Node);
+ return Res;
+ end;
+ when Tok_Ident =>
+ declare
+ Inter : Node_Acc;
+ begin
+ Inter := Get_Decl (Token_Sym);
+ if Inter = null then
+ Parse_Error ("undefined type name symbol "
+ & Get_String (Token_Sym.Ident));
+ end if;
+ if Inter.Kind /= Decl_Type then
+ Parse_Error ("type declarator expected");
+ end if;
+ Res := Inter.Decl_Dtype;
+ end;
+ when Tok_Access =>
+ declare
+ Dtype : Node_Acc;
+ begin
+ Next_Token;
+ if Tok = Tok_Semicolon then
+ Res := new Node'
+ (Kind => Type_Access,
+ Type_Onode => New_Access_Type (O_Tnode_Null),
+ Access_Dtype => null);
+ else
+ Dtype := Parse_Type;
+ Res := new Node'
+ (Kind => Type_Access,
+ Type_Onode => New_Access_Type (Dtype.Type_Onode),
+ Access_Dtype => Dtype);
+ end if;
+ return Res;
+ end;
+ when Tok_Record =>
+ Next_Token;
+ if Tok = Tok_Semicolon then
+ -- Uncomplete record type.
+ Res := new Node'(Kind => Type_Record,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ New_Uncomplete_Record_Type (Res.Type_Onode);
+ return Res;
+ end if;
+
+ Res := new Node'(Kind => Type_Record,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ Parse_Record_Type (Res);
+ when Tok_Union =>
+ Next_Token;
+ Res := new Node'(Kind => Type_Union,
+ Type_Onode => O_Tnode_Null,
+ Record_Union_Fields => null);
+ Parse_Union_Type (Res);
+
+ when Tok_Boolean =>
+ declare
+ False_Lit, True_Lit : Node_Acc;
+ begin
+ Res := new Node'(Kind => Type_Boolean,
+ Type_Onode => O_Tnode_Null,
+ Enum_Lits => null);
+ Next_Expect (Tok_Left_Brace, "'{' expected");
+ Next_Expect (Tok_Ident, "identifier expected");
+ False_Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Next_Expect (Tok_Comma, "',' expected");
+ Next_Expect (Tok_Ident, "identifier expected");
+ True_Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Next_Expect (Tok_Right_Brace, "'}' expected");
+ False_Lit.Lit_Next := True_Lit;
+ Res.Enum_Lits := False_Lit;
+ New_Boolean_Type (Res.Type_Onode,
+ False_Lit.Lit_Name, False_Lit.Lit_Cnode,
+ True_Lit.Lit_Name, True_Lit.Lit_Cnode);
+ end;
+ when Tok_Enum =>
+ declare
+ List : O_Enum_List;
+ Lit : Node_Acc;
+ Last_Lit : Node_Acc;
+ begin
+ Res := new Node'(Kind => Type_Enum,
+ Type_Onode => O_Tnode_Null,
+ Enum_Lits => null);
+ Last_Lit := null;
+ Push_Scope;
+ Next_Expect (Tok_Left_Brace);
+ Next_Token;
+ -- FIXME: set a size to the enum.
+ Start_Enum_Type (List, 8);
+ loop
+ Expect (Tok_Ident);
+ Lit := new Node'(Kind => Node_Lit,
+ Decl_Dtype => Res,
+ Decl_Storage => O_Storage_Public,
+ Lit_Name => Token_Sym.Ident,
+ Lit_Cnode => O_Cnode_Null,
+ Lit_Next => null);
+ Add_Decl (Token_Sym, Lit);
+ New_Enum_Literal (List, Lit.Lit_Name, Lit.Lit_Cnode);
+ if Last_Lit = null then
+ Res.Enum_Lits := Lit;
+ else
+ Last_Lit.Lit_Next := Lit;
+ end if;
+ Last_Lit := Lit;
+ Next_Expect (Tok_Equal);
+ Next_Expect (Tok_Num);
+ Next_Token;
+ exit when Tok = Tok_Right_Brace;
+ Expect (Tok_Comma);
+ Next_Token;
+ end loop;
+ Finish_Enum_Type (List, Res.Type_Onode);
+ Pop_Scope;
+ end;
+ when others =>
+ Parse_Error ("bad type " & Token_Type'Image (Tok));
+ return null;
+ end case;
+ Next_Token;
+ return Res;
+ end Parse_Type;
+
+ procedure Parse_Type_Completion (Decl : Node_Acc)
+ is
+ begin
+ case Tok is
+ when Tok_Record =>
+ Next_Token;
+ Parse_Record_Type (Decl.Decl_Dtype);
+ Next_Token;
+ when Tok_Access =>
+ Next_Token;
+ declare
+ Dtype : Node_Acc;
+ begin
+ Dtype := Parse_Type;
+ Decl.Decl_Dtype.Access_Dtype := Dtype;
+ Finish_Access_Type (Decl.Decl_Dtype.Type_Onode,
+ Dtype.Type_Onode);
+ end;
+ when others =>
+ Parse_Error ("'access' or 'record' expected");
+ end case;
+ end Parse_Type_Completion;
+
+-- procedure Parse_Declaration;
+
+ procedure Parse_Expression (Expr_Type : Node_Acc;
+ Expr : out O_Enode;
+ Res_Type : out Node_Acc);
+ procedure Parse_Name (Prefix : Node_Acc;
+ Name : out O_Lnode; N_Type : out Node_Acc);
+ procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc);
+
+ -- Expect: '('
+ -- Let: next token.
+ procedure Parse_Association (Constr : in out O_Assoc_List;
+ Decl : Node_Acc);
+
+ function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc
+ is
+ Field : Node_Acc;
+ begin
+ Field := Aggr_Type.Record_Union_Fields;
+ while Field /= null loop
+ exit when Field.Field_Ident = Token_Sym;
+ Field := Field.Field_Next;
+ end loop;
+ if Field = null then
+ Parse_Error ("no such field name");
+ end if;
+ return Field;
+ end Find_Field_By_Name;
+
+ -- expect: offsetof id.
+ function Parse_Offsetof (Atype : Node_Acc) return O_Cnode
+ is
+ Rec_Type : Node_Acc;
+ Rec_Field : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Rec_Type := Get_Decl (Token_Sym);
+ if Rec_Type.Kind /= Decl_Type
+ or else Rec_Type.Decl_Dtype.Kind /= Type_Record
+ then
+ Parse_Error ("type name expected");
+ end if;
+ Next_Expect (Tok_Dot);
+ Next_Expect (Tok_Ident);
+ Rec_Field := Find_Field_By_Name (Rec_Type.Decl_Dtype);
+ Next_Expect (Tok_Right_Paren);
+ return New_Offsetof (Rec_Type.Decl_Dtype.Type_Onode,
+ Rec_Field.Field_Fnode,
+ Atype.Type_Onode);
+ end Parse_Offsetof;
+
+ function Parse_Sizeof (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ if Tok /= Tok_Ident then
+ Parse_Error ("type name expected");
+ end if;
+ Res := New_Sizeof
+ (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
+ Atype.Type_Onode);
+ Next_Expect (Tok_Right_Paren);
+ return Res;
+ end Parse_Sizeof;
+
+ function Parse_Alignof (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ if Tok /= Tok_Ident then
+ Parse_Error ("type name expected");
+ end if;
+ Res := New_Alignof
+ (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
+ Atype.Type_Onode);
+ Next_Expect (Tok_Right_Paren);
+ return Res;
+ end Parse_Alignof;
+
+ -- Parse a literal whose type is ATYPE.
+ function Parse_Typed_Literal (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ case Tok is
+ when Tok_Num =>
+ case Atype.Kind is
+ when Type_Signed =>
+ Res := New_Signed_Literal
+ (Atype.Type_Onode, Integer_64 (Token_Number));
+ when Type_Unsigned =>
+ Res := New_Unsigned_Literal
+ (Atype.Type_Onode, Token_Number);
+ when others =>
+ Parse_Error ("bad type for integer literal");
+ end case;
+ when Tok_Minus =>
+ Next_Token;
+ case Tok is
+ when Tok_Num =>
+ declare
+ V : Integer_64;
+ begin
+ if Token_Number = Unsigned_64 (Integer_64'Last) + 1 then
+ V := Integer_64'First;
+ else
+ V := -Integer_64 (Token_Number);
+ end if;
+ Res := New_Signed_Literal (Atype.Type_Onode, V);
+ end;
+ when Tok_Float_Num =>
+ Res := New_Float_Literal (Atype.Type_Onode, -Token_Float);
+ when others =>
+ Parse_Error ("bad token after '-'");
+ end case;
+ when Tok_Float_Num =>
+ Res := New_Float_Literal (Atype.Type_Onode, Token_Float);
+ when Tok_Ident =>
+ declare
+ Pfx : Node_Acc;
+ N : Node_Acc;
+ begin
+ -- Note: we don't use get_decl, since the name can be a literal
+ -- name, which is not directly visible.
+ if Token_Sym.Name /= null
+ and then Token_Sym.Name.Inter.Kind = Decl_Type
+ then
+ -- A typed expression.
+ Pfx := Token_Sym.Name.Inter;
+ N := Pfx.Decl_Dtype;
+ if Atype /= null and then N /= Atype then
+ Parse_Error ("type mismatch");
+ end if;
+ Next_Expect (Tok_Tick);
+ Next_Token;
+ if Tok = Tok_Left_Brack then
+ Next_Token;
+ Res := Parse_Typed_Literal (N);
+ Expect (Tok_Right_Brack);
+ elsif Tok = Tok_Ident then
+ if Token_Sym = Id_Offsetof then
+ Res := Parse_Offsetof (N);
+ elsif Token_Sym = Id_Sizeof then
+ Res := Parse_Sizeof (N);
+ elsif Token_Sym = Id_Alignof then
+ Res := Parse_Alignof (N);
+ elsif Token_Sym = Id_Address
+ or Token_Sym = Id_Unchecked_Address
+ or Token_Sym = Id_Subprg_Addr
+ then
+ Res := Parse_Constant_Address (Pfx);
+ elsif Token_Sym = Id_Conv then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Res := Parse_Typed_Literal (N);
+ Expect (Tok_Right_Paren);
+ else
+ Parse_Error ("offsetof or sizeof attributes expected");
+ end if;
+ else
+ Parse_Error ("'[' or attribute expected");
+ end if;
+ else
+ if Atype.Kind /= Type_Enum
+ and then Atype.Kind /= Type_Boolean
+ then
+ Parse_Error ("name allowed only for enumeration");
+ end if;
+ N := Atype.Enum_Lits;
+ while N /= null loop
+ if Is_Equal (N.Lit_Name, Token_Sym.Ident) then
+ Res := N.Lit_Cnode;
+ exit;
+ end if;
+ N := N.Lit_Next;
+ end loop;
+ if N = null then
+ Parse_Error ("no matching literal");
+ return O_Cnode_Null;
+ end if;
+ end if;
+ end;
+ when Tok_Null =>
+ Res := New_Null_Access (Atype.Type_Onode);
+ when others =>
+ Parse_Error ("bad primary expression: " & Token_Type'Image (Tok));
+ return O_Cnode_Null;
+ end case;
+ Next_Token;
+ return Res;
+ end Parse_Typed_Literal;
+
+ -- expect: next token
+ -- Parse an expression starting with NAME.
+ procedure Parse_Named_Expression
+ (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean;
+ Res : out O_Enode;
+ Res_Type : out Node_Acc)
+ is
+ begin
+ if Tok = Tok_Tick then
+ Next_Token;
+ if Tok = Tok_Left_Brack then
+ -- Typed literal.
+ Next_Token;
+ Res := New_Lit (Parse_Typed_Literal (Name.Decl_Dtype));
+ Res_Type := Name.Decl_Dtype;
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ elsif Tok = Tok_Left_Paren then
+ -- Typed expression (used for comparaison operators)
+ Next_Token;
+ Parse_Expression (Name.Decl_Dtype, Res, Res_Type);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ elsif Tok = Tok_Ident then
+ -- Attribute.
+ if Token_Sym = Id_Conv then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Parse_Expression (null, Res, Res_Type);
+ -- Discard Res_Type.
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ Res_Type := Name.Decl_Dtype;
+ Res := New_Convert_Ov (Res, Res_Type.Type_Onode);
+ -- Fall-through.
+ elsif Token_Sym = Id_Address
+ or Token_Sym = Id_Unchecked_Address
+ or Token_Sym = Id_Subprg_Addr
+ then
+ Res_Type := Name.Decl_Dtype;
+ Res := Parse_Address (Name);
+ -- Fall-through.
+ elsif Token_Sym = Id_Sizeof then
+ Res_Type := Name.Decl_Dtype;
+ Res := New_Lit (Parse_Sizeof (Res_Type));
+ Next_Token;
+ return;
+ elsif Token_Sym = Id_Alignof then
+ Res_Type := Name.Decl_Dtype;
+ Res := New_Lit (Parse_Alignof (Res_Type));
+ Next_Token;
+ return;
+ elsif Token_Sym = Id_Alloca then
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Parse_Expression (null, Res, Res_Type);
+ -- Discard Res_Type.
+ Res_Type := Name.Decl_Dtype;
+ Res := New_Alloca (Res_Type.Type_Onode, Res);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return;
+ elsif Token_Sym = Id_Offsetof then
+ Res_Type := Atype;
+ Res := New_Lit (Parse_Offsetof (Res_Type));
+ Next_Token;
+ return;
+ else
+ Parse_Error ("unknown attribute name");
+ end if;
+ -- Fall-through.
+ else
+ Parse_Error ("typed expression expected");
+ end if;
+ elsif Tok = Tok_Left_Paren then
+ if Name.Kind /= Node_Function then
+ Parse_Error ("function name expected");
+ end if;
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Parse_Association (Constr, Name);
+ Res := New_Function_Call (Constr);
+ Res_Type := Name.Decl_Dtype;
+ -- Fall-through.
+ end;
+ elsif Name.Kind = Node_Object
+ or else Name.Kind = Decl_Param
+ then
+ -- Name.
+ declare
+ Lval : O_Lnode;
+ begin
+ Parse_Name (Name, Lval, Res_Type);
+ Res := New_Value (Lval);
+ end;
+ else
+ Parse_Error ("bad ident expression: "
+ & Token_Type'Image (Tok));
+ end if;
+
+ -- Continue.
+ -- R_TYPE and RES must be set.
+ if Tok = Tok_Dot then
+ if Stop_At_All then
+ return;
+ end if;
+ Next_Token;
+ if Tok = Tok_All then
+ if Res_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ declare
+ N : O_Lnode;
+ begin
+ Next_Token;
+ N := New_Access_Element (Res);
+ Res_Type := Res_Type.Access_Dtype;
+ Parse_Lvalue (N, Res_Type);
+ Res := New_Value (N);
+ end;
+ return;
+ else
+ Parse_Error ("'.all' expected");
+ end if;
+ end if;
+ end Parse_Named_Expression;
+
+ procedure Parse_Primary_Expression (Atype : Node_Acc;
+ Res : out O_Enode;
+ Res_Type : out Node_Acc)
+ is
+ begin
+ case Tok is
+ when Tok_Num
+ | Tok_Float_Num =>
+ if Atype = null then
+ Parse_Error ("numeric literal without type context");
+ end if;
+ Res_Type := Atype;
+ Res := New_Lit (Parse_Typed_Literal (Atype));
+ when Tok_Ident =>
+ declare
+ N : Node_Acc;
+ begin
+ N := Get_Decl (Token_Sym);
+ Next_Token;
+ Parse_Named_Expression (Atype, N, False, Res, Res_Type);
+ end;
+ when Tok_Left_Paren =>
+ Next_Token;
+ Parse_Expression (Atype, Res, Res_Type);
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ when others =>
+ Parse_Error ("bad primary expression: " & Token_Type'Image (Tok));
+ end case;
+ end Parse_Primary_Expression;
+
+ -- Parse '-' EXPR, 'not' EXPR, 'abs' EXPR or EXPR.
+ procedure Parse_Unary_Expression (Atype : Node_Acc;
+ Res : out O_Enode;
+ Res_Type : out Node_Acc)
+ is
+ begin
+ case Tok is
+ when Tok_Minus =>
+ Next_Token;
+ Parse_Primary_Expression (Atype, Res, Res_Type);
+ Res := New_Monadic_Op (ON_Neg_Ov, Res);
+ when Tok_Not =>
+ Next_Token;
+ Parse_Unary_Expression (Atype, Res, Res_Type);
+ Res := New_Monadic_Op (ON_Not, Res);
+ when Tok_Abs =>
+ Next_Token;
+ Parse_Unary_Expression (Atype, Res, Res_Type);
+ Res := New_Monadic_Op (ON_Abs_Ov, Res);
+ when others =>
+ Parse_Primary_Expression (Atype, Res, Res_Type);
+ end case;
+ end Parse_Unary_Expression;
+
+ function Check_Sharp (Op_Ov : ON_Op_Kind) return ON_Op_Kind is
+ begin
+ Next_Expect (Tok_Sharp);
+ Next_Token;
+ return Op_Ov;
+ end Check_Sharp;
+
+ procedure Parse_Expression (Expr_Type : Node_Acc;
+ Expr : out O_Enode;
+ Res_Type : out Node_Acc)
+ is
+ Op_Type : Node_Acc;
+ L : O_Enode;
+ R : O_Enode;
+ Op : ON_Op_Kind;
+ begin
+ if Expr_Type = null or else Expr_Type.Kind = Type_Boolean then
+ -- The type of the expression isn't known, as this can be a
+ -- comparaison operator.
+ Op_Type := null;
+ else
+ Op_Type := Expr_Type;
+ end if;
+ Parse_Unary_Expression (Op_Type, L, Res_Type);
+ case Tok is
+ when Tok_Div =>
+ Op := Check_Sharp (ON_Div_Ov);
+ when Tok_Plus =>
+ Op := Check_Sharp (ON_Add_Ov);
+ when Tok_Minus =>
+ Op := Check_Sharp (ON_Sub_Ov);
+ when Tok_Star =>
+ Op := Check_Sharp (ON_Mul_Ov);
+ when Tok_Mod =>
+ Op := Check_Sharp (ON_Mod_Ov);
+ when Tok_Rem =>
+ Op := Check_Sharp (ON_Rem_Ov);
+
+ when Tok_Equal =>
+ Op := ON_Eq;
+ when Tok_Not_Equal =>
+ Op := ON_Neq;
+ when Tok_Greater =>
+ Op := ON_Gt;
+ when Tok_Greater_Eq =>
+ Op := ON_Ge;
+ when Tok_Less =>
+ Op := ON_Lt;
+ when Tok_Less_Eq =>
+ Op := ON_Le;
+
+ when Tok_Or =>
+ Op := ON_Or;
+ Next_Token;
+ when Tok_And =>
+ Op := ON_And;
+ Next_Token;
+ when Tok_Xor =>
+ Op := ON_Xor;
+ Next_Token;
+
+ when others =>
+ Expr := L;
+ return;
+ end case;
+ if Op in ON_Compare_Op_Kind then
+ Next_Token;
+ end if;
+
+ Parse_Unary_Expression (Res_Type, R, Res_Type);
+ case Op is
+ when ON_Dyadic_Op_Kind =>
+ Expr := New_Dyadic_Op (Op, L, R);
+ when ON_Compare_Op_Kind =>
+ if Expr_Type = null then
+ Parse_Error ("comparaison operator requires a type");
+ end if;
+ Expr := New_Compare_Op (Op, L, R, Expr_Type.Type_Onode);
+ Res_Type := Expr_Type;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Parse_Expression;
+
+ -- Expect and leave: next token
+ procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc)
+ is
+ begin
+ loop
+ case Tok is
+ when Tok_Dot =>
+ Next_Token;
+ if Tok = Tok_All then
+ if N_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ N := New_Access_Element (New_Value (N));
+ N_Type := N_Type.Access_Dtype;
+ Next_Token;
+ elsif Tok = Tok_Ident then
+ if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union
+ then
+ Parse_Error
+ ("type of prefix is neither a record nor an union");
+ end if;
+ declare
+ Field : Node_Acc;
+ begin
+ Field := Find_Field_By_Name (N_Type);
+ N := New_Selected_Element (N, Field.Field_Fnode);
+ N_Type := Field.Field_Type;
+ Next_Token;
+ end;
+ else
+ Parse_Error
+ ("'.' must be followed by 'all' or a field name");
+ end if;
+ when Tok_Left_Brack =>
+ declare
+ V : O_Enode;
+ Bt : Node_Acc;
+ Res_Type : Node_Acc;
+ begin
+ Next_Token;
+ if N_Type.Kind = Type_Subarray then
+ Bt := N_Type.Subarray_Base;
+ else
+ Bt := N_Type;
+ end if;
+ if Bt.Kind /= Type_Array then
+ Parse_Error ("type of prefix is not an array");
+ end if;
+ Parse_Expression (Bt.Array_Index, V, Res_Type);
+ if Tok = Tok_Elipsis then
+ N := New_Slice (N, Bt.Type_Onode, V);
+ Next_Token;
+ else
+ N := New_Indexed_Element (N, V);
+ N_Type := Bt.Array_Element;
+ end if;
+ Expect (Tok_Right_Brack);
+ Next_Token;
+ end;
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Parse_Lvalue;
+
+ procedure Parse_Name (Prefix : Node_Acc;
+ Name : out O_Lnode; N_Type : out Node_Acc)
+ is
+ begin
+ case Prefix.Kind is
+ when Decl_Param =>
+ Name := New_Obj (Prefix.Param_Node);
+ N_Type := Prefix.Decl_Dtype;
+ when Node_Object =>
+ Name := New_Obj (Prefix.Obj_Node);
+ N_Type := Prefix.Decl_Dtype;
+ when Decl_Type =>
+ declare
+ Val : O_Enode;
+ begin
+ Parse_Named_Expression (null, Prefix, True, Val, N_Type);
+ if N_Type /= Prefix.Decl_Dtype then
+ Parse_Error ("type doesn't match");
+ end if;
+ if Tok = Tok_Dot then
+ Next_Token;
+ if Tok = Tok_All then
+ if N_Type.Kind /= Type_Access then
+ Parse_Error ("type of prefix is not an access");
+ end if;
+ Name := New_Access_Element (Val);
+ N_Type := N_Type.Access_Dtype;
+ Next_Token;
+ else
+ Parse_Error ("'.all' expected");
+ end if;
+ else
+ Parse_Error ("name expected");
+ end if;
+ end;
+ when others =>
+ Parse_Error ("invalid name");
+ end case;
+ Parse_Lvalue (Name, N_Type);
+ end Parse_Name;
+
+ -- Expect: '('
+ -- Let: next token.
+ procedure Parse_Association (Constr : in out O_Assoc_List; Decl : Node_Acc)
+ is
+ Param : Node_Acc;
+ Expr : O_Enode;
+ Expr_Type : Node_Acc;
+ begin
+ Start_Association (Constr, Decl.Subprg_Node);
+ if Tok /= Tok_Left_Paren then
+ Parse_Error ("'(' expected for a subprogram call");
+ end if;
+ Next_Token;
+ Param := Decl.Subprg_Params;
+ while Tok /= Tok_Right_Paren loop
+ if Param = null then
+ Parse_Error ("too many parameters");
+ end if;
+ Parse_Expression (Param.Decl_Dtype, Expr, Expr_Type);
+ New_Association (Constr, Expr);
+ Param := Param.Param_Next;
+ exit when Tok /= Tok_Comma;
+ Next_Token;
+ end loop;
+ if Param /= null then
+ Parse_Error ("missing parameters");
+ end if;
+ if Tok /= Tok_Right_Paren then
+ Parse_Error ("')' expected to finish a subprogram call, found "
+ & Token_Type'Image (Tok));
+ end if;
+ Next_Token;
+ end Parse_Association;
+
+ type Loop_Info;
+ type Loop_Info_Acc is access Loop_Info;
+ type Loop_Info is record
+ Num : Natural;
+ Blk : O_Snode;
+ Prev : Loop_Info_Acc;
+ end record;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => Loop_Info_Acc, Object => Loop_Info);
+
+ Loop_Stack : Loop_Info_Acc := null;
+
+ function Find_Loop (N : Natural) return Loop_Info_Acc
+ is
+ Res : Loop_Info_Acc;
+ begin
+ Res := Loop_Stack;
+ while Res /= null loop
+ if Res.Num = N then
+ return Res;
+ end if;
+ Res := Res.Prev;
+ end loop;
+ return null;
+ end Find_Loop;
+
+ Current_Subprg : Node_Acc := null;
+
+ procedure Parse_Statement;
+
+ -- Expect : next token
+ -- Let: next token
+ procedure Parse_Statements is
+ begin
+ loop
+ exit when Tok = Tok_End;
+ exit when Tok = Tok_Else;
+ exit when Tok = Tok_When;
+ Parse_Statement;
+ end loop;
+ end Parse_Statements;
+
+ -- Expect : next token
+ -- Let: next token
+ procedure Parse_Statement is
+ begin
+ if Flag_Renumber then
+ New_Debug_Line_Stmt (Lineno);
+ end if;
+
+ case Tok is
+ when Tok_Comment =>
+ Next_Token;
+
+ when Tok_Declare =>
+ Start_Declare_Stmt;
+ Parse_Compound_Statement;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ Finish_Declare_Stmt;
+
+ when Tok_Line_Number =>
+ Next_Expect (Tok_Num);
+ if Flag_Renumber = False then
+ New_Debug_Line_Stmt (Natural (Token_Number));
+ end if;
+ Next_Token;
+
+ when Tok_If =>
+ declare
+ If_Blk : O_If_Block;
+ Cond : O_Enode;
+ Cond_Type : Node_Acc;
+ begin
+ Next_Token;
+ Parse_Expression (null, Cond, Cond_Type);
+ Start_If_Stmt (If_Blk, Cond);
+ Expect (Tok_Then);
+ Next_Token;
+ Parse_Statements;
+ if Tok = Tok_Else then
+ Next_Token;
+ New_Else_Stmt (If_Blk);
+ Parse_Statements;
+ end if;
+ Finish_If_Stmt (If_Blk);
+ Expect (Tok_End);
+ Next_Expect (Tok_If);
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+
+ when Tok_Loop =>
+ declare
+ Info : Loop_Info_Acc;
+ Num : Natural;
+ begin
+ Next_Expect (Tok_Num);
+ Num := Natural (Token_Number);
+ if Find_Loop (Num) /= null then
+ Parse_Error ("loop label already defined");
+ end if;
+ Info := new Loop_Info;
+ Info.Num := Num;
+ Info.Prev := Loop_Stack;
+ Loop_Stack := Info;
+ Start_Loop_Stmt (Info.Blk);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ Parse_Statements;
+ Finish_Loop_Stmt (Info.Blk);
+ Next_Expect (Tok_Loop);
+ Next_Expect (Tok_Semicolon);
+ Loop_Stack := Info.Prev;
+ Free (Info);
+ Next_Token;
+ end;
+
+ when Tok_Exit
+ | Tok_Next =>
+ declare
+ Label : Loop_Info_Acc;
+ Etok : Token_Type;
+ begin
+ Etok := Tok;
+ Next_Expect (Tok_Loop);
+ Next_Expect (Tok_Num);
+ Label := Find_Loop (Natural (Token_Number));
+ if Label = null then
+ Parse_Error ("no such loop");
+ end if;
+ if Etok = Tok_Exit then
+ New_Exit_Stmt (Label.Blk);
+ else
+ New_Next_Stmt (Label.Blk);
+ end if;
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+
+ when Tok_Return =>
+ declare
+ Res : O_Enode;
+ Res_Type : Node_Acc;
+ begin
+ Next_Token;
+ if Tok /= Tok_Semicolon then
+ Parse_Expression (Current_Subprg.Decl_Dtype, Res, Res_Type);
+ New_Return_Stmt (Res);
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected at end of return statement");
+ end if;
+ else
+ New_Return_Stmt;
+ end if;
+ Next_Token;
+ end;
+
+ when Tok_Ident =>
+ -- This is either a procedure call or an assignment.
+ declare
+ Inter : Node_Acc;
+ begin
+ Inter := Get_Decl (Token_Sym);
+ Next_Token;
+ if Tok = Tok_Left_Paren then
+ -- A procedure call.
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Parse_Association (Constr, Inter);
+ New_Procedure_Call (Constr);
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected after call");
+ end if;
+ Next_Token;
+ return;
+ end;
+ else
+ -- An assignment.
+ declare
+ Name : O_Lnode;
+ Expr : O_Enode;
+ Expr_Type : Node_Acc;
+ N_Type : Node_Acc;
+ begin
+ Parse_Name (Inter, Name, N_Type);
+ if Tok /= Tok_Assign then
+ Parse_Error ("`:=' expected after a variable");
+ end if;
+ Next_Token;
+ Parse_Expression (N_Type, Expr, Expr_Type);
+ New_Assign_Stmt (Name, Expr);
+ if Tok /= Tok_Semicolon then
+ Parse_Error ("';' expected at end of assignment");
+ end if;
+ Next_Token;
+ return;
+ end;
+ end if;
+ end;
+
+ when Tok_Case =>
+ declare
+ Case_Blk : O_Case_Block;
+ L : O_Cnode;
+ Choice : O_Enode;
+ Choice_Type : Node_Acc;
+ begin
+ Next_Token;
+ Parse_Expression (null, Choice, Choice_Type);
+ Start_Case_Stmt (Case_Blk, Choice);
+ Expect (Tok_Is);
+ Next_Token;
+ loop
+ exit when Tok = Tok_End;
+ Expect (Tok_When);
+ Next_Token;
+ Start_Choice (Case_Blk);
+ loop
+ if Tok = Tok_Default then
+ New_Default_Choice (Case_Blk);
+ Next_Token;
+ else
+ L := Parse_Typed_Literal (Choice_Type);
+ if Tok = Tok_Elipsis then
+ Next_Token;
+ New_Range_Choice
+ (Case_Blk, L, Parse_Typed_Literal (Choice_Type));
+ else
+ New_Expr_Choice (Case_Blk, L);
+ end if;
+ end if;
+ exit when Tok = Tok_Arrow;
+ Expect (Tok_Comma);
+ Next_Token;
+ end loop;
+ -- Skip '=>'.
+ Next_Token;
+ Finish_Choice (Case_Blk);
+ Parse_Statements;
+ end loop;
+ Finish_Case_Stmt (Case_Blk);
+ Expect (Tok_End);
+ Next_Expect (Tok_Case);
+ Next_Expect (Tok_Semicolon);
+ Next_Token;
+ end;
+ when others =>
+ Parse_Error ("bad statement: " & Token_Type'Image (Tok));
+ end case;
+ end Parse_Statement;
+
+ procedure Parse_Compound_Statement is
+ begin
+ if Tok /= Tok_Declare then
+ Parse_Error ("'declare' expected to start a statements block");
+ end if;
+ Next_Token;
+
+ Push_Scope;
+
+ -- Parse declarations.
+ while Tok /= Tok_Begin loop
+ Parse_Declaration;
+ end loop;
+ Next_Token;
+
+ -- Parse statements.
+ Parse_Statements;
+ Expect (Tok_End);
+ Next_Token;
+
+ Pop_Scope;
+ end Parse_Compound_Statement;
+
+ -- Parse (P1 : T1; P2: T2; ...)
+ function Parse_Parameter_List return Node_Acc
+ is
+ First, Last : Node_Acc;
+ P : Node_Acc;
+ begin
+ Expect (Tok_Left_Paren);
+ Next_Token;
+ if Tok = Tok_Right_Paren then
+ Next_Token;
+ return null;
+ end if;
+ First := null;
+ Last := null;
+ loop
+ Expect (Tok_Ident);
+ P := new Node'(Kind => Decl_Param,
+ Decl_Dtype => null,
+ Decl_Storage => O_Storage_Public,
+ Param_Node => O_Dnode_Null,
+ Param_Name => Token_Sym,
+ Param_Next => null);
+ -- Link
+ if Last = null then
+ First := P;
+ else
+ Last.Param_Next := P;
+ end if;
+ Last := P;
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ P.Decl_Dtype := Parse_Type;
+ exit when Tok = Tok_Right_Paren;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end loop;
+ Next_Token;
+ return First;
+ end Parse_Parameter_List;
+
+ procedure Create_Interface_List (Constr : in out O_Inter_List;
+ First_Inter : Node_Acc)
+ is
+ Inter : Node_Acc;
+ begin
+ Inter := First_Inter;
+ while Inter /= null loop
+ New_Interface_Decl (Constr, Inter.Param_Node, Inter.Param_Name.Ident,
+ Inter.Decl_Dtype.Type_Onode);
+ Inter := Inter.Param_Next;
+ end loop;
+ end Create_Interface_List;
+
+ procedure Check_Parameter_List (List : Node_Acc)
+ is
+ Param : Node_Acc;
+ begin
+ Next_Expect (Tok_Left_Paren);
+ Next_Token;
+ Param := List;
+ while Tok /= Tok_Right_Paren loop
+ if Param = null then
+ Parse_Error ("subprogram redefined with more parameters");
+ end if;
+ Expect (Tok_Ident);
+ if Token_Sym /= Param.Param_Name then
+ Parse_Error ("subprogram redefined with different parameter name");
+ end if;
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ if Parse_Type /= Param.Decl_Dtype then
+ Parse_Error ("subprogram redefined with different parameter type");
+ end if;
+ Param := Param.Param_Next;
+ exit when Tok = Tok_Right_Paren;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end loop;
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ if Param /= null then
+ Parse_Error ("subprogram redefined with less parameters");
+ end if;
+ end Check_Parameter_List;
+
+ procedure Parse_Subprogram_Body (Subprg : Node_Acc)
+ is
+ Param : Node_Acc;
+ Prev_Subprg : Node_Acc;
+ begin
+ Prev_Subprg := Current_Subprg;
+ Current_Subprg := Subprg;
+
+ Start_Subprogram_Body (Subprg.Subprg_Node);
+ Push_Scope;
+
+ -- Put parameters in the current scope.
+ Param := Subprg.Subprg_Params;
+ while Param /= null loop
+ Add_Decl (Param.Param_Name, Param);
+ Param := Param.Param_Next;
+ end loop;
+
+ Parse_Compound_Statement;
+
+ Pop_Scope;
+ Finish_Subprogram_Body;
+
+ Current_Subprg := Prev_Subprg;
+ end Parse_Subprogram_Body;
+
+ procedure Parse_Function_Definition (Storage : O_Storage)
+ is
+ Constr : O_Inter_List;
+ Sym : Syment_Acc;
+ N : Node_Acc;
+ begin
+ Expect (Tok_Function);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ if Sym.Name /= null then
+ N := Get_Decl (Sym);
+ Check_Parameter_List (N.Subprg_Params);
+ Expect (Tok_Return);
+ Next_Expect (Tok_Ident);
+ Next_Token;
+ else
+ N := new Node'(Kind => Node_Function,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Subprg_Node => O_Dnode_Null,
+ Subprg_Name => Sym,
+ Subprg_Params => null);
+ Next_Token;
+ N.Subprg_Params := Parse_Parameter_List;
+ Expect (Tok_Return);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+
+ Start_Function_Decl (Constr, N.Subprg_Name.Ident, Storage,
+ N.Decl_Dtype.Type_Onode);
+ Create_Interface_List (Constr, N.Subprg_Params);
+ Finish_Subprogram_Decl (Constr, N.Subprg_Node);
+
+ Add_Decl (Sym, N);
+ end if;
+
+ if Tok = Tok_Declare then
+ Parse_Subprogram_Body (N);
+ end if;
+ end Parse_Function_Definition;
+
+ procedure Parse_Procedure_Definition (Storage : O_Storage)
+ is
+ Constr : O_Inter_List;
+ Sym : Syment_Acc;
+ N : Node_Acc;
+ begin
+ Expect (Tok_Procedure);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ if Sym.Name /= null then
+ N := Get_Decl (Sym);
+ Check_Parameter_List (N.Subprg_Params);
+ else
+ N := new Node'(Kind => Node_Procedure,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Subprg_Node => O_Dnode_Null,
+ Subprg_Name => Sym,
+ Subprg_Params => null);
+ Next_Token;
+ N.Subprg_Params := Parse_Parameter_List;
+
+ Start_Procedure_Decl (Constr, N.Subprg_Name.Ident, Storage);
+ Create_Interface_List (Constr, N.Subprg_Params);
+ Finish_Subprogram_Decl (Constr, N.Subprg_Node);
+
+ Add_Decl (Sym, N);
+ end if;
+
+ if Tok = Tok_Declare then
+ Parse_Subprogram_Body (N);
+ end if;
+ end Parse_Procedure_Definition;
+
+ function Parse_Address (Prefix : Node_Acc) return O_Enode
+ is
+ Pfx : Node_Acc;
+ N : O_Lnode;
+ N_Type : Node_Acc;
+ Res : O_Enode;
+ Attr : Syment_Acc;
+ T : O_Tnode;
+ begin
+ Attr := Token_Sym;
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ T := Prefix.Decl_Dtype.Type_Onode;
+ if Attr = Id_Subprg_Addr then
+ Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ if Pfx.Kind not in Nodes_Subprogram then
+ Parse_Error ("subprogram identifier expected");
+ end if;
+ Res := New_Lit (New_Subprogram_Address (Pfx.Subprg_Node, T));
+ Next_Token;
+ else
+ Next_Token;
+ Parse_Name (Pfx, N, N_Type);
+ if Attr = Id_Address then
+ Res := New_Address (N, T);
+ elsif Attr = Id_Unchecked_Address then
+ Res := New_Unchecked_Address (N, T);
+ else
+ Parse_Error ("address attribute expected");
+ end if;
+ end if;
+ Expect (Tok_Right_Paren);
+ Next_Token;
+ return Res;
+ end Parse_Address;
+
+ function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode
+ is
+ Pfx : Node_Acc;
+ Res : O_Cnode;
+ Attr : Syment_Acc;
+ T : O_Tnode;
+ begin
+ Attr := Token_Sym;
+ Next_Expect (Tok_Left_Paren);
+ Next_Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ T := Prefix.Decl_Dtype.Type_Onode;
+ if Attr = Id_Subprg_Addr then
+ Expect (Tok_Ident);
+ Pfx := Get_Decl (Token_Sym);
+ if Pfx.Kind not in Nodes_Subprogram then
+ Parse_Error ("subprogram identifier expected");
+ end if;
+ Res := New_Subprogram_Address (Pfx.Subprg_Node, T);
+ Next_Token;
+ else
+ Next_Token;
+ if Attr = Id_Address then
+ Res := New_Global_Address (Pfx.Obj_Node, T);
+ elsif Attr = Id_Unchecked_Address then
+ Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T);
+ else
+ Parse_Error ("address attribute expected");
+ end if;
+ end if;
+ Expect (Tok_Right_Paren);
+ return Res;
+ end Parse_Constant_Address;
+
+ function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ case Atype.Kind is
+ when Type_Subarray =>
+ declare
+ Constr : O_Array_Aggr_List;
+ El : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Start_Array_Aggr (Constr, Atype.Type_Onode);
+ El := Atype.Subarray_Base.Array_Element;
+ for I in Natural loop
+ exit when Tok = Tok_Right_Brace;
+ if I /= 0 then
+ Expect (Tok_Comma);
+ Next_Token;
+ end if;
+ New_Array_Aggr_El (Constr, Parse_Constant_Value (El));
+ end loop;
+ Finish_Array_Aggr (Constr, Res);
+ Next_Token;
+ return Res;
+ end;
+ when Type_Unsigned
+ | Type_Signed
+ | Type_Enum
+ | Type_Float
+ | Type_Boolean
+ | Type_Access =>
+ --return Parse_Primary_Expression (Atype);
+ return Parse_Typed_Literal (Atype);
+ when Type_Record =>
+ declare
+ Constr : O_Record_Aggr_List;
+ Field : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Start_Record_Aggr (Constr, Atype.Type_Onode);
+ Field := Atype.Record_Union_Fields;
+ while Field /= null loop
+ if Tok = Tok_Dot then
+ Next_Expect (Tok_Ident);
+ if Token_Sym /= Field.Field_Ident then
+ Parse_Error ("bad field name");
+ end if;
+ Next_Expect (Tok_Equal);
+ Next_Token;
+ end if;
+ New_Record_Aggr_El
+ (Constr, Parse_Constant_Value (Field.Field_Type));
+ Field := Field.Field_Next;
+ if Field /= null then
+ Expect (Tok_Comma);
+ Next_Token;
+ end if;
+ end loop;
+ Finish_Record_Aggr (Constr, Res);
+ Expect (Tok_Right_Brace);
+ Next_Token;
+ return Res;
+ end;
+ when Type_Union =>
+ declare
+ Field : Node_Acc;
+ begin
+ Expect (Tok_Left_Brace);
+ Next_Token;
+ Expect (Tok_Dot);
+ Next_Expect (Tok_Ident);
+ Field := Find_Field_By_Name (Atype);
+ Next_Expect (Tok_Equal);
+ Next_Token;
+ Res := New_Union_Aggr
+ (Atype.Type_Onode, Field.Field_Fnode,
+ Parse_Constant_Value (Field.Field_Type));
+ Expect (Tok_Right_Brace);
+ Next_Token;
+ return Res;
+ end;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Parse_Constant_Value;
+
+ procedure Parse_Constant_Declaration (Storage : O_Storage)
+ is
+ N : Node_Acc;
+ Sym : Syment_Acc;
+ --Val : O_Cnode;
+ begin
+ Expect (Tok_Constant);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ N := new Node'(Kind => Node_Object,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Obj_Name => Sym.Ident,
+ Obj_Node => O_Dnode_Null);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+ New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode);
+ Add_Decl (Sym, N);
+
+-- if Storage /= O_Storage_External then
+-- Expect (Tok_Assign);
+-- Next_Token;
+-- Start_Const_Value (N.Obj_Node);
+-- Val := Parse_Constant_Value (N.Decl_Dtype);
+-- Finish_Const_Value (N.Obj_Node, Val);
+-- end if;
+ end Parse_Constant_Declaration;
+
+ procedure Parse_Constant_Value_Declaration
+ is
+ N : Node_Acc;
+ Val : O_Cnode;
+ begin
+ Next_Expect (Tok_Ident);
+ N := Get_Decl (Token_Sym);
+ if N.Kind /= Node_Object then
+ Parse_Error ("name of a constant expected");
+ end if;
+ -- FIXME: should check storage,
+ -- should check the object is a constant,
+ -- should check the object has no value.
+ Next_Expect (Tok_Assign);
+ Next_Token;
+ Start_Const_Value (N.Obj_Node);
+ Val := Parse_Constant_Value (N.Decl_Dtype);
+ Finish_Const_Value (N.Obj_Node, Val);
+ end Parse_Constant_Value_Declaration;
+
+ procedure Parse_Var_Declaration (Storage : O_Storage)
+ is
+ N : Node_Acc;
+ Sym : Syment_Acc;
+ begin
+ Expect (Tok_Var);
+ Next_Expect (Tok_Ident);
+ Sym := Token_Sym;
+ N := new Node'(Kind => Node_Object,
+ Decl_Dtype => null,
+ Decl_Storage => Storage,
+ Obj_Name => Sym.Ident,
+ Obj_Node => O_Dnode_Null);
+ Next_Expect (Tok_Colon);
+ Next_Token;
+ N.Decl_Dtype := Parse_Type;
+ New_Var_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode);
+ Add_Decl (Sym, N);
+ end Parse_Var_Declaration;
+
+ procedure Parse_Stored_Decl (Storage : O_Storage)
+ is
+ begin
+ Next_Token;
+ if Tok = Tok_Function then
+ Parse_Function_Definition (Storage);
+ elsif Tok = Tok_Procedure then
+ Parse_Procedure_Definition (Storage);
+ elsif Tok = Tok_Constant then
+ Parse_Constant_Declaration (Storage);
+ elsif Tok = Tok_Var then
+ Parse_Var_Declaration (Storage);
+ else
+ Parse_Error ("function declaration expected");
+ end if;
+ end Parse_Stored_Decl;
+
+ procedure Parse_Declaration
+ is
+ Inter : Node_Acc;
+ S : Syment_Acc;
+ begin
+ if Flag_Renumber then
+ New_Debug_Line_Decl (Lineno);
+ end if;
+
+ case Tok is
+ when Tok_Type =>
+ Next_Token;
+ if Tok /= Tok_Ident then
+ Parse_Error ("identifier for type expected");
+ end if;
+ S := Token_Sym;
+ Next_Expect (Tok_Is);
+ Next_Token;
+ if Is_Defined (S) then
+ Parse_Type_Completion (Get_Decl (S));
+ else
+ Inter := new Node'(Kind => Decl_Type,
+ Decl_Storage => O_Storage_Public,
+ Decl_Dtype => Parse_Type);
+ Add_Decl (S, Inter);
+ New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode);
+ end if;
+ when Tok_External =>
+ Parse_Stored_Decl (O_Storage_External);
+ when Tok_Private =>
+ Parse_Stored_Decl (O_Storage_Private);
+ when Tok_Public =>
+ Parse_Stored_Decl (O_Storage_Public);
+ when Tok_Local =>
+ Parse_Stored_Decl (O_Storage_Local);
+ when Tok_Constant =>
+ Parse_Constant_Value_Declaration;
+ when Tok_Comment =>
+ New_Debug_Comment_Decl (Token_Ident (1 .. Token_Idlen));
+ Next_Token;
+ return;
+ when Tok_File_Name =>
+ if Flag_Renumber = False then
+ New_Debug_Filename_Decl (Token_Ident (1 .. Token_Idlen));
+ end if;
+ Next_Token;
+ return;
+ when others =>
+ Parse_Error ("declaration expected");
+ end case;
+ Expect (Tok_Semicolon);
+ Next_Token;
+ end Parse_Declaration;
+
+-- procedure Put (Str : String)
+-- is
+-- L : Integer;
+-- begin
+-- L := Write (Standout, Str'Address, Str'Length);
+-- end Put;
+
+ function Parse (Filename : String_Acc) return Boolean
+ is
+ begin
+ -- Initialize symbol table.
+ Add_Keyword ("type", Tok_Type);
+ Add_Keyword ("return", Tok_Return);
+ Add_Keyword ("if", Tok_If);
+ Add_Keyword ("then", Tok_Then);
+ Add_Keyword ("else", Tok_Else);
+ Add_Keyword ("elsif", Tok_Elsif);
+ Add_Keyword ("loop", Tok_Loop);
+ Add_Keyword ("exit", Tok_Exit);
+ Add_Keyword ("next", Tok_Next);
+ Add_Keyword ("signed", Tok_Signed);
+ Add_Keyword ("unsigned", Tok_Unsigned);
+ Add_Keyword ("float", Tok_Float);
+ Add_Keyword ("is", Tok_Is);
+ Add_Keyword ("of", Tok_Of);
+ Add_Keyword ("all", Tok_All);
+ Add_Keyword ("not", Tok_Not);
+ Add_Keyword ("abs", Tok_Abs);
+ Add_Keyword ("or", Tok_Or);
+ Add_Keyword ("and", Tok_And);
+ Add_Keyword ("xor", Tok_Xor);
+ Add_Keyword ("mod", Tok_Mod);
+ Add_Keyword ("rem", Tok_Rem);
+ Add_Keyword ("array", Tok_Array);
+ Add_Keyword ("access", Tok_Access);
+ Add_Keyword ("record", Tok_Record);
+ Add_Keyword ("union", Tok_Union);
+ Add_Keyword ("end", Tok_End);
+ Add_Keyword ("boolean", Tok_Boolean);
+ Add_Keyword ("enum", Tok_Enum);
+ Add_Keyword ("external", Tok_External);
+ Add_Keyword ("private", Tok_Private);
+ Add_Keyword ("public", Tok_Public);
+ Add_Keyword ("local", Tok_Local);
+ Add_Keyword ("procedure", Tok_Procedure);
+ Add_Keyword ("function", Tok_Function);
+ Add_Keyword ("constant", Tok_Constant);
+ Add_Keyword ("var", Tok_Var);
+ Add_Keyword ("subarray", Tok_Subarray);
+ Add_Keyword ("declare", Tok_Declare);
+ Add_Keyword ("begin", Tok_Begin);
+ Add_Keyword ("end", Tok_End);
+ Add_Keyword ("null", Tok_Null);
+ Add_Keyword ("case", Tok_Case);
+ Add_Keyword ("when", Tok_When);
+ Add_Keyword ("default", Tok_Default);
+
+ Id_Address := New_Symbol ("address");
+ Id_Unchecked_Address := New_Symbol ("unchecked_address");
+ Id_Subprg_Addr := New_Symbol ("subprg_addr");
+ Id_Conv := New_Symbol ("conv");
+ Id_Sizeof := New_Symbol ("sizeof");
+ Id_Alignof := New_Symbol ("alignof");
+ Id_Alloca := New_Symbol ("alloca");
+ Id_Offsetof := New_Symbol ("offsetof");
+
+ -- Initialize the scanner.
+ Buf (1) := NUL;
+ Pos := 1;
+ Lineno := 1;
+ if Filename = null then
+ Fd := Standin;
+ File_Name := new String'("*stdin*");
+ else
+ declare
+ Name : String (1 .. Filename'Length + 1);
+ --("C:\cygwin\home\tgingold\src\ortho\x86\tests\olang\ex2.ol",
+ begin
+ Name (1 .. Filename'Length) := Filename.all;
+ Name (Name'Last) := NUL;
+ File_Name := Filename;
+ Fd := Open_Read (Name'Address, Text);
+ if Fd = Invalid_FD then
+ Puterr ("cannot open '" & Filename.all & ''');
+ Newline_Err;
+ return False;
+ end if;
+ end;
+ end if;
+
+ New_Debug_Filename_Decl (File_Name.all);
+
+ Push_Scope;
+ Next_Token;
+ while Tok /= Tok_Eof loop
+ Parse_Declaration;
+ end loop;
+ Pop_Scope;
+
+ if Fd /= Standin then
+ Close (Fd);
+ end if;
+ return True;
+ exception
+ when E : others =>
+ Puterr (Ada.Exceptions.Exception_Information (E));
+ raise;
+ end Parse;
+end Ortho_Front;
diff --git a/src/ortho/ortho_front.ads b/src/ortho/ortho_front.ads
new file mode 100644
index 000000000..1d20e15d7
--- /dev/null
+++ b/src/ortho/ortho_front.ads
@@ -0,0 +1,41 @@
+-- Ortho front-end specifications.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package Ortho_Front is
+ type String_Acc is access String;
+
+ -- Called before decode_option.
+ -- This procedure can only do internal initializations. It cannot call
+ -- ortho subprograms.
+ procedure Init;
+
+ -- An ortho back-end decodes the command line. Unknown options may
+ -- be decoded by the user, with this function.
+ -- When an ortho back-end encounter an unknown option, it sets OPT with
+ -- this option and ARG with the next one, if any.
+ --
+ -- DECODE_OPTION must return the number of argument used, ie:
+ -- 0 if OPT is unknown.
+ -- 1 if OPT is known but ARG is unused.
+ -- 2 if OPT is known and ARG used.
+ function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural;
+
+ -- Start to parse file FILENAME.
+ -- Return False in case of error.
+ function Parse (Filename : String_Acc) return Boolean;
+end Ortho_Front;
diff --git a/src/ortho/ortho_jit.ads b/src/ortho/ortho_jit.ads
new file mode 100644
index 000000000..89c3663f3
--- /dev/null
+++ b/src/ortho/ortho_jit.ads
@@ -0,0 +1,43 @@
+-- Ortho JIT specifications.
+-- 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 System; use System;
+with Ortho_Nodes; use Ortho_Nodes;
+
+package Ortho_Jit is
+ -- Initialize the whole engine.
+ procedure Init;
+
+ -- Set address of non-defined global variables or functions.
+ procedure Set_Address (Decl : O_Dnode; Addr : Address);
+ -- Get address of a global.
+ function Get_Address (Decl : O_Dnode) return Address;
+
+ -- Do link.
+ procedure Link (Status : out Boolean);
+
+ -- Release memory (but the generated code).
+ procedure Finish;
+
+ function Decode_Option (Option : String) return Boolean;
+ procedure Disp_Help;
+
+ -- Return the name of the code generator, to be displayed by --version.
+ function Get_Jit_Name return String;
+end Ortho_Jit;
+
diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads
new file mode 100644
index 000000000..178187482
--- /dev/null
+++ b/src/ortho/ortho_nodes.common.ads
@@ -0,0 +1,453 @@
+-- Ortho specifications.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces; use Interfaces;
+with Ortho_Ident;
+use Ortho_Ident;
+
+-- Interface to create nodes.
+package ORTHO_NODES is
+
+ type O_Enode is private;
+ type O_Cnode is private;
+ type O_Lnode is private;
+ type O_Tnode is private;
+ type O_Snode is private;
+ type O_Dnode is private;
+ type O_Fnode is private;
+
+ O_Cnode_Null : constant O_Cnode;
+ O_Dnode_Null : constant O_Dnode;
+ O_Enode_Null : constant O_Enode;
+ O_Fnode_Null : constant O_Fnode;
+ O_Lnode_Null : constant O_Lnode;
+ O_Snode_Null : constant O_Snode;
+ O_Tnode_Null : constant O_Tnode;
+
+ -- True if the code generated supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean;
+
+ ------------------------
+ -- Type definitions --
+ ------------------------
+
+ type O_Element_List is limited private;
+
+ -- Build a record type.
+ procedure Start_Record_Type (Elements : out O_Element_List);
+ -- Add a field in the record; not constrained array are prohibited, since
+ -- its size is unlimited.
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode);
+ -- Finish the record type.
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an uncomplete record type:
+ -- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
+ -- This type can be declared or used to define access types on it.
+ -- Then, complete (if necessary) the record type, by calling
+ -- START_UNCOMPLETE_RECORD_TYPE, NEW_RECORD_FIELD and FINISH_RECORD_TYPE.
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode);
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List);
+
+ -- Build an union type.
+ procedure Start_Union_Type (Elements : out O_Element_List);
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode);
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
+ -- Build an access type.
+ -- DTYPE may be O_tnode_null in order to build an incomplete access type.
+ -- It is completed with finish_access_type.
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode;
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode);
+
+ -- Build an array type.
+ -- The array is not constrained and unidimensional.
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode;
+
+ -- Build a constrained array type.
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode;
+
+ -- Build a scalar type; size may be 8, 16, 32 or 64.
+ function New_Unsigned_Type (Size : Natural) return O_Tnode;
+ function New_Signed_Type (Size : Natural) return O_Tnode;
+
+ -- Build a float type.
+ function New_Float_Type return O_Tnode;
+
+ -- Build a boolean 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);
+
+ -- Create an enumeration
+ type O_Enum_List is limited private;
+
+ -- Elements are declared in order, the first is ordered from 0.
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural);
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident; Res : out O_Cnode);
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode);
+
+ ----------------
+ -- Literals --
+ ----------------
+
+ -- Create a literal from an integer.
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode;
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode;
+
+ -- Create a null access literal.
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
+
+ -- Build a record/array aggregate.
+ -- The aggregate is constant, and therefore can be only used to initialize
+ -- constant declaration.
+ -- ATYPE must be either a record type or an array subtype.
+ -- Elements must be added in the order, and must be literals or aggregates.
+ type O_Record_Aggr_List is limited private;
+ type O_Array_Aggr_List is limited private;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List;
+ Atype : O_Tnode);
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Record_Aggr (List : in out O_Record_Aggr_List;
+ Res : out O_Cnode);
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode);
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode);
+ procedure Finish_Array_Aggr (List : in out O_Array_Aggr_List;
+ Res : out O_Cnode);
+
+ -- Build an union aggregate.
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode;
+
+ -- Returns the size in bytes of ATYPE. The result is a literal of
+ -- unsigned type RTYPE
+ -- ATYPE cannot be an unconstrained array type.
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the alignment in bytes for ATYPE. The result is a literal of
+ -- unsgined type RTYPE.
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
+ -- Returns the offset of FIELD in its record ATYPE. The result is a
+ -- literal of unsigned type or access type RTYPE.
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of a subprogram.
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode;
+
+ -------------------
+ -- Expressions --
+ -------------------
+
+ type ON_Op_Kind is
+ (
+ -- Not an operation; invalid.
+ ON_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov, -- ON_Dyadic_Op_Kind
+ ON_Sub_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mul_Ov, -- ON_Dyadic_Op_Kind
+ ON_Div_Ov, -- ON_Dyadic_Op_Kind
+ ON_Rem_Ov, -- ON_Dyadic_Op_Kind
+ ON_Mod_Ov, -- ON_Dyadic_Op_Kind
+
+ -- Binary operations.
+ ON_And, -- ON_Dyadic_Op_Kind
+ ON_Or, -- ON_Dyadic_Op_Kind
+ ON_Xor, -- ON_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ ON_Not, -- ON_Monadic_Op_Kind
+ ON_Neg_Ov, -- ON_Monadic_Op_Kind
+ ON_Abs_Ov, -- ON_Monadic_Op_Kind
+
+ -- Comparaisons
+ ON_Eq, -- ON_Compare_Op_Kind
+ ON_Neq, -- ON_Compare_Op_Kind
+ ON_Le, -- ON_Compare_Op_Kind
+ ON_Lt, -- ON_Compare_Op_Kind
+ ON_Ge, -- ON_Compare_Op_Kind
+ ON_Gt -- ON_Compare_Op_Kind
+ );
+
+ subtype ON_Dyadic_Op_Kind is ON_Op_Kind range ON_Add_Ov .. ON_Xor;
+ subtype ON_Monadic_Op_Kind is ON_Op_Kind range ON_Not .. ON_Abs_Ov;
+ subtype ON_Compare_Op_Kind is ON_Op_Kind range ON_Eq .. ON_Gt;
+
+ type O_Storage is (O_Storage_External,
+ O_Storage_Public,
+ O_Storage_Private,
+ O_Storage_Local);
+ -- Specifies the storage kind of a declaration.
+ -- O_STORAGE_EXTERNAL:
+ -- The declaration do not either reserve memory nor generate code, and
+ -- is imported either from an other file or from a later place in the
+ -- current file.
+ -- O_STORAGE_PUBLIC, O_STORAGE_PRIVATE:
+ -- The declaration reserves memory or generates code.
+ -- With O_STORAGE_PUBLIC, the declaration is exported outside of the
+ -- file while with O_STORAGE_PRIVATE, the declaration is local to the
+ -- file.
+
+ Type_Error : exception;
+ Syntax_Error : exception;
+
+ -- Create a value from a literal.
+ function New_Lit (Lit : O_Cnode) return O_Enode;
+
+ -- Create a dyadic operation.
+ -- Left and right nodes must have the same type.
+ -- Binary operation is allowed only on boolean types.
+ -- The result is of the type of the operands.
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode;
+
+ -- Create a monadic operation.
+ -- Result is of the type of operand.
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode;
+
+ -- Create a comparaison operator.
+ -- NTYPE is the type of the result and must be a boolean type.
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode;
+
+
+ type O_Inter_List is limited private;
+ type O_Assoc_List is limited private;
+ type O_If_Block is limited private;
+ type O_Case_Block is limited private;
+
+
+ -- Get an element of an array.
+ -- INDEX must be of the type of the array index.
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get a slice of an array; this is equivalent to a conversion between
+ -- an array or an array subtype and an array subtype.
+ -- RES_TYPE must be an array_sub_type whose base type is the same as the
+ -- base type of ARR.
+ -- INDEX must be of the type of the array index.
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode;
+
+ -- Get an element of a record.
+ -- Type of REC must be a record type.
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode;
+
+ -- Reference an access.
+ -- Type of ACC must be an access type.
+ function New_Access_Element (Acc : O_Enode) return O_Lnode;
+
+ -- Do a conversion.
+ -- Allowed conversions are:
+ -- FIXME: to write.
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode;
+
+ -- Get the address of LVALUE.
+ -- ATYPE must be a type access whose designated type is the type of LVALUE.
+ -- FIXME: what about arrays.
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode;
+
+ -- Same as New_Address but without any restriction.
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode;
+
+ -- Get the value of an Lvalue.
+ function New_Value (Lvalue : O_Lnode) return O_Enode;
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode;
+
+ -- Get an lvalue from a declaration.
+ function New_Obj (Obj : O_Dnode) return O_Lnode;
+
+ -- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
+
+ -- Declare a type.
+ -- This simply gives a name to a type.
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode);
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ -- Filename of the next declaration.
+ procedure New_Debug_Filename_Decl (Filename : String);
+
+ -- Line number of the next declaration.
+ procedure New_Debug_Line_Decl (Line : Natural);
+
+ -- Add a comment in the declarative region.
+ procedure New_Debug_Comment_Decl (Comment : String);
+
+ -- Declare a constant.
+ -- This simply gives a name to a constant value or aggregate.
+ -- A constant cannot be modified and its storage cannot be local.
+ -- ATYPE must be constrained.
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Set the value of a non-external constant.
+ procedure Start_Const_Value (Const : in out O_Dnode);
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode);
+
+ -- Create a variable declaration.
+ -- A variable can be local only inside a function.
+ -- ATYPE must be constrained.
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
+
+ -- Start a subprogram declaration.
+ -- Note: nested subprograms are allowed, ie o_storage_local subprograms can
+ -- be declared inside a subprograms. It is not allowed to declare
+ -- o_storage_external subprograms inside a subprograms.
+ -- Return type and interfaces cannot be a composite type.
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
+ -- For a subprogram without return value.
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
+
+ -- Add an interface declaration to INTERFACES.
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
+ -- Finish the function declaration, get the node and a statement list.
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode);
+ -- Start a subprogram body.
+ -- Note: the declaration may have an external storage, in this case it
+ -- becomes public.
+ procedure Start_Subprogram_Body (Func : O_Dnode);
+ -- Finish a subprogram body.
+ procedure Finish_Subprogram_Body;
+
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ -- Add a line number as a statement.
+ procedure New_Debug_Line_Stmt (Line : Natural);
+
+ -- Add a comment as a statement.
+ procedure New_Debug_Comment_Stmt (Comment : String);
+
+ -- Start a declarative region.
+ procedure Start_Declare_Stmt;
+ procedure Finish_Declare_Stmt;
+
+ -- Create a function call or a procedure call.
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode);
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode);
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode;
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List);
+
+ -- Assign VALUE to TARGET, type must be the same or compatible.
+ -- FIXME: what about slice assignment?
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode);
+
+ -- Exit from the subprogram and return VALUE.
+ procedure New_Return_Stmt (Value : O_Enode);
+ -- Exit from the subprogram, which doesn't return value.
+ procedure New_Return_Stmt;
+
+ -- Build an IF statement.
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+ procedure New_Else_Stmt (Block : in out O_If_Block);
+ procedure Finish_If_Stmt (Block : in out O_If_Block);
+
+ -- Create a infinite loop statement.
+ procedure Start_Loop_Stmt (Label : out O_Snode);
+ procedure Finish_Loop_Stmt (Label : in out O_Snode);
+
+ -- Exit from a loop stmt or from a for stmt.
+ procedure New_Exit_Stmt (L : O_Snode);
+ -- Go to the start of a loop stmt or of a for stmt.
+ -- Loops/Fors between L and the current points are exited.
+ procedure New_Next_Stmt (L : O_Snode);
+
+ -- Case statement.
+ -- VALUE is the selector and must be a discrete type.
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode);
+ -- A choice branch is composed of expr, range or default choices.
+ -- A choice branch is enclosed between a Start_Choice and a Finish_Choice.
+ -- The statements are after the finish_choice.
+ procedure Start_Choice (Block : in out O_Case_Block);
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode);
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode);
+ procedure New_Default_Choice (Block : in out O_Case_Block);
+ procedure Finish_Choice (Block : in out O_Case_Block);
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block);
+
+private
+ --- PRIVATE PART is defined by ortho_nodes.ads in one of the subdirectory.
+end ORTHO_NODES;
diff --git a/src/parse.adb b/src/parse.adb
new file mode 100644
index 000000000..97ff87691
--- /dev/null
+++ b/src/parse.adb
@@ -0,0 +1,7143 @@
+-- VHDL parser.
+-- 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 Iir_Chains; use Iir_Chains;
+with Ada.Text_IO; use Ada.Text_IO;
+with Types; use Types;
+with Tokens; use Tokens;
+with Scanner; use Scanner;
+with Iirs_Utils; use Iirs_Utils;
+with Errorout; use Errorout;
+with Std_Names; use Std_Names;
+with Flags; use Flags;
+with Parse_Psl;
+with Name_Table;
+with Str_Table;
+with Xrefs;
+
+-- Recursive descendant parser.
+-- Each subprogram (should) parse one production rules.
+-- Rules are written in a comment just before the subprogram.
+-- terminals are written in upper case.
+-- non-terminal are written in lower case.
+-- syntaxic category of a non-terminal are written in upper case.
+-- eg: next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ;
+-- Or (|) must be aligned by the previous or, or with the '=' character.
+-- Indentation is 4.
+--
+-- To document what is expected for input and what is left as an output
+-- concerning token stream, a precond and a postcond comment shoud be
+-- added before the above rules.
+-- a token (such as IF or ';') means the current token is this token.
+-- 'a token' means the current token was analysed.
+-- 'next token' means the current token is to be analysed.
+
+
+package body Parse is
+
+ -- current_token must be valid.
+ -- Leaves a token.
+ function Parse_Simple_Expression (Primary : Iir := Null_Iir)
+ return Iir_Expression;
+ function Parse_Primary return Iir_Expression;
+ function Parse_Use_Clause return Iir_Use_Clause;
+
+ function Parse_Association_List return Iir;
+ function Parse_Association_List_In_Parenthesis return Iir;
+
+ function Parse_Sequential_Statements (Parent : Iir) return Iir;
+ function Parse_Configuration_Item return Iir;
+ function Parse_Block_Configuration return Iir_Block_Configuration;
+ procedure Parse_Concurrent_Statements (Parent : Iir);
+ function Parse_Subprogram_Declaration (Parent : Iir) return Iir;
+ function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir;
+ procedure Parse_Component_Specification (Res : Iir);
+ function Parse_Binding_Indication return Iir_Binding_Indication;
+ function Parse_Aggregate return Iir;
+ function Parse_Signature return Iir_Signature;
+ procedure Parse_Declarative_Part (Parent : Iir);
+ function Parse_Tolerance_Aspect_Opt return Iir;
+
+ Expect_Error: exception;
+
+ -- Copy the current location into an iir.
+ procedure Set_Location (Node : Iir) is
+ begin
+ Set_Location (Node, Get_Token_Location);
+ end Set_Location;
+
+ procedure Set_End_Location (Node : Iir) is
+ begin
+ Set_End_Location (Node, Get_Token_Location);
+ end Set_End_Location;
+
+ procedure Unexpected (Where: String) is
+ begin
+ Error_Msg_Parse
+ ("unexpected token '" & Image (Current_Token) & "' in a " & Where);
+ end Unexpected;
+
+-- procedure Unexpected_Eof is
+-- begin
+-- Error_Msg_Parse ("unexpected end of file");
+-- end Unexpected_Eof;
+
+ -- Emit an error if the current_token if different from TOKEN.
+ -- Otherwise, accept the current_token (ie set it to tok_invalid, unless
+ -- TOKEN is Tok_Identifier).
+ procedure Expect (Token: Token_Type; Msg: String := "") is
+ begin
+ if Current_Token /= Token then
+ if Msg'Length > 0 then
+ Error_Msg_Parse (Msg);
+ Error_Msg_Parse ("(found: " & Image (Current_Token) & ")");
+ else
+ Error_Msg_Parse
+ (''' & Image(Token) & "' is expected instead of '"
+ & Image (Current_Token) & ''');
+ end if;
+ raise Expect_Error;
+ end if;
+
+ -- Accept the current_token.
+ if Current_Token /= Tok_Identifier then
+ Invalidate_Current_Token;
+ end if;
+ exception
+ when Parse_Error =>
+ Put_Line ("found " & Token_Type'Image (Current_Token));
+ if Current_Token = Tok_Identifier then
+ Put_Line ("identifier: " & Name_Table.Image (Current_Identifier));
+ end if;
+ raise;
+ end Expect;
+
+ -- Scan a token and expect it.
+ procedure Scan_Expect (Token: Token_Type; Msg: String := "") is
+ begin
+ Scan;
+ Expect (Token, Msg);
+ end Scan_Expect;
+
+ -- If the current_token is an identifier, it must be equal to name.
+ -- In this case, a token is eaten.
+ -- If the current_token is not an identifier, this is a noop.
+ procedure Check_End_Name (Name : Name_Id; Decl : Iir) is
+ begin
+ if Current_Token /= Tok_Identifier then
+ return;
+ end if;
+ if Name = Null_Identifier then
+ Error_Msg_Parse
+ ("end label for an unlabeled declaration or statement");
+ else
+ if Current_Identifier /= Name then
+ Error_Msg_Parse
+ ("mispelling, """ & Name_Table.Image (Name) & """ expected");
+ else
+ Set_End_Has_Identifier (Decl, True);
+ Xrefs.Xref_End (Get_Token_Location, Decl);
+ end if;
+ end if;
+ Scan;
+ end Check_End_Name;
+
+ procedure Check_End_Name (Decl : Iir) is
+ begin
+ Check_End_Name (Get_Identifier (Decl), Decl);
+ end Check_End_Name;
+
+
+ -- Expect ' END tok [ name ] ; '
+ procedure Check_End_Name (Tok : Token_Type; Decl : Iir) is
+ begin
+ if Current_Token /= Tok_End then
+ Error_Msg_Parse ("""end " & Image (Tok) & ";"" expected");
+ else
+ Scan;
+ if Current_Token /= Tok then
+ Error_Msg_Parse
+ ("""end"" must be followed by """ & Image (Tok) & """");
+ else
+ Set_End_Has_Reserved_Id (Decl, True);
+ Scan;
+ end if;
+ Check_End_Name (Decl);
+ Expect (Tok_Semi_Colon);
+ end if;
+ end Check_End_Name;
+
+ procedure Eat_Tokens_Until_Semi_Colon is
+ begin
+ loop
+ case Current_Token is
+ when Tok_Semi_Colon
+ | Tok_Eof =>
+ exit;
+ when others =>
+ Scan;
+ end case;
+ end loop;
+ end Eat_Tokens_Until_Semi_Colon;
+
+ -- Expect and scan ';' emit an error message using MSG if not present.
+ procedure Scan_Semi_Colon (Msg : String) is
+ begin
+ if Current_Token /= Tok_Semi_Colon then
+ Error_Msg_Parse ("missing "";"" at end of " & Msg);
+ else
+ Scan;
+ end if;
+ end Scan_Semi_Colon;
+
+ -- precond : next token
+ -- postcond: next token.
+ --
+ -- [� 4.3.2 ]
+ -- mode ::= IN | OUT | INOUT | BUFFER | LINKAGE
+ --
+ -- If there is no mode, DEFAULT is returned.
+ function Parse_Mode (Default: Iir_Mode) return Iir_Mode is
+ begin
+ case Current_Token is
+ when Tok_Identifier =>
+ return Default;
+ when Tok_In =>
+ Scan;
+ if Current_Token = Tok_Out then
+ -- Nice message for Ada users...
+ Error_Msg_Parse ("typo error, in out must be 'inout' in vhdl");
+ Scan;
+ return Iir_Inout_Mode;
+ end if;
+ return Iir_In_Mode;
+ when Tok_Out =>
+ Scan;
+ return Iir_Out_Mode;
+ when Tok_Inout =>
+ Scan;
+ return Iir_Inout_Mode;
+ when Tok_Linkage =>
+ Scan;
+ return Iir_Linkage_Mode;
+ when Tok_Buffer =>
+ Scan;
+ return Iir_Buffer_Mode;
+ when others =>
+ Error_Msg_Parse
+ ("mode is 'in', 'out', 'inout', 'buffer' or 'linkage'");
+ return Iir_In_Mode;
+ end case;
+ end Parse_Mode;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �4.3.1.2 ]
+ -- signal_kind ::= REGISTER | BUS
+ --
+ -- If there is no signal_kind, then no_signal_kind is returned.
+ function Parse_Signal_Kind return Iir_Signal_Kind is
+ begin
+ if Current_Token = Tok_Bus then
+ Scan;
+ return Iir_Bus_Kind;
+ elsif Current_Token = Tok_Register then
+ Scan;
+ return Iir_Register_Kind;
+ else
+ return Iir_No_Signal_Kind;
+ end if;
+ end Parse_Signal_Kind;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- Parse a range.
+ -- If LEFT is not null_iir, then it must be an expression corresponding to
+ -- the left limit of the range, and the current_token must be either
+ -- tok_to or tok_downto.
+ -- If left is null_iir, the current token is used to create the left limit
+ -- expression.
+ --
+ -- [3.1]
+ -- range ::= RANGE_attribute_name
+ -- | simple_expression direction simple_expression
+ function Parse_Range_Expression (Left: Iir; Discrete: Boolean := False)
+ return Iir
+ is
+ Res : Iir;
+ Left1: Iir;
+ begin
+ if Left /= Null_Iir then
+ Left1 := Left;
+ else
+ Left1 := Parse_Simple_Expression;
+ end if;
+
+ case Current_Token is
+ when Tok_To =>
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Set_Direction (Res, Iir_To);
+ when Tok_Downto =>
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Set_Direction (Res, Iir_Downto);
+ when Tok_Range =>
+ if not Discrete then
+ Unexpected ("range definition");
+ end if;
+ Scan;
+ if Current_Token = Tok_Box then
+ Unexpected ("range expression expected");
+ Scan;
+ return Null_Iir;
+ end if;
+ Res := Parse_Range_Expression (Null_Iir, False);
+ if Res /= Null_Iir then
+ Set_Type (Res, Left1);
+ end if;
+ return Res;
+ when others =>
+ if Left1 = Null_Iir then
+ return Null_Iir;
+ end if;
+ if Is_Range_Attribute_Name (Left1) then
+ return Left1;
+ end if;
+ if Discrete
+ and then Get_Kind (Left1) in Iir_Kinds_Denoting_Name
+ then
+ return Left1;
+ end if;
+ Error_Msg_Parse ("'to' or 'downto' expected");
+ return Null_Iir;
+ end case;
+ Set_Left_Limit (Res, Left1);
+ Location_Copy (Res, Left1);
+
+ Scan;
+ Set_Right_Limit (Res, Parse_Simple_Expression);
+ return Res;
+ end Parse_Range_Expression;
+
+ -- [ 3.1 ]
+ -- range_constraint ::= RANGE range
+ --
+ -- [ 3.1 ]
+ -- range ::= range_attribute_name
+ -- | simple_expression direction simple_expression
+ --
+ -- [ 3.1 ]
+ -- direction ::= TO | DOWNTO
+
+ -- precond: TO or DOWNTO
+ -- postcond: next token
+ function Parse_Range_Right (Left : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Set_Location (Res);
+ Set_Left_Limit (Res, Left);
+
+ case Current_Token is
+ when Tok_To =>
+ Set_Direction (Res, Iir_To);
+ when Tok_Downto =>
+ Set_Direction (Res, Iir_Downto);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Scan;
+ Set_Right_Limit (Res, Parse_Simple_Expression);
+ return Res;
+ end Parse_Range_Right;
+
+ -- precond: next token
+ -- postcond: next token
+ function Parse_Range return Iir
+ is
+ Left: Iir;
+ begin
+ Left := Parse_Simple_Expression;
+
+ case Current_Token is
+ when Tok_To
+ | Tok_Downto =>
+ return Parse_Range_Right (Left);
+ when others =>
+ if Left /= Null_Iir then
+ if Is_Range_Attribute_Name (Left) then
+ return Left;
+ end if;
+ Error_Msg_Parse ("'to' or 'downto' expected");
+ end if;
+ return Null_Iir;
+ end case;
+ end Parse_Range;
+
+ -- precond: next token (after RANGE)
+ -- postcond: next token
+ function Parse_Range_Constraint return Iir is
+ begin
+ if Current_Token = Tok_Box then
+ Error_Msg_Parse ("range constraint required");
+ Scan;
+ return Null_Iir;
+ end if;
+
+ return Parse_Range;
+ end Parse_Range_Constraint;
+
+ -- precond: next token (after RANGE)
+ -- postcond: next token
+ function Parse_Range_Constraint_Of_Subtype_Indication
+ (Type_Mark : Iir;
+ Resolution_Indication : Iir := Null_Iir)
+ return Iir
+ is
+ Def : Iir;
+ begin
+ Def := Create_Iir (Iir_Kind_Subtype_Definition);
+ Location_Copy (Def, Type_Mark);
+ Set_Subtype_Type_Mark (Def, Type_Mark);
+ Set_Range_Constraint (Def, Parse_Range_Constraint);
+ Set_Resolution_Indication (Def, Resolution_Indication);
+ Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt);
+
+ return Def;
+ end Parse_Range_Constraint_Of_Subtype_Indication;
+
+ -- precond: next token
+ -- postcond: next token
+ --
+ -- [ 3.2.1 ]
+ -- discrete_range ::= discrete_subtype_indication | range
+ function Parse_Discrete_Range return Iir
+ is
+ Left: Iir;
+ begin
+ Left := Parse_Simple_Expression;
+
+ case Current_Token is
+ when Tok_To
+ | Tok_Downto =>
+ return Parse_Range_Right (Left);
+ when Tok_Range =>
+ return Parse_Subtype_Indication (Left);
+ when others =>
+ -- Either a /range/_attribute_name or a type_mark.
+ return Left;
+ end case;
+ end Parse_Discrete_Range;
+
+ -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier.
+ -- Emit an error message if the name is not an operator name.
+ function Str_To_Operator_Name (Str : String_Fat_Acc;
+ Len : Nat32;
+ Loc : Location_Type) return Name_Id
+ is
+ -- LRM93 2.1
+ -- Extra spaces are not allowed in an operator symbol, and the
+ -- case of letters is not signifiant.
+
+ -- LRM93 2.1
+ -- The sequence of characters represented by an operator symbol
+ -- must be an operator belonging to one of classes of operators
+ -- defined in section 7.2.
+
+ procedure Bad_Operator_Symbol is
+ begin
+ Error_Msg_Parse ("""" & String (Str (1 .. Len))
+ & """ is not an operator symbol", Loc);
+ end Bad_Operator_Symbol;
+
+ procedure Check_Vhdl93 is
+ begin
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("""" & String (Str (1 .. Len))
+ & """ is not a vhdl87 operator symbol", Loc);
+ end if;
+ end Check_Vhdl93;
+
+ Id : Name_Id;
+ C1, C2, C3, C4 : Character;
+ begin
+ C1 := Str (1);
+ case Len is
+ when 1 =>
+ -- =, <, >, +, -, *, /, &
+ case C1 is
+ when '=' =>
+ Id := Name_Op_Equality;
+ when '>' =>
+ Id := Name_Op_Greater;
+ when '<' =>
+ Id := Name_Op_Less;
+ when '+' =>
+ Id := Name_Op_Plus;
+ when '-' =>
+ Id := Name_Op_Minus;
+ when '*' =>
+ Id := Name_Op_Mul;
+ when '/' =>
+ Id := Name_Op_Div;
+ when '&' =>
+ Id := Name_Op_Concatenation;
+ when others =>
+ Bad_Operator_Symbol;
+ Id := Name_Op_Plus;
+ end case;
+ when 2 =>
+ -- or, /=, <=, >=, **
+ C2 := Str (2);
+ case C1 is
+ when 'o' | 'O' =>
+ Id := Name_Or;
+ if C2 /= 'r' and C2 /= 'R' then
+ Bad_Operator_Symbol;
+ end if;
+ when '/' =>
+ Id := Name_Op_Inequality;
+ if C2 /= '=' then
+ Bad_Operator_Symbol;
+ end if;
+ when '<' =>
+ Id := Name_Op_Less_Equal;
+ if C2 /= '=' then
+ Bad_Operator_Symbol;
+ end if;
+ when '>' =>
+ Id := Name_Op_Greater_Equal;
+ if C2 /= '=' then
+ Bad_Operator_Symbol;
+ end if;
+ when '*' =>
+ Id := Name_Op_Exp;
+ if C2 /= '*' then
+ Bad_Operator_Symbol;
+ end if;
+ when '?' =>
+ if Vhdl_Std < Vhdl_08 then
+ Bad_Operator_Symbol;
+ Id := Name_Op_Condition;
+ elsif C2 = '?' then
+ Id := Name_Op_Condition;
+ elsif C2 = '=' then
+ Id := Name_Op_Match_Equality;
+ elsif C2 = '<' then
+ Id := Name_Op_Match_Less;
+ elsif C2 = '>' then
+ Id := Name_Op_Match_Greater;
+ else
+ Bad_Operator_Symbol;
+ Id := Name_Op_Condition;
+ end if;
+ when others =>
+ Bad_Operator_Symbol;
+ Id := Name_Op_Equality;
+ end case;
+ when 3 =>
+ -- mod, rem, and, xor, nor, abs, not, sll, sla, sra, srl, rol
+ -- ror
+ C2 := Str (2);
+ C3 := Str (3);
+ case C1 is
+ when 'm' | 'M' =>
+ Id := Name_Mod;
+ if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'd' and C3 /= 'D')
+ then
+ Bad_Operator_Symbol;
+ end if;
+ when 'a' | 'A' =>
+ if (C2 = 'n' or C2 = 'N') and (C3 = 'd' or C3 = 'D') then
+ Id := Name_And;
+ elsif (C2 = 'b' or C2 = 'B') and (C3 = 's' or C3 = 'S') then
+ Id := Name_Abs;
+ else
+ Id := Name_And;
+ Bad_Operator_Symbol;
+ end if;
+ when 'x' | 'X' =>
+ Id := Name_Xor;
+ if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'r' and C3 /= 'R')
+ then
+ Bad_Operator_Symbol;
+ end if;
+ when 'n' | 'N' =>
+ if C2 = 'o' or C2 = 'O' then
+ if C3 = 'r' or C3 = 'R' then
+ Id := Name_Nor;
+ elsif C3 = 't' or C3 = 'T' then
+ Id := Name_Not;
+ else
+ Id := Name_Not;
+ Bad_Operator_Symbol;
+ end if;
+ else
+ Id := Name_Not;
+ Bad_Operator_Symbol;
+ end if;
+ when 's' | 'S' =>
+ if C2 = 'l' or C2 = 'L' then
+ if C3 = 'l' or C3 = 'L' then
+ Check_Vhdl93;
+ Id := Name_Sll;
+ elsif C3 = 'a' or C3 = 'A' then
+ Check_Vhdl93;
+ Id := Name_Sla;
+ else
+ Id := Name_Sll;
+ Bad_Operator_Symbol;
+ end if;
+ elsif C2 = 'r' or C2 = 'R' then
+ if C3 = 'l' or C3 = 'L' then
+ Check_Vhdl93;
+ Id := Name_Srl;
+ elsif C3 = 'a' or C3 = 'A' then
+ Check_Vhdl93;
+ Id := Name_Sra;
+ else
+ Id := Name_Srl;
+ Bad_Operator_Symbol;
+ end if;
+ else
+ Id := Name_Sll;
+ Bad_Operator_Symbol;
+ end if;
+ when 'r' | 'R' =>
+ if C2 = 'e' or C2 = 'E' then
+ if C3 = 'm' or C3 = 'M' then
+ Id := Name_Rem;
+ else
+ Id := Name_Rem;
+ Bad_Operator_Symbol;
+ end if;
+ elsif C2 = 'o' or C2 = 'O' then
+ if C3 = 'l' or C3 = 'L' then
+ Check_Vhdl93;
+ Id := Name_Rol;
+ elsif C3 = 'r' or C3 = 'R' then
+ Check_Vhdl93;
+ Id := Name_Ror;
+ else
+ Id := Name_Rol;
+ Bad_Operator_Symbol;
+ end if;
+ else
+ Id := Name_Rem;
+ Bad_Operator_Symbol;
+ end if;
+ when '?' =>
+ if Vhdl_Std < Vhdl_08 then
+ Bad_Operator_Symbol;
+ Id := Name_Op_Match_Less_Equal;
+ else
+ if C2 = '<' and C3 = '=' then
+ Id := Name_Op_Match_Less_Equal;
+ elsif C2 = '>' and C3 = '=' then
+ Id := Name_Op_Match_Greater_Equal;
+ elsif C2 = '/' and C3 = '=' then
+ Id := Name_Op_Match_Inequality;
+ else
+ Bad_Operator_Symbol;
+ Id := Name_Op_Match_Less_Equal;
+ end if;
+ end if;
+ when others =>
+ Id := Name_And;
+ Bad_Operator_Symbol;
+ end case;
+ when 4 =>
+ -- nand, xnor
+ C2 := Str (2);
+ C3 := Str (3);
+ C4 := Str (4);
+ if (C1 = 'n' or C1 = 'N')
+ and (C2 = 'a' or C2 = 'A')
+ and (C3 = 'n' or C3 = 'N')
+ and (C4 = 'd' or C4 = 'D')
+ then
+ Id := Name_Nand;
+ elsif (C1 = 'x' or C1 = 'X')
+ and (C2 = 'n' or C2 = 'N')
+ and (C3 = 'o' or C3 = 'O')
+ and (C4 = 'r' or C4 = 'R')
+ then
+ Check_Vhdl93;
+ Id := Name_Xnor;
+ else
+ Id := Name_Nand;
+ Bad_Operator_Symbol;
+ end if;
+ when others =>
+ Id := Name_Op_Plus;
+ Bad_Operator_Symbol;
+ end case;
+ return Id;
+ end Str_To_Operator_Name;
+
+ function Scan_To_Operator_Name (Loc : Location_Type) return Name_Id is
+ begin
+ return Str_To_Operator_Name
+ (Str_Table.Get_String_Fat_Acc (Current_String_Id),
+ Current_String_Length,
+ Loc);
+ end Scan_To_Operator_Name;
+ pragma Inline (Scan_To_Operator_Name);
+
+ -- Convert string literal STR to an operator symbol.
+ -- Emit an error message if the string is not an operator name.
+ function String_To_Operator_Symbol (Str : Iir_String_Literal)
+ return Iir
+ is
+ Id : Name_Id;
+ Res : Iir;
+ begin
+ Id := Str_To_Operator_Name
+ (Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)),
+ Get_String_Length (Str),
+ Get_Location (Str));
+ Res := Create_Iir (Iir_Kind_Operator_Symbol);
+ Location_Copy (Res, Str);
+ Set_Identifier (Res, Id);
+ Free_Iir (Str);
+ return Res;
+ end String_To_Operator_Symbol;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �6.1 ]
+ -- name ::= simple_name
+ -- | operator_symbol
+ -- | selected_name
+ -- | indexed_name
+ -- | slice_name
+ -- | attribute_name
+ --
+ -- [ �6.2 ]
+ -- simple_name ::= identifier
+ --
+ -- [ �6.5 ]
+ -- slice_name ::= prefix ( discrete_range )
+ --
+ -- [ �6.3 ]
+ -- selected_name ::= prefix . suffix
+ --
+ -- [ �6.1 ]
+ -- prefix ::= name
+ -- | function_call
+ --
+ -- [ �6.3 ]
+ -- suffix ::= simple_name
+ -- | character_literal
+ -- | operator_symbol
+ -- | ALL
+ --
+ -- [ �3.2.1 ]
+ -- discrete_range ::= DISCRETE_subtype_indication | range
+ --
+ -- [ �3.1 ]
+ -- range ::= RANGE_attribute_name
+ -- | simple_expression direction simple_expression
+ --
+ -- [ �3.1 ]
+ -- direction ::= TO | DOWNTO
+ --
+ -- [ �6.6 ]
+ -- attribute_name ::=
+ -- prefix [ signature ] ' attribute_designator [ ( expression ) ]
+ --
+ -- [ �6.6 ]
+ -- attribute_designator ::= ATTRIBUTE_simple_name
+ --
+ -- Note: in order to simplify the parsing, this function may return a
+ -- signature without attribute designator. Signatures may appear at 3
+ -- places:
+ -- - in attribute name
+ -- - in alias declaration
+ -- - in entity designator
+ function Parse_Name_Suffix (Pfx : Iir; Allow_Indexes: Boolean := True)
+ return Iir
+ is
+ Res: Iir;
+ Prefix: Iir;
+ begin
+ Res := Pfx;
+ loop
+ Prefix := Res;
+
+ case Current_Token is
+ when Tok_Left_Bracket =>
+ if Get_Kind (Prefix) = Iir_Kind_String_Literal then
+ Prefix := String_To_Operator_Symbol (Prefix);
+ end if;
+
+ -- There is a signature. They are normally followed by an
+ -- attribute.
+ Res := Parse_Signature;
+ Set_Signature_Prefix (Res, Prefix);
+
+ when Tok_Tick =>
+ -- There is an attribute.
+ if Get_Kind (Prefix) = Iir_Kind_String_Literal then
+ Prefix := String_To_Operator_Symbol (Prefix);
+ end if;
+
+ Scan;
+ if Current_Token = Tok_Left_Paren then
+ -- A qualified expression.
+ Res := Create_Iir (Iir_Kind_Qualified_Expression);
+ Set_Type_Mark (Res, Prefix);
+ Location_Copy (Res, Prefix);
+ Set_Expression (Res, Parse_Aggregate);
+ return Res;
+ elsif Current_Token /= Tok_Range
+ and then Current_Token /= Tok_Identifier
+ then
+ Expect (Tok_Identifier, "required for an attribute name");
+ return Null_Iir;
+ end if;
+ Res := Create_Iir (Iir_Kind_Attribute_Name);
+ Set_Identifier (Res, Current_Identifier);
+ Set_Location (Res);
+ if Get_Kind (Prefix) = Iir_Kind_Signature then
+ Set_Attribute_Signature (Res, Prefix);
+ Set_Prefix (Res, Get_Signature_Prefix (Prefix));
+ else
+ Set_Prefix (Res, Prefix);
+ end if;
+
+ -- accept the identifier.
+ Scan;
+
+ when Tok_Left_Paren =>
+ if not Allow_Indexes then
+ return Res;
+ end if;
+
+ if Get_Kind (Prefix) = Iir_Kind_String_Literal then
+ Prefix := String_To_Operator_Symbol (Prefix);
+ end if;
+
+ Res := Create_Iir (Iir_Kind_Parenthesis_Name);
+ Set_Location (Res);
+ Set_Prefix (Res, Prefix);
+ Set_Association_Chain
+ (Res, Parse_Association_List_In_Parenthesis);
+
+ when Tok_Dot =>
+ if Get_Kind (Prefix) = Iir_Kind_String_Literal then
+ Prefix := String_To_Operator_Symbol (Prefix);
+ end if;
+
+ Scan;
+ case Current_Token is
+ when Tok_All =>
+ Res := Create_Iir (Iir_Kind_Selected_By_All_Name);
+ Set_Location (Res);
+ Set_Prefix (Res, Prefix);
+ when Tok_Identifier
+ | Tok_Character =>
+ Res := Create_Iir (Iir_Kind_Selected_Name);
+ Set_Location (Res);
+ Set_Prefix (Res, Prefix);
+ Set_Identifier (Res, Current_Identifier);
+ when Tok_String =>
+ Res := Create_Iir (Iir_Kind_Selected_Name);
+ Set_Location (Res);
+ Set_Prefix (Res, Prefix);
+ Set_Identifier
+ (Res, Scan_To_Operator_Name (Get_Token_Location));
+ when others =>
+ Error_Msg_Parse ("an identifier or all is expected");
+ end case;
+ Scan;
+ when others =>
+ return Res;
+ end case;
+ end loop;
+ end Parse_Name_Suffix;
+
+ function Parse_Name (Allow_Indexes: Boolean := True) return Iir
+ is
+ Res: Iir;
+ begin
+ case Current_Token is
+ when Tok_Identifier =>
+ Res := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Identifier (Res, Current_Identifier);
+ Set_Location (Res);
+ when Tok_String =>
+ Res := Create_Iir (Iir_Kind_String_Literal);
+ Set_String_Id (Res, Current_String_Id);
+ Set_String_Length (Res, Current_String_Length);
+ Set_Location (Res);
+ when others =>
+ Error_Msg_Parse ("identifier expected here");
+ raise Parse_Error;
+ end case;
+
+ Scan;
+
+ return Parse_Name_Suffix (Res, Allow_Indexes);
+ end Parse_Name;
+
+ -- Emit an error message if MARK doesn't have the form of a type mark.
+ procedure Check_Type_Mark (Mark : Iir) is
+ begin
+ case Get_Kind (Mark) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ null;
+ when others =>
+ Error_Msg_Parse ("type mark must be a name of a type", Mark);
+ end case;
+ end Check_Type_Mark;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ 4.2 ]
+ -- type_mark ::= type_name
+ -- | subtype_name
+ function Parse_Type_Mark (Check_Paren : Boolean := False) return Iir
+ is
+ Res : Iir;
+ Old : Iir;
+ pragma Unreferenced (Old);
+ begin
+ Res := Parse_Name (Allow_Indexes => False);
+ Check_Type_Mark (Res);
+ if Check_Paren and then Current_Token = Tok_Left_Paren then
+ Error_Msg_Parse ("index constraint not allowed here");
+ Old := Parse_Name_Suffix (Res, True);
+ end if;
+ return Res;
+ end Parse_Type_Mark;
+
+ -- precond : CONSTANT, SIGNAL, VARIABLE. FILE or identifier
+ -- postcond: next token (';' or ')')
+ --
+ -- [ LRM93 4.3.2 ] [ LRM08 6.5.2 ]
+ -- interface_declaration ::= interface_constant_declaration
+ -- | interface_signal_declaration
+ -- | interface_variable_declaration
+ -- | interface_file_declaration
+ --
+ --
+ -- [ LRM93 3.2.2 ]
+ -- identifier_list ::= identifier { , identifier }
+ --
+ -- [ LRM93 4.3.2 ]
+ -- interface_constant_declaration ::=
+ -- [ CONSTANT ] identifier_list : [ IN ] subtype_indication
+ -- [ := STATIC_expression ]
+ --
+ -- [ LRM93 4.3.2 ]
+ -- interface_file_declaration ::= FILE identifier_list : subtype_indication
+ --
+ -- [ LRM93 4.3.2 ]
+ -- interface_signal_declaration ::=
+ -- [ SIGNAL ] identifier_list : [ mode ] subtype_indication [ BUS ]
+ -- [ := STATIC_expression ]
+ --
+ -- [ LRM93 4.3.2 ]
+ -- interface_variable_declaration ::=
+ -- [ VARIABLE ] identifier_list : [ mode ] subtype_indication
+ -- [ := STATIC_expression ]
+ --
+ -- The default kind of interface declaration is DEFAULT.
+ function Parse_Interface_Object_Declaration (Ctxt : Interface_Kind_Type)
+ return Iir
+ is
+ Kind : Iir_Kind;
+ Res, Last : Iir;
+ First, Prev_First : Iir;
+ Inter: Iir;
+ Is_Default : Boolean;
+ Interface_Mode: Iir_Mode;
+ Interface_Type: Iir;
+ Signal_Kind: Iir_Signal_Kind;
+ Default_Value: Iir;
+ Lexical_Layout : Iir_Lexical_Layout_Type;
+ begin
+ Res := Null_Iir;
+ Last := Null_Iir;
+
+ -- LRM08 6.5.2 Interface object declarations
+ -- Interface obejcts include interface constants that appear as
+ -- generics of a design entity, a component, a block, a package or
+ -- a subprogram, or as constant parameter of subprograms; interface
+ -- signals that appear as ports of a design entity, component or
+ -- block, or as signal parameters of subprograms; interface variables
+ -- that appear as variable parameter subprograms; interface files
+ -- that appear as file parameters of subrograms.
+ case Current_Token is
+ when Tok_Identifier =>
+ -- The class of the object is unknown. Select default
+ -- according to the above rule, assuming the mode is IN. If
+ -- the mode is not IN, Parse_Interface_Object_Declaration will
+ -- change the class.
+ case Ctxt is
+ when Generic_Interface_List
+ | Parameter_Interface_List =>
+ Kind := Iir_Kind_Interface_Constant_Declaration;
+ when Port_Interface_List =>
+ Kind := Iir_Kind_Interface_Signal_Declaration;
+ end case;
+ when Tok_Constant =>
+ Kind := Iir_Kind_Interface_Constant_Declaration;
+ when Tok_Signal =>
+ if Ctxt = Generic_Interface_List then
+ Error_Msg_Parse
+ ("signal interface not allowed in generic clause");
+ end if;
+ Kind := Iir_Kind_Interface_Signal_Declaration;
+ when Tok_Variable =>
+ if Ctxt not in Parameter_Interface_List then
+ Error_Msg_Parse
+ ("variable interface not allowed in generic or port clause");
+ end if;
+ Kind := Iir_Kind_Interface_Variable_Declaration;
+ when Tok_File =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("file interface not allowed in vhdl 87");
+ end if;
+ if Ctxt not in Parameter_Interface_List then
+ Error_Msg_Parse
+ ("variable interface not allowed in generic or port clause");
+ end if;
+ Kind := Iir_Kind_Interface_File_Declaration;
+ when others =>
+ -- Fall back in case of parse error.
+ Kind := Iir_Kind_Interface_Variable_Declaration;
+ end case;
+
+ Inter := Create_Iir (Kind);
+
+ if Current_Token = Tok_Identifier then
+ Is_Default := True;
+ Lexical_Layout := 0;
+ else
+ Is_Default := False;
+ Lexical_Layout := Iir_Lexical_Has_Class;
+
+ -- Skip 'signal', 'variable', 'constant' or 'file'.
+ Scan;
+ end if;
+
+ Prev_First := Last;
+ First := Inter;
+ loop
+ if Current_Token /= Tok_Identifier then
+ Expect (Tok_Identifier);
+ end if;
+ Set_Identifier (Inter, Current_Identifier);
+ Set_Location (Inter);
+
+ if Res = Null_Iir then
+ Res := Inter;
+ else
+ Set_Chain (Last, Inter);
+ end if;
+ Last := Inter;
+
+ -- Skip identifier
+ Scan;
+
+ exit when Current_Token = Tok_Colon;
+ Expect (Tok_Comma, "',' or ':' expected after identifier");
+
+ -- Skip ','
+ Scan;
+
+ Inter := Create_Iir (Kind);
+ end loop;
+
+ Expect (Tok_Colon, "':' must follow the interface element identifier");
+
+ -- Skip ':'
+ Scan;
+
+ -- LRM93 2.1.1 LRM08 4.2.2.1
+ -- If the mode is INOUT or OUT, and no object class is explicitly
+ -- specified, variable is assumed.
+ if Is_Default
+ and then Ctxt in Parameter_Interface_List
+ and then (Current_Token = Tok_Inout or else Current_Token = Tok_Out)
+ then
+ -- Convert into variable.
+ declare
+ O_Interface : Iir_Interface_Constant_Declaration;
+ N_Interface : Iir_Interface_Variable_Declaration;
+ begin
+ O_Interface := First;
+ while O_Interface /= Null_Iir loop
+ N_Interface :=
+ Create_Iir (Iir_Kind_Interface_Variable_Declaration);
+ Location_Copy (N_Interface, O_Interface);
+ Set_Identifier (N_Interface,
+ Get_Identifier (O_Interface));
+ if Prev_First = Null_Iir then
+ Res := N_Interface;
+ else
+ Set_Chain (Prev_First, N_Interface);
+ end if;
+ Prev_First := N_Interface;
+ if O_Interface = First then
+ First := N_Interface;
+ end if;
+ Last := N_Interface;
+ Inter := Get_Chain (O_Interface);
+ Free_Iir (O_Interface);
+ O_Interface := Inter;
+ end loop;
+ Inter := First;
+ end;
+ end if;
+
+ -- Update lexical layout if mode is present.
+ case Current_Token is
+ when Tok_In
+ | Tok_Out
+ | Tok_Inout
+ | Tok_Linkage
+ | Tok_Buffer =>
+ Lexical_Layout := Lexical_Layout or Iir_Lexical_Has_Mode;
+ when others =>
+ null;
+ end case;
+
+ -- Parse mode (and handle default mode).
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_File_Declaration =>
+ if Parse_Mode (Iir_Unknown_Mode) /= Iir_Unknown_Mode then
+ Error_Msg_Parse
+ ("mode can't be specified for a file interface");
+ end if;
+ Interface_Mode := Iir_Inout_Mode;
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Variable_Declaration =>
+ -- LRM93 4.3.2
+ -- If no mode is explicitly given in an interface declaration
+ -- other than an interface file declaration, mode IN is
+ -- assumed.
+ Interface_Mode := Parse_Mode (Iir_In_Mode);
+ when Iir_Kind_Interface_Constant_Declaration =>
+ Interface_Mode := Parse_Mode (Iir_In_Mode);
+ if Interface_Mode /= Iir_In_Mode then
+ Error_Msg_Parse ("mode must be 'in' for a constant");
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Interface_Type := Parse_Subtype_Indication;
+
+ -- Signal kind (but only for signal).
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then
+ Signal_Kind := Parse_Signal_Kind;
+ else
+ Signal_Kind := Iir_No_Signal_Kind;
+ end if;
+
+ if Current_Token = Tok_Assign then
+ if Get_Kind (Inter) = Iir_Kind_Interface_File_Declaration then
+ Error_Msg_Parse
+ ("default expression not allowed for an interface file");
+ end if;
+
+ -- Skip ':='
+ Scan;
+
+ Default_Value := Parse_Expression;
+ else
+ Default_Value := Null_Iir;
+ end if;
+
+ -- Subtype_Indication and Default_Value are set only on the first
+ -- interface.
+ Set_Subtype_Indication (First, Interface_Type);
+ if Get_Kind (First) /= Iir_Kind_Interface_File_Declaration then
+ Set_Default_Value (First, Default_Value);
+ end if;
+
+ Inter := First;
+ while Inter /= Null_Iir loop
+ Set_Mode (Inter, Interface_Mode);
+ Set_Is_Ref (Inter, Inter /= First);
+ if Inter = Last then
+ Set_Lexical_Layout (Inter,
+ Lexical_Layout or Iir_Lexical_Has_Type);
+ else
+ Set_Lexical_Layout (Inter, Lexical_Layout);
+ end if;
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then
+ Set_Signal_Kind (Inter, Signal_Kind);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+
+ return Res;
+ end Parse_Interface_Object_Declaration;
+
+ -- Precond : 'package'
+ -- Postcond: next token
+ --
+ -- 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 ( <> )
+ -- | GENERIC MAP ( DEFAULT )
+ function Parse_Interface_Package_Declaration return Iir
+ is
+ Inter : Iir;
+ Map : Iir;
+ begin
+ Inter := Create_Iir (Iir_Kind_Interface_Package_Declaration);
+
+ -- Skip 'package'
+ Scan_Expect (Tok_Identifier,
+ "an identifier is expected after ""package""");
+ Set_Identifier (Inter, Current_Identifier);
+ Set_Location (Inter);
+
+ -- Skip identifier
+ Scan_Expect (Tok_Is);
+
+ -- Skip 'is'
+ Scan_Expect (Tok_New);
+
+ -- Skip 'new'
+ Scan;
+
+ Set_Uninstantiated_Package_Name (Inter, Parse_Name (False));
+
+ Expect (Tok_Generic);
+
+ -- Skip 'generic'
+ Scan_Expect (Tok_Map);
+
+ -- Skip 'map'
+ Scan_Expect (Tok_Left_Paren);
+
+ -- Skip '('
+ Scan;
+
+ case Current_Token is
+ when Tok_Box =>
+ Map := Null_Iir;
+ -- Skip '<>'
+ Scan;
+ when others =>
+ Map := Parse_Association_List;
+ end case;
+ Set_Generic_Map_Aspect_Chain (Inter, Map);
+
+ Expect (Tok_Right_Paren);
+
+ -- Skip ')'
+ Scan;
+
+ return Inter;
+ end Parse_Interface_Package_Declaration;
+
+ -- Precond : '('
+ -- Postcond: next token
+ --
+ -- LRM08 6.5.6 Interface lists
+ -- interface_list ::= interface_element { ';' interface_element }
+ --
+ -- interface_element ::= interface_declaration
+ function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir)
+ return Iir
+ is
+ Res, Last : Iir;
+ Inters : Iir;
+ Next : Iir;
+ Prev_Loc : Location_Type;
+ begin
+ Expect (Tok_Left_Paren);
+
+ Res := Null_Iir;
+ Last := Null_Iir;
+ loop
+ Prev_Loc := Get_Token_Location;
+
+ -- Skip '(' or ';'
+ Scan;
+
+ case Current_Token is
+ when Tok_Identifier
+ | Tok_Signal
+ | Tok_Variable
+ | Tok_Constant
+ | Tok_File =>
+ -- An inteface object.
+ Inters := Parse_Interface_Object_Declaration (Ctxt);
+ when Tok_Package =>
+ if Ctxt /= Generic_Interface_List then
+ Error_Msg_Parse
+ ("package interface only allowed in generic interface");
+ elsif Flags.Vhdl_Std < Vhdl_08 then
+ Error_Msg_Parse
+ ("package interface not allowed before vhdl 08");
+ end if;
+ Inters := Parse_Interface_Package_Declaration;
+ when Tok_Right_Paren =>
+ if Res = Null_Iir then
+ Error_Msg_Parse
+ ("empty interface list not allowed", Prev_Loc);
+ else
+ Error_Msg_Parse
+ ("extra ';' at end of interface list", Prev_Loc);
+ end if;
+ exit;
+ when others =>
+ Error_Msg_Parse
+ ("'signal', 'constant', 'variable', 'file' "
+ & "or identifier expected");
+ -- Use a variable interface as a fall-back.
+ Inters := Parse_Interface_Object_Declaration (Ctxt);
+ end case;
+
+ -- Chain
+ if Last = Null_Iir then
+ Res := Inters;
+ else
+ Set_Chain (Last, Inters);
+ end if;
+
+ -- Set parent and set Last to the last interface.
+ Last := Inters;
+ loop
+ Set_Parent (Last, Parent);
+ Next := Get_Chain (Last);
+ exit when Next = Null_Iir;
+ Last := Next;
+ end loop;
+
+ exit when Current_Token /= Tok_Semi_Colon;
+ end loop;
+
+ if Current_Token /= Tok_Right_Paren then
+ Error_Msg_Parse ("')' expected at end of interface list");
+ end if;
+
+ -- Skip ')'
+ Scan;
+
+ return Res;
+ end Parse_Interface_List;
+
+ -- precond : PORT
+ -- postcond: next token
+ --
+ -- [ �1.1.1 ]
+ -- port_clause ::= PORT ( port_list ) ;
+ --
+ -- [ �1.1.1.2 ]
+ -- port_list ::= PORT_interface_list
+ procedure Parse_Port_Clause (Parent : Iir)
+ is
+ Res: Iir;
+ El : Iir;
+ begin
+ -- Skip 'port'
+ pragma Assert (Current_Token = Tok_Port);
+ Scan;
+
+ Res := Parse_Interface_List (Port_Interface_List, Parent);
+
+ -- Check the interface are signal interfaces.
+ El := Res;
+ while El /= Null_Iir loop
+ if Get_Kind (El) /= Iir_Kind_Interface_Signal_Declaration then
+ Error_Msg_Parse ("port must be a signal", El);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ Scan_Semi_Colon ("port clause");
+ Set_Port_Chain (Parent, Res);
+ end Parse_Port_Clause;
+
+ -- precond : GENERIC
+ -- postcond: next token
+ --
+ -- [ LRM93 1.1.1, LRM08 6.5.6.2 ]
+ -- generic_clause ::= GENERIC ( generic_list ) ;
+ --
+ -- [ LRM93 1.1.1.1, LRM08 6.5.6.2]
+ -- generic_list ::= GENERIC_interface_list
+ procedure Parse_Generic_Clause (Parent : Iir)
+ is
+ Res: Iir;
+ begin
+ -- Skip 'generic'
+ pragma Assert (Current_Token = Tok_Generic);
+ Scan;
+
+ Res := Parse_Interface_List (Generic_Interface_List, Parent);
+ Set_Generic_Chain (Parent, Res);
+
+ Scan_Semi_Colon ("generic clause");
+ end Parse_Generic_Clause;
+
+ -- precond : a token.
+ -- postcond: next token
+ --
+ -- [ �1.1.1 ]
+ -- entity_header ::=
+ -- [ FORMAL_generic_clause ]
+ -- [ FORMAL_port_clause ]
+ --
+ -- [ �4.5 ]
+ -- [ LOCAL_generic_clause ]
+ -- [ LOCAL_port_clause ]
+ procedure Parse_Generic_Port_Clauses (Parent : Iir)
+ is
+ Has_Port, Has_Generic : Boolean;
+ begin
+ Has_Port := False;
+ Has_Generic := False;
+ loop
+ if Current_Token = Tok_Generic then
+ if Has_Generic then
+ Error_Msg_Parse ("at most one generic clause is allowed");
+ end if;
+ if Has_Port then
+ Error_Msg_Parse ("generic clause must precede port clause");
+ end if;
+ Has_Generic := True;
+ Parse_Generic_Clause (Parent);
+ elsif Current_Token = Tok_Port then
+ if Has_Port then
+ Error_Msg_Parse ("at most one port clause is allowed");
+ end if;
+ Has_Port := True;
+ Parse_Port_Clause (Parent);
+ else
+ exit;
+ end if;
+ end loop;
+ end Parse_Generic_Port_Clauses;
+
+ -- precond : a token
+ -- postcond: next token
+ --
+ -- [ �3.1.1 ]
+ -- enumeration_type_definition ::=
+ -- ( enumeration_literal { , enumeration_literal } )
+ --
+ -- [ �3.1.1 ]
+ -- enumeration_literal ::= identifier | character_literal
+ function Parse_Enumeration_Type_Definition
+ return Iir_Enumeration_Type_Definition
+ is
+ Pos: Iir_Int32;
+ Enum_Lit: Iir_Enumeration_Literal;
+ Enum_Type: Iir_Enumeration_Type_Definition;
+ Enum_List : Iir_List;
+ begin
+ -- This is an enumeration.
+ Enum_Type := Create_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Location (Enum_Type);
+ Enum_List := Create_Iir_List;
+ Set_Enumeration_Literal_List (Enum_Type, Enum_List);
+
+ -- LRM93 3.1.1
+ -- The position number of the first listed enumeration literal is zero.
+ Pos := 0;
+ -- scan every literal.
+ Scan;
+ if Current_Token = Tok_Right_Paren then
+ Error_Msg_Parse ("at least one literal must be declared");
+ Scan;
+ return Enum_Type;
+ end if;
+ loop
+ if Current_Token /= Tok_Identifier
+ and then Current_Token /= Tok_Character
+ then
+ if Current_Token = Tok_Eof then
+ Error_Msg_Parse ("unexpected end of file");
+ return Enum_Type;
+ end if;
+ Error_Msg_Parse ("identifier or character expected");
+ end if;
+ Enum_Lit := Create_Iir (Iir_Kind_Enumeration_Literal);
+ Set_Identifier (Enum_Lit, Current_Identifier);
+ Set_Location (Enum_Lit);
+ Set_Enum_Pos (Enum_Lit, Pos);
+
+ -- LRM93 3.1.1
+ -- the position number for each additional enumeration literal is
+ -- one more than that if its predecessor in the list.
+ Pos := Pos + 1;
+
+ Append_Element (Enum_List, Enum_Lit);
+
+ -- next token.
+ Scan;
+ exit when Current_Token = Tok_Right_Paren;
+ if Current_Token /= Tok_Comma then
+ Error_Msg_Parse ("')' or ',' is expected after an enum literal");
+ end if;
+
+ -- scan a literal.
+ Scan;
+ if Current_Token = Tok_Right_Paren then
+ Error_Msg_Parse ("extra ',' ignored");
+ exit;
+ end if;
+ end loop;
+ Scan;
+ return Enum_Type;
+ end Parse_Enumeration_Type_Definition;
+
+ -- precond : ARRAY
+ -- postcond: ??
+ --
+ -- [ LRM93 3.2.1 ]
+ -- array_type_definition ::= unconstrained_array_definition
+ -- | constrained_array_definition
+ --
+ -- unconstrained_array_definition ::=
+ -- ARRAY ( index_subtype_definition { , index_subtype_definition } )
+ -- OF element_subtype_indication
+ --
+ -- constrained_array_definition ::=
+ -- ARRAY index_constraint OF element_subtype_indication
+ --
+ -- index_subtype_definition ::= type_mark RANGE <>
+ --
+ -- index_constraint ::= ( discrete_range { , discrete_range } )
+ --
+ -- discrete_range ::= discrete_subtype_indication | range
+ --
+ -- [ LRM08 5.3.2.1 ]
+ -- array_type_definition ::= unbounded_array_definition
+ -- | constrained_array_definition
+ --
+ -- unbounded_array_definition ::=
+ -- ARRAY ( index_subtype_definition { , index_subtype_definition } )
+ -- OF element_subtype_indication
+ function Parse_Array_Definition return Iir
+ is
+ Index_Constrained : Boolean;
+ Array_Constrained : Boolean;
+ First : Boolean;
+ Res_Type: Iir;
+ Index_List : Iir_List;
+
+ Loc : Location_Type;
+ Def : Iir;
+ Type_Mark : Iir;
+ Element_Subtype : Iir;
+ begin
+ Loc := Get_Token_Location;
+
+ -- Skip 'array', scan '('
+ Scan_Expect (Tok_Left_Paren);
+ Scan;
+
+ First := True;
+ Index_List := Create_Iir_List;
+
+ loop
+ -- The accepted syntax can be one of:
+ -- * index_subtype_definition, which is:
+ -- * type_mark RANGE <>
+ -- * discrete_range, which is either:
+ -- * /discrete/_subtype_indication
+ -- * [ resolution_indication ] type_mark [ range_constraint ]
+ -- * range_constraint ::= RANGE range
+ -- * range
+ -- * /range/_attribute_name
+ -- * simple_expression direction simple_expression
+
+ -- Parse a simple expression (for the range), which can also parse a
+ -- name.
+ Type_Mark := Parse_Simple_Expression;
+
+ case Current_Token is
+ when Tok_Range =>
+ -- Skip 'range'
+ Scan;
+
+ if Current_Token = Tok_Box then
+ -- Parsed 'RANGE <>': this is an index_subtype_definition.
+ Index_Constrained := False;
+ Scan;
+ Def := Type_Mark;
+ else
+ -- This is a /discrete/_subtype_indication
+ Index_Constrained := True;
+ Def :=
+ Parse_Range_Constraint_Of_Subtype_Indication (Type_Mark);
+ end if;
+ when Tok_To
+ | Tok_Downto =>
+ -- A range
+ Index_Constrained := True;
+ Def := Parse_Range_Right (Type_Mark);
+ when others =>
+ -- For a /range/_attribute_name
+ Index_Constrained := True;
+ Def := Type_Mark;
+ end case;
+
+ Append_Element (Index_List, Def);
+
+ if First then
+ Array_Constrained := Index_Constrained;
+ First := False;
+ else
+ if Array_Constrained /= Index_Constrained then
+ Error_Msg_Parse
+ ("cannot mix constrained and unconstrained index");
+ end if;
+ end if;
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+
+ -- Skip ')' and 'of'
+ Expect (Tok_Right_Paren);
+ Scan_Expect (Tok_Of);
+ Scan;
+
+ Element_Subtype := Parse_Subtype_Indication;
+
+ if Array_Constrained then
+ -- Sem_Type will create the array type.
+ Res_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Element_Subtype (Res_Type, Element_Subtype);
+ Set_Index_Constraint_List (Res_Type, Index_List);
+ else
+ Res_Type := Create_Iir (Iir_Kind_Array_Type_Definition);
+ Set_Element_Subtype_Indication (Res_Type, Element_Subtype);
+ Set_Index_Subtype_Definition_List (Res_Type, Index_List);
+ end if;
+ Set_Location (Res_Type, Loc);
+
+ return Res_Type;
+ end Parse_Array_Definition;
+
+ -- precond : UNITS
+ -- postcond: next token
+ --
+ -- [ LRM93 3.1.3 ]
+ -- physical_type_definition ::=
+ -- range_constraint
+ -- UNITS
+ -- base_unit_declaration
+ -- { secondary_unit_declaration }
+ -- END UNITS [ PHYSICAL_TYPE_simple_name ]
+ --
+ -- [ LRM93 3.1.3 ]
+ -- base_unit_declaration ::= identifier ;
+ --
+ -- [ LRM93 3.1.3 ]
+ -- secondary_unit_declaration ::= identifier = physical_literal ;
+ function Parse_Physical_Type_Definition (Parent : Iir)
+ return Iir_Physical_Type_Definition
+ is
+ use Iir_Chains.Unit_Chain_Handling;
+ Res: Iir_Physical_Type_Definition;
+ Unit: Iir_Unit_Declaration;
+ Last : Iir_Unit_Declaration;
+ Multiplier : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Physical_Type_Definition);
+ Set_Location (Res);
+
+ -- Skip 'units'
+ Expect (Tok_Units);
+ Scan;
+
+ -- Parse primary unit.
+ Expect (Tok_Identifier);
+ Unit := Create_Iir (Iir_Kind_Unit_Declaration);
+ Set_Location (Unit);
+ Set_Parent (Unit, Parent);
+ Set_Identifier (Unit, Current_Identifier);
+
+ -- Skip identifier
+ Scan;
+
+ Scan_Semi_Colon ("primary unit");
+
+ Build_Init (Last);
+ Append (Last, Res, Unit);
+
+ -- Parse secondary units.
+ while Current_Token /= Tok_End loop
+ Unit := Create_Iir (Iir_Kind_Unit_Declaration);
+ Set_Location (Unit);
+ Set_Identifier (Unit, Current_Identifier);
+
+ -- Skip identifier.
+ Scan_Expect (Tok_Equal);
+
+ -- Skip '='.
+ Scan;
+
+ Multiplier := Parse_Primary;
+ Set_Physical_Literal (Unit, Multiplier);
+ case Get_Kind (Multiplier) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Physical_Int_Literal =>
+ null;
+ when Iir_Kind_Physical_Fp_Literal =>
+ Error_Msg_Parse
+ ("secondary units may only be defined with integer literals");
+ when others =>
+ Error_Msg_Parse ("a physical literal is expected here");
+ end case;
+ Append (Last, Res, Unit);
+ Scan_Semi_Colon ("secondary unit");
+ end loop;
+
+ -- Skip 'end'.
+ Scan;
+
+ Expect (Tok_Units);
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'units'.
+ Scan;
+ return Res;
+ end Parse_Physical_Type_Definition;
+
+ -- precond : RECORD
+ -- postcond: next token
+ --
+ -- [ LRM93 3.2.2 ]
+ -- record_type_definition ::=
+ -- RECORD
+ -- element_declaration
+ -- { element_declaration }
+ -- END RECORD [ RECORD_TYPE_simple_name ]
+ --
+ -- element_declaration ::=
+ -- identifier_list : element_subtype_definition
+ --
+ -- element_subtype_definition ::= subtype_indication
+ function Parse_Record_Type_Definition return Iir_Record_Type_Definition
+ is
+ Res: Iir_Record_Type_Definition;
+ El_List : Iir_List;
+ El: Iir_Element_Declaration;
+ First : Iir;
+ Pos: Iir_Index32;
+ Subtype_Indication: Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Record_Type_Definition);
+ Set_Location (Res);
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+
+ -- Skip 'record'
+ Scan;
+
+ Pos := 0;
+ First := Null_Iir;
+ loop
+ pragma Assert (First = Null_Iir);
+ -- Parse identifier_list
+ loop
+ El := Create_Iir (Iir_Kind_Element_Declaration);
+ Set_Location (El);
+ if First = Null_Iir then
+ First := El;
+ end if;
+ Expect (Tok_Identifier);
+ Set_Identifier (El, Current_Identifier);
+ Append_Element (El_List, El);
+ Set_Element_Position (El, Pos);
+ Pos := Pos + 1;
+ if First = Null_Iir then
+ First := El;
+ end if;
+
+ -- Skip identifier
+ Scan;
+
+ exit when Current_Token /= Tok_Comma;
+
+ Set_Has_Identifier_List (El, True);
+
+ -- Skip ','
+ Scan;
+ end loop;
+
+ -- Scan ':'.
+ Expect (Tok_Colon);
+ Scan;
+
+ -- Parse element subtype indication.
+ Subtype_Indication := Parse_Subtype_Indication;
+ Set_Subtype_Indication (First, Subtype_Indication);
+
+ First := Null_Iir;
+ Scan_Semi_Colon ("element declaration");
+ exit when Current_Token = Tok_End;
+ end loop;
+
+ -- Skip 'end'
+ Scan_Expect (Tok_Record);
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'record'
+ Scan;
+
+ return Res;
+ end Parse_Record_Type_Definition;
+
+ -- precond : ACCESS
+ -- postcond: ?
+ --
+ -- [ LRM93 3.3]
+ -- access_type_definition ::= ACCESS subtype_indication.
+ function Parse_Access_Type_Definition return Iir_Access_Type_Definition
+ is
+ Res : Iir_Access_Type_Definition;
+ begin
+ Res := Create_Iir (Iir_Kind_Access_Type_Definition);
+ Set_Location (Res);
+
+ -- Skip 'access'
+ Expect (Tok_Access);
+ Scan;
+
+ Set_Designated_Subtype_Indication (Res, Parse_Subtype_Indication);
+
+ return Res;
+ end Parse_Access_Type_Definition;
+
+ -- precond : FILE
+ -- postcond: next token
+ --
+ -- [ LRM93 3.4 ]
+ -- file_type_definition ::= FILE OF type_mark
+ function Parse_File_Type_Definition return Iir_File_Type_Definition
+ is
+ Res : Iir_File_Type_Definition;
+ Type_Mark: Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_File_Type_Definition);
+ Set_Location (Res);
+ -- Accept token 'file'.
+ Scan_Expect (Tok_Of);
+ Scan;
+ Type_Mark := Parse_Type_Mark (Check_Paren => True);
+ if Get_Kind (Type_Mark) not in Iir_Kinds_Denoting_Name then
+ Error_Msg_Parse ("type mark expected");
+ else
+ Set_File_Type_Mark (Res, Type_Mark);
+ end if;
+ return Res;
+ end Parse_File_Type_Definition;
+
+ -- precond : PROTECTED
+ -- postcond: ';'
+ --
+ -- [ 3.5 ]
+ -- protected_type_definition ::= protected_type_declaration
+ -- | protected_type_body
+ --
+ -- [ 3.5.1 ]
+ -- protected_type_declaration ::= PROTECTED
+ -- protected_type_declarative_part
+ -- END PROTECTED [ simple_name ]
+ --
+ -- protected_type_declarative_part ::=
+ -- { protected_type_declarative_item }
+ --
+ -- protected_type_declarative_item ::=
+ -- subprogram_declaration
+ -- | attribute_specification
+ -- | use_clause
+ --
+ -- [ 3.5.2 ]
+ -- protected_type_body ::= PROTECTED BODY
+ -- protected_type_body_declarative_part
+ -- END PROTECTED BODY [ simple_name ]
+ --
+ -- protected_type_body_declarative_part ::=
+ -- { protected_type_body_declarative_item }
+ --
+ -- protected_type_body_declarative_item ::=
+ -- subprogram_declaration
+ -- | subprogram_body
+ -- | type_declaration
+ -- | subtype_declaration
+ -- | constant_declaration
+ -- | variable_declaration
+ -- | file_declaration
+ -- | alias_declaration
+ -- | attribute_declaration
+ -- | attribute_specification
+ -- | use_clause
+ -- | group_template_declaration
+ -- | group_declaration
+ function Parse_Protected_Type_Definition
+ (Ident : Name_Id; Loc : Location_Type) return Iir
+ is
+ Res : Iir;
+ Decl : Iir;
+ begin
+ Scan;
+ if Current_Token = Tok_Body then
+ Res := Create_Iir (Iir_Kind_Protected_Type_Body);
+ Scan;
+ Decl := Res;
+ else
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ Res := Create_Iir (Iir_Kind_Protected_Type_Declaration);
+ Set_Location (Res, Loc);
+ Set_Type_Definition (Decl, Res);
+ end if;
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+
+ Parse_Declarative_Part (Res);
+
+ Expect (Tok_End);
+ Scan_Expect (Tok_Protected);
+ Set_End_Has_Reserved_Id (Res, True);
+ if Get_Kind (Res) = Iir_Kind_Protected_Type_Body then
+ Scan_Expect (Tok_Body);
+ end if;
+ Scan;
+ Check_End_Name (Ident, Res);
+ return Decl;
+ end Parse_Protected_Type_Definition;
+
+ -- precond : TYPE
+ -- postcond: a token
+ --
+ -- [ LRM93 4.1 ]
+ -- type_definition ::= scalar_type_definition
+ -- | composite_type_definition
+ -- | access_type_definition
+ -- | file_type_definition
+ -- | protected_type_definition
+ --
+ -- [ LRM93 3.1 ]
+ -- scalar_type_definition ::= enumeration_type_definition
+ -- | integer_type_definition
+ -- | floating_type_definition
+ -- | physical_type_definition
+ --
+ -- [ LRM93 3.2 ]
+ -- composite_type_definition ::= array_type_definition
+ -- | record_type_definition
+ --
+ -- [ LRM93 3.1.2 ]
+ -- integer_type_definition ::= range_constraint
+ --
+ -- [ LRM93 3.1.4 ]
+ -- floating_type_definition ::= range_constraint
+ function Parse_Type_Declaration (Parent : Iir) return Iir
+ is
+ Def : Iir;
+ Loc : Location_Type;
+ Ident : Name_Id;
+ Decl : Iir;
+ begin
+ -- The current token must be type.
+ pragma Assert (Current_Token = Tok_Type);
+
+ -- Get the identifier
+ Scan_Expect (Tok_Identifier,
+ "an identifier is expected after 'type' keyword");
+ Loc := Get_Token_Location;
+ Ident := Current_Identifier;
+
+ -- Skip identifier
+ Scan;
+
+ if Current_Token = Tok_Semi_Colon then
+ -- If there is a ';', this is an imcomplete type declaration.
+ Invalidate_Current_Token;
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+ return Decl;
+ end if;
+
+ if Current_Token /= Tok_Is then
+ Error_Msg_Parse ("'is' expected here");
+ -- Act as if IS token was forgotten.
+ else
+ -- Eat IS token.
+ Scan;
+ end if;
+
+ case Current_Token is
+ when Tok_Left_Paren =>
+ -- This is an enumeration.
+ Def := Parse_Enumeration_Type_Definition;
+ Decl := Null_Iir;
+
+ when Tok_Range =>
+ -- This is a range definition.
+ Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+
+ -- Skip 'range'
+ Scan;
+
+ Def := Parse_Range_Constraint;
+ Set_Type_Definition (Decl, Def);
+
+ if Current_Token = Tok_Units then
+ -- A physical type definition.
+ declare
+ Unit_Def : Iir;
+ begin
+ Unit_Def := Parse_Physical_Type_Definition (Parent);
+ if Current_Token = Tok_Identifier then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("simple_name not allowed here in vhdl87");
+ end if;
+ Check_End_Name (Get_Identifier (Decl), Unit_Def);
+ end if;
+ if Def /= Null_Iir then
+ Set_Type (Def, Unit_Def);
+ end if;
+ end;
+ end if;
+
+ when Tok_Array =>
+ Def := Parse_Array_Definition;
+ Decl := Null_Iir;
+
+ when Tok_Record =>
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+ Def := Parse_Record_Type_Definition;
+ Set_Type_Definition (Decl, Def);
+ if Current_Token = Tok_Identifier then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("simple_name not allowed here in vhdl87");
+ end if;
+ Check_End_Name (Get_Identifier (Decl), Def);
+ end if;
+
+ when Tok_Access =>
+ Def := Parse_Access_Type_Definition;
+ Decl := Null_Iir;
+
+ when Tok_File =>
+ Def := Parse_File_Type_Definition;
+ Decl := Null_Iir;
+
+ when Tok_Identifier =>
+ if Current_Identifier = Name_Protected then
+ Error_Msg_Parse ("protected type not allowed in vhdl87/93");
+ Decl := Parse_Protected_Type_Definition (Ident, Loc);
+ else
+ Error_Msg_Parse ("type '" & Name_Table.Image (Ident) &
+ "' cannot be defined from another type");
+ Error_Msg_Parse ("(you should declare a subtype)");
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ Eat_Tokens_Until_Semi_Colon;
+ end if;
+
+ when Tok_Protected =>
+ if Flags.Vhdl_Std < Vhdl_00 then
+ Error_Msg_Parse ("protected type not allowed in vhdl87/93");
+ end if;
+ Decl := Parse_Protected_Type_Definition (Ident, Loc);
+
+ when others =>
+ Error_Msg_Parse
+ ("type definition starting with a keyword such as RANGE, ARRAY");
+ Error_Msg_Parse
+ (" FILE, RECORD or '(' is expected here");
+ Eat_Tokens_Until_Semi_Colon;
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ end case;
+
+ if Decl = Null_Iir then
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_File_Type_Definition =>
+ Decl := Create_Iir (Iir_Kind_Type_Declaration);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration);
+ when others =>
+ Error_Kind ("parse_type_declaration", Def);
+ end case;
+ Set_Type_Definition (Decl, Def);
+ end if;
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+
+ -- ';' is expected after end of type declaration
+ Expect (Tok_Semi_Colon);
+ Invalidate_Current_Token;
+ return Decl;
+ end Parse_Type_Declaration;
+
+ -- precond: '(' or identifier
+ -- postcond: next token
+ --
+ -- [ LRM08 6.3 ]
+ --
+ -- resolution_indication ::=
+ -- resolution_function_name | ( element_resolution )
+ --
+ -- element_resolution ::=
+ -- array_element_resolution | record_resolution
+ --
+ -- array_element_resolution ::= resolution_indication
+ --
+ -- record_resolution ::=
+ -- record_element_resolution { , record_element_resolution }
+ --
+ -- record_element_resolution ::=
+ -- record_element_simple_name resolution_indication
+ function Parse_Resolution_Indication return Iir
+ is
+ Ind : Iir;
+ Def : Iir;
+ Loc : Location_Type;
+ begin
+ if Current_Token = Tok_Identifier then
+ -- Resolution function name.
+ return Parse_Name (Allow_Indexes => False);
+ elsif Current_Token = Tok_Left_Paren then
+ -- Element resolution.
+ Loc := Get_Token_Location;
+
+ -- Eat '('
+ Scan;
+
+ Ind := Parse_Resolution_Indication;
+ if Current_Token = Tok_Identifier
+ or else Current_Token = Tok_Left_Paren
+ then
+ declare
+ Id : Name_Id;
+ El : Iir;
+ First, Last : Iir;
+ begin
+ -- This was in fact a record_resolution.
+ if Get_Kind (Ind) = Iir_Kind_Simple_Name then
+ Id := Get_Identifier (Ind);
+ else
+ Error_Msg_Parse ("element name expected", Ind);
+ Id := Null_Identifier;
+ end if;
+ Free_Iir (Ind);
+
+ Def := Create_Iir (Iir_Kind_Record_Resolution);
+ Set_Location (Def, Loc);
+ Sub_Chain_Init (First, Last);
+ loop
+ El := Create_Iir (Iir_Kind_Record_Element_Resolution);
+ Set_Location (El, Loc);
+ Set_Identifier (El, Id);
+ Set_Resolution_Indication (El, Parse_Resolution_Indication);
+ Sub_Chain_Append (First, Last, El);
+ exit when Current_Token = Tok_Right_Paren;
+
+ -- Eat ','
+ Expect (Tok_Comma);
+ Scan;
+
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse ("record element identifier expected");
+ exit;
+ end if;
+ Id := Current_Identifier;
+ Loc := Get_Token_Location;
+
+ -- Eat identifier
+ Scan;
+ end loop;
+ Set_Record_Element_Resolution_Chain (Def, First);
+ end;
+ else
+ Def := Create_Iir (Iir_Kind_Array_Element_Resolution);
+ Set_Location (Def, Loc);
+ Set_Resolution_Indication (Def, Ind);
+ end if;
+
+ -- Eat ')'
+ Expect (Tok_Right_Paren);
+ Scan;
+
+ return Def;
+ else
+ Error_Msg_Parse ("resolution indication expected");
+ raise Parse_Error;
+ end if;
+ end Parse_Resolution_Indication;
+
+ -- precond : '('
+ -- postcond: next token
+ --
+ -- [ LRM08 6.3 Subtype declarations ]
+ -- element_constraint ::=
+ -- array_constraint | record_constraint
+ --
+ -- [ LRM08 5.3.2.1 Array types ]
+ -- array_constraint ::=
+ -- index_constraint [ array_element_constraint ]
+ -- | ( open ) [ array_element_constraint ]
+ --
+ -- array_element_constraint ::= element_constraint
+ --
+ -- RES is the resolution_indication of the subtype indication.
+ function Parse_Element_Constraint return Iir
+ is
+ Def : Iir;
+ El : Iir;
+ Index_List : Iir_List;
+ begin
+ -- Index_constraint.
+ Def := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Location (Def);
+
+ -- Eat '('.
+ Scan;
+
+ if Current_Token = Tok_Open then
+ -- Eat 'open'.
+ Scan;
+ else
+ Index_List := Create_Iir_List;
+ Set_Index_Constraint_List (Def, Index_List);
+ -- index_constraint ::= (discrete_range {, discrete_range} )
+ loop
+ El := Parse_Discrete_Range;
+ Append_Element (Index_List, El);
+
+ exit when Current_Token = Tok_Right_Paren;
+
+ -- Eat ','
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ end if;
+
+ -- Eat ')'
+ Expect (Tok_Right_Paren);
+ Scan;
+
+ if Current_Token = Tok_Left_Paren then
+ Set_Element_Subtype (Def, Parse_Element_Constraint);
+ end if;
+ return Def;
+ end Parse_Element_Constraint;
+
+ -- precond : tolerance
+ -- postcond: next token
+ --
+ -- [ LRM93 4.2 ]
+ -- tolerance_aspect ::= TOLERANCE string_expression
+ function Parse_Tolerance_Aspect_Opt return Iir is
+ begin
+ if AMS_Vhdl
+ and then Current_Token = Tok_Tolerance
+ then
+ Scan;
+ return Parse_Expression;
+ else
+ return Null_Iir;
+ end if;
+ end Parse_Tolerance_Aspect_Opt;
+
+ -- precond : identifier or '('
+ -- postcond: next token
+ --
+ -- [ LRM93 4.2 ]
+ -- subtype_indication ::=
+ -- [ RESOLUTION_FUNCTION_name ] type_mark [ constraint ]
+ --
+ -- constraint ::= range_constraint | index_constraint
+ --
+ -- [ LRM08 6.3 ]
+ -- subtype_indication ::=
+ -- [ resolution_indication ] type_mark [ constraint ]
+ --
+ -- constraint ::=
+ -- range_constraint | array_constraint | record_constraint
+ --
+ -- NAME is the type_mark when already parsed (in range expression or
+ -- allocator by type).
+ function Parse_Subtype_Indication (Name : Iir := Null_Iir)
+ return Iir
+ is
+ Type_Mark : Iir;
+ Def: Iir;
+ Resolution_Indication: Iir;
+ Tolerance : Iir;
+ begin
+ -- FIXME: location.
+ Resolution_Indication := Null_Iir;
+ Def := Null_Iir;
+
+ if Name /= Null_Iir then
+ -- The type_mark was already parsed.
+ Type_Mark := Name;
+ Check_Type_Mark (Name);
+ else
+ if Current_Token = Tok_Left_Paren then
+ if Vhdl_Std < Vhdl_08 then
+ Error_Msg_Parse
+ ("resolution_indication not allowed before vhdl08");
+ end if;
+ Resolution_Indication := Parse_Resolution_Indication;
+ end if;
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse ("type mark expected in a subtype indication");
+ raise Parse_Error;
+ end if;
+ Type_Mark := Parse_Type_Mark (Check_Paren => False);
+ end if;
+
+ if Current_Token = Tok_Identifier then
+ if Resolution_Indication /= Null_Iir then
+ Error_Msg_Parse ("resolution function already indicated");
+ end if;
+ Resolution_Indication := Type_Mark;
+ Type_Mark := Parse_Type_Mark (Check_Paren => False);
+ end if;
+
+ case Current_Token is
+ when Tok_Left_Paren =>
+ -- element_constraint.
+ Def := Parse_Element_Constraint;
+ Set_Subtype_Type_Mark (Def, Type_Mark);
+ Set_Resolution_Indication (Def, Resolution_Indication);
+ Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt);
+
+ when Tok_Range =>
+ -- range_constraint.
+ -- Skip 'range'
+ Scan;
+
+ Def := Parse_Range_Constraint_Of_Subtype_Indication
+ (Type_Mark, Resolution_Indication);
+
+ when others =>
+ Tolerance := Parse_Tolerance_Aspect_Opt;
+ if Resolution_Indication /= Null_Iir
+ or else Tolerance /= Null_Iir
+ then
+ -- A subtype needs to be created.
+ Def := Create_Iir (Iir_Kind_Subtype_Definition);
+ Location_Copy (Def, Type_Mark);
+ Set_Subtype_Type_Mark (Def, Type_Mark);
+ Set_Resolution_Indication (Def, Resolution_Indication);
+ Set_Tolerance (Def, Tolerance);
+ else
+ -- This is just an alias.
+ Def := Type_Mark;
+ end if;
+ end case;
+ return Def;
+ end Parse_Subtype_Indication;
+
+ -- precond : SUBTYPE
+ -- postcond: ';'
+ --
+ -- [ �4.2 ]
+ -- subtype_declaration ::= SUBTYPE identifier IS subtype_indication ;
+ function Parse_Subtype_Declaration return Iir_Subtype_Declaration
+ is
+ Decl: Iir_Subtype_Declaration;
+ Def: Iir;
+ begin
+ Decl := Create_Iir (Iir_Kind_Subtype_Declaration);
+
+ Scan_Expect (Tok_Identifier);
+ Set_Identifier (Decl, Current_Identifier);
+ Set_Location (Decl);
+
+ Scan_Expect (Tok_Is);
+ Scan;
+ Def := Parse_Subtype_Indication;
+ Set_Subtype_Indication (Decl, Def);
+
+ Expect (Tok_Semi_Colon);
+ return Decl;
+ end Parse_Subtype_Declaration;
+
+ -- precond : NATURE
+ -- postcond: a token
+ --
+ -- [ �4.8 ]
+ -- nature_definition ::= scalar_nature_definition
+ -- | composite_nature_definition
+ --
+ -- [ �3.5.1 ]
+ -- scalar_nature_definition ::= type_mark ACROSS
+ -- type_mark THROUGH
+ -- identifier REFERENCE
+ --
+ -- [ �3.5.2 ]
+ -- composite_nature_definition ::= array_nature_definition
+ -- | record_nature_definition
+ function Parse_Nature_Declaration return Iir
+ is
+ Def : Iir;
+ Ref : Iir;
+ Loc : Location_Type;
+ Ident : Name_Id;
+ Decl : Iir;
+ begin
+ -- The current token must be type.
+ if Current_Token /= Tok_Nature then
+ raise Program_Error;
+ end if;
+
+ -- Get the identifier
+ Scan_Expect (Tok_Identifier,
+ "an identifier is expected after 'nature'");
+ Loc := Get_Token_Location;
+ Ident := Current_Identifier;
+
+ Scan;
+
+ if Current_Token /= Tok_Is then
+ Error_Msg_Parse ("'is' expected here");
+ -- Act as if IS token was forgotten.
+ else
+ -- Eat IS token.
+ Scan;
+ end if;
+
+ case Current_Token is
+ when Tok_Array =>
+ -- TODO
+ Error_Msg_Parse ("array nature definition not supported");
+ Def := Null_Iir;
+ Eat_Tokens_Until_Semi_Colon;
+ when Tok_Record =>
+ -- TODO
+ Error_Msg_Parse ("record nature definition not supported");
+ Def := Null_Iir;
+ Eat_Tokens_Until_Semi_Colon;
+ when Tok_Identifier =>
+ Def := Create_Iir (Iir_Kind_Scalar_Nature_Definition);
+ Set_Location (Def, Loc);
+ Set_Across_Type (Def, Parse_Type_Mark);
+ if Current_Token = Tok_Across then
+ Scan;
+ else
+ Expect (Tok_Across, "'across' expected after type mark");
+ end if;
+ Set_Through_Type (Def, Parse_Type_Mark);
+ if Current_Token = Tok_Through then
+ Scan;
+ else
+ Expect (Tok_Across, "'through' expected after type mark");
+ end if;
+ if Current_Token = Tok_Identifier then
+ Ref := Create_Iir (Iir_Kind_Terminal_Declaration);
+ Set_Identifier (Ref, Current_Identifier);
+ Set_Location (Ref);
+ Set_Reference (Def, Ref);
+ Scan;
+ if Current_Token = Tok_Reference then
+ Scan;
+ else
+ Expect (Tok_Reference, "'reference' expected");
+ Eat_Tokens_Until_Semi_Colon;
+ end if;
+ else
+ Error_Msg_Parse ("reference identifier expected");
+ Eat_Tokens_Until_Semi_Colon;
+ end if;
+ when others =>
+ Error_Msg_Parse ("nature definition expected here");
+ Eat_Tokens_Until_Semi_Colon;
+ end case;
+
+ Decl := Create_Iir (Iir_Kind_Nature_Declaration);
+ Set_Nature (Decl, Def);
+ Set_Identifier (Decl, Ident);
+ Set_Location (Decl, Loc);
+
+ -- ';' is expected after end of type declaration
+ Expect (Tok_Semi_Colon);
+ Invalidate_Current_Token;
+ return Decl;
+ end Parse_Nature_Declaration;
+
+ -- precond : identifier
+ -- postcond: next token
+ --
+ -- LRM 4.8 Nature declaration
+ --
+ -- subnature_indication ::=
+ -- nature_mark [ index_constraint ]
+ -- [ TOLERANCE string_expression ACROSS string_expression THROUGH ]
+ --
+ -- nature_mark ::=
+ -- nature_name | subnature_name
+ function Parse_Subnature_Indication return Iir is
+ Nature_Mark : Iir;
+ begin
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse ("nature mark expected in a subnature indication");
+ raise Parse_Error;
+ end if;
+ Nature_Mark := Parse_Name (Allow_Indexes => False);
+
+ if Current_Token = Tok_Left_Paren then
+ -- TODO
+ Error_Msg_Parse
+ ("index constraint not supported for subnature indication");
+ raise Parse_Error;
+ end if;
+
+ if Current_Token = Tok_Tolerance then
+ Error_Msg_Parse
+ ("tolerance not supported for subnature indication");
+ raise Parse_Error;
+ end if;
+ return Nature_Mark;
+ end Parse_Subnature_Indication;
+
+ -- precond : TERMINAL
+ -- postcond: ;
+ --
+ -- [ 4.3.1.5 Terminal declarations ]
+ -- terminal_declaration ::=
+ -- TERMINAL identifier_list : subnature_indication
+ function Parse_Terminal_Declaration (Parent : Iir) return Iir
+ is
+ -- First and last element of the chain to be returned.
+ First, Last : Iir;
+ Terminal : Iir;
+ Subnature : Iir;
+ begin
+ Sub_Chain_Init (First, Last);
+
+ loop
+ -- 'terminal' or "," was just scanned.
+ Terminal := Create_Iir (Iir_Kind_Terminal_Declaration);
+ Scan_Expect (Tok_Identifier);
+ Set_Identifier (Terminal, Current_Identifier);
+ Set_Location (Terminal);
+ Set_Parent (Terminal, Parent);
+
+ Sub_Chain_Append (First, Last, Terminal);
+
+ Scan;
+ exit when Current_Token = Tok_Colon;
+ if Current_Token /= Tok_Comma then
+ Error_Msg_Parse
+ ("',' or ':' is expected after "
+ & "identifier in terminal declaration");
+ raise Expect_Error;
+ end if;
+ end loop;
+
+ -- The colon was parsed.
+ Scan;
+ Subnature := Parse_Subnature_Indication;
+
+ Terminal := First;
+ while Terminal /= Null_Iir loop
+ -- Type definitions are factorized. This is OK, but not done by
+ -- sem.
+ if Terminal = First then
+ Set_Nature (Terminal, Subnature);
+ else
+ Set_Nature (Terminal, Null_Iir);
+ end if;
+ Terminal := Get_Chain (Terminal);
+ end loop;
+ Expect (Tok_Semi_Colon);
+ return First;
+ end Parse_Terminal_Declaration;
+
+ -- precond : QUANTITY
+ -- postcond: ;
+ --
+ -- [ 4.3.1.6 Quantity declarations ]
+ -- quantity_declaration ::=
+ -- free_quantity_declaration
+ -- | branch_quantity_declaration
+ -- | source_quantity_declaration
+ --
+ -- free_quantity_declaration ::=
+ -- QUANTITY identifier_list : subtype_indication [ := expression ] ;
+ --
+ -- branch_quantity_declaration ::=
+ -- QUANTITY [ across_aspect ] [ through_aspect ] terminal_aspect ;
+ --
+ -- source_quantity_declaration ::=
+ -- QUANTITY identifier_list : subtype_indication source_aspect ;
+ --
+ -- across_aspect ::=
+ -- identifier_list [ tolerance_aspect ] [ := expression ] ACROSS
+ --
+ -- through_aspect ::=
+ -- identifier_list [ tolerance_aspect ] [ := expression ] THROUGH
+ --
+ -- terminal_aspect ::=
+ -- plus_terminal_name [ TO minus_terminal_name ]
+ function Parse_Quantity_Declaration (Parent : Iir) return Iir
+ is
+ -- First and last element of the chain to be returned.
+ First, Last : Iir;
+ Object : Iir;
+ New_Object : Iir;
+ Tolerance : Iir;
+ Default_Value : Iir;
+ Kind : Iir_Kind;
+ Plus_Terminal : Iir;
+ begin
+ Sub_Chain_Init (First, Last);
+
+ -- Eat 'quantity'
+ Scan;
+
+ loop
+ -- Quantity or "," was just scanned. We assume a free quantity
+ -- declaration and will change to branch or source quantity if
+ -- necessary.
+ Object := Create_Iir (Iir_Kind_Free_Quantity_Declaration);
+ Expect (Tok_Identifier);
+ Set_Identifier (Object, Current_Identifier);
+ Set_Location (Object);
+ Set_Parent (Object, Parent);
+
+ Sub_Chain_Append (First, Last, Object);
+
+ -- Eat identifier
+ Scan;
+ exit when Current_Token /= Tok_Comma;
+
+ -- Eat ','
+ Scan;
+ end loop;
+
+ case Current_Token is
+ when Tok_Colon =>
+ -- Either a free quantity (or a source quantity)
+ -- TODO
+ raise Program_Error;
+ when Tok_Tolerance
+ | Tok_Assign
+ | Tok_Across
+ | Tok_Through =>
+ -- A branch quantity
+
+ -- Parse tolerance aspect
+ Tolerance := Parse_Tolerance_Aspect_Opt;
+
+ -- Parse default value
+ if Current_Token = Tok_Assign then
+ Scan;
+ Default_Value := Parse_Expression;
+ else
+ Default_Value := Null_Iir;
+ end if;
+
+ case Current_Token is
+ when Tok_Across =>
+ Kind := Iir_Kind_Across_Quantity_Declaration;
+ when Tok_Through =>
+ Kind := Iir_Kind_Through_Quantity_Declaration;
+ when others =>
+ Error_Msg_Parse ("'across' or 'through' expected here");
+ Eat_Tokens_Until_Semi_Colon;
+ raise Expect_Error;
+ end case;
+
+ -- Eat across/through
+ Scan;
+
+ -- Change declarations
+ Object := First;
+ Sub_Chain_Init (First, Last);
+ while Object /= Null_Iir loop
+ New_Object := Create_Iir (Kind);
+ Location_Copy (New_Object, Object);
+ Set_Identifier (New_Object, Get_Identifier (Object));
+ Set_Parent (New_Object, Parent);
+ Set_Tolerance (New_Object, Tolerance);
+ Set_Default_Value (New_Object, Default_Value);
+
+ Sub_Chain_Append (First, Last, New_Object);
+
+ if Object /= First then
+ Set_Plus_Terminal (New_Object, Null_Iir);
+ end if;
+ New_Object := Get_Chain (Object);
+ Free_Iir (Object);
+ Object := New_Object;
+ end loop;
+
+ -- Parse terminal (or first identifier of through declarations)
+ Plus_Terminal := Parse_Name;
+
+ case Current_Token is
+ when Tok_Comma
+ | Tok_Tolerance
+ | Tok_Assign
+ | Tok_Through
+ | Tok_Across =>
+ -- Through quantity declaration. Convert the Plus_Terminal
+ -- to a declaration.
+ Object := Create_Iir (Iir_Kind_Through_Quantity_Declaration);
+ New_Object := Object;
+ Location_Copy (Object, Plus_Terminal);
+ if Get_Kind (Plus_Terminal) /= Iir_Kind_Simple_Name then
+ Error_Msg_Parse
+ ("identifier for quantity declaration expected");
+ else
+ Set_Identifier (Object, Get_Identifier (Plus_Terminal));
+ end if;
+ Set_Plus_Terminal (Object, Null_Iir);
+ Free_Iir (Plus_Terminal);
+
+ loop
+ Set_Parent (Object, Parent);
+ Sub_Chain_Append (First, Last, Object);
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+
+ Object := Create_Iir
+ (Iir_Kind_Through_Quantity_Declaration);
+ Set_Location (Object);
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse
+ ("identifier for quantity declaration expected");
+ else
+ Set_Identifier (Object, Current_Identifier);
+ Scan;
+ end if;
+ Set_Plus_Terminal (Object, Null_Iir);
+
+ end loop;
+
+ -- Parse tolerance aspect
+ Set_Tolerance (Object, Parse_Tolerance_Aspect_Opt);
+
+ -- Parse default value
+ if Current_Token = Tok_Assign then
+ Scan;
+ Set_Default_Value (Object, Parse_Expression);
+ end if;
+
+ -- Scan 'through'
+ if Current_Token = Tok_Through then
+ Scan;
+ elsif Current_Token = Tok_Across then
+ Error_Msg_Parse ("across quantity declaration must appear"
+ & " before though declaration");
+ Scan;
+ else
+ Error_Msg_Parse ("'through' expected");
+ end if;
+
+ -- Parse plus terminal
+ Plus_Terminal := Parse_Name;
+ when others =>
+ null;
+ end case;
+
+ Set_Plus_Terminal (First, Plus_Terminal);
+
+ -- Parse minus terminal (if present)
+ if Current_Token = Tok_To then
+ Scan;
+ Set_Minus_Terminal (First, Parse_Name);
+ end if;
+ when others =>
+ Error_Msg_Parse ("missign type or across/throught aspect "
+ & "in quantity declaration");
+ Eat_Tokens_Until_Semi_Colon;
+ raise Expect_Error;
+ end case;
+ Expect (Tok_Semi_Colon);
+ return First;
+ end Parse_Quantity_Declaration;
+
+ -- precond : token (CONSTANT, SIGNAL, VARIABLE, FILE)
+ -- postcond: ;
+ --
+ -- KIND can be iir_kind_constant_declaration, iir_kind_file_declaration
+ -- or iir_kind_variable_declaration
+ --
+ -- [ LRM93 4.3.1 ]
+ -- object_declaration ::= constant_declaration
+ -- | signal_declaration
+ -- | variable_declaration
+ -- | file_declaration
+ --
+ -- [ LRM93 4.3.1.1 ]
+ -- constant_declaration ::=
+ -- CONSTANT identifier_list : subtype_indication [ := expression ]
+ --
+ -- [ LRM87 4.3.2 ]
+ -- file_declaration ::=
+ -- FILE identifier : subtype_indication IS [ mode ] file_logical_name
+ --
+ -- [ LRM93 4.3.1.4 ]
+ -- file_declaration ::=
+ -- FILE identifier_list : subtype_indication [ file_open_information ]
+ --
+ -- [ LRM93 4.3.1.4 ]
+ -- file_open_information ::=
+ -- [ OPEN FILE_OPEN_KIND_expression ] IS file_logical_name
+ --
+ -- [ LRM93 4.3.1.4 ]
+ -- file_logical_name ::= STRING_expression
+ --
+ -- [ LRM93 4.3.1.3 ]
+ -- variable_declaration ::=
+ -- [ SHARED ] VARIABLE identifier_list : subtype_indication
+ -- [ := expression ]
+ --
+ -- [ LRM93 4.3.1.2 ]
+ -- signal_declaration ::=
+ -- SIGNAL identifier_list : subtype_information [ signal_kind ]
+ -- [ := expression ]
+ --
+ -- [ LRM93 4.3.1.2 ]
+ -- signal_kind ::= REGISTER | BUS
+ --
+ -- FIXME: file_open_information.
+ function Parse_Object_Declaration (Parent : Iir) return Iir
+ is
+ -- First and last element of the chain to be returned.
+ First, Last : Iir;
+ Object: Iir;
+ Object_Type: Iir;
+ Default_Value : Iir;
+ Mode: Iir_Mode;
+ Signal_Kind : Iir_Signal_Kind;
+ Open_Kind : Iir;
+ Logical_Name : Iir;
+ Kind: Iir_Kind;
+ Shared : Boolean;
+ Has_Mode : Boolean;
+ begin
+ Sub_Chain_Init (First, Last);
+
+ -- object keyword was just scanned.
+ case Current_Token is
+ when Tok_Signal =>
+ Kind := Iir_Kind_Signal_Declaration;
+ when Tok_Constant =>
+ Kind := Iir_Kind_Constant_Declaration;
+ when Tok_File =>
+ Kind := Iir_Kind_File_Declaration;
+ when Tok_Variable =>
+ Kind := Iir_Kind_Variable_Declaration;
+ Shared := False;
+ when Tok_Shared =>
+ Kind := Iir_Kind_Variable_Declaration;
+ Shared := True;
+ Scan_Expect (Tok_Variable);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ loop
+ -- object or "," was just scanned.
+ Object := Create_Iir (Kind);
+ if Kind = Iir_Kind_Variable_Declaration then
+ Set_Shared_Flag (Object, Shared);
+ end if;
+ Scan_Expect (Tok_Identifier);
+ Set_Identifier (Object, Current_Identifier);
+ Set_Location (Object);
+ Set_Parent (Object, Parent);
+
+ Sub_Chain_Append (First, Last, Object);
+
+ Scan;
+ exit when Current_Token = Tok_Colon;
+ if Current_Token /= Tok_Comma then
+ case Current_Token is
+ when Tok_Assign =>
+ Error_Msg_Parse ("missign type in " & Disp_Name (Kind));
+ exit;
+ when others =>
+ Error_Msg_Parse
+ ("',' or ':' is expected after identifier in "
+ & Disp_Name (Kind));
+ raise Expect_Error;
+ end case;
+ end if;
+ Set_Has_Identifier_List (Object, True);
+ end loop;
+
+ -- Eat ':'
+ Scan;
+
+ Object_Type := Parse_Subtype_Indication;
+
+ if Kind = Iir_Kind_Signal_Declaration then
+ Signal_Kind := Parse_Signal_Kind;
+ end if;
+
+ if Current_Token = Tok_Assign then
+ if Kind = Iir_Kind_File_Declaration then
+ Error_Msg_Parse
+ ("default expression not allowed for a file declaration");
+ end if;
+
+ -- Skip ':='.
+ Scan;
+
+ Default_Value := Parse_Expression;
+ else
+ Default_Value := Null_Iir;
+ end if;
+
+ if Kind = Iir_Kind_File_Declaration then
+ if Current_Token = Tok_Open then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'open' and open kind expression not allowed in vhdl 87");
+ end if;
+ Scan;
+ Open_Kind := Parse_Expression;
+ else
+ Open_Kind := Null_Iir;
+ end if;
+
+ -- LRM 4.3.1.4
+ -- The default mode is IN, if no mode is specified.
+ Mode := Iir_In_Mode;
+
+ Logical_Name := Null_Iir;
+ Has_Mode := False;
+ if Current_Token = Tok_Is then
+ -- Skip 'is'.
+ Scan;
+
+ case Current_Token is
+ when Tok_In | Tok_Out | Tok_Inout =>
+ if Flags.Vhdl_Std >= Vhdl_93 then
+ Error_Msg_Parse ("mode allowed only in vhdl 87");
+ end if;
+ Mode := Parse_Mode (Iir_In_Mode);
+ if Mode = Iir_Inout_Mode then
+ Error_Msg_Parse ("inout mode not allowed for file");
+ end if;
+ Has_Mode := True;
+ when others =>
+ null;
+ end case;
+ Logical_Name := Parse_Expression;
+ elsif Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("file name expected (vhdl 87)");
+ end if;
+ end if;
+
+ Set_Subtype_Indication (First, Object_Type);
+ if Kind /= Iir_Kind_File_Declaration then
+ Set_Default_Value (First, Default_Value);
+ end if;
+
+ Object := First;
+ while Object /= Null_Iir loop
+ case Kind is
+ when Iir_Kind_File_Declaration =>
+ Set_Mode (Object, Mode);
+ Set_File_Open_Kind (Object, Open_Kind);
+ Set_File_Logical_Name (Object, Logical_Name);
+ Set_Has_Mode (Object, Has_Mode);
+ when Iir_Kind_Signal_Declaration =>
+ Set_Signal_Kind (Object, Signal_Kind);
+ when others =>
+ null;
+ end case;
+ Set_Is_Ref (Object, Object /= First);
+ Object := Get_Chain (Object);
+ end loop;
+
+ -- ';' is not eaten.
+ Expect (Tok_Semi_Colon);
+
+ return First;
+ end Parse_Object_Declaration;
+
+ -- precond : COMPONENT
+ -- postcond: ';'
+ --
+ -- [ �4.5 ]
+ -- component_declaration ::=
+ -- COMPONENT identifier [ IS ]
+ -- [ LOCAL_generic_clause ]
+ -- [ LOCAL_port_clause ]
+ -- END COMPONENT [ COMPONENT_simple_name ] ;
+ function Parse_Component_Declaration
+ return Iir_Component_Declaration
+ is
+ Component: Iir_Component_Declaration;
+ begin
+ Component := Create_Iir (Iir_Kind_Component_Declaration);
+ Scan_Expect (Tok_Identifier,
+ "an identifier is expected after 'component'");
+ Set_Identifier (Component, Current_Identifier);
+ Set_Location (Component);
+ Scan;
+ if Current_Token = Tok_Is then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("""is"" keyword is not allowed here by vhdl 87");
+ end if;
+ Set_Has_Is (Component, True);
+ Scan;
+ end if;
+ Parse_Generic_Port_Clauses (Component);
+ Check_End_Name (Tok_Component, Component);
+ return Component;
+ end Parse_Component_Declaration;
+
+ -- precond : '['
+ -- postcond: next token after ']'
+ --
+ -- [ 2.3.2 ]
+ -- signature ::= [ [ type_mark { , type_mark } ] [ RETURN type_mark ] ]
+ function Parse_Signature return Iir_Signature
+ is
+ Res : Iir_Signature;
+ List : Iir_List;
+ begin
+ Expect (Tok_Left_Bracket);
+ Res := Create_Iir (Iir_Kind_Signature);
+ Set_Location (Res);
+
+ -- Skip '['
+ Scan;
+
+ -- List of type_marks.
+ if Current_Token = Tok_Identifier then
+ List := Create_Iir_List;
+ Set_Type_Marks_List (Res, List);
+ loop
+ Append_Element (List, Parse_Type_Mark (Check_Paren => True));
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+ end if;
+
+ if Current_Token = Tok_Return then
+ -- Skip 'return'
+ Scan;
+
+ Set_Return_Type_Mark (Res, Parse_Name);
+ end if;
+
+ -- Skip ']'
+ Expect (Tok_Right_Bracket);
+ Scan;
+
+ return Res;
+ end Parse_Signature;
+
+ -- precond : ALIAS
+ -- postcond: a token
+ --
+ -- [ LRM93 4.3.3 ]
+ -- alias_declaration ::=
+ -- ALIAS alias_designator [ : subtype_indication ]
+ -- IS name [ signature ] ;
+ --
+ -- [ LRM93 4.3.3 ]
+ -- alias_designator ::= identifier | character_literal | operator_symbol
+ --
+ -- FIXME: signature is not part of the node.
+ function Parse_Alias_Declaration return Iir
+ is
+ Res: Iir;
+ Ident : Name_Id;
+ begin
+ -- Eat 'alias'.
+ Scan;
+
+ Res := Create_Iir (Iir_Kind_Object_Alias_Declaration);
+ Set_Location (Res);
+
+ case Current_Token is
+ when Tok_Identifier =>
+ Ident := Current_Identifier;
+ when Tok_Character =>
+ Ident := Current_Identifier;
+ when Tok_String =>
+ Ident := Scan_To_Operator_Name (Get_Token_Location);
+ -- FIXME: vhdl87
+ -- FIXME: operator symbol.
+ when others =>
+ Error_Msg_Parse ("alias designator expected");
+ end case;
+
+ -- Eat identifier.
+ Set_Identifier (Res, Ident);
+ Scan;
+
+ if Current_Token = Tok_Colon then
+ Scan;
+ Set_Subtype_Indication (Res, Parse_Subtype_Indication);
+ end if;
+
+ -- FIXME: nice message if token is ':=' ?
+ Expect (Tok_Is);
+ Scan;
+ Set_Name (Res, Parse_Name);
+
+ return Res;
+ end Parse_Alias_Declaration;
+
+ -- precond : FOR
+ -- postcond: ';'
+ --
+ -- [ �5.2 ]
+ -- configuration_specification ::=
+ -- FOR component_specification binding_indication ;
+ function Parse_Configuration_Specification
+ return Iir_Configuration_Specification
+ is
+ Res : Iir_Configuration_Specification;
+ begin
+ Res := Create_Iir (Iir_Kind_Configuration_Specification);
+ Set_Location (Res);
+ Expect (Tok_For);
+ Scan;
+ Parse_Component_Specification (Res);
+ Set_Binding_Indication (Res, Parse_Binding_Indication);
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Configuration_Specification;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ � 5.2 ]
+ -- entity_class := ENTITY | ARCHITECTURE | CONFIGURATION | PROCEDURE
+ -- | FUNCTION | PACKAGE | TYPE | SUBTYPE | CONSTANT
+ -- | SIGNAL | VARIABLE | COMPONENT | LABEL | LITERAL
+ -- | UNITS | GROUP | FILE
+ function Parse_Entity_Class return Token_Type
+ is
+ Res : Token_Type;
+ begin
+ case Current_Token is
+ when Tok_Entity
+ | Tok_Architecture
+ | Tok_Configuration
+ | Tok_Procedure
+ | Tok_Function
+ | Tok_Package
+ | Tok_Type
+ | Tok_Subtype
+ | Tok_Constant
+ | Tok_Signal
+ | Tok_Variable
+ | Tok_Component
+ | Tok_Label =>
+ null;
+ when Tok_Literal
+ | Tok_Units
+ | Tok_Group
+ | Tok_File =>
+ null;
+ when others =>
+ Error_Msg_Parse
+ (''' & Tokens.Image (Current_Token) & "' is not a entity class");
+ end case;
+ Res := Current_Token;
+ Scan;
+ return Res;
+ end Parse_Entity_Class;
+
+ function Parse_Entity_Class_Entry return Iir_Entity_Class
+ is
+ Res : Iir_Entity_Class;
+ begin
+ Res := Create_Iir (Iir_Kind_Entity_Class);
+ Set_Location (Res);
+ Set_Entity_Class (Res, Parse_Entity_Class);
+ return Res;
+ end Parse_Entity_Class_Entry;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �5.1 ]
+ -- entity_designator ::= entity_tag [ signature ]
+ --
+ -- entity_tag ::= simple_name | character_literal | operator_symbol
+ function Parse_Entity_Designator return Iir
+ is
+ Res : Iir;
+ Name : Iir;
+ begin
+ case Current_Token is
+ when Tok_Identifier =>
+ Res := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Location (Res);
+ Set_Identifier (Res, Current_Identifier);
+ when Tok_Character =>
+ Res := Create_Iir (Iir_Kind_Character_Literal);
+ Set_Location (Res);
+ Set_Identifier (Res, Current_Identifier);
+ when Tok_String =>
+ Res := Create_Iir (Iir_Kind_Operator_Symbol);
+ Set_Location (Res);
+ Set_Identifier (Res, Scan_To_Operator_Name (Get_Token_Location));
+ when others =>
+ Error_Msg_Parse ("identifier, character or string expected");
+ raise Expect_Error;
+ end case;
+ Scan;
+ if Current_Token = Tok_Left_Bracket then
+ Name := Res;
+ Res := Parse_Signature;
+ Set_Signature_Prefix (Res, Name);
+ end if;
+ return Res;
+ end Parse_Entity_Designator;
+
+ -- precond : next token
+ -- postcond: IS
+ --
+ -- [ �5.1 ]
+ -- entity_name_list ::= entity_designator { , entity_designator }
+ -- | OTHERS
+ -- | ALL
+ procedure Parse_Entity_Name_List
+ (Attribute : Iir_Attribute_Specification)
+ is
+ List : Iir_List;
+ El : Iir;
+ begin
+ case Current_Token is
+ when Tok_All =>
+ List := Iir_List_All;
+ Scan;
+ when Tok_Others =>
+ List := Iir_List_Others;
+ Scan;
+ when others =>
+ List := Create_Iir_List;
+ loop
+ El := Parse_Entity_Designator;
+ Append_Element (List, El);
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+ end case;
+ Set_Entity_Name_List (Attribute, List);
+ if Current_Token = Tok_Colon then
+ Scan;
+ Set_Entity_Class (Attribute, Parse_Entity_Class);
+ else
+ Error_Msg_Parse
+ ("missing ':' and entity kind in attribute specification");
+ end if;
+ end Parse_Entity_Name_List;
+
+ -- precond : ATTRIBUTE
+ -- postcond: ';'
+ --
+ -- [ 4.4 ]
+ -- attribute_declaration ::= ATTRIBUTE identifier : type_mark ;
+ --
+ -- [ 5.1 ]
+ -- attribute_specification ::=
+ -- ATTRIBUTE attribute_designator OF entity_specification
+ -- IS expression ;
+ function Parse_Attribute return Iir
+ is
+ Loc : Location_Type;
+ Ident : Name_Id;
+ begin
+ Expect (Tok_Attribute);
+ Scan_Expect (Tok_Identifier);
+ Loc := Get_Token_Location;
+ Ident := Current_Identifier;
+ Scan;
+ case Current_Token is
+ when Tok_Colon =>
+ declare
+ Res : Iir_Attribute_Declaration;
+ begin
+ Res := Create_Iir (Iir_Kind_Attribute_Declaration);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Ident);
+ Scan;
+ Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True));
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end;
+ when Tok_Of =>
+ declare
+ Res : Iir_Attribute_Specification;
+ Designator : Iir_Simple_Name;
+ begin
+ Res := Create_Iir (Iir_Kind_Attribute_Specification);
+ Set_Location (Res, Loc);
+ Designator := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Location (Designator, Loc);
+ Set_Identifier (Designator, Ident);
+ Set_Attribute_Designator (Res, Designator);
+ Scan;
+ Parse_Entity_Name_List (Res);
+ Expect (Tok_Is);
+ Scan;
+ Set_Expression (Res, Parse_Expression);
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end;
+ when others =>
+ Error_Msg_Parse ("':' or 'of' expected after identifier");
+ return Null_Iir;
+ end case;
+ end Parse_Attribute;
+
+ -- precond : GROUP
+ -- postcond: ';'
+ --
+ -- [ �4.6 ]
+ -- group_template_declaration ::=
+ -- GROUP identifier IS (entity_class_entry_list) ;
+ --
+ -- entity_class_entry_list ::= entity_class_entry { , entity_class_entry }
+ --
+ -- entity_class_entry ::= entity_class [ <> ]
+ function Parse_Group return Iir is
+ Loc : Location_Type;
+ Ident : Name_Id;
+ begin
+ Expect (Tok_Group);
+ Scan_Expect (Tok_Identifier);
+ Loc := Get_Token_Location;
+ Ident := Current_Identifier;
+ Scan;
+ case Current_Token is
+ when Tok_Is =>
+ declare
+ use Iir_Chains.Entity_Class_Entry_Chain_Handling;
+ Res : Iir_Group_Template_Declaration;
+ El : Iir_Entity_Class;
+ Last : Iir_Entity_Class;
+ begin
+ Res := Create_Iir (Iir_Kind_Group_Template_Declaration);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Ident);
+ Scan_Expect (Tok_Left_Paren);
+ Scan;
+ Build_Init (Last);
+ loop
+ Append (Last, Res, Parse_Entity_Class_Entry);
+ if Current_Token = Tok_Box then
+ El := Create_Iir (Iir_Kind_Entity_Class);
+ Set_Location (El);
+ Set_Entity_Class (El, Tok_Box);
+ Append (Last, Res, El);
+ Scan;
+ if Current_Token = Tok_Comma then
+ Error_Msg_Parse
+ ("'<>' is allowed only for the last "
+ & "entity class entry");
+ end if;
+ end if;
+ exit when Current_Token = Tok_Right_Paren;
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ Scan_Expect (Tok_Semi_Colon);
+ return Res;
+ end;
+ when Tok_Colon =>
+ declare
+ Res : Iir_Group_Declaration;
+ List : Iir_Group_Constituent_List;
+ begin
+ Res := Create_Iir (Iir_Kind_Group_Declaration);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Ident);
+ Scan;
+ Set_Group_Template_Name
+ (Res, Parse_Name (Allow_Indexes => False));
+ Expect (Tok_Left_Paren);
+ Scan;
+ List := Create_Iir_List;
+ Set_Group_Constituent_List (Res, List);
+ loop
+ Append_Element (List, Parse_Name (Allow_Indexes => False));
+ exit when Current_Token = Tok_Right_Paren;
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ Scan_Expect (Tok_Semi_Colon);
+ return Res;
+ end;
+ when others =>
+ Error_Msg_Parse ("':' or 'is' expected here");
+ return Null_Iir;
+ end case;
+ end Parse_Group;
+
+ -- precond : next token
+ -- postcond: ':'
+ --
+ -- [ �5.4 ]
+ -- signal_list ::= signal_name { , signal_name }
+ -- | OTHERS
+ -- | ALL
+ function Parse_Signal_List return Iir_List
+ is
+ Res : Iir_List;
+ begin
+ case Current_Token is
+ when Tok_Others =>
+ Scan;
+ return Iir_List_Others;
+ when Tok_All =>
+ Scan;
+ return Iir_List_All;
+ when others =>
+ Res := Create_Iir_List;
+ loop
+ Append_Element (Res, Parse_Name);
+ exit when Current_Token = Tok_Colon;
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ return Res;
+ end case;
+ end Parse_Signal_List;
+
+ -- precond : DISCONNECT
+ -- postcond: ';'
+ --
+ -- [ �5.4 ]
+ -- disconnection_specification ::=
+ -- DISCONNECT guarded_signal_specification AFTER time_expression ;
+ function Parse_Disconnection_Specification
+ return Iir_Disconnection_Specification
+ is
+ Res : Iir_Disconnection_Specification;
+ begin
+ Res := Create_Iir (Iir_Kind_Disconnection_Specification);
+ Set_Location (Res);
+
+ -- Skip 'disconnect'
+ Expect (Tok_Disconnect);
+ Scan;
+
+ Set_Signal_List (Res, Parse_Signal_List);
+
+ -- Skip ':'
+ Expect (Tok_Colon);
+ Scan;
+
+ Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True));
+
+ -- Skip 'after'
+ Expect (Tok_After);
+ Scan;
+
+ Set_Expression (Res, Parse_Expression);
+ return Res;
+ end Parse_Disconnection_Specification;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ LRM93 4 ]
+ -- declaration ::= type_declaration
+ -- | subtype_declaration
+ -- | object_declaration
+ -- | interface_declaration
+ -- | alias_declaration
+ -- | attribute_declaration
+ -- | component_declaration
+ -- | group_template_declaration
+ -- | group_declaration
+ -- | entity_declaration
+ -- | configuration_declaration
+ -- | subprogram_declaration
+ -- | package_declaration
+ procedure Parse_Declarative_Part (Parent : Iir)
+ is
+ use Declaration_Chain_Handling;
+ Last_Decl : Iir;
+ Decl : Iir;
+ begin
+ Build_Init (Last_Decl);
+ loop
+ Decl := Null_Iir;
+ case Current_Token is
+ when Tok_Invalid =>
+ raise Internal_Error;
+ when Tok_Type =>
+ Decl := Parse_Type_Declaration (Parent);
+
+ -- LRM 2.5 Package declarations
+ -- If a package declarative item is a type declaration that is
+ -- a full type declaration whose type definition is a
+ -- protected_type definition, then that protected type
+ -- definition must not be a protected type body.
+ if Decl /= Null_Iir
+ and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Body
+ then
+ case Get_Kind (Parent) is
+ when Iir_Kind_Package_Declaration =>
+ Error_Msg_Parse ("protected type body not allowed "
+ & "in package declaration", Decl);
+ when others =>
+ null;
+ end case;
+ end if;
+ when Tok_Subtype =>
+ Decl := Parse_Subtype_Declaration;
+ when Tok_Nature =>
+ Decl := Parse_Nature_Declaration;
+ when Tok_Terminal =>
+ Decl := Parse_Terminal_Declaration (Parent);
+ when Tok_Quantity =>
+ Decl := Parse_Quantity_Declaration (Parent);
+ when Tok_Signal =>
+ case Get_Kind (Parent) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Error_Msg_Parse
+ ("signal declaration not allowed in subprogram body");
+ when Iir_Kinds_Process_Statement =>
+ Error_Msg_Parse
+ ("signal declaration not allowed in process");
+ when others =>
+ null;
+ end case;
+ Decl := Parse_Object_Declaration (Parent);
+ when Tok_Constant =>
+ Decl := Parse_Object_Declaration (Parent);
+ when Tok_Variable =>
+ -- FIXME: remove this message (already checked during sem).
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body =>
+ -- FIXME: replace HERE with the kind of declaration
+ -- ie: "not allowed in a package" rather than "here".
+ Error_Msg_Parse ("variable declaration not allowed here");
+ when others =>
+ null;
+ end case;
+ Decl := Parse_Object_Declaration (Parent);
+ when Tok_Shared =>
+ if Flags.Vhdl_Std <= Vhdl_87 then
+ Error_Msg_Parse ("shared variable not allowed in vhdl 87");
+ end if;
+ Decl := Parse_Object_Declaration (Parent);
+ when Tok_File =>
+ Decl := Parse_Object_Declaration (Parent);
+ when Tok_Function
+ | Tok_Procedure
+ | Tok_Pure
+ | Tok_Impure =>
+ Decl := Parse_Subprogram_Declaration (Parent);
+ when Tok_Alias =>
+ Decl := Parse_Alias_Declaration;
+ when Tok_Component =>
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body
+ | Iir_Kinds_Process_Statement =>
+ Error_Msg_Parse
+ ("component declaration are not allowed here");
+ when others =>
+ null;
+ end case;
+ Decl := Parse_Component_Declaration;
+ when Tok_For =>
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kinds_Process_Statement =>
+ Error_Msg_Parse
+ ("configuration specification not allowed here");
+ when others =>
+ null;
+ end case;
+ Decl := Parse_Configuration_Specification;
+ when Tok_Attribute =>
+ Decl := Parse_Attribute;
+ when Tok_Disconnect =>
+ case Get_Kind (Parent) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kinds_Process_Statement =>
+ Error_Msg_Parse
+ ("disconnect specification not allowed here");
+ when others =>
+ null;
+ end case;
+ Decl := Parse_Disconnection_Specification;
+ when Tok_Use =>
+ Decl := Parse_Use_Clause;
+ when Tok_Group =>
+ Decl := Parse_Group;
+
+ when Tok_Identifier =>
+ Error_Msg_Parse
+ ("object class keyword such as 'variable' is expected");
+ Eat_Tokens_Until_Semi_Colon;
+ when Tok_Semi_Colon =>
+ Error_Msg_Parse ("';' (semi colon) not allowed alone");
+ Scan;
+ when others =>
+ exit;
+ end case;
+ if Decl /= Null_Iir then
+ Append_Subchain (Last_Decl, Parent, Decl);
+ end if;
+
+ if Current_Token = Tok_Semi_Colon or Current_Token = Tok_Invalid then
+ Scan;
+ end if;
+ end loop;
+ end Parse_Declarative_Part;
+
+ -- precond : ENTITY
+ -- postcond: ';'
+ --
+ -- [ �1.1 ]
+ -- entity_declaration ::=
+ -- ENTITY identifier IS
+ -- entiy_header
+ -- entity_declarative_part
+ -- [ BEGIN
+ -- entity_statement_part ]
+ -- END [ ENTITY ] [ ENTITY_simple_name ]
+ --
+ -- [ �1.1.1 ]
+ -- entity_header ::=
+ -- [ FORMAL_generic_clause ]
+ -- [ FORMAL_port_clause ]
+ procedure Parse_Entity_Declaration (Unit : Iir_Design_Unit)
+ is
+ Res: Iir_Entity_Declaration;
+ begin
+ Expect (Tok_Entity);
+ Res := Create_Iir (Iir_Kind_Entity_Declaration);
+
+ -- Get identifier.
+ Scan_Expect (Tok_Identifier,
+ "an identifier is expected after ""entity""");
+ Set_Identifier (Res, Current_Identifier);
+ Set_Location (Res);
+
+ Scan_Expect (Tok_Is, "missing ""is"" after identifier");
+ Scan;
+
+ Parse_Generic_Port_Clauses (Res);
+
+ Parse_Declarative_Part (Res);
+
+ if Current_Token = Tok_Begin then
+ Set_Has_Begin (Res, True);
+ Scan;
+ Parse_Concurrent_Statements (Res);
+ end if;
+
+ -- end keyword is expected to finish an entity declaration
+ Expect (Tok_End);
+ Set_End_Location (Unit);
+
+ Scan;
+ if Current_Token = Tok_Entity then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("""entity"" keyword not allowed here by vhdl 87");
+ end if;
+ Set_End_Has_Reserved_Id (Res, True);
+ Scan;
+ end if;
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ Invalidate_Current_Token;
+ Set_Library_Unit (Unit, Res);
+ end Parse_Entity_Declaration;
+
+ -- [ LRM93 7.3.2 ]
+ -- choice ::= simple_expression
+ -- | discrete_range
+ -- | ELEMENT_simple_name
+ -- | OTHERS
+ function Parse_A_Choice (Expr: Iir) return Iir
+ is
+ A_Choice: Iir;
+ Expr1: Iir;
+ begin
+ if Expr = Null_Iir then
+ if Current_Token = Tok_Others then
+ A_Choice := Create_Iir (Iir_Kind_Choice_By_Others);
+ Set_Location (A_Choice);
+
+ -- Skip 'others'
+ Scan;
+
+ return A_Choice;
+ else
+ Expr1 := Parse_Expression;
+
+ if Expr1 = Null_Iir then
+ -- Handle parse error now.
+ -- FIXME: skip until '=>'.
+ A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression);
+ Set_Location (A_Choice);
+ return A_Choice;
+ end if;
+ end if;
+ else
+ Expr1 := Expr;
+ end if;
+ if Is_Range_Attribute_Name (Expr1) then
+ A_Choice := Create_Iir (Iir_Kind_Choice_By_Range);
+ Location_Copy (A_Choice, Expr1);
+ Set_Choice_Range (A_Choice, Expr1);
+ return A_Choice;
+ elsif Current_Token = Tok_To or else Current_Token = Tok_Downto then
+ A_Choice := Create_Iir (Iir_Kind_Choice_By_Range);
+ Location_Copy (A_Choice, Expr1);
+ Set_Choice_Range (A_Choice, Parse_Range_Right (Expr1));
+ return A_Choice;
+ else
+ A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression);
+ Location_Copy (A_Choice, Expr1);
+ Set_Choice_Expression (A_Choice, Expr1);
+ return A_Choice;
+ end if;
+ end Parse_A_Choice;
+
+ -- [ LRM93 7.3.2 ]
+ -- choices ::= choice { | choice }
+ --
+ -- Leave tok_double_arrow as current token.
+ function Parse_Choices (Expr: Iir) return Iir
+ is
+ First, Last : Iir;
+ A_Choice: Iir;
+ Expr1 : Iir;
+ begin
+ Sub_Chain_Init (First, Last);
+ Expr1 := Expr;
+ loop
+ A_Choice := Parse_A_Choice (Expr1);
+ if First /= Null_Iir then
+ Set_Same_Alternative_Flag (A_Choice, True);
+ if Get_Kind (A_Choice) = Iir_Kind_Choice_By_Others then
+ Error_Msg_Parse ("'others' choice must be alone");
+ end if;
+ end if;
+ Sub_Chain_Append (First, Last, A_Choice);
+ if Current_Token /= Tok_Bar then
+ return First;
+ end if;
+ Scan;
+ Expr1 := Null_Iir;
+ end loop;
+ end Parse_Choices;
+
+ -- precond : '('
+ -- postcond: next token
+ --
+ -- This can be an expression or an aggregate.
+ --
+ -- [ LRM93 7.3.2 ]
+ -- aggregate ::= ( element_association { , element_association } )
+ --
+ -- [ LRM93 7.3.2 ]
+ -- element_association ::= [ choices => ] expression
+ function Parse_Aggregate return Iir
+ is
+ use Iir_Chains.Association_Choices_Chain_Handling;
+ Expr: Iir;
+ Res: Iir;
+ Last : Iir;
+ Assoc: Iir;
+ Loc : Location_Type;
+ begin
+ Loc := Get_Token_Location;
+
+ -- Skip '('
+ Scan;
+
+ if Current_Token /= Tok_Others then
+ Expr := Parse_Expression;
+ case Current_Token is
+ when Tok_Comma
+ | Tok_Double_Arrow
+ | Tok_Bar =>
+ -- This is really an aggregate
+ null;
+ when Tok_Right_Paren =>
+ -- This was just a braced expression.
+
+ -- Eat ')'.
+ Scan;
+
+ if Get_Kind (Expr) = Iir_Kind_Aggregate then
+ -- Parenthesis around aggregate is useless and change the
+ -- context for array aggregate.
+ Warning_Msg_Sem
+ ("suspicious parenthesis around aggregate", Expr);
+ elsif not Flag_Parse_Parenthesis then
+ return Expr;
+ end if;
+
+ -- Create a node for the parenthesis.
+ Res := Create_Iir (Iir_Kind_Parenthesis_Expression);
+ Set_Location (Res, Loc);
+ Set_Expression (Res, Expr);
+ return Res;
+
+ when Tok_Semi_Colon =>
+ -- Surely a missing parenthesis.
+ -- FIXME: in case of multiple missing parenthesises, several
+ -- messages will be displayed
+ Error_Msg_Parse ("missing ')' for opening parenthesis at "
+ & Get_Location_Str (Loc, Filename => False));
+ return Expr;
+ when others =>
+ -- Surely a parse error...
+ null;
+ end case;
+ else
+ Expr := Null_Iir;
+ end if;
+ Res := Create_Iir (Iir_Kind_Aggregate);
+ Set_Location (Res, Loc);
+ Build_Init (Last);
+ loop
+ if Current_Token = Tok_Others then
+ Assoc := Parse_A_Choice (Null_Iir);
+ Expect (Tok_Double_Arrow);
+ Scan;
+ Expr := Parse_Expression;
+ else
+ if Expr = Null_Iir then
+ Expr := Parse_Expression;
+ end if;
+ if Expr = Null_Iir then
+ return Null_Iir;
+ end if;
+ case Current_Token is
+ when Tok_Comma
+ | Tok_Right_Paren =>
+ Assoc := Create_Iir (Iir_Kind_Choice_By_None);
+ Location_Copy (Assoc, Expr);
+ when others =>
+ Assoc := Parse_Choices (Expr);
+ Expect (Tok_Double_Arrow);
+ Scan;
+ Expr := Parse_Expression;
+ end case;
+ end if;
+ Set_Associated_Expr (Assoc, Expr);
+ Append_Subchain (Last, Res, Assoc);
+ exit when Current_Token = Tok_Right_Paren;
+ Expect (Tok_Comma);
+ Scan;
+ Expr := Null_Iir;
+ end loop;
+ Scan;
+ return Res;
+ end Parse_Aggregate;
+
+ -- precond : NEW
+ -- postcond: next token
+ --
+ -- [LRM93 7.3.6]
+ -- allocator ::= NEW subtype_indication
+ -- | NEW qualified_expression
+ function Parse_Allocator return Iir
+ is
+ Loc: Location_Type;
+ Res : Iir;
+ Expr: Iir;
+ begin
+ Loc := Get_Token_Location;
+
+ -- Accept 'new'.
+ Scan;
+ Expr := Parse_Name (Allow_Indexes => False);
+ if Get_Kind (Expr) /= Iir_Kind_Qualified_Expression then
+ -- This is a subtype_indication.
+ Res := Create_Iir (Iir_Kind_Allocator_By_Subtype);
+ Expr := Parse_Subtype_Indication (Expr);
+ Set_Subtype_Indication (Res, Expr);
+ else
+ Res := Create_Iir (Iir_Kind_Allocator_By_Expression);
+ Set_Expression (Res, Expr);
+ end if;
+
+ Set_Location (Res, Loc);
+ return Res;
+ end Parse_Allocator;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- primary ::= name
+ -- | literal
+ -- | aggregate
+ -- | function_call
+ -- | qualified_expression
+ -- | type_conversion
+ -- | allocator
+ -- | ( expression )
+ --
+ -- [ �7.3.1 ]
+ -- literal ::= numeric_literal
+ -- | enumeration_literal
+ -- | string_literal
+ -- | bit_string_literal
+ -- | NULL
+ --
+ -- [ �7.3.1 ]
+ -- numeric_literal ::= abstract_literal
+ -- | physical_literal
+ --
+ -- [ �13.4 ]
+ -- abstract_literal ::= decimal_literal | based_literal
+ --
+ -- [ �3.1.3 ]
+ -- physical_literal ::= [ abstract_literal ] UNIT_name
+ function Parse_Primary return Iir_Expression
+ is
+ Res: Iir_Expression;
+ Int: Iir_Int64;
+ Fp: Iir_Fp64;
+ Loc: Location_Type;
+ begin
+ case Current_Token is
+ when Tok_Integer =>
+ Int := Current_Iir_Int64;
+ Loc := Get_Token_Location;
+
+ -- Skip integer
+ Scan;
+
+ if Current_Token = Tok_Identifier then
+ -- physical literal
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False));
+ else
+ -- integer literal
+ Res := Create_Iir (Iir_Kind_Integer_Literal);
+ end if;
+ Set_Location (Res, Loc);
+ Set_Value (Res, Int);
+ return Res;
+
+ when Tok_Real =>
+ Fp := Current_Iir_Fp64;
+ Loc := Get_Token_Location;
+
+ -- Skip real
+ Scan;
+
+ if Current_Token = Tok_Identifier then
+ -- physical literal
+ Res := Create_Iir (Iir_Kind_Physical_Fp_Literal);
+ Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False));
+ else
+ -- real literal
+ Res := Create_Iir (Iir_Kind_Floating_Point_Literal);
+ end if;
+ Set_Location (Res, Loc);
+ Set_Fp_Value (Res, Fp);
+ return Res;
+
+ when Tok_Identifier =>
+ return Parse_Name (Allow_Indexes => True);
+ when Tok_Character =>
+ Res := Current_Text;
+ Scan;
+ if Current_Token = Tok_Tick then
+ Error_Msg_Parse
+ ("prefix of an attribute can't be a character literal");
+ -- skip tick.
+ Scan;
+ -- skip attribute designator
+ Scan;
+ end if;
+ return Res;
+ when Tok_Left_Paren =>
+ return Parse_Aggregate;
+ when Tok_String =>
+ return Parse_Name;
+ when Tok_Null =>
+ Res := Create_Iir (Iir_Kind_Null_Literal);
+ Set_Location (Res);
+ Scan;
+ return Res;
+ when Tok_New =>
+ return Parse_Allocator;
+ when Tok_Bit_String =>
+ Res := Create_Iir (Iir_Kind_Bit_String_Literal);
+ Set_Location (Res);
+ Set_String_Id (Res, Current_String_Id);
+ Set_String_Length (Res, Current_String_Length);
+ case Current_Iir_Int64 is
+ when 1 =>
+ Set_Bit_String_Base (Res, Base_2);
+ when 3 =>
+ Set_Bit_String_Base (Res, Base_8);
+ when 4 =>
+ Set_Bit_String_Base (Res, Base_16);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Scan;
+ return Res;
+ when Tok_Minus
+ | Tok_Plus =>
+ Error_Msg_Parse
+ ("'-' and '+' are not allowed in primary, use parenthesis");
+ return Parse_Simple_Expression;
+ when Tok_Comma
+ | Tok_Semi_Colon
+ | Tok_Eof
+ | Tok_End =>
+ -- Token not to be skipped
+ Unexpected ("primary");
+ return Null_Iir;
+ when others =>
+ Unexpected ("primary");
+ Scan;
+ return Null_Iir;
+ end case;
+ end Parse_Primary;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- factor ::= primary [ ** primary ]
+ -- | ABS primary
+ -- | NOT primary
+ -- | logical_operator primary [ VHDL08 9.1 ]
+ function Build_Unary_Factor (Primary : Iir; Op : Iir_Kind) return Iir is
+ Res : Iir;
+ begin
+ if Primary /= Null_Iir then
+ return Primary;
+ end if;
+ Res := Create_Iir (Op);
+ Set_Location (Res);
+ Scan;
+ Set_Operand (Res, Parse_Primary);
+ return Res;
+ end Build_Unary_Factor;
+
+ function Build_Unary_Factor_08 (Primary : Iir; Op : Iir_Kind) return Iir is
+ begin
+ if Primary /= Null_Iir then
+ return Primary;
+ end if;
+ if Flags.Vhdl_Std < Vhdl_08 then
+ Error_Msg_Parse ("missing left operand of logical expression");
+ -- Skip operator
+ Scan;
+ return Parse_Primary;
+ else
+ return Build_Unary_Factor (Primary, Op);
+ end if;
+ end Build_Unary_Factor_08;
+
+ function Parse_Factor (Primary : Iir := Null_Iir) return Iir_Expression is
+ Res, Left: Iir_Expression;
+ begin
+ case Current_Token is
+ when Tok_Abs =>
+ return Build_Unary_Factor (Primary, Iir_Kind_Absolute_Operator);
+ when Tok_Not =>
+ return Build_Unary_Factor (Primary, Iir_Kind_Not_Operator);
+
+ when Tok_And =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_And_Operator);
+ when Tok_Or =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_Or_Operator);
+ when Tok_Nand =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_Nand_Operator);
+ when Tok_Nor =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_Nor_Operator);
+ when Tok_Xor =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_Xor_Operator);
+ when Tok_Xnor =>
+ return Build_Unary_Factor_08
+ (Primary, Iir_Kind_Reduction_Xnor_Operator);
+
+ when others =>
+ if Primary /= Null_Iir then
+ Left := Primary;
+ else
+ Left := Parse_Primary;
+ end if;
+ if Current_Token = Tok_Double_Star then
+ Res := Create_Iir (Iir_Kind_Exponentiation_Operator);
+ Set_Location (Res);
+ Scan;
+ Set_Left (Res, Left);
+ Set_Right (Res, Parse_Primary);
+ return Res;
+ else
+ return Left;
+ end if;
+ end case;
+ end Parse_Factor;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- term ::= factor { multiplying_operator factor }
+ --
+ -- [ �7.2 ]
+ -- multiplying_operator ::= * | / | MOD | REM
+ function Parse_Term (Primary : Iir) return Iir_Expression is
+ Res, Tmp: Iir_Expression;
+ begin
+ Res := Parse_Factor (Primary);
+ while Current_Token in Token_Multiplying_Operator_Type loop
+ case Current_Token is
+ when Tok_Star =>
+ Tmp := Create_Iir (Iir_Kind_Multiplication_Operator);
+ when Tok_Slash =>
+ Tmp := Create_Iir (Iir_Kind_Division_Operator);
+ when Tok_Mod =>
+ Tmp := Create_Iir (Iir_Kind_Modulus_Operator);
+ when Tok_Rem =>
+ Tmp := Create_Iir (Iir_Kind_Remainder_Operator);
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Location (Tmp);
+ Set_Left (Tmp, Res);
+ Scan;
+ Set_Right (Tmp, Parse_Factor);
+ Res := Tmp;
+ end loop;
+ return Res;
+ end Parse_Term;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- simple_expression ::= [ sign ] term { adding_operator term }
+ --
+ -- [ �7.2 ]
+ -- sign ::= + | -
+ --
+ -- [ �7.2 ]
+ -- adding_operator ::= + | - | &
+ function Parse_Simple_Expression (Primary : Iir := Null_Iir)
+ return Iir_Expression
+ is
+ Res, Tmp: Iir_Expression;
+ begin
+ if Current_Token in Token_Sign_Type
+ and then Primary = Null_Iir
+ then
+ case Current_Token is
+ when Tok_Plus =>
+ Res := Create_Iir (Iir_Kind_Identity_Operator);
+ when Tok_Minus =>
+ Res := Create_Iir (Iir_Kind_Negation_Operator);
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Location (Res);
+ Scan;
+ Set_Operand (Res, Parse_Term (Null_Iir));
+ else
+ Res := Parse_Term (Primary);
+ end if;
+ while Current_Token in Token_Adding_Operator_Type loop
+ case Current_Token is
+ when Tok_Plus =>
+ Tmp := Create_Iir (Iir_Kind_Addition_Operator);
+ when Tok_Minus =>
+ Tmp := Create_Iir (Iir_Kind_Substraction_Operator);
+ when Tok_Ampersand =>
+ Tmp := Create_Iir (Iir_Kind_Concatenation_Operator);
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Location (Tmp);
+ Scan;
+ Set_Left (Tmp, Res);
+ Set_Right (Tmp, Parse_Term (Null_Iir));
+ Res := Tmp;
+ end loop;
+ return Res;
+ end Parse_Simple_Expression;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- shift_expression ::=
+ -- simple_expression [ shift_operator simple_expression ]
+ --
+ -- [ �7.2 ]
+ -- shift_operator ::= SLL | SRL | SLA | SRA | ROL | ROR
+ function Parse_Shift_Expression return Iir_Expression is
+ Res, Tmp: Iir_Expression;
+ begin
+ Tmp := Parse_Simple_Expression;
+ if Current_Token not in Token_Shift_Operator_Type then
+ return Tmp;
+ elsif Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("shift operators not allowed in vhdl 87");
+ end if;
+ case Current_Token is
+ when Tok_Sll =>
+ Res := Create_Iir (Iir_Kind_Sll_Operator);
+ when Tok_Sla =>
+ Res := Create_Iir (Iir_Kind_Sla_Operator);
+ when Tok_Srl =>
+ Res := Create_Iir (Iir_Kind_Srl_Operator);
+ when Tok_Sra =>
+ Res := Create_Iir (Iir_Kind_Sra_Operator);
+ when Tok_Rol =>
+ Res := Create_Iir (Iir_Kind_Rol_Operator);
+ when Tok_Ror =>
+ Res := Create_Iir (Iir_Kind_Ror_Operator);
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Location (Res);
+ Scan;
+ Set_Left (Res, Tmp);
+ Set_Right (Res, Parse_Simple_Expression);
+ return Res;
+ end Parse_Shift_Expression;
+
+ -- precond : next token (relational_operator)
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- relational_operator shift_expression
+ function Parse_Relation_Rhs (Left : Iir) return Iir
+ is
+ Res, Tmp: Iir_Expression;
+ begin
+ Tmp := Left;
+
+ -- This loop is just to handle errors such as a = b = c.
+ loop
+ case Current_Token is
+ when Tok_Equal =>
+ Res := Create_Iir (Iir_Kind_Equality_Operator);
+ when Tok_Not_Equal =>
+ Res := Create_Iir (Iir_Kind_Inequality_Operator);
+ when Tok_Less =>
+ Res := Create_Iir (Iir_Kind_Less_Than_Operator);
+ when Tok_Less_Equal =>
+ Res := Create_Iir (Iir_Kind_Less_Than_Or_Equal_Operator);
+ when Tok_Greater =>
+ Res := Create_Iir (Iir_Kind_Greater_Than_Operator);
+ when Tok_Greater_Equal =>
+ Res := Create_Iir (Iir_Kind_Greater_Than_Or_Equal_Operator);
+ when Tok_Match_Equal =>
+ Res := Create_Iir (Iir_Kind_Match_Equality_Operator);
+ when Tok_Match_Not_Equal =>
+ Res := Create_Iir (Iir_Kind_Match_Inequality_Operator);
+ when Tok_Match_Less =>
+ Res := Create_Iir (Iir_Kind_Match_Less_Than_Operator);
+ when Tok_Match_Less_Equal =>
+ Res := Create_Iir (Iir_Kind_Match_Less_Than_Or_Equal_Operator);
+ when Tok_Match_Greater =>
+ Res := Create_Iir (Iir_Kind_Match_Greater_Than_Operator);
+ when Tok_Match_Greater_Equal =>
+ Res := Create_Iir
+ (Iir_Kind_Match_Greater_Than_Or_Equal_Operator);
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Location (Res);
+ Scan;
+ Set_Left (Res, Tmp);
+ Set_Right (Res, Parse_Shift_Expression);
+ exit when Current_Token not in Token_Relational_Operator_Type;
+ Error_Msg_Parse
+ ("use parenthesis for consecutive relational expressions");
+ Tmp := Res;
+ end loop;
+ return Res;
+ end Parse_Relation_Rhs;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- relation ::= shift_expression [ relational_operator shift_expression ]
+ --
+ -- [ �7.2 ]
+ -- relational_operator ::= = | /= | < | <= | > | >=
+ -- | ?= | ?/= | ?< | ?<= | ?> | ?>=
+ function Parse_Relation return Iir
+ is
+ Tmp: Iir;
+ begin
+ Tmp := Parse_Shift_Expression;
+ if Current_Token not in Token_Relational_Operator_Type then
+ return Tmp;
+ end if;
+
+ return Parse_Relation_Rhs (Tmp);
+ end Parse_Relation;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �7.1 ]
+ -- expression ::= relation { AND relation }
+ -- | relation { OR relation }
+ -- | relation { XOR relation }
+ -- | relation [ NAND relation }
+ -- | relation [ NOR relation }
+ -- | relation { XNOR relation }
+ function Parse_Expression_Rhs (Left : Iir) return Iir
+ is
+ Res, Tmp: Iir;
+
+ -- OP_TOKEN contains the operator combinaison.
+ Op_Token: Token_Type;
+ begin
+ Tmp := Left;
+ Op_Token := Tok_Invalid;
+ loop
+ case Current_Token is
+ when Tok_And =>
+ Res := Create_Iir (Iir_Kind_And_Operator);
+ when Tok_Or =>
+ Res := Create_Iir (Iir_Kind_Or_Operator);
+ when Tok_Xor =>
+ Res := Create_Iir (Iir_Kind_Xor_Operator);
+ when Tok_Nand =>
+ Res := Create_Iir (Iir_Kind_Nand_Operator);
+ when Tok_Nor =>
+ Res := Create_Iir (Iir_Kind_Nor_Operator);
+ when Tok_Xnor =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'xnor' keyword not allowed in vhdl 87");
+ end if;
+ Res := Create_Iir (Iir_Kind_Xnor_Operator);
+ when others =>
+ return Tmp;
+ end case;
+
+ if Op_Token = Tok_Invalid then
+ Op_Token := Current_Token;
+ else
+ -- Check after the case, since current_token may not be an
+ -- operator...
+ -- TODO: avoid repetition of this message ?
+ if Op_Token = Tok_Nand or Op_Token = Tok_Nor then
+ Error_Msg_Parse ("sequence of 'nor' or 'nand' not allowed");
+ Error_Msg_Parse ("('nor' and 'nand' are not associative)");
+ end if;
+ if Op_Token /= Current_Token then
+ -- Expression is a sequence of relations, with the same
+ -- operator.
+ Error_Msg_Parse ("only one type of logical operators may be "
+ & "used to combine relation");
+ end if;
+ end if;
+
+ Set_Location (Res);
+ Scan;
+
+ -- Catch errors for Ada programmers.
+ if Current_Token = Tok_Then or Current_Token = Tok_Else then
+ Error_Msg_Parse ("""or else"" and ""and then"" sequences "
+ & "are not allowed in vhdl");
+ Error_Msg_Parse ("""and"" and ""or"" are short-circuit "
+ & "operators for BIT and BOOLEAN types");
+ Scan;
+ end if;
+
+ Set_Left (Res, Tmp);
+ Set_Right (Res, Parse_Relation);
+ Tmp := Res;
+ end loop;
+ end Parse_Expression_Rhs;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- LRM08 9.1 General
+ -- expression ::= condition_operator primary
+ -- | logical_expression
+ function Parse_Expression return Iir_Expression
+ is
+ Res : Iir;
+ begin
+ if Current_Token = Tok_Condition then
+ Res := Create_Iir (Iir_Kind_Condition_Operator);
+ Set_Location (Res);
+
+ -- Skip '??'
+ Scan;
+
+ Set_Operand (Res, Parse_Primary);
+ else
+ Res := Parse_Expression_Rhs (Parse_Relation);
+ end if;
+
+ return Res;
+ end Parse_Expression;
+
+ -- precond : next token
+ -- postcond: next token.
+ --
+ -- [ �8.4 ]
+ -- waveform ::= waveform_element { , waveform_element }
+ -- | UNAFFECTED
+ --
+ -- [ �8.4.1 ]
+ -- waveform_element ::= VALUE_expression [ AFTER TIME_expression ]
+ -- | NULL [ AFTER TIME_expression ]
+ function Parse_Waveform return Iir_Waveform_Element
+ is
+ Res: Iir_Waveform_Element;
+ We, Last_We : Iir_Waveform_Element;
+ begin
+ if Current_Token = Tok_Unaffected then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'unaffected' is not allowed in vhdl87");
+ end if;
+ Scan;
+ return Null_Iir;
+ else
+ Sub_Chain_Init (Res, Last_We);
+ loop
+ We := Create_Iir (Iir_Kind_Waveform_Element);
+ Sub_Chain_Append (Res, Last_We, We);
+ Set_Location (We);
+ -- Note: NULL is handled as a null_literal.
+ Set_We_Value (We, Parse_Expression);
+ if Current_Token = Tok_After then
+ Scan;
+ Set_Time (We, Parse_Expression);
+ end if;
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+ return Res;
+ end if;
+ end Parse_Waveform;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �8.4 ]
+ -- delay_mechanism ::= TRANSPORT
+ -- | [ REJECT TIME_expression ] INERTIAL
+ procedure Parse_Delay_Mechanism (Assign: Iir) is
+ begin
+ if Current_Token = Tok_Transport then
+ Set_Delay_Mechanism (Assign, Iir_Transport_Delay);
+ Scan;
+ else
+ Set_Delay_Mechanism (Assign, Iir_Inertial_Delay);
+ if Current_Token = Tok_Reject then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'reject' delay mechanism not allowed in vhdl 87");
+ end if;
+ Scan;
+ Set_Reject_Time_Expression (Assign, Parse_Expression);
+ Expect (Tok_Inertial);
+ Scan;
+ elsif Current_Token = Tok_Inertial then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'inertial' keyword not allowed in vhdl 87");
+ end if;
+ Scan;
+ end if;
+ end if;
+ end Parse_Delay_Mechanism;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �9.5 ]
+ -- options ::= [ GUARDED ] [ delay_mechanism ]
+ procedure Parse_Options (Stmt : Iir) is
+ begin
+ if Current_Token = Tok_Guarded then
+ Set_Guard (Stmt, Stmt);
+ Scan;
+ end if;
+ Parse_Delay_Mechanism (Stmt);
+ end Parse_Options;
+
+ -- precond : next tkoen
+ -- postcond: ';'
+ --
+ -- [ �9.5.1 ]
+ -- conditional_signal_assignment ::=
+ -- target <= options conditional_waveforms ;
+ --
+ -- [ �9.5.1 ]
+ -- conditional_waveforms ::=
+ -- { waveform WHEN condition ELSE }
+ -- waveform [ WHEN condition ]
+ function Parse_Conditional_Signal_Assignment (Target: Iir) return Iir
+ is
+ use Iir_Chains.Conditional_Waveform_Chain_Handling;
+ Res: Iir;
+ Cond_Wf, Last_Cond_Wf : Iir_Conditional_Waveform;
+ begin
+ Res := Create_Iir (Iir_Kind_Concurrent_Conditional_Signal_Assignment);
+ Set_Target (Res, Target);
+ Location_Copy (Res, Get_Target (Res));
+
+ case Current_Token is
+ when Tok_Less_Equal =>
+ null;
+ when Tok_Assign =>
+ Error_Msg_Parse ("':=' not allowed in concurrent statement, "
+ & "replaced by '<='");
+ when others =>
+ Expect (Tok_Less_Equal);
+ end case;
+ Scan;
+
+ Parse_Options (Res);
+
+ Build_Init (Last_Cond_Wf);
+ loop
+ Cond_Wf := Create_Iir (Iir_Kind_Conditional_Waveform);
+ Append (Last_Cond_Wf, Res, Cond_Wf);
+ Set_Location (Cond_Wf);
+ Set_Waveform_Chain (Cond_Wf, Parse_Waveform);
+ exit when Current_Token /= Tok_When;
+ Scan;
+ Set_Condition (Cond_Wf, Parse_Expression);
+ if Current_Token /= Tok_Else then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("else missing in vhdl 87");
+ end if;
+ exit;
+ end if;
+ Scan;
+ end loop;
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Conditional_Signal_Assignment;
+
+ -- precond : WITH
+ -- postcond: ';'
+ --
+ -- [ �9.5.2 ]
+ -- selected_signal_assignment ::=
+ -- WITH expresion SELECT
+ -- target <= options selected_waveforms ;
+ --
+ -- [ �9.5.2 ]
+ -- selected_waveforms ::=
+ -- { waveform WHEN choices , }
+ -- waveform WHEN choices
+ function Parse_Selected_Signal_Assignment return Iir
+ is
+ use Iir_Chains.Selected_Waveform_Chain_Handling;
+ Res: Iir;
+ Assoc: Iir;
+ Wf_Chain : Iir_Waveform_Element;
+ Target : Iir;
+ Last : Iir;
+ begin
+ Scan; -- accept 'with' token.
+ Res := Create_Iir (Iir_Kind_Concurrent_Selected_Signal_Assignment);
+ Set_Location (Res);
+ Set_Expression (Res, Parse_Expression);
+
+ Expect (Tok_Select, "'select' expected after expression");
+ Scan;
+ if Current_Token = Tok_Left_Paren then
+ Target := Parse_Aggregate;
+ else
+ Target := Parse_Name (Allow_Indexes => True);
+ end if;
+ Set_Target (Res, Target);
+ Expect (Tok_Less_Equal);
+ Scan;
+
+ Parse_Options (Res);
+
+ Build_Init (Last);
+ loop
+ Wf_Chain := Parse_Waveform;
+ Expect (Tok_When, "'when' expected after waveform");
+ Scan;
+ Assoc := Parse_Choices (Null_Iir);
+ Set_Associated_Chain (Assoc, Wf_Chain);
+ Append_Subchain (Last, Res, Assoc);
+ exit when Current_Token = Tok_Semi_Colon;
+ Expect (Tok_Comma, "',' (comma) expected after choice");
+ Scan;
+ end loop;
+ return Res;
+ end Parse_Selected_Signal_Assignment;
+
+ -- precond : next token
+ -- postcond: next token.
+ --
+ -- [ �8.1 ]
+ -- sensitivity_list ::= SIGNAL_name { , SIGNAL_name }
+ procedure Parse_Sensitivity_List (List: Iir_Designator_List)
+ is
+ El : Iir;
+ begin
+ loop
+ El := Parse_Name (Allow_Indexes => True);
+ case Get_Kind (El) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Indexed_Name =>
+ null;
+ when others =>
+ Error_Msg_Parse
+ ("only names are allowed in a sensitivity list");
+ end case;
+ Append_Element (List, El);
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+ end Parse_Sensitivity_List;
+
+ -- precond : ASSERT
+ -- postcond: next token
+ -- Note: this fill an sequential or a concurrent statement.
+ --
+ -- [ �8.2 ]
+ -- assertion ::= ASSERT condition
+ -- [ REPORT expression ] [ SEVERITY expression ]
+ procedure Parse_Assertion (Stmt: Iir) is
+ begin
+ Set_Location (Stmt);
+ Scan;
+ Set_Assertion_Condition (Stmt, Parse_Expression);
+ if Current_Token = Tok_Report then
+ Scan;
+ Set_Report_Expression (Stmt, Parse_Expression);
+ end if;
+ if Current_Token = Tok_Severity then
+ Scan;
+ Set_Severity_Expression (Stmt, Parse_Expression);
+ if Current_Token = Tok_Report then
+ -- Nice message in case of inversion.
+ Error_Msg_Parse
+ ("report expression must precede severity expression");
+ Scan;
+ Set_Report_Expression (Stmt, Parse_Expression);
+ end if;
+ end if;
+ end Parse_Assertion;
+
+ -- precond : REPORT
+ -- postcond: next token
+ --
+ -- [ 8.3 ]
+ -- report_statement ::= REPORT expression [ SEVERITY expression ]
+ function Parse_Report_Statement return Iir_Report_Statement
+ is
+ Res : Iir_Report_Statement;
+ begin
+ Res := Create_Iir (Iir_Kind_Report_Statement);
+ Set_Location (Res);
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("report statement not allowed in vhdl87");
+ end if;
+ Scan;
+ Set_Report_Expression (Res, Parse_Expression);
+ if Current_Token = Tok_Severity then
+ Scan;
+ Set_Severity_Expression (Res, Parse_Expression);
+ end if;
+ return Res;
+ end Parse_Report_Statement;
+
+ -- precond : WAIT
+ -- postcond: ';'
+ --
+ -- [ �8.1 ]
+ -- wait_statement ::=
+ -- [ label : ] WAIT [ sensitivity_clause ] [ condition_clause ]
+ -- [ timeout_clause ] ;
+ --
+ -- [ �8.1 ]
+ -- sensitivity_clause ::= ON sensitivity_list
+ --
+ -- [ �8.1 ]
+ -- condition_clause ::= UNTIL conditiion
+ --
+ -- [ �8.1 ]
+ -- timeout_clause ::= FOR TIME_expression
+ function Parse_Wait_Statement return Iir_Wait_Statement
+ is
+ Res: Iir_Wait_Statement;
+ List: Iir_List;
+ begin
+ Res := Create_Iir (Iir_Kind_Wait_Statement);
+ Set_Location (Res);
+ Scan;
+ case Current_Token is
+ when Tok_On =>
+ List := Create_Iir_List;
+ Set_Sensitivity_List (Res, List);
+ Scan;
+ Parse_Sensitivity_List (List);
+ when Tok_Until =>
+ null;
+ when Tok_For =>
+ null;
+ when Tok_Semi_Colon =>
+ return Res;
+ when others =>
+ Error_Msg_Parse ("'on', 'until', 'for' or ';' expected");
+ Eat_Tokens_Until_Semi_Colon;
+ return Res;
+ end case;
+ case Current_Token is
+ when Tok_On =>
+ Error_Msg_Parse ("only one sensitivity is allowed");
+ -- FIXME: sync
+ return Res;
+ when Tok_Until =>
+ Scan;
+ Set_Condition_Clause (Res, Parse_Expression);
+ when Tok_For =>
+ null;
+ when Tok_Semi_Colon =>
+ return Res;
+ when others =>
+ Error_Msg_Parse ("'until', 'for' or ';' expected");
+ Eat_Tokens_Until_Semi_Colon;
+ return Res;
+ end case;
+ case Current_Token is
+ when Tok_On =>
+ Error_Msg_Parse ("only one sensitivity clause is allowed");
+ -- FIXME: sync
+ return Res;
+ when Tok_Until =>
+ Error_Msg_Parse ("only one condition clause is allowed");
+ -- FIXME: sync
+ return Res;
+ when Tok_For =>
+ Scan;
+ Set_Timeout_Clause (Res, Parse_Expression);
+ return Res;
+ when Tok_Semi_Colon =>
+ return Res;
+ when others =>
+ Error_Msg_Parse ("'for' or ';' expected");
+ Eat_Tokens_Until_Semi_Colon;
+ return Res;
+ end case;
+ end Parse_Wait_Statement;
+
+ -- precond : IF
+ -- postcond: next token.
+ --
+ -- [ �8.7 ]
+ -- if_statement ::=
+ -- [ IF_label : ]
+ -- IF condition THEN
+ -- sequence_of_statements
+ -- { ELSIF condition THEN
+ -- sequence_of_statements }
+ -- [ ELSE
+ -- sequence_of_statements ]
+ -- END IF [ IF_label ] ;
+ --
+ -- FIXME: end label.
+ function Parse_If_Statement (Parent : Iir) return Iir_If_Statement
+ is
+ Res: Iir_If_Statement;
+ Clause: Iir;
+ N_Clause: Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_If_Statement);
+ Set_Location (Res);
+ Set_Parent (Res, Parent);
+ Scan;
+ Clause := Res;
+ loop
+ Set_Condition (Clause, Parse_Expression);
+ Expect (Tok_Then, "'then' is expected here");
+ Scan;
+ Set_Sequential_Statement_Chain
+ (Clause, Parse_Sequential_Statements (Res));
+ exit when Current_Token = Tok_End;
+ N_Clause := Create_Iir (Iir_Kind_Elsif);
+ Set_Location (N_Clause);
+ Set_Else_Clause (Clause, N_Clause);
+ Clause := N_Clause;
+ if Current_Token = Tok_Else then
+ Scan;
+ Set_Sequential_Statement_Chain
+ (Clause, Parse_Sequential_Statements (Res));
+ exit;
+ elsif Current_Token = Tok_Elsif then
+ Scan;
+ else
+ Error_Msg_Parse ("'else' or 'elsif' expected");
+ end if;
+ end loop;
+ Expect (Tok_End);
+ Scan_Expect (Tok_If);
+ Scan;
+ return Res;
+ end Parse_If_Statement;
+
+ function Parenthesis_Name_To_Procedure_Call (Name: Iir; Kind : Iir_Kind)
+ return Iir
+ is
+ Res: Iir;
+ Call : Iir_Procedure_Call;
+ begin
+ Res := Create_Iir (Kind);
+ Location_Copy (Res, Name);
+ Call := Create_Iir (Iir_Kind_Procedure_Call);
+ Location_Copy (Call, Name);
+ Set_Procedure_Call (Res, Call);
+ case Get_Kind (Name) is
+ when Iir_Kind_Parenthesis_Name =>
+ Set_Prefix (Call, Get_Prefix (Name));
+ Set_Parameter_Association_Chain
+ (Call, Get_Association_Chain (Name));
+ Free_Iir (Name);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Set_Prefix (Call, Name);
+ when Iir_Kind_Attribute_Name =>
+ Error_Msg_Parse ("attribute cannot be used as procedure call");
+ when others =>
+ Error_Kind ("parenthesis_name_to_procedure_call", Name);
+ end case;
+ return Res;
+ end Parenthesis_Name_To_Procedure_Call;
+
+ -- precond : identifier
+ -- postcond: next token
+ --
+ -- [ LRM93 8.9 ]
+ -- parameter_specification ::= identifier IN discrete_range
+ function Parse_Parameter_Specification (Parent : Iir)
+ return Iir_Iterator_Declaration
+ is
+ Decl : Iir_Iterator_Declaration;
+ begin
+ Decl := Create_Iir (Iir_Kind_Iterator_Declaration);
+ Set_Location (Decl);
+ Set_Parent (Decl, Parent);
+
+ Expect (Tok_Identifier);
+ Set_Identifier (Decl, Current_Identifier);
+
+ -- Skip identifier
+ Scan_Expect (Tok_In);
+
+ -- Skip 'in'
+ Scan;
+
+ Set_Discrete_Range (Decl, Parse_Discrete_Range);
+ return Decl;
+ end Parse_Parameter_Specification;
+
+ -- precond: '<='
+ -- postcond: next token
+ --
+ -- [ �8.4 ]
+ -- signal_assignment_statement ::=
+ -- [ label : ] target <= [ delay_mechanism ] waveform ;
+ function Parse_Signal_Assignment_Statement (Target : Iir) return Iir
+ is
+ Stmt : Iir;
+ Wave_Chain : Iir_Waveform_Element;
+ begin
+ Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement);
+ Location_Copy (Stmt, Target);
+ Set_Target (Stmt, Target);
+ Scan;
+ Parse_Delay_Mechanism (Stmt);
+ Wave_Chain := Parse_Waveform;
+ -- LRM 8.4 Signal assignment statement
+ -- It is an error is the reserved word UNAFFECTED appears as a
+ -- waveform in a (sequential) signa assignment statement.
+ if Wave_Chain = Null_Iir then
+ Error_Msg_Parse
+ ("'unaffected' is not allowed in a sequential statement");
+ end if;
+ Set_Waveform_Chain (Stmt, Wave_Chain);
+ return Stmt;
+ end Parse_Signal_Assignment_Statement;
+
+ -- precond: ':='
+ -- postcond: next token
+ --
+ -- [ �8.5 ]
+ -- variable_assignment_statement ::=
+ -- [ label : ] target := expression ;
+ function Parse_Variable_Assignment_Statement (Target : Iir) return Iir
+ is
+ Stmt : Iir;
+ begin
+ Stmt := Create_Iir (Iir_Kind_Variable_Assignment_Statement);
+ Location_Copy (Stmt, Target);
+ Set_Target (Stmt, Target);
+ Scan;
+ Set_Expression (Stmt, Parse_Expression);
+ return Stmt;
+ end Parse_Variable_Assignment_Statement;
+
+ -- precond: next token
+ -- postcond: next token
+ --
+ -- [ 8 ]
+ -- sequence_of_statement ::= { sequential_statement }
+ --
+ -- [ 8 ]
+ -- sequential_statement ::= wait_statement
+ -- | assertion_statement
+ -- | report_statement
+ -- | signal_assignment_statement
+ -- | variable_assignment_statement
+ -- | procedure_call_statement
+ -- | if_statement
+ -- | case_statement
+ -- | loop_statement
+ -- | next_statement
+ -- | exit_statement
+ -- | return_statement
+ -- | null_statement
+ --
+ -- [ 8.13 ]
+ -- null_statement ::= [ label : ] NULL ;
+ --
+ -- [ 8.12 ]
+ -- return_statement ::= [ label : ] RETURN [ expression ]
+ --
+ -- [ 8.10 ]
+ -- next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ;
+ --
+ -- [ 8.11 ]
+ -- exit_statement ::= [ label : ] EXIT [ LOOP_label ] [ WHEN condition ] ;
+ --
+ -- [ 8.9 ]
+ -- loop_statement ::=
+ -- [ LOOP_label : ]
+ -- [ iteration_scheme ] LOOP
+ -- sequence_of_statements
+ -- END LOOP [ LOOP_label ] ;
+ --
+ -- [ 8.9 ]
+ -- iteration_scheme ::= WHILE condition
+ -- | FOR LOOP_parameter_specification
+ --
+ -- [ 8.8 ]
+ -- case_statement ::=
+ -- [ CASE_label : ]
+ -- CASE expression IS
+ -- case_statement_alternative
+ -- { case_statement_alternative }
+ -- END CASE [ CASE_label ] ;
+ --
+ -- [ 8.8 ]
+ -- case_statement_alternative ::= WHEN choices => sequence_of_statements
+ --
+ -- [ 8.2 ]
+ -- assertion_statement ::= [ label : ] assertion ;
+ --
+ -- [ 8.3 ]
+ -- report_statement ::= [ label : ] REPORT expression SEVERITY expression ;
+ function Parse_Sequential_Assignment_Statement (Target : Iir) return Iir
+ is
+ Stmt : Iir;
+ Call : Iir;
+ begin
+ if Current_Token = Tok_Less_Equal then
+ return Parse_Signal_Assignment_Statement (Target);
+ elsif Current_Token = Tok_Assign then
+ return Parse_Variable_Assignment_Statement (Target);
+ elsif Current_Token = Tok_Semi_Colon then
+ return Parenthesis_Name_To_Procedure_Call
+ (Target, Iir_Kind_Procedure_Call_Statement);
+ else
+ Error_Msg_Parse ("""<="" or "":="" expected instead of "
+ & Image (Current_Token));
+ Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement);
+ Call := Create_Iir (Iir_Kind_Procedure_Call);
+ Set_Prefix (Call, Target);
+ Set_Procedure_Call (Stmt, Call);
+ Set_Location (Call);
+ Eat_Tokens_Until_Semi_Colon;
+ return Stmt;
+ end if;
+ end Parse_Sequential_Assignment_Statement;
+
+ function Parse_Sequential_Statements (Parent : Iir)
+ return Iir
+ is
+ First_Stmt : Iir;
+ Last_Stmt : Iir;
+ Stmt: Iir;
+ Label: Name_Id;
+ Loc : Location_Type;
+ Target : Iir;
+ begin
+ First_Stmt := Null_Iir;
+ Last_Stmt := Null_Iir;
+ -- Expect a current_token.
+ loop
+ Loc := Get_Token_Location;
+ if Current_Token = Tok_Identifier then
+ Label := Current_Identifier;
+ Scan;
+ if Current_Token = Tok_Colon then
+ Scan;
+ else
+ Target := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Identifier (Target, Label);
+ Set_Location (Target, Loc);
+ Label := Null_Identifier;
+ Target := Parse_Name_Suffix (Target, True);
+ Stmt := Parse_Sequential_Assignment_Statement (Target);
+ goto Has_Stmt;
+ end if;
+ else
+ Label := Null_Identifier;
+ end if;
+
+ case Current_Token is
+ when Tok_Null =>
+ Stmt := Create_Iir (Iir_Kind_Null_Statement);
+ Scan;
+ when Tok_Assert =>
+ Stmt := Create_Iir (Iir_Kind_Assertion_Statement);
+ Parse_Assertion (Stmt);
+ when Tok_Report =>
+ Stmt := Parse_Report_Statement;
+ when Tok_If =>
+ Stmt := Parse_If_Statement (Parent);
+ Set_Label (Stmt, Label);
+ Set_Location (Stmt, Loc);
+ if Flags.Vhdl_Std >= Vhdl_93c then
+ Check_End_Name (Stmt);
+ end if;
+ when Tok_Identifier
+ | Tok_String =>
+ -- String for an expanded name with operator_symbol prefix.
+ Stmt := Parse_Sequential_Assignment_Statement (Parse_Name);
+ when Tok_Left_Paren =>
+ declare
+ Target : Iir;
+ begin
+ Target := Parse_Aggregate;
+ if Current_Token = Tok_Less_Equal then
+ Stmt := Parse_Signal_Assignment_Statement (Target);
+ elsif Current_Token = Tok_Assign then
+ Stmt := Parse_Variable_Assignment_Statement (Target);
+ else
+ Error_Msg_Parse ("'<=' or ':=' expected");
+ return First_Stmt;
+ end if;
+ end;
+
+ when Tok_Return =>
+ Stmt := Create_Iir (Iir_Kind_Return_Statement);
+ Scan;
+ if Current_Token /= Tok_Semi_Colon then
+ Set_Expression (Stmt, Parse_Expression);
+ end if;
+
+ when Tok_For =>
+ Stmt := Create_Iir (Iir_Kind_For_Loop_Statement);
+ Set_Location (Stmt, Loc);
+ Set_Label (Stmt, Label);
+
+ -- Skip 'for'
+ Scan;
+
+ Set_Parameter_Specification
+ (Stmt, Parse_Parameter_Specification (Stmt));
+
+ -- Skip 'loop'
+ Expect (Tok_Loop);
+ Scan;
+
+ Set_Sequential_Statement_Chain
+ (Stmt, Parse_Sequential_Statements (Stmt));
+
+ -- Skip 'end'
+ Expect (Tok_End);
+ Scan_Expect (Tok_Loop);
+
+ -- Skip 'loop'
+ Scan;
+
+ Check_End_Name (Stmt);
+ -- A loop statement can have a label, even in vhdl87.
+ Label := Null_Identifier;
+
+ when Tok_While
+ | Tok_Loop =>
+ Stmt := Create_Iir (Iir_Kind_While_Loop_Statement);
+ Set_Location (Stmt);
+ Set_Label (Stmt, Label);
+ if Current_Token = Tok_While then
+ Scan;
+ Set_Condition (Stmt, Parse_Expression);
+ Expect (Tok_Loop);
+ end if;
+ Scan;
+ Set_Sequential_Statement_Chain
+ (Stmt, Parse_Sequential_Statements (Stmt));
+ Expect (Tok_End);
+ Scan_Expect (Tok_Loop);
+ Scan;
+ Check_End_Name (Stmt);
+ -- A loop statement can have a label, even in vhdl87.
+ Label := Null_Identifier;
+
+ when Tok_Next
+ | Tok_Exit =>
+ if Current_Token = Tok_Next then
+ Stmt := Create_Iir (Iir_Kind_Next_Statement);
+ else
+ Stmt := Create_Iir (Iir_Kind_Exit_Statement);
+ end if;
+
+ -- Skip 'next' or 'exit'.
+ Scan;
+
+ if Current_Token = Tok_Identifier then
+ Set_Loop_Label (Stmt, Parse_Name (Allow_Indexes => False));
+ end if;
+
+ if Current_Token = Tok_When then
+ -- Skip 'when'.
+ Scan;
+
+ Set_Condition (Stmt, Parse_Expression);
+ end if;
+
+ when Tok_Case =>
+ declare
+ use Iir_Chains.Case_Statement_Alternative_Chain_Handling;
+ Assoc: Iir;
+ Last_Assoc : Iir;
+ begin
+ Stmt := Create_Iir (Iir_Kind_Case_Statement);
+ Set_Location (Stmt);
+ Set_Label (Stmt, Label);
+ Scan;
+ Set_Expression (Stmt, Parse_Expression);
+ Expect (Tok_Is);
+ Scan;
+ if Current_Token = Tok_End then
+ Error_Msg_Parse ("missing alternative in case statement");
+ end if;
+ Build_Init (Last_Assoc);
+ while Current_Token /= Tok_End loop
+ -- Eat 'when'
+ Expect (Tok_When);
+ Scan;
+
+ if Current_Token = Tok_Double_Arrow then
+ Error_Msg_Parse ("missing expression in alternative");
+ Assoc := Create_Iir (Iir_Kind_Choice_By_Expression);
+ Set_Location (Assoc);
+ else
+ Assoc := Parse_Choices (Null_Iir);
+ end if;
+
+ -- Eat '=>'
+ Expect (Tok_Double_Arrow);
+ Scan;
+
+ Set_Associated_Chain
+ (Assoc, Parse_Sequential_Statements (Stmt));
+ Append_Subchain (Last_Assoc, Stmt, Assoc);
+ end loop;
+
+ -- Eat 'end', 'case'
+ Scan_Expect (Tok_Case);
+ Scan;
+
+ if Flags.Vhdl_Std >= Vhdl_93c then
+ Check_End_Name (Stmt);
+ end if;
+ end;
+ when Tok_Wait =>
+ Stmt := Parse_Wait_Statement;
+ when others =>
+ return First_Stmt;
+ end case;
+ << Has_Stmt >> null;
+ Set_Parent (Stmt, Parent);
+ Set_Location (Stmt, Loc);
+ if Label /= Null_Identifier then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Sem
+ ("this statement can't have a label in vhdl 87", Stmt);
+ else
+ Set_Label (Stmt, Label);
+ end if;
+ end if;
+ Scan_Semi_Colon ("statement");
+
+ -- Append it to the chain.
+ if First_Stmt = Null_Iir then
+ First_Stmt := Stmt;
+ else
+ Set_Chain (Last_Stmt, Stmt);
+ end if;
+ Last_Stmt := Stmt;
+ end loop;
+ end Parse_Sequential_Statements;
+
+ -- precond : PROCEDURE, FUNCTION, PURE or IMPURE.
+ -- postcond: ';'
+ --
+ -- [ �2.1 ]
+ -- subprogram_declaration ::= subprogram_specification ;
+ --
+ -- [ �2.1 ]
+ -- subprogram_specification ::=
+ -- PROCEDURE designator [ ( formal_parameter_list ) ]
+ -- | [ PURE | IMPURE ] FUNCTION designator [ ( formal_parameter_list ) ]
+ -- RETURN type_mark
+ --
+ -- [ �2.2 ]
+ -- subprogram_body ::=
+ -- subprogram_specification IS
+ -- subprogram_declarative_part
+ -- BEGIN
+ -- subprogram_statement_part
+ -- END [ subprogram_kind ] [ designator ] ;
+ --
+ -- [ �2.1 ]
+ -- designator ::= identifier | operator_symbol
+ --
+ -- [ �2.1 ]
+ -- operator_symbol ::= string_literal
+ function Parse_Subprogram_Declaration (Parent : Iir) return Iir
+ is
+ Kind : Iir_Kind;
+ Inters : Iir;
+ Subprg: Iir;
+ Subprg_Body : Iir;
+ Old : Iir;
+ pragma Unreferenced (Old);
+ begin
+ -- Create the node.
+ case Current_Token is
+ when Tok_Procedure =>
+ Kind := Iir_Kind_Procedure_Declaration;
+ when Tok_Function
+ | Tok_Pure
+ | Tok_Impure =>
+ Kind := Iir_Kind_Function_Declaration;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Subprg := Create_Iir (Kind);
+ Set_Location (Subprg);
+
+ case Current_Token is
+ when Tok_Procedure =>
+ null;
+ when Tok_Function =>
+ -- LRM93 2.1
+ -- A function is impure if its specification contains the
+ -- reserved word IMPURE; otherwise it is said to be pure.
+ Set_Pure_Flag (Subprg, True);
+ when Tok_Pure
+ | Tok_Impure =>
+ Set_Pure_Flag (Subprg, Current_Token = Tok_Pure);
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'pure' and 'impure' are not allowed in vhdl 87");
+ end if;
+ Set_Has_Pure (Subprg, True);
+ -- FIXME: what to do in case of error ??
+ -- Eat PURE or IMPURE.
+ Scan;
+ Expect (Tok_Function, "'function' must follow 'pure' or 'impure'");
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Eat PROCEDURE or FUNCTION.
+ Scan;
+
+ if Current_Token = Tok_Identifier then
+ Set_Identifier (Subprg, Current_Identifier);
+ Set_Location (Subprg);
+ elsif Current_Token = Tok_String then
+ if Kind = Iir_Kind_Procedure_Declaration then
+ -- LRM93 2.1
+ -- A procedure designator is always an identifier.
+ Error_Msg_Parse ("a procedure name must be an identifier");
+ end if;
+ -- LRM93 2.1
+ -- A function designator is either an identifier or an operator
+ -- symbol.
+ Set_Identifier (Subprg, Scan_To_Operator_Name (Get_Token_Location));
+ Set_Location (Subprg);
+ else
+ -- Just to display a parse error.
+ Expect (Tok_Identifier);
+ end if;
+
+ Scan;
+ if Current_Token = Tok_Left_Paren then
+ -- Parse the interface declaration.
+ if Kind = Iir_Kind_Function_Declaration then
+ Inters := Parse_Interface_List
+ (Function_Parameter_Interface_List, Subprg);
+ else
+ Inters := Parse_Interface_List
+ (Procedure_Parameter_Interface_List, Subprg);
+ end if;
+ Set_Interface_Declaration_Chain (Subprg, Inters);
+ end if;
+
+ if Current_Token = Tok_Return then
+ if Kind = Iir_Kind_Procedure_Declaration then
+ Error_Msg_Parse ("'return' not allowed for a procedure");
+ Error_Msg_Parse ("(remove return part or define a function)");
+
+ -- Skip 'return'
+ Scan;
+
+ Old := Parse_Type_Mark;
+ else
+ -- Skip 'return'
+ Scan;
+
+ Set_Return_Type_Mark
+ (Subprg, Parse_Type_Mark (Check_Paren => True));
+ end if;
+ else
+ if Kind = Iir_Kind_Function_Declaration then
+ Error_Msg_Parse ("'return' expected");
+ end if;
+ end if;
+
+ if Current_Token = Tok_Semi_Colon then
+ return Subprg;
+ end if;
+
+ -- The body.
+ Set_Has_Body (Subprg, True);
+ if Kind = Iir_Kind_Function_Declaration then
+ Subprg_Body := Create_Iir (Iir_Kind_Function_Body);
+ else
+ Subprg_Body := Create_Iir (Iir_Kind_Procedure_Body);
+ end if;
+ Location_Copy (Subprg_Body, Subprg);
+
+ Set_Subprogram_Body (Subprg, Subprg_Body);
+ Set_Subprogram_Specification (Subprg_Body, Subprg);
+ Set_Chain (Subprg, Subprg_Body);
+
+ if Get_Kind (Parent) = Iir_Kind_Package_Declaration then
+ Error_Msg_Parse ("subprogram body not allowed in package spec");
+ end if;
+ Expect (Tok_Is);
+ Scan;
+ Parse_Declarative_Part (Subprg_Body);
+ Expect (Tok_Begin);
+ Scan;
+ Set_Sequential_Statement_Chain
+ (Subprg_Body, Parse_Sequential_Statements (Subprg_Body));
+ Expect (Tok_End);
+ Scan;
+
+ case Current_Token is
+ when Tok_Function =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'function' not allowed here by vhdl 87");
+ end if;
+ if Kind = Iir_Kind_Procedure_Declaration then
+ Error_Msg_Parse ("'procedure' expected instead of 'function'");
+ end if;
+ Set_End_Has_Reserved_Id (Subprg_Body, True);
+ Scan;
+ when Tok_Procedure =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'procedure' not allowed here by vhdl 87");
+ end if;
+ if Kind = Iir_Kind_Function_Declaration then
+ Error_Msg_Parse ("'function' expected instead of 'procedure'");
+ end if;
+ Set_End_Has_Reserved_Id (Subprg_Body, True);
+ Scan;
+ when others =>
+ null;
+ end case;
+ case Current_Token is
+ when Tok_Identifier =>
+ Check_End_Name (Get_Identifier (Subprg), Subprg_Body);
+ when Tok_String =>
+ if Scan_To_Operator_Name (Get_Token_Location)
+ /= Get_Identifier (Subprg)
+ then
+ Error_Msg_Parse
+ ("mispelling, 'end """ & Image_Identifier (Subprg)
+ & """;' expected");
+ end if;
+ Set_End_Has_Identifier (Subprg_Body, True);
+ Scan;
+ when others =>
+ null;
+ end case;
+ Expect (Tok_Semi_Colon);
+ return Subprg;
+ end Parse_Subprogram_Declaration;
+
+ -- precond: PROCESS
+ -- postcond: null
+ --
+ -- [ LRM87 9.2 / LRM08 11.3 ]
+ -- process_statement ::=
+ -- [ PROCESS_label : ]
+ -- [ POSTPONED ] PROCESS [ ( process_sensitivity_list ) ] [ IS ]
+ -- process_declarative_part
+ -- BEGIN
+ -- process_statement_part
+ -- END [ POSTPONED ] PROCESS [ PROCESS_label ] ;
+ --
+ -- process_sensitivity_list ::= ALL | sensitivity_list
+ function Parse_Process_Statement
+ (Label: Name_Id; Loc : Location_Type; Is_Postponed : Boolean)
+ return Iir
+ is
+ Res: Iir;
+ Sensitivity_List : Iir_List;
+ begin
+ -- The PROCESS keyword was just scaned.
+ Scan;
+
+ if Current_Token = Tok_Left_Paren then
+ Res := Create_Iir (Iir_Kind_Sensitized_Process_Statement);
+ Scan;
+ if Current_Token = Tok_All then
+ if Vhdl_Std < Vhdl_08 then
+ Error_Msg_Parse
+ ("all sensitized process allowed only in vhdl 08");
+ end if;
+ Sensitivity_List := Iir_List_All;
+ Scan;
+ else
+ Sensitivity_List := Create_Iir_List;
+ Parse_Sensitivity_List (Sensitivity_List);
+ end if;
+ Set_Sensitivity_List (Res, Sensitivity_List);
+ Expect (Tok_Right_Paren);
+ Scan;
+ else
+ Res := Create_Iir (Iir_Kind_Process_Statement);
+ end if;
+
+ Set_Location (Res, Loc);
+ Set_Label (Res, Label);
+
+ if Current_Token = Tok_Is then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("""is"" not allowed here by vhdl 87");
+ end if;
+ Set_Has_Is (Res, True);
+ Scan;
+ end if;
+
+ -- declarative part.
+ Parse_Declarative_Part (Res);
+
+ -- Skip 'begin'.
+ Expect (Tok_Begin);
+ Scan;
+
+ Set_Sequential_Statement_Chain (Res, Parse_Sequential_Statements (Res));
+
+ -- Skip 'end'.
+ Expect (Tok_End);
+ Scan;
+
+ if Current_Token = Tok_Postponed then
+ if not Is_Postponed then
+ -- LRM93 9.2
+ -- If the reserved word POSTPONED appears at the end of a process
+ -- statement, the process must be a postponed process.
+ Error_Msg_Parse ("process is not a postponed process");
+ end if;
+
+ Set_End_Has_Postponed (Res, True);
+
+ -- Skip 'postponed',
+ Scan;
+ end if;
+
+ if Current_Token = Tok_Semi_Colon then
+ Error_Msg_Parse ("""end"" must be followed by ""process""");
+ else
+ Expect (Tok_Process);
+ Scan;
+ Set_End_Has_Reserved_Id (Res, True);
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ end if;
+ return Res;
+ end Parse_Process_Statement;
+
+ -- precond : NEXT_TOKEN
+ -- postcond: NEXT_TOKEN
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- association_list ::= association_element { , association_element }
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- association_element ::= [ formal_part => ] actual_part
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- actual_part ::= actual_designator
+ -- | FUNCTION_name ( actual_designator )
+ -- | type_mark ( actual_designator )
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- actual_designator ::= expression
+ -- | SIGNAL_name
+ -- | VARIABLE_name
+ -- | FILE_name
+ -- | OPEN
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- formal_part ::= formal_designator
+ -- | FUNCTION_name ( formal_designator )
+ -- | type_mark ( formal_designator )
+ --
+ -- [ LRM93 4.3.2.2 ]
+ -- formal_designator ::= GENERIC_name
+ -- | PORT_name
+ -- | PARAMETER_name
+ --
+ -- Note: an actual part is parsed as an expression.
+ function Parse_Association_List return Iir
+ is
+ Res, Last: Iir;
+ El: Iir;
+ Formal: Iir;
+ Actual: Iir;
+ Nbr_Assocs : Natural;
+ Loc : Location_Type;
+ begin
+ Sub_Chain_Init (Res, Last);
+
+ if Current_Token = Tok_Right_Paren then
+ Error_Msg_Parse ("empty association list is not allowed");
+ return Res;
+ end if;
+
+ Nbr_Assocs := 1;
+ loop
+ -- Parse formal and actual.
+ Loc := Get_Token_Location;
+ Formal := Null_Iir;
+
+ if Current_Token /= Tok_Open then
+ Actual := Parse_Expression;
+ case Current_Token is
+ when Tok_To
+ | Tok_Downto =>
+ -- To/downto can appear in slice name (which are parsed as
+ -- function call).
+
+ if Actual = Null_Iir then
+ -- Left expression is missing ie: (downto x).
+ Scan;
+ Actual := Parse_Expression;
+ else
+ Actual := Parse_Range_Expression (Actual);
+ end if;
+ if Nbr_Assocs /= 1 then
+ Error_Msg_Parse ("multi-dimensional slice is forbidden");
+ end if;
+
+ when Tok_Double_Arrow =>
+ Formal := Actual;
+
+ -- Skip '=>'
+ Scan;
+ Loc := Get_Token_Location;
+
+ if Current_Token /= Tok_Open then
+ Actual := Parse_Expression;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end if;
+
+ if Current_Token = Tok_Open then
+ El := Create_Iir (Iir_Kind_Association_Element_Open);
+ Set_Location (El);
+
+ -- Skip 'open'
+ Scan;
+ else
+ El := Create_Iir (Iir_Kind_Association_Element_By_Expression);
+ Set_Location (El, Loc);
+ Set_Actual (El, Actual);
+ end if;
+ Set_Formal (El, Formal);
+
+ Sub_Chain_Append (Res, Last, El);
+ exit when Current_Token = Tok_Right_Paren;
+ Expect (Tok_Comma);
+ Scan;
+ Nbr_Assocs := Nbr_Assocs + 1;
+ end loop;
+
+ return Res;
+ end Parse_Association_List;
+
+ -- precond : NEXT_TOKEN
+ -- postcond: NEXT_TOKEN
+ --
+ -- Parse: '(' association_list ')'
+ function Parse_Association_List_In_Parenthesis return Iir
+ is
+ Res : Iir;
+ begin
+ -- Skip '('
+ Expect (Tok_Left_Paren);
+ Scan;
+
+ Res := Parse_Association_List;
+
+ -- Skip ')'
+ Scan;
+
+ return Res;
+ end Parse_Association_List_In_Parenthesis;
+
+ -- precond : GENERIC
+ -- postcond: next token
+ --
+ -- [ LRM93 5.2.1.2, LRM08 6.5.7.2 ]
+ -- generic_map_aspect ::= GENERIC MAP ( GENERIC_association_list )
+ function Parse_Generic_Map_Aspect return Iir is
+ begin
+ Expect (Tok_Generic);
+ Scan_Expect (Tok_Map);
+ Scan;
+ return Parse_Association_List_In_Parenthesis;
+ end Parse_Generic_Map_Aspect;
+
+ -- precond : PORT
+ -- postcond: next token
+ --
+ -- [ �5.2.1.2 ]
+ -- port_map_aspect ::= PORT MAP ( PORT_association_list )
+ function Parse_Port_Map_Aspect return Iir is
+ begin
+ Expect (Tok_Port);
+ Scan_Expect (Tok_Map);
+ Scan;
+ return Parse_Association_List_In_Parenthesis;
+ end Parse_Port_Map_Aspect;
+
+ -- precond : COMPONENT | ENTIY | CONFIGURATION
+ -- postcond : next_token
+ --
+ -- instantiated_unit ::=
+ -- [ COMPONENT ] component_name
+ -- ENTITY entity_name [ ( architecture_identifier ) ]
+ -- CONFIGURATION configuration_name
+ function Parse_Instantiated_Unit return Iir
+ is
+ Res : Iir;
+ begin
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("component instantiation using keyword 'component', 'entity',");
+ Error_Msg_Parse (" or 'configuration' is not allowed in vhdl87");
+ end if;
+
+ case Current_Token is
+ when Tok_Component =>
+ Scan;
+ return Parse_Name (False);
+ when Tok_Entity =>
+ Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity);
+ Set_Location (Res);
+ Scan;
+ Set_Entity_Name (Res, Parse_Name (False));
+ if Current_Token = Tok_Left_Paren then
+ Scan_Expect (Tok_Identifier);
+ Set_Architecture (Res, Current_Text);
+ Scan_Expect (Tok_Right_Paren);
+ Scan;
+ end if;
+ return Res;
+ when Tok_Configuration =>
+ Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration);
+ Set_Location (Res);
+ Scan_Expect (Tok_Identifier);
+ Set_Configuration_Name (Res, Parse_Name (False));
+ return Res;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Parse_Instantiated_Unit;
+
+ -- precond : next token
+ -- postcond: ';'
+ --
+ -- component_instantiation_statement ::=
+ -- INSTANTIATION_label :
+ -- instantiated_unit [ generic_map_aspect ] [ port_map_aspect ] ;
+ function Parse_Component_Instantiation (Name: Iir)
+ return Iir_Component_Instantiation_Statement is
+ Res: Iir_Component_Instantiation_Statement;
+ begin
+ Res := Create_Iir (Iir_Kind_Component_Instantiation_Statement);
+ Set_Location (Res);
+
+ Set_Instantiated_Unit (Res, Name);
+
+ if Current_Token = Tok_Generic then
+ Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect);
+ end if;
+ if Current_Token = Tok_Port then
+ Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect);
+ end if;
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Component_Instantiation;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �9.1 ]
+ -- block_header ::= [ generic_clause [ generic_map_aspect ; ] ]
+ -- [ port_clause [ port_map_aspect ; ] ]
+ function Parse_Block_Header return Iir_Block_Header is
+ Res : Iir_Block_Header;
+ begin
+ Res := Create_Iir (Iir_Kind_Block_Header);
+ Set_Location (Res);
+ if Current_Token = Tok_Generic then
+ Parse_Generic_Clause (Res);
+ if Current_Token = Tok_Generic then
+ Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect);
+ Scan_Semi_Colon ("generic map aspect");
+ end if;
+ end if;
+ if Current_Token = Tok_Port then
+ Parse_Port_Clause (Res);
+ if Current_Token = Tok_Port then
+ Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect);
+ Scan_Semi_Colon ("port map aspect");
+ end if;
+ end if;
+ return Res;
+ end Parse_Block_Header;
+
+ -- precond : BLOCK
+ -- postcond: ';'
+ --
+ -- [ �9.1 ]
+ -- block_statement ::=
+ -- BLOCK_label :
+ -- BLOCK [ ( GUARD_expression ) ] [ IS ]
+ -- block_header
+ -- block_declarative_part
+ -- BEGIN
+ -- block_statement_part
+ -- END BLOCK [ BLOCK_label ] ;
+ --
+ -- [ �9.1 ]
+ -- block_declarative_part ::= { block_declarative_item }
+ --
+ -- [ �9.1 ]
+ -- block_statement_part ::= { concurrent_statement }
+ function Parse_Block_Statement (Label: Name_Id; Loc : Location_Type)
+ return Iir_Block_Statement
+ is
+ Res : Iir_Block_Statement;
+ Guard : Iir_Guard_Signal_Declaration;
+ begin
+ if Label = Null_Identifier then
+ Error_Msg_Parse ("a block statement must have a label");
+ end if;
+
+ -- block was just parsed.
+ Res := Create_Iir (Iir_Kind_Block_Statement);
+ Set_Location (Res, Loc);
+ Set_Label (Res, Label);
+ Scan;
+ if Current_Token = Tok_Left_Paren then
+ Guard := Create_Iir (Iir_Kind_Guard_Signal_Declaration);
+ Set_Location (Guard);
+ Set_Guard_Decl (Res, Guard);
+ Scan;
+ Set_Guard_Expression (Guard, Parse_Expression);
+ Expect (Tok_Right_Paren, "a ')' is expected after guard expression");
+ Scan;
+ end if;
+ if Current_Token = Tok_Is then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'is' not allowed here in vhdl87");
+ end if;
+ Scan;
+ end if;
+ if Current_Token = Tok_Generic or Current_Token = Tok_Port then
+ Set_Block_Header (Res, Parse_Block_Header);
+ end if;
+ if Current_Token /= Tok_Begin then
+ Parse_Declarative_Part (Res);
+ end if;
+ Expect (Tok_Begin);
+ Scan;
+ Parse_Concurrent_Statements (Res);
+ Check_End_Name (Tok_Block, Res);
+ return Res;
+ end Parse_Block_Statement;
+
+ -- precond : IF or FOR
+ -- postcond: ';'
+ --
+ -- [ LRM93 9.7 ]
+ -- generate_statement ::=
+ -- GENERATE_label : generation_scheme GENERATE
+ -- [ { block_declarative_item }
+ -- BEGIN ]
+ -- { concurrent_statement }
+ -- END GENERATE [ GENERATE_label ] ;
+ --
+ -- [ LRM93 9.7 ]
+ -- generation_scheme ::=
+ -- FOR GENERATE_parameter_specification
+ -- | IF condition
+ --
+ -- FIXME: block_declarative item.
+ function Parse_Generate_Statement (Label : Name_Id; Loc : Location_Type)
+ return Iir_Generate_Statement
+ is
+ Res : Iir_Generate_Statement;
+ begin
+ if Label = Null_Identifier then
+ Error_Msg_Parse ("a generate statement must have a label");
+ end if;
+ Res := Create_Iir (Iir_Kind_Generate_Statement);
+ Set_Location (Res, Loc);
+ Set_Label (Res, Label);
+ case Current_Token is
+ when Tok_For =>
+ Scan;
+ Set_Generation_Scheme (Res, Parse_Parameter_Specification (Res));
+ when Tok_If =>
+ Scan;
+ Set_Generation_Scheme (Res, Parse_Expression);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Expect (Tok_Generate);
+
+ Scan;
+ -- Check for a block declarative item.
+ case Current_Token is
+ when
+ -- subprogram_declaration
+ -- subprogram_body
+ Tok_Procedure
+ | Tok_Function
+ | Tok_Pure
+ | Tok_Impure
+ -- type_declaration
+ | Tok_Type
+ -- subtype_declaration
+ | Tok_Subtype
+ -- constant_declaration
+ | Tok_Constant
+ -- signal_declaration
+ | Tok_Signal
+ -- shared_variable_declaration
+ | Tok_Shared
+ | Tok_Variable
+ -- file_declaration
+ | Tok_File
+ -- alias_declaration
+ | Tok_Alias
+ -- component_declaration
+ | Tok_Component
+ -- attribute_declaration
+ -- attribute_specification
+ | Tok_Attribute
+ -- configuration_specification
+ | Tok_For
+ -- disconnection_specification
+ | Tok_Disconnect
+ -- use_clause
+ | Tok_Use
+ -- group_template_declaration
+ -- group_declaration
+ | Tok_Group
+ | Tok_Begin =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("declarations not allowed in a generate in vhdl87");
+ end if;
+ Parse_Declarative_Part (Res);
+ Expect (Tok_Begin);
+ Set_Has_Begin (Res, True);
+ Scan;
+ when others =>
+ null;
+ end case;
+
+ Parse_Concurrent_Statements (Res);
+
+ Expect (Tok_End);
+
+ -- Skip 'end'
+ Scan_Expect (Tok_Generate);
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'generate'
+ Scan;
+
+ -- LRM93 9.7
+ -- If a label appears at the end of a generate statement, it must repeat
+ -- the generate label.
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Generate_Statement;
+
+ -- precond : first token
+ -- postcond: END
+ --
+ -- [ �9 ]
+ -- concurrent_statement ::= block_statement
+ -- | process_statement
+ -- | concurrent_procedure_call_statement
+ -- | concurrent_assertion_statement
+ -- | concurrent_signal_assignment_statement
+ -- | component_instantiation_statement
+ -- | generate_statement
+ --
+ -- [ �9.4 ]
+ -- concurrent_assertion_statement ::=
+ -- [ label : ] [ POSTPONED ] assertion ;
+ --
+ -- [ �9.3 ]
+ -- concurrent_procedure_call_statement ::=
+ -- [ label : ] [ POSTPONED ] procedure_call ;
+ --
+ -- [ �9.5 ]
+ -- concurrent_signal_assignment_statement ::=
+ -- [ label : ] [ POSTPONED ] conditional_signal_assignment
+ -- | [ label : ] [ POSTPONED ] selected_signal_assignment
+ function Parse_Concurrent_Assignment (Target : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ case Current_Token is
+ when Tok_Less_Equal
+ | Tok_Assign =>
+ -- This is a conditional signal assignment.
+ -- Error for ':=' is handled by the subprogram.
+ return Parse_Conditional_Signal_Assignment (Target);
+ when Tok_Semi_Colon =>
+ -- a procedure call or a component instantiation.
+ -- Parse it as a procedure call, may be revert to a
+ -- component instantiation during sem.
+ Expect (Tok_Semi_Colon);
+ return Parenthesis_Name_To_Procedure_Call
+ (Target, Iir_Kind_Concurrent_Procedure_Call_Statement);
+ when Tok_Generic | Tok_Port =>
+ -- or a component instantiation.
+ return Parse_Component_Instantiation (Target);
+ when others =>
+ -- or a simple simultaneous statement
+ if AMS_Vhdl then
+ Res := Create_Iir (Iir_Kind_Simple_Simultaneous_Statement);
+ Set_Simultaneous_Left (Res, Parse_Simple_Expression (Target));
+ if Current_Token /= Tok_Equal_Equal then
+ Error_Msg_Parse ("'==' expected after expression");
+ else
+ Set_Location (Res);
+ Scan;
+ end if;
+ Set_Simultaneous_Right (Res, Parse_Simple_Expression);
+ Set_Tolerance (Res, Parse_Tolerance_Aspect_Opt);
+ Expect (Tok_Semi_Colon);
+ return Res;
+ else
+ return Parse_Conditional_Signal_Assignment
+ (Parse_Simple_Expression (Target));
+ end if;
+ end case;
+ end Parse_Concurrent_Assignment;
+
+ function Parse_Psl_Default_Clock return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Psl_Default_Clock);
+ Scanner.Flag_Psl := True;
+ Scan_Expect (Tok_Psl_Clock);
+ Scan_Expect (Tok_Is);
+ Scan;
+ Set_Psl_Boolean (Res, Parse_Psl.Parse_Psl_Boolean);
+ Expect (Tok_Semi_Colon);
+ Scanner.Flag_Scan_In_Comment := False;
+ Scanner.Flag_Psl := False;
+ return Res;
+ end Parse_Psl_Default_Clock;
+
+ function Parse_Psl_Declaration return Iir
+ is
+ Tok : constant Token_Type := Current_Token;
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Psl_Declaration);
+ Scan;
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse ("property name expected here");
+ else
+ Set_Identifier (Res, Current_Identifier);
+ end if;
+ Scanner.Flag_Psl := True;
+ Set_Psl_Declaration (Res, Parse_Psl.Parse_Psl_Declaration (Tok));
+ Expect (Tok_Semi_Colon);
+ Scanner.Flag_Scan_In_Comment := False;
+ Scanner.Flag_Psl := False;
+ return Res;
+ end Parse_Psl_Declaration;
+
+ function Parse_Psl_Assert_Statement return Iir
+ is
+ Res : Iir;
+ begin
+ case Current_Token is
+ when Tok_Psl_Assert =>
+ Res := Create_Iir (Iir_Kind_Psl_Assert_Statement);
+ when Tok_Psl_Cover =>
+ Res := Create_Iir (Iir_Kind_Psl_Cover_Statement);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Scan extended PSL tokens.
+ Scanner.Flag_Psl := True;
+
+ -- Skip 'assert'
+ Scan;
+
+ Set_Psl_Property (Res, Parse_Psl.Parse_Psl_Property);
+
+ -- No more PSL tokens after the property.
+ Scanner.Flag_Psl := False;
+
+ if Current_Token = Tok_Report then
+ -- Skip 'report'
+ Scan;
+
+ Set_Report_Expression (Res, Parse_Expression);
+ end if;
+
+ if Current_Token = Tok_Severity then
+ -- Skip 'severity'
+ Scan;
+
+ Set_Severity_Expression (Res, Parse_Expression);
+ end if;
+
+ Expect (Tok_Semi_Colon);
+ Scanner.Flag_Scan_In_Comment := False;
+ return Res;
+ end Parse_Psl_Assert_Statement;
+
+ procedure Parse_Concurrent_Statements (Parent : Iir)
+ is
+ Last_Stmt : Iir;
+ Stmt: Iir;
+ Label: Name_Id;
+ Id: Iir;
+ Postponed : Boolean;
+ Loc : Location_Type;
+ Target : Iir;
+
+ procedure Postponed_Not_Allowed is
+ begin
+ if Postponed then
+ Error_Msg_Parse ("'postponed' not allowed here");
+ Postponed := False;
+ end if;
+ end Postponed_Not_Allowed;
+ begin
+ -- begin was just parsed.
+ Last_Stmt := Null_Iir;
+ loop
+ Stmt := Null_Iir;
+ Label := Null_Identifier;
+ Postponed := False;
+ Loc := Get_Token_Location;
+
+ -- Try to find a label.
+ if Current_Token = Tok_Identifier then
+ Label := Current_Identifier;
+ Scan;
+ if Current_Token = Tok_Colon then
+ -- The identifier is really a label.
+ Scan;
+ else
+ -- This is not a label.
+ Target := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Location (Target, Loc);
+ Set_Identifier (Target, Label);
+ Label := Null_Identifier;
+ Target := Parse_Name_Suffix (Target);
+ Stmt := Parse_Concurrent_Assignment (Target);
+ goto Has_Stmt;
+ end if;
+ end if;
+
+ if Current_Token = Tok_Postponed then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'postponed' is not allowed in vhdl 87");
+ else
+ Postponed := True;
+ end if;
+ Scan;
+ end if;
+
+ case Current_Token is
+ when Tok_End =>
+ Postponed_Not_Allowed;
+ if Label /= Null_Identifier then
+ Error_Msg_Parse
+ ("no label is allowed before the 'end' keyword");
+ end if;
+ return;
+ when Tok_Identifier =>
+ Target := Parse_Name (Allow_Indexes => True);
+ Stmt := Parse_Concurrent_Assignment (Target);
+ if Get_Kind (Stmt) = Iir_Kind_Component_Instantiation_Statement
+ and then Postponed
+ then
+ Error_Msg_Parse ("'postponed' not allowed for " &
+ "an instantiation statement");
+ Postponed := False;
+ end if;
+ when Tok_Left_Paren =>
+ Id := Parse_Aggregate;
+ if Current_Token = Tok_Less_Equal then
+ -- This is a conditional signal assignment.
+ Stmt := Parse_Conditional_Signal_Assignment (Id);
+ else
+ Error_Msg_Parse ("'<=' expected after aggregate");
+ Eat_Tokens_Until_Semi_Colon;
+ end if;
+ when Tok_Process =>
+ Stmt := Parse_Process_Statement (Label, Loc, Postponed);
+ when Tok_Assert =>
+ Stmt := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement);
+ Parse_Assertion (Stmt);
+ Expect (Tok_Semi_Colon);
+ when Tok_With =>
+ Stmt := Parse_Selected_Signal_Assignment;
+ when Tok_Block =>
+ Postponed_Not_Allowed;
+ Stmt := Parse_Block_Statement (Label, Loc);
+ when Tok_If
+ | Tok_For =>
+ if Postponed then
+ Error_Msg_Parse
+ ("'postponed' not allowed before a generate statement");
+ Postponed := False;
+ end if;
+ Stmt := Parse_Generate_Statement (Label, Loc);
+ when Tok_Eof =>
+ Error_Msg_Parse ("unexpected end of file, 'END;' expected");
+ return;
+ when Tok_Component
+ | Tok_Entity
+ | Tok_Configuration =>
+ Postponed_Not_Allowed;
+ declare
+ Unit : Iir;
+ begin
+ Unit := Parse_Instantiated_Unit;
+ Stmt := Parse_Component_Instantiation (Unit);
+ end;
+ when Tok_Psl_Default =>
+ Postponed_Not_Allowed;
+ Stmt := Parse_Psl_Default_Clock;
+ when Tok_Psl_Property
+ | Tok_Psl_Sequence
+ | Tok_Psl_Endpoint =>
+ Postponed_Not_Allowed;
+ Stmt := Parse_Psl_Declaration;
+ when Tok_Psl_Assert
+ | Tok_Psl_Cover =>
+ Postponed_Not_Allowed;
+ Stmt := Parse_Psl_Assert_Statement;
+ when others =>
+ -- FIXME: improve message:
+ -- instead of 'unexpected token 'signal' in conc stmt list'
+ -- report: 'signal declarations are not allowed in conc stmt'
+ Unexpected ("concurrent statement list");
+ Eat_Tokens_Until_Semi_Colon;
+ end case;
+
+ << Has_Stmt >> null;
+
+ -- stmt can be null in case of error.
+ if Stmt /= Null_Iir then
+ Set_Location (Stmt, Loc);
+ if Label /= Null_Identifier then
+ Set_Label (Stmt, Label);
+ end if;
+ Set_Parent (Stmt, Parent);
+ if Postponed then
+ Set_Postponed_Flag (Stmt, True);
+ end if;
+ -- Append it to the chain.
+ if Last_Stmt = Null_Iir then
+ Set_Concurrent_Statement_Chain (Parent, Stmt);
+ else
+ Set_Chain (Last_Stmt, Stmt);
+ end if;
+ Last_Stmt := Stmt;
+ end if;
+
+ Scan;
+ end loop;
+ end Parse_Concurrent_Statements;
+
+ -- precond : LIBRARY
+ -- postcond: ;
+ --
+ -- [ LRM93 11.2 ]
+ -- library_clause ::= LIBRARY logical_name_list
+ function Parse_Library_Clause return Iir
+ is
+ First, Last : Iir;
+ Library: Iir_Library_Clause;
+ begin
+ Sub_Chain_Init (First, Last);
+ Expect (Tok_Library);
+ loop
+ Library := Create_Iir (Iir_Kind_Library_Clause);
+
+ -- Skip 'library' or ','.
+ Scan_Expect (Tok_Identifier);
+
+ Set_Identifier (Library, Current_Identifier);
+ Set_Location (Library);
+ Sub_Chain_Append (First, Last, Library);
+
+ -- Skip identifier.
+ Scan;
+
+ exit when Current_Token = Tok_Semi_Colon;
+ Expect (Tok_Comma);
+
+ Set_Has_Identifier_List (Library, True);
+ end loop;
+
+ -- Skip ';'.
+ Scan;
+ return First;
+ end Parse_Library_Clause;
+
+ -- precond : USE
+ -- postcond: ;
+ --
+ -- [ �10.4 ]
+ -- use_clause ::= USE selected_name { , selected_name }
+ --
+ -- FIXME: should be a list.
+ function Parse_Use_Clause return Iir_Use_Clause
+ is
+ Use_Clause: Iir_Use_Clause;
+ First, Last : Iir;
+ begin
+ First := Null_Iir;
+ Last := Null_Iir;
+ Scan;
+ loop
+ Use_Clause := Create_Iir (Iir_Kind_Use_Clause);
+ Set_Location (Use_Clause);
+ Expect (Tok_Identifier);
+ Set_Selected_Name (Use_Clause, Parse_Name);
+
+ -- Chain use clauses.
+ if First = Null_Iir then
+ First := Use_Clause;
+ else
+ Set_Use_Clause_Chain (Last, Use_Clause);
+ end if;
+ Last := Use_Clause;
+
+ exit when Current_Token = Tok_Semi_Colon;
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ return First;
+ end Parse_Use_Clause;
+
+ -- precond : ARCHITECTURE
+ -- postcond: ';'
+ --
+ -- [ �1.2 ]
+ -- architecture_body ::=
+ -- ARCHITECTURE identifier OF ENTITY_name IS
+ -- architecture_declarative_part
+ -- BEGIN
+ -- architecture_statement_part
+ -- END [ ARCHITECTURE ] [ ARCHITECTURE_simple_name ] ;
+ procedure Parse_Architecture_Body (Unit : Iir_Design_Unit)
+ is
+ Res: Iir_Architecture_Body;
+ begin
+ Expect (Tok_Architecture);
+ Res := Create_Iir (Iir_Kind_Architecture_Body);
+
+ -- Get identifier.
+ Scan_Expect (Tok_Identifier);
+ Set_Identifier (Res, Current_Identifier);
+ Set_Location (Res);
+ Scan;
+ if Current_Token = Tok_Is then
+ Error_Msg_Parse ("architecture identifier is missing");
+ else
+ Expect (Tok_Of);
+ Scan;
+ Set_Entity_Name (Res, Parse_Name (False));
+ Expect (Tok_Is);
+ end if;
+
+ Scan;
+ Parse_Declarative_Part (Res);
+
+ Expect (Tok_Begin);
+ Scan;
+ Parse_Concurrent_Statements (Res);
+ -- end was scanned.
+ Set_End_Location (Unit);
+ Scan;
+ if Current_Token = Tok_Architecture then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'architecture' keyword not allowed here by vhdl 87");
+ end if;
+ Set_End_Has_Reserved_Id (Res, True);
+ Scan;
+ end if;
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ Set_Library_Unit (Unit, Res);
+ end Parse_Architecture_Body;
+
+ -- precond : next token
+ -- postcond: a token
+ --
+ -- [ �5.2 ]
+ -- instantiation_list ::= INSTANTIATION_label { , INSTANTIATION_label }
+ -- | OTHERS
+ -- | ALL
+ function Parse_Instantiation_List return Iir_List
+ is
+ Res : Iir_List;
+ begin
+ case Current_Token is
+ when Tok_All =>
+ Scan;
+ return Iir_List_All;
+ when Tok_Others =>
+ Scan;
+ return Iir_List_Others;
+ when Tok_Identifier =>
+ Res := Create_Iir_List;
+ loop
+ Append_Element (Res, Current_Text);
+ Scan;
+ exit when Current_Token /= Tok_Comma;
+ Expect (Tok_Comma);
+ Scan;
+ end loop;
+ return Res;
+ when others =>
+ Error_Msg_Parse ("instantiation list expected");
+ return Null_Iir_List;
+ end case;
+ end Parse_Instantiation_List;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �5.2 ]
+ -- component_specification ::= instantiation_list : COMPONENT_name
+ procedure Parse_Component_Specification (Res : Iir)
+ is
+ List : Iir_List;
+ begin
+ List := Parse_Instantiation_List;
+ Set_Instantiation_List (Res, List);
+ Expect (Tok_Colon);
+ Scan_Expect (Tok_Identifier);
+ Set_Component_Name (Res, Parse_Name);
+ end Parse_Component_Specification;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �5.2.1.1 ]
+ -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ]
+ -- | CONFIGURATION CONFIGURATION_name
+ -- | OPEN
+ function Parse_Entity_Aspect return Iir
+ is
+ Res : Iir;
+ begin
+ case Current_Token is
+ when Tok_Entity =>
+ Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity);
+ Set_Location (Res);
+ Scan_Expect (Tok_Identifier);
+ Set_Entity_Name (Res, Parse_Name (False));
+ if Current_Token = Tok_Left_Paren then
+ Scan_Expect (Tok_Identifier);
+ Set_Architecture (Res, Current_Text);
+ Scan_Expect (Tok_Right_Paren);
+ Scan;
+ end if;
+ when Tok_Configuration =>
+ Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration);
+ Set_Location (Res);
+ Scan_Expect (Tok_Identifier);
+ Set_Configuration_Name (Res, Parse_Name (False));
+ when Tok_Open =>
+ Res := Create_Iir (Iir_Kind_Entity_Aspect_Open);
+ Set_Location (Res);
+ Scan;
+ when others =>
+ -- FIXME: if the token is an identifier, try as if the 'entity'
+ -- keyword is missing.
+ Error_Msg_Parse
+ ("'entity', 'configuration' or 'open' keyword expected");
+ end case;
+ return Res;
+ end Parse_Entity_Aspect;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [ �5.2.1 ]
+ -- binding_indication ::=
+ -- [ USE entity_aspect ]
+ -- [ generic_map_aspect ]
+ -- [ port_map_aspect ]
+ function Parse_Binding_Indication return Iir_Binding_Indication
+ is
+ Res : Iir_Binding_Indication;
+ begin
+ case Current_Token is
+ when Tok_Use
+ | Tok_Generic
+ | Tok_Port =>
+ null;
+ when others =>
+ return Null_Iir;
+ end case;
+ Res := Create_Iir (Iir_Kind_Binding_Indication);
+ Set_Location (Res);
+ if Current_Token = Tok_Use then
+ Scan;
+ Set_Entity_Aspect (Res, Parse_Entity_Aspect);
+ end if;
+ if Current_Token = Tok_Generic then
+ Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect);
+ end if;
+ if Current_Token = Tok_Port then
+ Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect);
+ end if;
+ return Res;
+ end Parse_Binding_Indication;
+
+ -- precond : ':' after instantiation_list.
+ -- postcond: ';'
+ --
+ -- [ �1.3.2 ]
+ -- component_configuration ::=
+ -- FOR component_specification
+ -- [ binding_indication ; ]
+ -- [ block_configuration ]
+ -- END FOR ;
+ function Parse_Component_Configuration (Loc : Location_Type;
+ Inst_List : Iir_List)
+ return Iir_Component_Configuration
+ is
+ Res : Iir_Component_Configuration;
+ begin
+ Res := Create_Iir (Iir_Kind_Component_Configuration);
+ Set_Location (Res, Loc);
+
+ -- Component specification.
+ Set_Instantiation_List (Res, Inst_List);
+ Expect (Tok_Colon);
+ Scan_Expect (Tok_Identifier);
+ Set_Component_Name (Res, Parse_Name);
+
+ case Current_Token is
+ when Tok_Use
+ | Tok_Generic
+ | Tok_Port =>
+ Set_Binding_Indication (Res, Parse_Binding_Indication);
+ Scan_Semi_Colon ("binding indication");
+ when others =>
+ null;
+ end case;
+ if Current_Token = Tok_For then
+ Set_Block_Configuration (Res, Parse_Block_Configuration);
+ -- Eat ';'.
+ Scan;
+ end if;
+ Expect (Tok_End);
+ Scan_Expect (Tok_For);
+ Scan_Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Component_Configuration;
+
+ -- precond : FOR
+ -- postcond: ';'
+ --
+ -- [ �1.3.1 ]
+ -- block_configuration ::=
+ -- FOR block_specification
+ -- { use_clause }
+ -- { configuration_item }
+ -- END FOR ;
+ --
+ -- [ �1.3.1 ]
+ -- block_specification ::=
+ -- ARCHITECTURE_name
+ -- | BLOCK_STATEMENT_label
+ -- | GENERATE_STATEMENT_label [ ( index_specification ) ]
+ function Parse_Block_Configuration_Suffix (Loc : Location_Type;
+ Block_Spec : Iir)
+ return Iir
+ is
+ Res : Iir_Block_Configuration;
+ begin
+ Res := Create_Iir (Iir_Kind_Block_Configuration);
+ Set_Location (Res, Loc);
+
+ Set_Block_Specification (Res, Block_Spec);
+
+ -- Parse use clauses.
+ if Current_Token = Tok_Use then
+ declare
+ Last : Iir;
+ use Declaration_Chain_Handling;
+ begin
+ Build_Init (Last);
+
+ while Current_Token = Tok_Use loop
+ Append_Subchain (Last, Res, Parse_Use_Clause);
+ -- Eat ';'.
+ Scan;
+ end loop;
+ end;
+ end if;
+
+ -- Parse configuration item list
+ declare
+ use Iir_Chains.Configuration_Item_Chain_Handling;
+ Last : Iir;
+ begin
+ Build_Init (Last);
+ while Current_Token /= Tok_End loop
+ Append (Last, Res, Parse_Configuration_Item);
+ -- Eat ';'.
+ Scan;
+ end loop;
+ end;
+ Scan_Expect (Tok_For);
+ Scan_Expect (Tok_Semi_Colon);
+ return Res;
+ end Parse_Block_Configuration_Suffix;
+
+ function Parse_Block_Configuration return Iir_Block_Configuration
+ is
+ Loc : Location_Type;
+ begin
+ Loc := Get_Token_Location;
+ Expect (Tok_For);
+
+ -- Parse label.
+ Scan;
+ return Parse_Block_Configuration_Suffix (Loc, Parse_Name);
+ end Parse_Block_Configuration;
+
+ -- precond : FOR
+ -- postcond: ';'
+ --
+ -- [ �1.3.1 ]
+ -- configuration_item ::= block_configuration
+ -- | component_configuration
+ function Parse_Configuration_Item return Iir
+ is
+ Loc : Location_Type;
+ List : Iir_List;
+ El : Iir;
+ begin
+ Loc := Get_Token_Location;
+ Expect (Tok_For);
+ Scan;
+
+ -- ALL and OTHERS are tokens from an instantiation list.
+ -- Thus, the rule is a component_configuration.
+ case Current_Token is
+ when Tok_All =>
+ Scan;
+ return Parse_Component_Configuration (Loc, Iir_List_All);
+ when Tok_Others =>
+ Scan;
+ return Parse_Component_Configuration (Loc, Iir_List_Others);
+ when Tok_Identifier =>
+ El := Current_Text;
+ Scan;
+ case Current_Token is
+ when Tok_Colon =>
+ -- The identifier was a label from an instantiation list.
+ List := Create_Iir_List;
+ Append_Element (List, El);
+ return Parse_Component_Configuration (Loc, List);
+ when Tok_Comma =>
+ -- The identifier was a label from an instantiation list.
+ List := Create_Iir_List;
+ Append_Element (List, El);
+ loop
+ Scan_Expect (Tok_Identifier);
+ Append_Element (List, Current_Text);
+ Scan;
+ exit when Current_Token /= Tok_Comma;
+ end loop;
+ return Parse_Component_Configuration (Loc, List);
+ when Tok_Left_Paren =>
+ El := Parse_Name_Suffix (El);
+ return Parse_Block_Configuration_Suffix (Loc, El);
+ when Tok_Use | Tok_For | Tok_End =>
+ -- Possibilities for a block_configuration.
+ -- FIXME: should use 'when others' ?
+ return Parse_Block_Configuration_Suffix (Loc, El);
+ when others =>
+ Error_Msg_Parse
+ ("block_configuration or component_configuration "
+ & "expected");
+ raise Parse_Error;
+ end case;
+ when others =>
+ Error_Msg_Parse ("configuration item expected");
+ raise Parse_Error;
+ end case;
+ end Parse_Configuration_Item;
+
+ -- precond : next token
+ -- postcond: next token
+ --
+ -- [� 1.3]
+ -- configuration_declarative_part ::= { configuration_declarative_item }
+ --
+ -- [� 1.3]
+ -- configuration_declarative_item ::= use_clause
+ -- | attribute_specification
+ -- | group_declaration
+ -- FIXME: attribute_specification, group_declaration
+ procedure Parse_Configuration_Declarative_Part (Parent : Iir)
+ is
+ use Declaration_Chain_Handling;
+ Last : Iir;
+ El : Iir;
+ begin
+ Build_Init (Last);
+ loop
+ case Current_Token is
+ when Tok_Invalid =>
+ raise Internal_Error;
+ when Tok_Use =>
+ Append_Subchain (Last, Parent, Parse_Use_Clause);
+ when Tok_Attribute =>
+ El := Parse_Attribute;
+ if El /= Null_Iir then
+ if Get_Kind (El) /= Iir_Kind_Attribute_Specification then
+ Error_Msg_Parse
+ ("attribute declaration not allowed here");
+ end if;
+ Append (Last, Parent, El);
+ end if;
+ when Tok_Group =>
+ El := Parse_Group;
+ if El /= Null_Iir then
+ if Get_Kind (El) /= Iir_Kind_Group_Declaration then
+ Error_Msg_Parse
+ ("group template declaration not allowed here");
+ end if;
+ Append (Last, Parent, El);
+ end if;
+ when others =>
+ exit;
+ end case;
+ Scan;
+ end loop;
+ end Parse_Configuration_Declarative_Part;
+
+ -- precond : CONFIGURATION
+ -- postcond: ';'
+ --
+ -- [ LRM93 1.3 ]
+ -- configuration_declaration ::=
+ -- CONFIGURATION identifier OF ENTITY_name IS
+ -- configuration_declarative_part
+ -- block_configuration
+ -- END [ CONFIGURATION ] [ CONFIGURATION_simple_name ] ;
+ --
+ -- [ LRM93 1.3 ]
+ -- configuration_declarative_part ::= { configuration_declarative_item }
+ procedure Parse_Configuration_Declaration (Unit : Iir_Design_Unit)
+ is
+ Res : Iir_Configuration_Declaration;
+ begin
+ if Current_Token /= Tok_Configuration then
+ raise Program_Error;
+ end if;
+ Res := Create_Iir (Iir_Kind_Configuration_Declaration);
+
+ -- Get identifier.
+ Scan_Expect (Tok_Identifier);
+ Set_Identifier (Res, Current_Identifier);
+ Set_Location (Res);
+
+ -- Skip identifier.
+ Scan_Expect (Tok_Of);
+
+ -- Skip 'of'.
+ Scan;
+
+ Set_Entity_Name (Res, Parse_Name (False));
+
+ -- Skip 'is'.
+ Expect (Tok_Is);
+ Scan;
+
+ Parse_Configuration_Declarative_Part (Res);
+
+ Set_Block_Configuration (Res, Parse_Block_Configuration);
+
+ Scan_Expect (Tok_End);
+ Set_End_Location (Unit);
+
+ -- Skip 'end'.
+ Scan;
+
+ if Current_Token = Tok_Configuration then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse
+ ("'configuration' keyword not allowed here by vhdl 87");
+ end if;
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'configuration'.
+ Scan;
+ end if;
+
+ -- LRM93 1.3
+ -- If a simple name appears at the end of a configuration declaration, it
+ -- must repeat the identifier of the configuration declaration.
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ Set_Library_Unit (Unit, Res);
+ end Parse_Configuration_Declaration;
+
+ -- precond : generic
+ -- postcond: next token
+ --
+ -- LRM08 4.7
+ -- package_header ::=
+ -- [ generic_clause -- LRM08 6.5.6.2
+ -- [ generic_map aspect ; ] ]
+ function Parse_Package_Header return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Package_Header);
+ Parse_Generic_Clause (Res);
+
+ if Current_Token = Tok_Generic then
+ Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect);
+ Scan_Semi_Colon ("generic map aspect");
+ end if;
+ return Res;
+ end Parse_Package_Header;
+
+ -- precond : token (after 'IS')
+ -- postcond: ';'
+ --
+ -- [ LRM93 2.5, LRM08 4.7 ]
+ -- package_declaration ::=
+ -- PACKAGE identifier IS
+ -- package_header -- LRM08
+ -- package_declarative_part
+ -- END [ PACKAGE ] [ PACKAGE_simple_name ] ;
+ procedure Parse_Package_Declaration
+ (Unit : Iir_Design_Unit; Id : Name_Id; Loc : Location_Type)
+ is
+ Res: Iir_Package_Declaration;
+ begin
+ Res := Create_Iir (Iir_Kind_Package_Declaration);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Id);
+
+ if Current_Token = Tok_Generic then
+ if Vhdl_Std < Vhdl_08 then
+ Error_Msg_Parse ("generic packages not allowed before vhdl 2008");
+ end if;
+ Set_Package_Header (Res, Parse_Package_Header);
+ end if;
+
+ Parse_Declarative_Part (Res);
+
+ Expect (Tok_End);
+ Set_End_Location (Unit);
+
+ -- Skip 'end'
+ Scan;
+
+ if Current_Token = Tok_Package then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87");
+ end if;
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'package'.
+ Scan;
+ end if;
+
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ Set_Library_Unit (Unit, Res);
+ end Parse_Package_Declaration;
+
+ -- precond : BODY
+ -- postcond: ';'
+ --
+ -- [ LRM93 2.6, LRM08 4.8 ]
+ -- package_body ::=
+ -- PACKAGE BODY PACKAGE_simple_name IS
+ -- package_body_declarative_part
+ -- END [ PACKAGE BODY ] [ PACKAGE_simple_name ] ;
+ procedure Parse_Package_Body (Unit : Iir_Design_Unit)
+ is
+ Res: Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Package_Body);
+ Set_Location (Res);
+
+ -- Get identifier.
+ Expect (Tok_Identifier);
+ Set_Identifier (Res, Current_Identifier);
+ Scan_Expect (Tok_Is);
+ Scan;
+
+ Parse_Declarative_Part (Res);
+
+ Expect (Tok_End);
+ Set_End_Location (Unit);
+
+ -- Skip 'end'
+ Scan;
+
+ if Current_Token = Tok_Package then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87");
+ end if;
+ Set_End_Has_Reserved_Id (Res, True);
+
+ -- Skip 'package'
+ Scan;
+
+ if Current_Token /= Tok_Body then
+ Error_Msg_Parse ("missing 'body' after 'package'");
+ else
+ -- Skip 'body'
+ Scan;
+ end if;
+ end if;
+
+ Check_End_Name (Res);
+ Expect (Tok_Semi_Colon);
+ Set_Library_Unit (Unit, Res);
+ end Parse_Package_Body;
+
+ -- precond : NEW
+ -- postcond: ';'
+ --
+ -- [ LRM08 4.9 ]
+ -- package_instantiation_declaration ::=
+ -- PACKAGE identifier IS NEW uninstantiated_package_name
+ -- [ generic_map_aspect ] ;
+ function Parse_Package_Instantiation_Declaration
+ (Id : Name_Id; Loc : Location_Type)
+ return Iir
+ is
+ Res: Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Package_Instantiation_Declaration);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Id);
+
+ -- Skip 'new'
+ Scan;
+
+ Set_Uninstantiated_Package_Name (Res, Parse_Name (False));
+
+ if Current_Token = Tok_Generic then
+ Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect);
+ end if;
+
+ Expect (Tok_Semi_Colon);
+
+ return Res;
+ end Parse_Package_Instantiation_Declaration;
+
+ -- precond : PACKAGE
+ -- postcond: ';'
+ --
+ -- package_declaration
+ -- | package_body
+ -- | package_instantiation_declaration
+ procedure Parse_Package (Unit : Iir_Design_Unit)
+ is
+ Loc : Location_Type;
+ Id : Name_Id;
+ begin
+ -- Skip 'package'
+ Scan;
+
+ if Current_Token = Tok_Body then
+ -- Skip 'body'
+ Scan;
+
+ Parse_Package_Body (Unit);
+ else
+ Expect (Tok_Identifier);
+ Id := Current_Identifier;
+ Loc := Get_Token_Location;
+
+ -- Skip identifier.
+ Scan;
+
+ -- Skip 'is'.
+ Expect (Tok_Is);
+ Scan;
+
+ if Current_Token = Tok_New then
+ Set_Library_Unit
+ (Unit,
+ Parse_Package_Instantiation_Declaration (Id, Loc));
+ -- Note: there is no 'end' in instantiation.
+ Set_End_Location (Unit, Get_Token_Location);
+ else
+ Parse_Package_Declaration (Unit, Id, Loc);
+ end if;
+ end if;
+ end Parse_Package;
+
+ -- Parse a design_unit.
+ -- The lexical scanner must have been initialized, but without a
+ -- current_token.
+ --
+ -- [ �11.1 ]
+ -- design_unit ::= context_clause library_unit
+ --
+ -- [ �11.3 ]
+ -- context_clause ::= { context_item }
+ --
+ -- [ �11.3 ]
+ -- context_item ::= library_clause | use_clause
+ function Parse_Design_Unit return Iir_Design_Unit
+ is
+ Res: Iir_Design_Unit;
+ Unit: Iir;
+ begin
+ -- Internal check: there must be no current_token.
+ if Current_Token /= Tok_Invalid then
+ raise Internal_Error;
+ end if;
+ Scan;
+ if Current_Token = Tok_Eof then
+ return Null_Iir;
+ end if;
+
+ -- Create the design unit node.
+ Res := Create_Iir (Iir_Kind_Design_Unit);
+ Set_Location (Res);
+ Set_Date_State (Res, Date_Extern);
+
+ -- Parse context clauses
+ declare
+ use Context_Items_Chain_Handling;
+ Last : Iir;
+ Els : Iir;
+ begin
+ Build_Init (Last);
+
+ loop
+ case Current_Token is
+ when Tok_Library =>
+ Els := Parse_Library_Clause;
+ when Tok_Use =>
+ Els := Parse_Use_Clause;
+ Scan;
+ when Tok_With =>
+ -- Be Ada friendly.
+ Error_Msg_Parse ("'with' not allowed in context clause "
+ & "(try 'use' or 'library')");
+ Els := Parse_Use_Clause;
+ Scan;
+ when others =>
+ exit;
+ end case;
+ Append_Subchain (Last, Res, Els);
+ end loop;
+ end;
+
+ -- Parse library unit
+ case Current_Token is
+ when Tok_Entity =>
+ Parse_Entity_Declaration (Res);
+ when Tok_Architecture =>
+ Parse_Architecture_Body (Res);
+ when Tok_Package =>
+ Parse_Package (Res);
+ when Tok_Configuration =>
+ Parse_Configuration_Declaration (Res);
+ when others =>
+ Error_Msg_Parse ("entity, architecture, package or configuration "
+ & "keyword expected");
+ return Null_Iir;
+ end case;
+ Unit := Get_Library_Unit (Res);
+ Set_Design_Unit (Unit, Res);
+ Set_Identifier (Res, Get_Identifier (Unit));
+ Set_Date (Res, Date_Parsed);
+ Invalidate_Current_Token;
+ return Res;
+ exception
+ when Expect_Error =>
+ raise Compilation_Error;
+ end Parse_Design_Unit;
+
+ -- [ �11.1 ]
+ -- design_file ::= design_unit { design_unit }
+ function Parse_Design_File return Iir_Design_File
+ is
+ Res : Iir_Design_File;
+ Design, Last_Design : Iir_Design_Unit;
+ begin
+ Res := Create_Iir (Iir_Kind_Design_File);
+ Set_Location (Res);
+
+ Last_Design := Null_Iir;
+ loop
+ Design := Parse.Parse_Design_Unit;
+ exit when Design = Null_Iir;
+ Set_Design_File (Design, Res);
+ if Last_Design = Null_Iir then
+ Set_First_Design_Unit (Res, Design);
+ else
+ Set_Chain (Last_Design, Design);
+ end if;
+ Last_Design := Design;
+ Set_Last_Design_Unit (Res, Last_Design);
+ end loop;
+ if Last_Design = Null_Iir then
+ Error_Msg_Parse ("design file is empty (no design unit found)");
+ end if;
+ return Res;
+ exception
+ when Parse_Error =>
+ return Null_Iir;
+ end Parse_Design_File;
+end Parse;
diff --git a/src/parse.ads b/src/parse.ads
new file mode 100644
index 000000000..26bdef3ec
--- /dev/null
+++ b/src/parse.ads
@@ -0,0 +1,44 @@
+-- VHDL parser.
+-- 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 Parse is
+ -- If True, create nodes for parenthesis expressions.
+ Flag_Parse_Parenthesis : Boolean := False;
+
+ -- Parse an expression.
+ -- (Used by PSL).
+ function Parse_Expression return Iir;
+ function Parse_Expression_Rhs (Left : Iir) return Iir;
+
+ -- Parse an relationnal operator and its rhs.
+ function Parse_Relation_Rhs (Left : Iir) return Iir;
+
+ -- Parse a single design unit.
+ -- The scanner must have been initialized, however, the current_token
+ -- shouldn't have been set.
+ -- At return, the last token accepted is the semi_colon that terminates
+ -- the library unit.
+ -- Return Null_Iir when end of file.
+ function Parse_Design_Unit return Iir_Design_Unit;
+
+ -- Parse a file.
+ -- The scanner must habe been initialized as for parse_design_unit.
+ -- Return Null_Iir in case of error.
+ function Parse_Design_File return Iir_Design_File;
+end Parse;
diff --git a/src/parse_psl.adb b/src/parse_psl.adb
new file mode 100644
index 000000000..7cb20ca3b
--- /dev/null
+++ b/src/parse_psl.adb
@@ -0,0 +1,667 @@
+-- VHDL PSL parser.
+-- 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 Iirs;
+with Scanner; use Scanner;
+with PSL.Errors; use PSL.Errors;
+with PSL.Priorities; use PSL.Priorities;
+with Parse;
+
+package body Parse_Psl is
+ function Create_Node_Loc (K : Nkind) return Node is
+ Res : Node;
+ begin
+ Res := PSL.Nodes.Create_Node (K);
+ Set_Location (Res, Get_Token_Location);
+ return Res;
+ end Create_Node_Loc;
+
+ function Parse_Number return Node is
+ Res : Node;
+ begin
+ if Current_Token = Tok_Integer then
+ Res := Create_Node_Loc (N_Number);
+ -- FIXME: handle overflow.
+ Set_Value (Res, Uns32 (Current_Iir_Int64));
+ Scan;
+ return Res;
+ elsif Current_Token = Tok_Inf then
+ -- FIXME: create node
+ Scan;
+ return Null_Node;
+ else
+ Error_Msg_Parse ("number expected");
+ return Null_Node;
+ end if;
+ end Parse_Number;
+
+ procedure Parse_Count (N : Node) is
+ begin
+ Set_Low_Bound (N, Parse_Number);
+ if Current_Token = Tok_To then
+ Scan;
+ Set_High_Bound (N, Parse_Number);
+ end if;
+ end Parse_Count;
+
+ function Psl_To_Vhdl (N : Node) return Iirs.Iir
+ is
+ use Iirs;
+ Res : Iir;
+ begin
+ case Get_Kind (N) is
+ when N_HDL_Expr =>
+ Res := Iirs.Iir (Get_HDL_Node (N));
+ Free_Node (N);
+ return Res;
+ when others =>
+ Error_Kind ("psl_to_vhdl", N);
+ end case;
+ end Psl_To_Vhdl;
+
+ function Vhdl_To_Psl (N : Iirs.Iir) return Node
+ is
+ Res : Node;
+ begin
+ Res := Create_Node_Loc (N_HDL_Expr);
+ Set_Location (Res, Iirs.Get_Location (N));
+ Set_HDL_Node (Res, Int32 (N));
+ return Res;
+ end Vhdl_To_Psl;
+
+ function Parse_FL_Property (Prio : Priority) return Node;
+ function Parse_Sequence return Node;
+
+ function Parse_Parenthesis_Boolean return Node;
+ function Parse_Boolean (Parent_Prio : Priority) return Node;
+
+ function Parse_Unary_Boolean return Node is
+ begin
+ return Vhdl_To_Psl (Parse.Parse_Expression);
+ end Parse_Unary_Boolean;
+
+ function Parse_Boolean_Rhs (Parent_Prio : Priority; Left : Node) return Node
+ is
+ Kind : Nkind;
+ Prio : Priority;
+ Res : Node;
+ Tmp : Node;
+ begin
+ Res := Left;
+ loop
+ case Current_Token is
+ when Tok_And =>
+ Kind := N_And_Bool;
+ Prio := Prio_Seq_And;
+ when Tok_Or =>
+ Kind := N_Or_Bool;
+ Prio := Prio_Seq_Or;
+ when others =>
+ return Res;
+ end case;
+ if Parent_Prio >= Prio then
+ return Res;
+ end if;
+ Tmp := Create_Node_Loc (Kind);
+ Scan;
+ Set_Left (Tmp, Res);
+ Res := Tmp;
+ Tmp := Parse_Boolean (Prio);
+ Set_Right (Res, Tmp);
+ end loop;
+ end Parse_Boolean_Rhs;
+
+ function Parse_Boolean (Parent_Prio : Priority) return Node
+ is
+ begin
+ return Parse_Boolean_Rhs (Parent_Prio, Parse_Unary_Boolean);
+ end Parse_Boolean;
+
+ function Parse_Psl_Boolean return PSL_Node is
+ begin
+ return Parse_Boolean (Prio_Lowest);
+ end Parse_Psl_Boolean;
+
+ function Parse_Parenthesis_Boolean return Node is
+ Res : Node;
+ begin
+ if Current_Token /= Tok_Left_Paren then
+ Error_Msg_Parse ("'(' expected before boolean expression");
+ return Null_Node;
+ else
+ Scan;
+ Res := Parse_Psl_Boolean;
+ if Current_Token = Tok_Right_Paren then
+ Scan;
+ else
+ Error_Msg_Parse ("missing matching ')' for boolean expression");
+ end if;
+ return Res;
+ end if;
+ end Parse_Parenthesis_Boolean;
+
+ function Parse_SERE (Prio : Priority) return Node is
+ Left, Res : Node;
+ Kind : Nkind;
+ Op_Prio : Priority;
+ begin
+ Left := Parse_Sequence; -- FIXME: allow boolean;
+ loop
+ case Current_Token is
+ when Tok_Semi_Colon =>
+ Kind := N_Concat_SERE;
+ Op_Prio := Prio_Seq_Concat;
+ when Tok_Colon =>
+ Kind := N_Fusion_SERE;
+ Op_Prio := Prio_Seq_Fusion;
+ when Tok_Within =>
+ Kind := N_Within_SERE;
+ Op_Prio := Prio_Seq_Within;
+ when Tok_Ampersand =>
+ -- For non-length matching and, the operator is '&'.
+ Kind := N_And_Seq;
+ Op_Prio := Prio_Seq_And;
+ when Tok_And_And =>
+ Kind := N_Match_And_Seq;
+ Op_Prio := Prio_Seq_And;
+ when Tok_Bar =>
+ Kind := N_Or_Seq;
+ Op_Prio := Prio_Seq_Or;
+-- when Tok_Bar_Bar =>
+-- Res := Create_Node_Loc (N_Or_Bool);
+-- Scan;
+-- Set_Left (Res, Left);
+-- Set_Right (Res, Parse_Boolean (Prio_Seq_Or));
+-- return Res;
+ when others =>
+ return Left;
+ end case;
+ if Prio >= Op_Prio then
+ return Left;
+ end if;
+ Res := Create_Node_Loc (Kind);
+ Scan;
+ Set_Left (Res, Left);
+ Set_Right (Res, Parse_SERE (Op_Prio));
+ Left := Res;
+ end loop;
+ end Parse_SERE;
+
+ -- precond: '{'
+ function Parse_Braced_SERE return Node is
+ Res : Node;
+ begin
+ if Current_Token /= Tok_Left_Curly then
+ raise Program_Error;
+ end if;
+ Res := Create_Node_Loc (N_Braced_SERE);
+ Scan;
+ Set_SERE (Res, Parse_SERE (Prio_Lowest));
+ if Current_Token /= Tok_Right_Curly then
+ Error_Msg_Parse ("missing '}' after braced SERE");
+ else
+ Scan;
+ end if;
+ return Res;
+ end Parse_Braced_SERE;
+
+ -- Parse [ Count ] ']'
+ function Parse_Maybe_Count (Kind : Nkind; Seq : Node) return Node is
+ N : Node;
+ begin
+ N := Create_Node_Loc (Kind);
+ Set_Sequence (N, Seq);
+ Scan;
+ if Current_Token /= Tok_Right_Bracket then
+ Parse_Count (N);
+ end if;
+ if Current_Token /= Tok_Right_Bracket then
+ Error_Msg_Parse ("missing ']'");
+ else
+ Scan;
+ end if;
+ return N;
+ end Parse_Maybe_Count;
+
+ procedure Parse_Bracket_Range (N : Node) is
+ begin
+ if Current_Token /= Tok_Left_Bracket then
+ Error_Msg_Parse ("'[' expected");
+ else
+ Scan;
+ Set_Low_Bound (N, Parse_Number);
+ if Current_Token /= Tok_To then
+ Error_Msg_Parse ("'to' expected in range after left bound");
+ else
+ Scan;
+ Set_High_Bound (N, Parse_Number);
+ end if;
+ if Current_Token /= Tok_Right_Bracket then
+ Error_Msg_Parse ("']' expected after range");
+ else
+ Scan;
+ end if;
+ end if;
+ end Parse_Bracket_Range;
+
+ function Parse_Bracket_Number return Node is
+ Res : Node;
+ begin
+ if Current_Token /= Tok_Left_Bracket then
+ Error_Msg_Parse ("'[' expected");
+ return Null_Node;
+ else
+ Scan;
+ Res := Parse_Number;
+ if Current_Token /= Tok_Right_Bracket then
+ Error_Msg_Parse ("']' expected after range");
+ else
+ Scan;
+ end if;
+ return Res;
+ end if;
+ end Parse_Bracket_Number;
+
+ function Parse_Sequence return Node is
+ Res, N : Node;
+ begin
+ case Current_Token is
+ when Tok_Left_Curly =>
+ Res := Parse_Braced_SERE;
+ when Tok_Brack_Star =>
+ return Parse_Maybe_Count (N_Star_Repeat_Seq, Null_Node);
+ when Tok_Left_Paren =>
+ Res := Parse_Parenthesis_Boolean;
+ if Current_Token = Tok_Or
+ or else Current_Token = Tok_And
+ then
+ Res := Parse_Boolean_Rhs (Prio_Lowest, Res);
+ end if;
+ when Tok_Brack_Plus_Brack =>
+ Res := Create_Node_Loc (N_Plus_Repeat_Seq);
+ Scan;
+ return Res;
+ when others =>
+ -- Repeated_SERE
+ Res := Parse_Unary_Boolean;
+ end case;
+ loop
+ case Current_Token is
+ when Tok_Brack_Star =>
+ Res := Parse_Maybe_Count (N_Star_Repeat_Seq, Res);
+ when Tok_Brack_Plus_Brack =>
+ N := Create_Node_Loc (N_Plus_Repeat_Seq);
+ Set_Sequence (N, Res);
+ Scan;
+ Res := N;
+ when Tok_Brack_Arrow =>
+ Res := Parse_Maybe_Count (N_Goto_Repeat_Seq, Res);
+ when Tok_Brack_Equal =>
+ N := Create_Node_Loc (N_Equal_Repeat_Seq);
+ Set_Sequence (N, Res);
+ Scan;
+ Parse_Count (N);
+ if Current_Token /= Tok_Right_Bracket then
+ Error_Msg_Parse ("missing ']'");
+ else
+ Scan;
+ end if;
+ Res := N;
+ when others =>
+ return Res;
+ end case;
+ end loop;
+ end Parse_Sequence;
+
+ -- precond: '('
+ -- postcond: next token
+ function Parse_Parenthesis_FL_Property return Node is
+ Res : Node;
+ Loc : Location_Type;
+ begin
+ Loc := Get_Token_Location;
+ if Current_Token /= Tok_Left_Paren then
+ Error_Msg_Parse ("'(' expected around property");
+ return Parse_FL_Property (Prio_Lowest);
+ else
+ Scan;
+ Res := Parse_FL_Property (Prio_Lowest);
+ if Current_Token /= Tok_Right_Paren then
+ Error_Msg_Parse ("missing matching ')' for '(' at line "
+ & Get_Location_Str (Loc, False));
+ else
+ Scan;
+ end if;
+ return Res;
+ end if;
+ end Parse_Parenthesis_FL_Property;
+
+ -- Parse [ '!' ] '[' finite_Range ']' '(' FL_Property ')'
+ function Parse_Range_Property (K : Nkind) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node_Loc (K);
+ Set_Strong_Flag (Res, Scan_Exclam_Mark);
+ Scan;
+ Parse_Bracket_Range (Res);
+ Set_Property (Res, Parse_Parenthesis_FL_Property);
+ return Res;
+ end Parse_Range_Property;
+
+ -- Parse [ '!' ] '(' Boolean ')' '[' Range ']' '(' FL_Property ')'
+ function Parse_Boolean_Range_Property (K : Nkind) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node_Loc (K);
+ Set_Strong_Flag (Res, Scan_Exclam_Mark);
+ Scan;
+ Set_Boolean (Res, Parse_Parenthesis_Boolean);
+ Parse_Bracket_Range (Res);
+ Set_Property (Res, Parse_Parenthesis_FL_Property);
+ return Res;
+ end Parse_Boolean_Range_Property;
+
+ function Parse_FL_Property_1 return Node
+ is
+ Res : Node;
+ Tmp : Node;
+ begin
+ case Current_Token is
+ when Tok_Always =>
+ Res := Create_Node_Loc (N_Always);
+ Scan;
+ Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance));
+ when Tok_Never =>
+ Res := Create_Node_Loc (N_Never);
+ Scan;
+ Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance));
+ when Tok_Eventually =>
+ Res := Create_Node_Loc (N_Eventually);
+ if not Scan_Exclam_Mark then
+ Error_Msg_Parse ("'eventually' must be followed by '!'");
+ end if;
+ Scan;
+ Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence));
+ when Tok_Next =>
+ Res := Create_Node_Loc (N_Next);
+ Scan;
+ if Current_Token = Tok_Left_Bracket then
+ Set_Number (Res, Parse_Bracket_Number);
+ Set_Property (Res, Parse_Parenthesis_FL_Property);
+ else
+ Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence));
+ end if;
+ when Tok_Next_A =>
+ Res := Parse_Range_Property (N_Next_A);
+ when Tok_Next_E =>
+ Res := Parse_Range_Property (N_Next_E);
+ when Tok_Next_Event =>
+ Res := Create_Node_Loc (N_Next_Event);
+ Scan;
+ Set_Boolean (Res, Parse_Parenthesis_Boolean);
+ if Current_Token = Tok_Left_Bracket then
+ Set_Number (Res, Parse_Bracket_Number);
+ end if;
+ Set_Property (Res, Parse_Parenthesis_FL_Property);
+ when Tok_Next_Event_A =>
+ Res := Parse_Boolean_Range_Property (N_Next_Event_A);
+ when Tok_Next_Event_E =>
+ Res := Parse_Boolean_Range_Property (N_Next_Event_E);
+ when Tok_Left_Paren =>
+ return Parse_Parenthesis_FL_Property;
+ when Tok_Left_Curly =>
+ Res := Parse_Sequence;
+ if Get_Kind (Res) = N_Braced_SERE
+ and then Current_Token = Tok_Left_Paren
+ then
+ -- FIXME: must check that RES is really a sequence
+ -- (and not a SERE).
+ Tmp := Create_Node_Loc (N_Overlap_Imp_Seq);
+ Set_Sequence (Tmp, Res);
+ Set_Property (Tmp, Parse_Parenthesis_FL_Property);
+ Res := Tmp;
+ end if;
+ when others =>
+ Res := Parse_Sequence;
+ end case;
+ return Res;
+ end Parse_FL_Property_1;
+
+ function Parse_St_Binary_FL_Property (K : Nkind; Left : Node) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node_Loc (K);
+ Set_Strong_Flag (Res, Scan_Exclam_Mark);
+ Set_Inclusive_Flag (Res, Scan_Underscore);
+ Scan;
+ Set_Left (Res, Left);
+ Set_Right (Res, Parse_FL_Property (Prio_FL_Bounding));
+ return Res;
+ end Parse_St_Binary_FL_Property;
+
+ function Parse_Binary_FL_Property (K : Nkind; Left : Node; Prio : Priority)
+ return Node
+ is
+ Res : Node;
+ begin
+ Res := Create_Node_Loc (K);
+ Scan;
+ Set_Left (Res, Left);
+ Set_Right (Res, Parse_FL_Property (Prio));
+ return Res;
+ end Parse_Binary_FL_Property;
+
+ function Parse_FL_Property (Prio : Priority) return Node
+ is
+ Res : Node;
+ N : Node;
+ begin
+ Res := Parse_FL_Property_1;
+ loop
+ case Current_Token is
+ when Tok_Minus_Greater =>
+ if Prio > Prio_Bool_Imp then
+ return Res;
+ end if;
+ N := Create_Node_Loc (N_Log_Imp_Prop);
+ Set_Left (N, Res);
+ Scan;
+ Set_Right (N, Parse_FL_Property (Prio_Bool_Imp));
+ Res := N;
+ when Tok_Bar_Arrow =>
+ if Prio > Prio_Seq_Imp then
+ return Res;
+ end if;
+ N := Create_Node_Loc (N_Overlap_Imp_Seq);
+ Set_Sequence (N, Res);
+ Scan;
+ Set_Property (N, Parse_FL_Property (Prio_Seq_Imp));
+ Res := N;
+ when Tok_Bar_Double_Arrow =>
+ if Prio > Prio_Seq_Imp then
+ return Res;
+ end if;
+ N := Create_Node_Loc (N_Imp_Seq);
+ Set_Sequence (N, Res);
+ Scan;
+ Set_Property (N, Parse_FL_Property (Prio_Seq_Imp));
+ Res := N;
+ when Tok_Abort =>
+ if Prio > Prio_FL_Abort then
+ return Res;
+ end if;
+ N := Create_Node_Loc (N_Abort);
+ Set_Property (N, Res);
+ Scan;
+ Set_Boolean (N, Parse_Boolean (Prio_Lowest));
+ -- Left associative.
+ return N;
+ when Tok_Exclam_Mark =>
+ N := Create_Node_Loc (N_Strong);
+ Set_Property (N, Res);
+ Scan;
+ Res := N;
+ when Tok_Until =>
+ if Prio > Prio_FL_Bounding then
+ return Res;
+ end if;
+ Res := Parse_St_Binary_FL_Property (N_Until, Res);
+ when Tok_Before =>
+ if Prio > Prio_FL_Bounding then
+ return Res;
+ end if;
+ Res := Parse_St_Binary_FL_Property (N_Before, Res);
+ when Tok_Or =>
+ if Prio > Prio_Seq_Or then
+ return Res;
+ end if;
+ Res := Parse_Binary_FL_Property (N_Or_Prop, Res, Prio_Seq_Or);
+ when Tok_And =>
+ if Prio > Prio_Seq_And then
+ return Res;
+ end if;
+ Res := Parse_Binary_FL_Property (N_And_Prop, Res, Prio_Seq_And);
+ when Token_Relational_Operator_Type =>
+ return Vhdl_To_Psl
+ (Parse.Parse_Relation_Rhs (Psl_To_Vhdl (Res)));
+ when Tok_Colon
+ | Tok_Bar
+ | Tok_Ampersand
+ | Tok_And_And =>
+ Error_Msg_Parse ("SERE operator '" & Image (Current_Token)
+ & "' is not allowed in property");
+ Scan;
+ N := Parse_FL_Property (Prio_Lowest);
+ return Res;
+ when Tok_Arobase =>
+ if Prio > Prio_Clock_Event then
+ return Res;
+ end if;
+ N := Create_Node_Loc (N_Clock_Event);
+ Set_Property (N, Res);
+ Scan;
+ Set_Boolean (N, Parse_Boolean (Prio_Clock_Event));
+ Res := N;
+ when others =>
+ return Res;
+ end case;
+ end loop;
+ end Parse_FL_Property;
+
+ function Parse_Psl_Property return PSL_Node is
+ begin
+ return Parse_FL_Property (Prio_Lowest);
+ end Parse_Psl_Property;
+
+ -- precond: identifier
+ -- postcond: ';'
+ --
+ -- 6.2.4.1 Property declaration
+ --
+ -- Property_Declaration ::=
+ -- PROPERTY psl_identifier [ ( Formal_Parameter_List ) ] DEF_SYM
+ -- property ;
+ function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node
+ is
+ Res : Node;
+ Param : Node;
+ Last_Param : Node;
+ Pkind : Nkind;
+ Kind : Nkind;
+ begin
+ case Tok is
+ when Tok_Psl_Property =>
+ Kind := N_Property_Declaration;
+ when Tok_Psl_Sequence =>
+ Kind := N_Sequence_Declaration;
+ when Tok_Psl_Endpoint =>
+ Kind := N_Endpoint_Declaration;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Res := Create_Node_Loc (Kind);
+ if Current_Token = Tok_Identifier then
+ Set_Identifier (Res, Current_Identifier);
+ Scan;
+ end if;
+
+ -- Formal parameter list.
+ if Current_Token = Tok_Left_Paren then
+ Last_Param := Null_Node;
+ loop
+ -- precond: '(' or ';'.
+ Scan;
+ case Current_Token is
+ when Tok_Psl_Const =>
+ Pkind := N_Const_Parameter;
+ when Tok_Psl_Boolean =>
+ Pkind := N_Boolean_Parameter;
+ when Tok_Psl_Property =>
+ Pkind := N_Property_Parameter;
+ when Tok_Psl_Sequence =>
+ Pkind := N_Sequence_Parameter;
+ when others =>
+ Error_Msg_Parse ("parameter type expected");
+ end case;
+
+ -- Formal parameters.
+ loop
+ -- precond: parameter_type or ','
+ Scan;
+ Param := Create_Node_Loc (Pkind);
+ if Current_Token /= Tok_Identifier then
+ Error_Msg_Parse ("identifier for parameter expected");
+ else
+ Set_Identifier (Param, Current_Identifier);
+ end if;
+ if Last_Param = Null_Node then
+ Set_Parameter_List (Res, Param);
+ else
+ Set_Chain (Last_Param, Param);
+ end if;
+ Last_Param := Param;
+ Scan;
+ exit when Current_Token /= Tok_Comma;
+ end loop;
+ exit when Current_Token = Tok_Right_Paren;
+ if Current_Token /= Tok_Semi_Colon then
+ Error_Msg_Parse ("';' expected between formal parameter");
+ end if;
+
+ end loop;
+ Scan;
+ end if;
+
+ if Current_Token /= Tok_Is then
+ Error_Msg_Parse ("'is' expected after identifier");
+ else
+ Scan;
+ end if;
+ case Kind is
+ when N_Property_Declaration =>
+ Set_Property (Res, Parse_Psl_Property);
+ when N_Sequence_Declaration
+ | N_Endpoint_Declaration =>
+ Set_Sequence (Res, Parse_Sequence);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Parse_Psl_Declaration;
+end Parse_Psl;
diff --git a/src/parse_psl.ads b/src/parse_psl.ads
new file mode 100644
index 000000000..62869feb8
--- /dev/null
+++ b/src/parse_psl.ads
@@ -0,0 +1,26 @@
+-- VHDL PSL parser.
+-- 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 Tokens; use Tokens;
+
+package Parse_Psl is
+ function Parse_Psl_Property return PSL_Node;
+ function Parse_Psl_Boolean return PSL_Node;
+ function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node;
+end Parse_Psl;
diff --git a/src/post_sems.adb b/src/post_sems.adb
new file mode 100644
index 000000000..78eda5015
--- /dev/null
+++ b/src/post_sems.adb
@@ -0,0 +1,71 @@
+-- Global checks after semantization 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 Types; use Types;
+with Std_Names; use Std_Names;
+with Ieee.Std_Logic_1164;
+with Ieee.Vital_Timing;
+with Flags; use Flags;
+
+package body Post_Sems is
+ procedure Post_Sem_Checks (Unit : Iir_Design_Unit)
+ is
+ Lib_Unit : constant Iir := Get_Library_Unit (Unit);
+ Lib : Iir_Library_Declaration;
+ Id : Name_Id;
+
+ Value : Iir_Attribute_Value;
+ Spec : Iir_Attribute_Specification;
+ Attr_Decl : Iir_Attribute_Declaration;
+ begin
+ -- No checks on package bodies.
+ if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then
+ return;
+ end if;
+
+ Id := Get_Identifier (Lib_Unit);
+ Lib := Get_Library (Get_Design_File (Unit));
+
+ if Get_Identifier (Lib) = Name_Ieee then
+ -- This is a unit of IEEE.
+ if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then
+ if Id = Name_Std_Logic_1164 then
+ Ieee.Std_Logic_1164.Extract_Declarations (Lib_Unit);
+ elsif Id = Name_VITAL_Timing then
+ Ieee.Vital_Timing.Extract_Declarations (Lib_Unit);
+ end if;
+ end if;
+ end if;
+
+ -- Look for VITAL attributes.
+ if Flag_Vital_Checks then
+ Value := Get_Attribute_Value_Chain (Lib_Unit);
+ while Value /= Null_Iir loop
+ Spec := Get_Attribute_Specification (Value);
+ Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Spec));
+ if Attr_Decl = Ieee.Vital_Timing.Vital_Level0_Attribute then
+ Ieee.Vital_Timing.Check_Vital_Level0 (Unit);
+ elsif Attr_Decl = Ieee.Vital_Timing.Vital_Level1_Attribute then
+ Ieee.Vital_Timing.Check_Vital_Level1 (Unit);
+ end if;
+
+ Value := Get_Chain (Value);
+ end loop;
+ end if;
+ end Post_Sem_Checks;
+end Post_Sems;
+
diff --git a/src/post_sems.ads b/src/post_sems.ads
new file mode 100644
index 000000000..ed042264e
--- /dev/null
+++ b/src/post_sems.ads
@@ -0,0 +1,25 @@
+-- Global checks after semantization 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 Post_Sems is
+ -- Do post semantization checks, such as VITAL checks.
+ -- This procedure is also used to extract declarations from ieee
+ -- packages.
+ procedure Post_Sem_Checks (Unit : Iir_Design_Unit);
+end Post_Sems;
diff --git a/src/psl-errors.ads b/src/psl-errors.ads
new file mode 100644
index 000000000..e99bb7de6
--- /dev/null
+++ b/src/psl-errors.ads
@@ -0,0 +1,3 @@
+with Errorout;
+
+package PSL.Errors renames Errorout;
diff --git a/src/psl/psl-build.adb b/src/psl/psl-build.adb
new file mode 100644
index 000000000..c3e47baa6
--- /dev/null
+++ b/src/psl/psl-build.adb
@@ -0,0 +1,1009 @@
+with GNAT.Table;
+with Ada.Text_IO; use Ada.Text_IO;
+with Types; use Types;
+with PSL.Errors; use PSL.Errors;
+with PSL.CSE; use PSL.CSE;
+with PSL.QM;
+with PSL.Disp_NFAs; use PSL.Disp_NFAs;
+with PSL.Optimize; use PSL.Optimize;
+with PSL.NFAs.Utils;
+with PSL.Prints;
+with PSL.NFAs; use PSL.NFAs;
+
+package body PSL.Build is
+ function Build_SERE_FA (N : Node) return NFA;
+
+
+ package Intersection is
+ function Build_Inter (L, R : NFA; Match_Len : Boolean) return NFA;
+ end Intersection;
+
+ package body Intersection is
+
+ type Stack_Entry_Id is new Natural;
+ No_Stack_Entry : constant Stack_Entry_Id := 0;
+ type Stack_Entry is record
+ L, R : NFA_State;
+ Res : NFA_State;
+ Next_Unhandled : Stack_Entry_Id;
+ end record;
+
+ package Stackt is new GNAT.Table
+ (Table_Component_Type => Stack_Entry,
+ Table_Index_Type => Stack_Entry_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ First_Unhandled : Stack_Entry_Id;
+
+ procedure Init_Stack is
+ begin
+ Stackt.Init;
+ First_Unhandled := No_Stack_Entry;
+ end Init_Stack;
+
+ function Not_Empty return Boolean is
+ begin
+ return First_Unhandled /= No_Stack_Entry;
+ end Not_Empty;
+
+ procedure Pop_State (L, R : out NFA_State) is
+ begin
+ L := Stackt.Table (First_Unhandled).L;
+ R := Stackt.Table (First_Unhandled).R;
+ First_Unhandled := Stackt.Table (First_Unhandled).Next_Unhandled;
+ end Pop_State;
+
+ function Get_State (N : NFA; L, R : NFA_State) return NFA_State
+ is
+ Res : NFA_State;
+ begin
+ for I in Stackt.First .. Stackt.Last loop
+ if Stackt.Table (I).L = L
+ and then Stackt.Table (I).R = R
+ then
+ return Stackt.Table (I).Res;
+ end if;
+ end loop;
+ Res := Add_State (N);
+ Stackt.Append ((L => L, R => R, Res => Res,
+ Next_Unhandled => First_Unhandled));
+ First_Unhandled := Stackt.Last;
+ return Res;
+ end Get_State;
+
+ function Build_Inter (L, R : NFA; Match_Len : Boolean) return NFA
+ is
+ Start_L, Start_R : NFA_State;
+ Final_L, Final_R : NFA_State;
+ S_L, S_R : NFA_State;
+ E_L, E_R : NFA_Edge;
+ Res : NFA;
+ Start : NFA_State;
+ Extra_L, Extra_R : NFA_Edge;
+ begin
+ Start_L := Get_Start_State (L);
+ Start_R := Get_Start_State (R);
+ Final_R := Get_Final_State (R);
+ Final_L := Get_Final_State (L);
+
+ if False then
+ Disp_Body (L);
+ Disp_Body (R);
+ Put ("//start state: ");
+ Disp_State (Start_L);
+ Put (",");
+ Disp_State (Start_R);
+ New_Line;
+ end if;
+
+ if Match_Len then
+ Extra_L := No_Edge;
+ Extra_R := No_Edge;
+ else
+ Extra_L := Add_Edge (Final_L, Final_L, True_Node);
+ Extra_R := Add_Edge (Final_R, Final_R, True_Node);
+ end if;
+
+ Res := Create_NFA;
+ Init_Stack;
+ Start := Get_State (Res, Start_L, Start_R);
+ Set_Start_State (Res, Start);
+
+ while Not_Empty loop
+ Pop_State (S_L, S_R);
+
+ if False then
+ Put ("//poped state: ");
+ Disp_State (S_L);
+ Put (",");
+ Disp_State (S_R);
+ New_Line;
+ end if;
+
+ E_L := Get_First_Src_Edge (S_L);
+ while E_L /= No_Edge loop
+ E_R := Get_First_Src_Edge (S_R);
+ while E_R /= No_Edge loop
+ if not (E_L = Extra_L and E_R = Extra_R) then
+ Add_Edge (Get_State (Res, S_L, S_R),
+ Get_State (Res,
+ Get_Edge_Dest (E_L),
+ Get_Edge_Dest (E_R)),
+ Build_Bool_And (Get_Edge_Expr (E_L),
+ Get_Edge_Expr (E_R)));
+ end if;
+ E_R := Get_Next_Src_Edge (E_R);
+ end loop;
+ E_L := Get_Next_Src_Edge (E_L);
+ end loop;
+ end loop;
+ Set_Final_State (Res, Get_State (Res, Final_L, Final_R));
+ Remove_Unreachable_States (Res);
+
+ if not Match_Len then
+ Remove_Edge (Extra_L);
+ Remove_Edge (Extra_R);
+ end if;
+
+ -- FIXME: free L and R.
+ return Res;
+ end Build_Inter;
+ end Intersection;
+
+ -- All edges from A are duplicated using B as a source.
+ -- Handle epsilon-edges.
+ procedure Duplicate_Src_Edges (N : NFA; A, B : NFA_State)
+ is
+ pragma Unreferenced (N);
+ E : NFA_Edge;
+ Expr : Node;
+ Dest : NFA_State;
+ begin
+ pragma Assert (A /= B);
+ E := Get_First_Src_Edge (A);
+ while E /= No_Edge loop
+ Expr := Get_Edge_Expr (E);
+ Dest := Get_Edge_Dest (E);
+ if Expr /= Null_Node then
+ Add_Edge (B, Dest, Expr);
+ end if;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ end Duplicate_Src_Edges;
+
+ -- All edges to A are duplicated using B as a destination.
+ -- Handle epsilon-edges.
+ procedure Duplicate_Dest_Edges (N : NFA; A, B : NFA_State)
+ is
+ pragma Unreferenced (N);
+ E : NFA_Edge;
+ Expr : Node;
+ Src : NFA_State;
+ begin
+ pragma Assert (A /= B);
+ E := Get_First_Dest_Edge (A);
+ while E /= No_Edge loop
+ Expr := Get_Edge_Expr (E);
+ Src := Get_Edge_Src (E);
+ if Expr /= Null_Node then
+ Add_Edge (Src, B, Expr);
+ end if;
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+ end Duplicate_Dest_Edges;
+
+ procedure Remove_Epsilon_Edge (N : NFA; S, D : NFA_State) is
+ begin
+ if Get_First_Src_Edge (S) = No_Edge then
+ -- No edge from S.
+ -- Move edges to S to D.
+ Redest_Edges (S, D);
+ Remove_Unconnected_State (N, S);
+ if Get_Start_State (N) = S then
+ Set_Start_State (N, D);
+ end if;
+ elsif Get_First_Dest_Edge (D) = No_Edge then
+ -- No edge to D.
+ -- Move edges from D to S.
+ Resource_Edges (D, S);
+ Remove_Unconnected_State (N, D);
+ if Get_Final_State (N) = D then
+ Set_Final_State (N, S);
+ end if;
+ else
+ Duplicate_Dest_Edges (N, S, D);
+ Duplicate_Src_Edges (N, D, S);
+ Remove_Identical_Src_Edges (S);
+ end if;
+ end Remove_Epsilon_Edge;
+
+ procedure Remove_Epsilon (N : NFA;
+ E : NFA_Edge) is
+ S : constant NFA_State := Get_Edge_Src (E);
+ D : constant NFA_State := Get_Edge_Dest (E);
+ begin
+ Remove_Edge (E);
+
+ Remove_Epsilon_Edge (N, S, D);
+ end Remove_Epsilon;
+
+ function Build_Concat (L, R : NFA) return NFA
+ is
+ Start_L, Start_R : NFA_State;
+ Final_L, Final_R : NFA_State;
+ Eps_L, Eps_R : Boolean;
+ E_L, E_R : NFA_Edge;
+ begin
+ Start_L := Get_Start_State (L);
+ Start_R := Get_Start_State (R);
+ Final_R := Get_Final_State (R);
+ Final_L := Get_Final_State (L);
+ Eps_L := Get_Epsilon_NFA (L);
+ Eps_R := Get_Epsilon_NFA (R);
+
+ Merge_NFA (L, R);
+
+ Set_Start_State (L, Start_L);
+ Set_Final_State (L, Final_R);
+ Set_Epsilon_NFA (L, False);
+
+ if Eps_L then
+ E_L := Add_Edge (Start_L, Final_L, Null_Node);
+ end if;
+
+ if Eps_R then
+ E_R := Add_Edge (Start_R, Final_R, Null_Node);
+ end if;
+
+ Remove_Epsilon_Edge (L, Final_L, Start_R);
+
+ if Eps_L then
+ Remove_Epsilon (L, E_L);
+ end if;
+ if Eps_R then
+ Remove_Epsilon (L, E_R);
+ end if;
+
+ if (Start_L = Final_L or else Eps_L)
+ and then (Start_R = Final_R or else Eps_R)
+ then
+ Set_Epsilon_NFA (L, True);
+ end if;
+
+ Remove_Identical_Src_Edges (Final_L);
+ Remove_Identical_Dest_Edges (Start_R);
+
+ return L;
+ end Build_Concat;
+
+ function Build_Or (L, R : NFA) return NFA
+ is
+ Start_L, Start_R : NFA_State;
+ Final_L, Final_R : NFA_State;
+ Eps : Boolean;
+ Start, Final : NFA_State;
+ E_S_L, E_S_R, E_L_F, E_R_F : NFA_Edge;
+ begin
+ Start_L := Get_Start_State (L);
+ Start_R := Get_Start_State (R);
+ Final_R := Get_Final_State (R);
+ Final_L := Get_Final_State (L);
+ Eps := Get_Epsilon_NFA (L) or Get_Epsilon_NFA (R);
+
+ -- Optimize [*0] | R.
+ if Start_L = Final_L
+ and then Get_First_Src_Edge (Start_L) = No_Edge
+ then
+ if Start_R /= Final_R then
+ Set_Epsilon_NFA (R, True);
+ end if;
+ -- FIXME
+ -- delete_NFA (L);
+ return R;
+ end if;
+
+ Merge_NFA (L, R);
+
+ -- Use Thompson construction.
+ Start := Add_State (L);
+ Set_Start_State (L, Start);
+ E_S_L := Add_Edge (Start, Start_L, Null_Node);
+ E_S_R := Add_Edge (Start, Start_R, Null_Node);
+
+ Final := Add_State (L);
+ Set_Final_State (L, Final);
+ E_L_F := Add_Edge (Final_L, Final, Null_Node);
+ E_R_F := Add_Edge (Final_R, Final, Null_Node);
+
+ Set_Epsilon_NFA (L, Eps);
+
+ Remove_Epsilon (L, E_S_L);
+ Remove_Epsilon (L, E_S_R);
+ Remove_Epsilon (L, E_L_F);
+ Remove_Epsilon (L, E_R_F);
+
+ return L;
+ end Build_Or;
+
+ function Build_Fusion (L, R : NFA) return NFA
+ is
+ Start_R : NFA_State;
+ Final_L, Final_R, S_L : NFA_State;
+ E_L : NFA_Edge;
+ E_R : NFA_Edge;
+ N_L, Expr : Node;
+ begin
+ Start_R := Get_Start_State (R);
+ Final_R := Get_Final_State (R);
+ Final_L := Get_Final_State (L);
+
+ Merge_NFA (L, R);
+
+ E_L := Get_First_Dest_Edge (Final_L);
+ while E_L /= No_Edge loop
+ S_L := Get_Edge_Src (E_L);
+ N_L := Get_Edge_Expr (E_L);
+
+ E_R := Get_First_Src_Edge (Start_R);
+ while E_R /= No_Edge loop
+ Expr := Build_Bool_And (N_L, Get_Edge_Expr (E_R));
+ Expr := PSL.QM.Reduce (Expr);
+ if Expr /= False_Node then
+ Add_Edge (S_L, Get_Edge_Dest (E_R), Expr);
+ end if;
+ E_R := Get_Next_Src_Edge (E_R);
+ end loop;
+ Remove_Identical_Src_Edges (S_L);
+ E_L := Get_Next_Dest_Edge (E_L);
+ end loop;
+
+ Set_Final_State (L, Final_R);
+
+ Set_Epsilon_NFA (L, False);
+
+ if Get_First_Src_Edge (Final_L) = No_Edge then
+ Remove_State (L, Final_L);
+ end if;
+ if Get_First_Dest_Edge (Start_R) = No_Edge then
+ Remove_State (L, Start_R);
+ end if;
+
+ return L;
+ end Build_Fusion;
+
+ function Build_Star_Repeat (N : Node) return NFA is
+ Res : NFA;
+ Start, Final, S : NFA_State;
+ Seq : Node;
+ begin
+ Seq := Get_Sequence (N);
+ if Seq = Null_Node then
+ -- Epsilon.
+ Res := Create_NFA;
+ S := Add_State (Res);
+ Set_Start_State (Res, S);
+ Set_Final_State (Res, S);
+ return Res;
+ end if;
+ Res := Build_SERE_FA (Seq);
+ Start := Get_Start_State (Res);
+ Final := Get_Final_State (Res);
+ Redest_Edges (Final, Start);
+ Set_Final_State (Res, Start);
+ Remove_Unconnected_State (Res, Final);
+ Set_Epsilon_NFA (Res, False);
+ return Res;
+ end Build_Star_Repeat;
+
+ function Build_Plus_Repeat (N : Node) return NFA is
+ Res : NFA;
+ Start, Final : NFA_State;
+ T : NFA_Edge;
+ begin
+ Res := Build_SERE_FA (Get_Sequence (N));
+ Start := Get_Start_State (Res);
+ Final := Get_Final_State (Res);
+ T := Get_First_Dest_Edge (Final);
+ while T /= No_Edge loop
+ Add_Edge (Get_Edge_Src (T), Start, Get_Edge_Expr (T));
+ T := Get_Next_Src_Edge (T);
+ end loop;
+ return Res;
+ end Build_Plus_Repeat;
+
+ -- Association actual to formals, so that when a formal is referenced, the
+ -- actual can be used instead.
+ procedure Assoc_Instance (Decl : Node; Instance : Node)
+ is
+ Formal : Node;
+ Actual : Node;
+ begin
+ -- Temporary associates actuals to formals.
+ Formal := Get_Parameter_List (Decl);
+ Actual := Get_Association_Chain (Instance);
+ while Formal /= Null_Node loop
+ if Actual = Null_Node then
+ -- Not enough actual.
+ raise Internal_Error;
+ end if;
+ if Get_Actual (Formal) /= Null_Node then
+ -- Recursion
+ raise Internal_Error;
+ end if;
+ Set_Actual (Formal, Get_Actual (Actual));
+ Formal := Get_Chain (Formal);
+ Actual := Get_Chain (Actual);
+ end loop;
+ if Actual /= Null_Node then
+ -- Too many actual.
+ raise Internal_Error;
+ end if;
+ end Assoc_Instance;
+
+ procedure Unassoc_Instance (Decl : Node)
+ is
+ Formal : Node;
+ begin
+ -- Remove temporary association.
+ Formal := Get_Parameter_List (Decl);
+ while Formal /= Null_Node loop
+ Set_Actual (Formal, Null_Node);
+ Formal := Get_Chain (Formal);
+ end loop;
+ end Unassoc_Instance;
+
+ function Build_SERE_FA (N : Node) return NFA
+ is
+ Res : NFA;
+ S1, S2 : NFA_State;
+ begin
+ case Get_Kind (N) is
+ when N_Booleans =>
+ Res := Create_NFA;
+ S1 := Add_State (Res);
+ S2 := Add_State (Res);
+ Set_Start_State (Res, S1);
+ Set_Final_State (Res, S2);
+ if N /= False_Node then
+ Add_Edge (S1, S2, N);
+ end if;
+ return Res;
+ when N_Braced_SERE =>
+ return Build_SERE_FA (Get_SERE (N));
+ when N_Concat_SERE =>
+ return Build_Concat (Build_SERE_FA (Get_Left (N)),
+ Build_SERE_FA (Get_Right (N)));
+ when N_Fusion_SERE =>
+ return Build_Fusion (Build_SERE_FA (Get_Left (N)),
+ Build_SERE_FA (Get_Right (N)));
+ when N_Match_And_Seq =>
+ return Intersection.Build_Inter (Build_SERE_FA (Get_Left (N)),
+ Build_SERE_FA (Get_Right (N)),
+ True);
+ when N_And_Seq =>
+ return Intersection.Build_Inter (Build_SERE_FA (Get_Left (N)),
+ Build_SERE_FA (Get_Right (N)),
+ False);
+ when N_Or_Prop
+ | N_Or_Seq =>
+ return Build_Or (Build_SERE_FA (Get_Left (N)),
+ Build_SERE_FA (Get_Right (N)));
+ when N_Star_Repeat_Seq =>
+ return Build_Star_Repeat (N);
+ when N_Plus_Repeat_Seq =>
+ return Build_Plus_Repeat (N);
+ when N_Sequence_Instance
+ | N_Endpoint_Instance =>
+ declare
+ Decl : Node;
+ begin
+ Decl := Get_Declaration (N);
+ Assoc_Instance (Decl, N);
+ Res := Build_SERE_FA (Get_Sequence (Decl));
+ Unassoc_Instance (Decl);
+ return Res;
+ end;
+ when N_Boolean_Parameter
+ | N_Sequence_Parameter =>
+ declare
+ Actual : constant Node := Get_Actual (N);
+ begin
+ if Actual = Null_Node then
+ raise Internal_Error;
+ end if;
+ return Build_SERE_FA (Actual);
+ end;
+ when others =>
+ Error_Kind ("build_sere_fa", N);
+ end case;
+ end Build_SERE_FA;
+
+ function Count_Edges (S : NFA_State) return Natural
+ is
+ Res : Natural;
+ E : NFA_Edge;
+ begin
+ Res := 0;
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Res := Res + 1;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ return Res;
+ end Count_Edges;
+
+ type Count_Vector is array (Natural range <>) of Natural;
+
+ procedure Count_All_Edges (N : NFA; Res : out Count_Vector)
+ is
+ S : NFA_State;
+ begin
+ S := Get_First_State (N);
+ while S /= No_State loop
+ Res (Natural (Get_State_Label (S))) := Count_Edges (S);
+ S := Get_Next_State (S);
+ end loop;
+ end Count_All_Edges;
+
+ pragma Unreferenced (Count_All_Edges);
+
+ package Determinize is
+ -- Create a new NFA that reaches its final state only when N fails
+ -- (ie when the final state is not reached).
+ function Determinize (N : NFA) return NFA;
+ end Determinize;
+
+ package body Determinize is
+ -- In all the comments N stands for the initial NFA (ie the NFA to
+ -- determinize).
+
+ use Prints;
+
+ Flag_Trace : constant Boolean := False;
+ Last_Label : Int32 := 0;
+
+ -- The tree associates a set of states in N to *an* uniq set in the
+ -- result NFA.
+ --
+ -- As the NFA is labelized, each node represent a state in N, and has
+ -- two branches: one for state is present and one for state is absent.
+ --
+ -- The leaves contain the state in the result NFA.
+ --
+ -- The leaves are chained to create a stack of state to handle.
+ --
+ -- The root of the tree is node Start_Tree_Id and represent the start
+ -- state of N.
+ type Deter_Tree_Id is new Natural;
+ No_Tree_Id : constant Deter_Tree_Id := 0;
+ Start_Tree_Id : constant Deter_Tree_Id := 1;
+
+ -- List of unhanded leaves.
+ Deter_Head : Deter_Tree_Id;
+
+ type Deter_Tree_Id_Bool_Array is array (Boolean) of Deter_Tree_Id;
+
+ -- Node in the tree.
+ type Deter_Tree_Entry is record
+ Parent : Deter_Tree_Id;
+
+ -- For non-leaf:
+ Child : Deter_Tree_Id_Bool_Array;
+
+ -- For leaf:
+ Link : Deter_Tree_Id;
+ State : NFA_State;
+ -- + value ?
+ end record;
+
+ package Detert is new GNAT.Table
+ (Table_Component_Type => Deter_Tree_Entry,
+ Table_Index_Type => Deter_Tree_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ type Bool_Vector is array (Natural range <>) of Boolean;
+ pragma Pack (Bool_Vector);
+
+ -- Convert a set of states in N to a state in the result NFA.
+ -- The set is represented by a vector of boolean. An element of the
+ -- vector is true iff the corresponding state is present.
+ function Add_Vector (V : Bool_Vector; N : NFA) return NFA_State
+ is
+ E : Deter_Tree_Id;
+ Added : Boolean;
+ Res : NFA_State;
+ begin
+ E := Start_Tree_Id;
+ Added := False;
+ for I in V'Range loop
+ if Detert.Table (E).Child (V (I)) = No_Tree_Id then
+ Detert.Append ((Child => (No_Tree_Id, No_Tree_Id),
+ Parent => E,
+ Link => No_Tree_Id,
+ State => No_State));
+ Detert.Table (E).Child (V (I)) := Detert.Last;
+ E := Detert.Last;
+ Added := True;
+ else
+ E := Detert.Table (E).Child (V (I));
+ Added := False;
+ end if;
+ end loop;
+ if Added then
+ -- Create the new state.
+ Res := Add_State (N);
+ Detert.Table (E).State := Res;
+
+ if Flag_Trace then
+ Set_State_Label (Res, Last_Label);
+ Put ("Result state" & Int32'Image (Last_Label) & " for");
+ for I in V'Range loop
+ if V (I) then
+ Put (Natural'Image (I));
+ end if;
+ end loop;
+ New_Line;
+ Last_Label := Last_Label + 1;
+ end if;
+
+ -- Put it to the list of states to be handled.
+ Detert.Table (E).Link := Deter_Head;
+ Deter_Head := E;
+
+ return Res;
+ else
+ return Detert.Table (E).State;
+ end if;
+ end Add_Vector;
+
+ -- Return true iff the stack is empty (ie all the states have been
+ -- handled).
+ function Stack_Empty return Boolean is
+ begin
+ return Deter_Head = No_Tree_Id;
+ end Stack_Empty;
+
+ -- Get an element from the stack.
+ -- Extract the state in the result NFA.
+ -- Rebuild the set of states in N (ie rebuild the vector of states).
+ procedure Stack_Pop (V : out Bool_Vector; S : out NFA_State)
+ is
+ L, P : Deter_Tree_Id;
+ begin
+ L := Deter_Head;
+ pragma Assert (L /= No_Tree_Id);
+ S := Detert.Table (L).State;
+ Deter_Head := Detert.Table (L).Link;
+
+ for I in reverse V'Range loop
+ pragma Assert (L /= Start_Tree_Id);
+ P := Detert.Table (L).Parent;
+ if L = Detert.Table (P).Child (True) then
+ V (I) := True;
+ elsif L = Detert.Table (P).Child (False) then
+ V (I) := False;
+ else
+ raise Program_Error;
+ end if;
+ L := P;
+ end loop;
+ pragma Assert (L = Start_Tree_Id);
+ end Stack_Pop;
+
+ type State_Vector is array (Natural range <>) of Natural;
+ type Expr_Vector is array (Natural range <>) of Node;
+
+ procedure Build_Arcs (N : NFA;
+ State : NFA_State;
+ States : State_Vector;
+ Exprs : Expr_Vector;
+ Expr : Node;
+ V : Bool_Vector)
+ is
+ begin
+ if Expr = False_Node then
+ return;
+ end if;
+
+ if States'Length = 0 then
+ declare
+ Reduced_Expr : constant Node := PSL.QM.Reduce (Expr);
+ --Reduced_Expr : constant Node := Expr;
+ S : NFA_State;
+ begin
+ if Reduced_Expr = False_Node then
+ return;
+ end if;
+ S := Add_Vector (V, N);
+ Add_Edge (State, S, Reduced_Expr);
+ if Flag_Trace then
+ Put (" Add edge");
+ Put (Int32'Image (Get_State_Label (State)));
+ Put (" to");
+ Put (Int32'Image (Get_State_Label (S)));
+ Put (", expr=");
+ Dump_Expr (Expr);
+ Put (", reduced=");
+ Dump_Expr (Reduced_Expr);
+ New_Line;
+ end if;
+ end;
+ else
+ declare
+ N_States : State_Vector renames
+ States (States'First + 1 .. States'Last);
+ N_V : Bool_Vector (V'Range) := V;
+ S : constant Natural := States (States'First);
+ E : constant Node := Exprs (S);
+ begin
+ N_V (S) := True;
+ if Expr = Null_Node then
+ Build_Arcs (N, State, N_States, Exprs, E, N_V);
+ Build_Arcs (N, State, N_States, Exprs,
+ Build_Bool_Not (E), V);
+ else
+ Build_Arcs (N, State, N_States, Exprs,
+ Build_Bool_And (E, Expr), N_V);
+ Build_Arcs (N, State, N_States, Exprs,
+ Build_Bool_And (Build_Bool_Not (E), Expr), V);
+ end if;
+ end;
+ end if;
+ end Build_Arcs;
+
+ function Determinize_1 (N : NFA; Nbr_States : Natural) return NFA
+ is
+ Final : Natural;
+ V : Bool_Vector (0 .. Nbr_States - 1);
+ Exprs : Expr_Vector (0 .. Nbr_States - 1);
+ S : NFA_State;
+ E : NFA_Edge;
+ D : Natural;
+ Edge_Expr : Node;
+ Expr : Node;
+ Nbr_Dest : Natural;
+ States : State_Vector (0 .. Nbr_States - 1);
+ Res : NFA;
+ State : NFA_State;
+ begin
+ Final := Natural (Get_State_Label (Get_Final_State (N)));
+
+ -- FIXME: handle epsilon or final = start -> create an empty NFA.
+
+ -- Initialize the tree.
+ Res := Create_NFA;
+ Detert.Init;
+ Detert.Append ((Child => (No_Tree_Id, No_Tree_Id),
+ Parent => No_Tree_Id,
+ Link => No_Tree_Id,
+ State => No_State));
+ pragma Assert (Detert.Last = Start_Tree_Id);
+ Deter_Head := No_Tree_Id;
+
+ -- Put the initial state in the tree and in the stack.
+ -- FIXME: ok, we know that its label is 0.
+ V := (0 => True, others => False);
+ State := Add_Vector (V, Res);
+ Set_Start_State (Res, State);
+
+ -- The failure state. As there is nothing to do with this
+ -- state, remove it from the stack.
+ V := (others => False);
+ State := Add_Vector (V, Res);
+ Set_Final_State (Res, State);
+ Stack_Pop (V, State);
+
+ -- Iterate on states in the result NFA that haven't yet been handled.
+ while not Stack_Empty loop
+ Stack_Pop (V, State);
+
+ if Flag_Trace then
+ Put_Line ("Handle result state"
+ & Int32'Image (Get_State_Label (State)));
+ end if;
+
+ -- Build edges vector.
+ Exprs := (others => Null_Node);
+ Expr := Null_Node;
+
+ S := Get_First_State (N);
+ Nbr_Dest := 0;
+ while S /= No_State loop
+ if V (Natural (Get_State_Label (S))) then
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ D := Natural (Get_State_Label (Get_Edge_Dest (E)));
+ Edge_Expr := Get_Edge_Expr (E);
+
+ if False and Flag_Trace then
+ Put_Line (" edge" & Int32'Image (Get_State_Label (S))
+ & " to" & Natural'Image (D));
+ end if;
+
+ if D = Final then
+ Edge_Expr := Build_Bool_Not (Edge_Expr);
+ if Expr = Null_Node then
+ Expr := Edge_Expr;
+ else
+ Expr := Build_Bool_And (Expr, Edge_Expr);
+ end if;
+ else
+ if Exprs (D) = Null_Node then
+ Exprs (D) := Edge_Expr;
+ States (Nbr_Dest) := D;
+ Nbr_Dest := Nbr_Dest + 1;
+ else
+ Exprs (D) := Build_Bool_Or (Exprs (D),
+ Edge_Expr);
+ end if;
+ end if;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ end if;
+ S := Get_Next_State (S);
+ end loop;
+
+ if Flag_Trace then
+ Put (" Final: expr=");
+ Print_Expr (Expr);
+ New_Line;
+ for I in 0 .. Nbr_Dest - 1 loop
+ Put (" Dest");
+ Put (Natural'Image (States (I)));
+ Put (" expr=");
+ Print_Expr (Exprs (States (I)));
+ New_Line;
+ end loop;
+ end if;
+
+ -- Build arcs.
+ if not (Nbr_Dest = 0 and Expr = Null_Node) then
+ Build_Arcs (Res, State,
+ States (0 .. Nbr_Dest - 1), Exprs, Expr,
+ Bool_Vector'(0 .. Nbr_States - 1 => False));
+ end if;
+ end loop;
+
+ --Remove_Unreachable_States (Res);
+ return Res;
+ end Determinize_1;
+
+ function Determinize (N : NFA) return NFA
+ is
+ Nbr_States : Natural;
+ begin
+ Labelize_States (N, Nbr_States);
+
+ if Flag_Trace then
+ Put_Line ("NFA to determinize:");
+ Disp_NFA (N);
+ Last_Label := 0;
+ end if;
+
+ return Determinize_1 (N, Nbr_States);
+ end Determinize;
+ end Determinize;
+
+ function Build_Initial_Rep (N : NFA) return NFA
+ is
+ S : constant NFA_State := Get_Start_State (N);
+ begin
+ Add_Edge (S, S, True_Node);
+ return N;
+ end Build_Initial_Rep;
+
+ procedure Build_Strong (N : NFA)
+ is
+ S : NFA_State;
+ Final : constant NFA_State := Get_Final_State (N);
+ begin
+ S := Get_First_State (N);
+ while S /= No_State loop
+ -- FIXME.
+ if S /= Final then
+ Add_Edge (S, Final, EOS_Node);
+ end if;
+ S := Get_Next_State (S);
+ end loop;
+ end Build_Strong;
+
+ procedure Build_Abort (N : NFA; Expr : Node)
+ is
+ S : NFA_State;
+ E : NFA_Edge;
+ Not_Expr : Node;
+ begin
+ Not_Expr := Build_Bool_Not (Expr);
+ S := Get_First_State (N);
+ while S /= No_State loop
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Set_Edge_Expr (E, Build_Bool_And (Not_Expr, Get_Edge_Expr (E)));
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ S := Get_Next_State (S);
+ end loop;
+ end Build_Abort;
+
+ function Build_Property_FA (N : Node) return NFA
+ is
+ L, R : NFA;
+ begin
+ case Get_Kind (N) is
+ when N_Sequences
+ | N_Booleans =>
+ -- Build A(S) or A(B)
+ R := Build_SERE_FA (N);
+ return Determinize.Determinize (R);
+ when N_Strong =>
+ R := Build_Property_FA (Get_Property (N));
+ Build_Strong (R);
+ return R;
+ when N_Imp_Seq =>
+ -- R |=> P --> {R; TRUE} |-> P
+ L := Build_SERE_FA (Get_Sequence (N));
+ R := Build_Property_FA (Get_Property (N));
+ return Build_Concat (L, R);
+ when N_Overlap_Imp_Seq =>
+ -- S |-> P is defined as Ac(S) : A(P)
+ L := Build_SERE_FA (Get_Sequence (N));
+ R := Build_Property_FA (Get_Property (N));
+ return Build_Fusion (L, R);
+ when N_Log_Imp_Prop =>
+ -- B -> P --> {B} |-> P --> Ac(B) : A(P)
+ L := Build_SERE_FA (Get_Left (N));
+ R := Build_Property_FA (Get_Right (N));
+ return Build_Fusion (L, R);
+ when N_And_Prop =>
+ -- P1 && P2 --> A(P1) | A(P2)
+ L := Build_Property_FA (Get_Left (N));
+ R := Build_Property_FA (Get_Right (N));
+ return Build_Or (L, R);
+ when N_Never =>
+ R := Build_SERE_FA (Get_Property (N));
+ return Build_Initial_Rep (R);
+ when N_Always =>
+ R := Build_Property_FA (Get_Property (N));
+ return Build_Initial_Rep (R);
+ when N_Abort =>
+ R := Build_Property_FA (Get_Property (N));
+ Build_Abort (R, Get_Boolean (N));
+ return R;
+ when N_Property_Instance =>
+ declare
+ Decl : Node;
+ begin
+ Decl := Get_Declaration (N);
+ Assoc_Instance (Decl, N);
+ R := Build_Property_FA (Get_Property (Decl));
+ Unassoc_Instance (Decl);
+ return R;
+ end;
+ when others =>
+ Error_Kind ("build_property_fa", N);
+ end case;
+ end Build_Property_FA;
+
+ function Build_FA (N : Node) return NFA
+ is
+ use PSL.NFAs.Utils;
+ Res : NFA;
+ begin
+ Res := Build_Property_FA (N);
+ if Optimize_Final then
+ pragma Debug (Check_NFA (Res));
+
+ Remove_Unreachable_States (Res);
+ Remove_Simple_Prefix (Res);
+ Merge_Identical_States (Res);
+ Merge_Edges (Res);
+ end if;
+ -- Clear the QM table.
+ PSL.QM.Reset;
+ return Res;
+ end Build_FA;
+end PSL.Build;
diff --git a/src/psl/psl-build.ads b/src/psl/psl-build.ads
new file mode 100644
index 000000000..d0ca26a39
--- /dev/null
+++ b/src/psl/psl-build.ads
@@ -0,0 +1,7 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Build is
+ Optimize_Final : Boolean := True;
+
+ function Build_FA (N : Node) return NFA;
+end PSL.Build;
diff --git a/src/psl/psl-cse.adb b/src/psl/psl-cse.adb
new file mode 100644
index 000000000..5d6f3df13
--- /dev/null
+++ b/src/psl/psl-cse.adb
@@ -0,0 +1,201 @@
+with Ada.Text_IO;
+with PSL.Prints;
+with Types; use Types;
+
+package body PSL.CSE is
+ function Is_X_And_Not_X (A, B : Node) return Boolean is
+ begin
+ return (Get_Kind (A) = N_Not_Bool
+ and then Get_Boolean (A) = B)
+ or else (Get_Kind (B) = N_Not_Bool
+ and then Get_Boolean (B) = A);
+ end Is_X_And_Not_X;
+
+ type Hash_Table_Type is array (Uns32 range 0 .. 128) of Node;
+ Hash_Table : Hash_Table_Type := (others => Null_Node);
+
+ function Compute_Hash (L, R : Node; Op : Uns32) return Uns32
+ is
+ begin
+ return Shift_Left (Get_Hash (L), 12)
+ xor Shift_Left (Get_Hash (R), 2)
+ xor Op;
+ end Compute_Hash;
+
+ function Compute_Hash (L: Node; Op : Uns32) return Uns32
+ is
+ begin
+ return Shift_Left (Get_Hash (L), 2) xor Op;
+ end Compute_Hash;
+
+ procedure Dump_Hash_Table (Level : Natural := 0)
+ is
+ use Ada.Text_IO;
+ Cnt : Natural;
+ Total : Natural;
+ N : Node;
+ begin
+ Total := 0;
+ for I in Hash_Table_Type'Range loop
+ Cnt := 0;
+ N := Hash_Table (I);
+ while N /= Null_Node loop
+ Cnt := Cnt + 1;
+ N := Get_Hash_Link (N);
+ end loop;
+ Put_Line ("Hash_table(" & Uns32'Image (I)
+ & "):" & Natural'Image (Cnt));
+ Total := Total + Cnt;
+ if Level > 0 then
+ Cnt := 0;
+ N := Hash_Table (I);
+ while N /= Null_Node loop
+ Put (Uns32'Image (Get_Hash (N)));
+ if Level > 1 then
+ Put (": ");
+ PSL.Prints.Dump_Expr (N);
+ New_Line;
+ end if;
+ Cnt := Cnt + 1;
+ N := Get_Hash_Link (N);
+ end loop;
+ if Level = 1 and then Cnt > 0 then
+ New_Line;
+ end if;
+ end if;
+ end loop;
+ Put_Line ("Total:" & Natural'Image (Total));
+ end Dump_Hash_Table;
+
+ function Build_Bool_And (L, R : Node) return Node
+ is
+ R1 : Node;
+ Res : Node;
+ Hash : Uns32;
+ Head, H : Node;
+ begin
+ if L = True_Node then
+ return R;
+ elsif R = True_Node then
+ return L;
+ elsif L = False_Node or else R = False_Node then
+ return False_Node;
+ elsif L = R then
+ return L;
+ elsif Is_X_And_Not_X (L, R) then
+ return False_Node;
+ end if;
+
+ -- More simple optimizations.
+ if Get_Kind (R) = N_And_Bool then
+ R1 := Get_Left (R);
+ if L = R1 then
+ return R;
+ elsif Is_X_And_Not_X (L, R1) then
+ return False_Node;
+ end if;
+ end if;
+
+ Hash := Compute_Hash (L, R, 2);
+ Head := Hash_Table (Hash mod Hash_Table'Length);
+ H := Head;
+ while H /= Null_Node loop
+ if Get_Hash (H) = Hash
+ and then Get_Kind (H) = N_And_Bool
+ and then Get_Left (H) = L
+ and then Get_Right (H) = R
+ then
+ return H;
+ end if;
+ H := Get_Hash_Link (H);
+ end loop;
+
+ Res := Create_Node (N_And_Bool);
+ Set_Left (Res, L);
+ Set_Right (Res, R);
+ Set_Hash_Link (Res, Head);
+ Set_Hash (Res, Hash);
+ Hash_Table (Hash mod Hash_Table'Length) := Res;
+ return Res;
+ end Build_Bool_And;
+
+ function Build_Bool_Or (L, R : Node) return Node
+ is
+ Res : Node;
+ Hash : Uns32;
+ Head, H : Node;
+ begin
+ if L = True_Node then
+ return L;
+ elsif R = True_Node then
+ return R;
+ elsif L = False_Node then
+ return R;
+ elsif R = False_Node then
+ return L;
+ elsif L = R then
+ return L;
+ elsif Is_X_And_Not_X (L, R) then
+ return True_Node;
+ end if;
+
+ Hash := Compute_Hash (L, R, 3);
+ Head := Hash_Table (Hash mod Hash_Table'Length);
+ H := Head;
+ while H /= Null_Node loop
+ if Get_Hash (H) = Hash
+ and then Get_Kind (H) = N_Or_Bool
+ and then Get_Left (H) = L
+ and then Get_Right (H) = R
+ then
+ return H;
+ end if;
+ H := Get_Hash_Link (H);
+ end loop;
+
+ Res := Create_Node (N_Or_Bool);
+ Set_Left (Res, L);
+ Set_Right (Res, R);
+ Set_Hash_Link (Res, Head);
+ Set_Hash (Res, Hash);
+ Hash_Table (Hash mod Hash_Table'Length) := Res;
+ return Res;
+ end Build_Bool_Or;
+
+ function Build_Bool_Not (N : Node) return Node is
+ Res : Node;
+ Hash : Uns32;
+ Head : Node;
+ H : Node;
+ begin
+ if N = True_Node then
+ return False_Node;
+ elsif N = False_Node then
+ return True_Node;
+ elsif Get_Kind (N) = N_Not_Bool then
+ return Get_Boolean (N);
+ end if;
+
+ -- Find in hash table.
+ Hash := Compute_Hash (N, 1);
+ Head := Hash_Table (Hash mod Hash_Table'Length);
+ H := Head;
+ while H /= Null_Node loop
+ if Get_Hash (H) = Hash
+ and then Get_Kind (H) = N_Not_Bool
+ and then Get_Boolean (H) = N
+ then
+ return H;
+ end if;
+ H := Get_Hash_Link (H);
+ end loop;
+
+ Res := Create_Node (N_Not_Bool);
+ Set_Boolean (Res, N);
+ Set_Hash_Link (Res, Head);
+ Set_Hash (Res, Hash);
+ Hash_Table (Hash mod Hash_Table'Length) := Res;
+
+ return Res;
+ end Build_Bool_Not;
+end PSL.CSE;
diff --git a/src/psl/psl-cse.ads b/src/psl/psl-cse.ads
new file mode 100644
index 000000000..e40b0eeb2
--- /dev/null
+++ b/src/psl/psl-cse.ads
@@ -0,0 +1,10 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.CSE is
+ -- Build boolean expressions while trying to make the node uniq.
+ function Build_Bool_And (L, R : Node) return Node;
+ function Build_Bool_Or (L, R : Node) return Node;
+ function Build_Bool_Not (N : Node) return Node;
+
+ procedure Dump_Hash_Table (Level : Natural := 0);
+end PSL.CSE;
diff --git a/src/psl/psl-disp_nfas.adb b/src/psl/psl-disp_nfas.adb
new file mode 100644
index 000000000..c8f1532b9
--- /dev/null
+++ b/src/psl/psl-disp_nfas.adb
@@ -0,0 +1,111 @@
+with Ada.Text_IO; use Ada.Text_IO;
+with Types; use Types;
+with PSL.Prints; use PSL.Prints;
+
+package body PSL.Disp_NFAs is
+ 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;
+
+ procedure Disp_Head (Name : String) is
+ begin
+ Put ("digraph ");
+ Put (Name);
+ Put_Line (" {");
+ Put_Line (" rankdir=LR;");
+ end Disp_Head;
+
+ procedure Disp_Tail is
+ begin
+ Put_Line ("}");
+ end Disp_Tail;
+
+ procedure Disp_Body (N : NFA) is
+ S, F : NFA_State;
+ T : NFA_Edge;
+ begin
+ S := Get_Start_State (N);
+ F := Get_Final_State (N);
+ if S /= No_State then
+ if S = F then
+ Put (" node [shape = doublecircle, style = bold];");
+ else
+ Put (" node [shape = circle, style = bold];");
+ end if;
+ Put (" /* Start: */ ");
+ Disp_State (S);
+ Put_Line (";");
+ end if;
+ if F /= No_State and then F /= S then
+ Put (" node [shape = doublecircle, style = solid];");
+ Put (" /* Final: */ ");
+ Disp_State (F);
+ Put_Line (";");
+ end if;
+ Put_Line (" node [shape = circle, style = solid];");
+
+ if Get_Epsilon_NFA (N) then
+ Put (" ");
+ Disp_State (Get_Start_State (N));
+ Put (" -> ");
+ Disp_State (Get_Final_State (N));
+ Put_Line (" [ label = ""*""]");
+ end if;
+
+ S := Get_First_State (N);
+ while S /= No_State loop
+ T := Get_First_Src_Edge (S);
+ if T = No_Edge then
+ if Get_First_Dest_Edge (S) = No_Edge then
+ Put (" ");
+ Disp_State (S);
+ Put_Line (";");
+ end if;
+ else
+ loop
+ Put (" ");
+ Disp_State (S);
+ Put (" -> ");
+ Disp_State (Get_Edge_Dest (T));
+ Put (" [ label = """);
+ Print_Expr (Get_Edge_Expr (T));
+ Put ('"');
+ if True then
+ Put (" /* Node =");
+ Put (Node'Image (Get_Edge_Expr (T)));
+ Put (" */");
+ end if;
+ if True then
+ Put (" /* Edge =");
+ Put (NFA_Edge'Image (T));
+ Put (" */");
+ end if;
+ Put_Line (" ];");
+
+ T := Get_Next_Src_Edge (T);
+ exit when T = No_Edge;
+ end loop;
+ end if;
+ S := Get_Next_State (S);
+ end loop;
+ end Disp_Body;
+
+ procedure Disp_NFA (N : NFA; Name : String := "nfa") is
+ begin
+ Disp_Head (Name);
+ Disp_Body (N);
+ Disp_Tail;
+ end Disp_NFA;
+
+ procedure Debug_NFA (N : NFA) is
+ begin
+ Labelize_States_Debug (N);
+ Disp_Head ("nfa");
+ Disp_Body (N);
+ Disp_Tail;
+ end Debug_NFA;
+
+ pragma Unreferenced (Debug_NFA);
+end PSL.Disp_NFAs;
diff --git a/src/psl/psl-disp_nfas.ads b/src/psl/psl-disp_nfas.ads
new file mode 100644
index 000000000..901eed72f
--- /dev/null
+++ b/src/psl/psl-disp_nfas.ads
@@ -0,0 +1,12 @@
+with PSL.NFAs; use PSL.NFAs;
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Disp_NFAs is
+ procedure Disp_Head (Name : String);
+ procedure Disp_Tail;
+ procedure Disp_Body (N : NFA);
+
+ procedure Disp_State (S : NFA_State);
+
+ procedure Disp_NFA (N : NFA; Name : String := "nfa");
+end PSL.Disp_NFAs;
diff --git a/src/psl/psl-dump_tree.adb b/src/psl/psl-dump_tree.adb
new file mode 100644
index 000000000..db636dbb0
--- /dev/null
+++ b/src/psl/psl-dump_tree.adb
@@ -0,0 +1,867 @@
+-- This is in fact -*- Ada -*-
+with Ada.Text_IO; use Ada.Text_IO;
+with Types; use Types;
+with Name_Table;
+with PSL.Errors;
+
+package body PSL.Dump_Tree is
+
+ procedure Disp_Indent (Indent : Natural) is
+ begin
+ Put (String'(1 .. 2 * Indent => ' '));
+ end Disp_Indent;
+
+ Hex_Digits : constant array (Integer range 0 .. 15) of Character
+ := "0123456789abcdef";
+
+ procedure Disp_Uns32 (Val : Uns32)
+ is
+ Res : String (1 .. 8);
+ V : Uns32 := Val;
+ begin
+ for I in reverse Res'Range loop
+ Res (I) := Hex_Digits (Integer (V mod 16));
+ V := V / 16;
+ end loop;
+ Put (Res);
+ end Disp_Uns32;
+
+ procedure Disp_Int32 (Val : Int32)
+ is
+ Res : String (1 .. 8);
+ V : Int32 := Val;
+ begin
+ for I in reverse Res'Range loop
+ Res (I) := Hex_Digits (Integer (V mod 16));
+ V := V / 16;
+ end loop;
+ Put (Res);
+ end Disp_Int32;
+
+ procedure Disp_HDL_Node (Val : HDL_Node)
+ is
+ begin
+ if Dump_Hdl_Node /= null then
+ Dump_Hdl_Node.all (Val);
+ else
+ Disp_Int32 (Val);
+ end if;
+ end Disp_HDL_Node;
+
+ procedure Disp_Node_Number (N : Node) is
+ begin
+ Put ('[');
+ Disp_Int32 (Int32 (N));
+ Put (']');
+ end Disp_Node_Number;
+
+ procedure Disp_NFA (Val : NFA) is
+ begin
+ Disp_Int32 (Int32 (Val));
+ end Disp_NFA;
+
+ procedure Disp_Header (Msg : String; Indent : Natural) is
+ begin
+ Disp_Indent (Indent);
+ Put (Msg);
+ Put (": ");
+ end Disp_Header;
+
+ procedure Disp_Identifier (N : Node) is
+ begin
+ Put (Name_Table.Image (Get_Identifier (N)));
+ New_Line;
+ end Disp_Identifier;
+
+ procedure Disp_Label (N : Node) is
+ begin
+ Put (Name_Table.Image (Get_Label (N)));
+ New_Line;
+ end Disp_Label;
+
+ procedure Disp_Boolean (Val : Boolean) is
+ begin
+ if Val then
+ Put ("true");
+ else
+ Put ("false");
+ end if;
+ end Disp_Boolean;
+
+ procedure Disp_PSL_Presence_Kind (Pres : PSL_Presence_Kind) is
+ begin
+ case Pres is
+ when Present_Pos =>
+ Put ('+');
+ when Present_Neg =>
+ Put ('-');
+ when Present_Unknown =>
+ Put ('?');
+ end case;
+ end Disp_PSL_Presence_Kind;
+
+ procedure Disp_Location (Loc : Location_Type) is
+ begin
+ Put (PSL.Errors.Get_Location_Str (Loc));
+ end Disp_Location;
+
+-- procedure Disp_String_Id (N : Node) is
+-- begin
+-- Put ('"');
+-- Put (Str_Table.Image (Get_String_Id (N)));
+-- Put ('"');
+-- New_Line;
+-- end Disp_String_Id;
+
+ -- Subprograms.
+ procedure Disp_Tree (N : Node; Indent : Natural; Full : boolean := False) is
+ begin
+ Disp_Indent (Indent);
+ Disp_Node_Number (N);
+ Put (": ");
+ if N = Null_Node then
+ Put_Line ("*NULL*");
+ return;
+ end if;
+ Put_Line (Nkind'Image (Get_Kind (N)));
+ Disp_Indent (Indent);
+ Put ("loc: ");
+ Disp_Location (Get_Location (N));
+ New_Line;
+ case Get_Kind (N) is
+ when N_Error =>
+ if not Full then
+ return;
+ end if;
+ null;
+ when N_Vmode =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Instance", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Instance (N), Indent + 1, Full);
+ Disp_Header ("Item_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Item_Chain (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Vunit =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Instance", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Instance (N), Indent + 1, Full);
+ Disp_Header ("Item_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Item_Chain (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Vprop =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Instance", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Instance (N), Indent + 1, Full);
+ Disp_Header ("Item_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Item_Chain (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Hdl_Mod_Name =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Prefix", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Prefix (N), Indent + 1, Full);
+ null;
+ when N_Assert_Directive =>
+ Disp_Header ("Label", Indent + 1);
+ Disp_Label (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("String", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_String (N), Indent + 1, Full);
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("NFA", Indent + 1);
+ Disp_NFA (Get_NFA (N));
+ New_Line;
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Property_Declaration =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Global_Clock", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Global_Clock (N), Indent + 1, Full);
+ Disp_Header ("Parameter_List", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Parameter_List (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Sequence_Declaration =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Parameter_List", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Parameter_List (N), Indent + 1, Full);
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Endpoint_Declaration =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Parameter_List", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Parameter_List (N), Indent + 1, Full);
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Const_Parameter =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Actual", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Actual (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Boolean_Parameter =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Actual", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Actual (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Property_Parameter =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Actual", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Actual (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Sequence_Parameter =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Actual", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Actual (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Sequence_Instance =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Declaration", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Declaration (N), Indent + 1, False);
+ Disp_Header ("Association_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Association_Chain (N), Indent + 1, Full);
+ null;
+ when N_Endpoint_Instance =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Declaration", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Declaration (N), Indent + 1, False);
+ Disp_Header ("Association_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Association_Chain (N), Indent + 1, Full);
+ null;
+ when N_Property_Instance =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Declaration", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Declaration (N), Indent + 1, False);
+ Disp_Header ("Association_Chain", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Association_Chain (N), Indent + 1, Full);
+ null;
+ when N_Actual =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Actual", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Actual (N), Indent + 1, Full);
+ Disp_Header ("Formal", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Formal (N), Indent + 1, Full);
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Clock_Event =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ null;
+ when N_Always =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ null;
+ when N_Never =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ null;
+ when N_Eventually =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ null;
+ when N_Strong =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ null;
+ when N_Imp_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ null;
+ when N_Overlap_Imp_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ null;
+ when N_Log_Imp_Prop =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Next =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Number", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Number (N), Indent + 1, Full);
+ null;
+ when N_Next_A =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Next_E =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Next_Event =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Number", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Number (N), Indent + 1, Full);
+ null;
+ when N_Next_Event_A =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Next_Event_E =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Abort =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Property", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Property (N), Indent + 1, Full);
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ null;
+ when N_Until =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ Disp_Header ("Inclusive_Flag", Indent + 1);
+ Disp_Boolean (Get_Inclusive_Flag (N));
+ New_Line;
+ null;
+ when N_Before =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Strong_Flag", Indent + 1);
+ Disp_Boolean (Get_Strong_Flag (N));
+ New_Line;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ Disp_Header ("Inclusive_Flag", Indent + 1);
+ Disp_Boolean (Get_Inclusive_Flag (N));
+ New_Line;
+ null;
+ when N_Or_Prop =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_And_Prop =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Braced_SERE =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("SERE", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_SERE (N), Indent + 1, Full);
+ null;
+ when N_Concat_SERE =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Fusion_SERE =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Within_SERE =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Match_And_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_And_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Or_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ null;
+ when N_Star_Repeat_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Goto_Repeat_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Plus_Repeat_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ null;
+ when N_Equal_Repeat_Seq =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Sequence", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Sequence (N), Indent + 1, Full);
+ Disp_Header ("Low_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Low_Bound (N), Indent + 1, Full);
+ Disp_Header ("High_Bound", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_High_Bound (N), Indent + 1, Full);
+ null;
+ when N_Not_Bool =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Boolean", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Boolean (N), Indent + 1, Full);
+ Disp_Header ("Presence", Indent + 1);
+ Disp_PSL_Presence_Kind (Get_Presence (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_And_Bool =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ Disp_Header ("Presence", Indent + 1);
+ Disp_PSL_Presence_Kind (Get_Presence (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_Or_Bool =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ Disp_Header ("Presence", Indent + 1);
+ Disp_PSL_Presence_Kind (Get_Presence (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_Imp_Bool =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Left", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Left (N), Indent + 1, Full);
+ Disp_Header ("Right", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Right (N), Indent + 1, Full);
+ Disp_Header ("Presence", Indent + 1);
+ Disp_PSL_Presence_Kind (Get_Presence (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_HDL_Expr =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Presence", Indent + 1);
+ Disp_PSL_Presence_Kind (Get_Presence (N));
+ New_Line;
+ Disp_Header ("HDL_Node", Indent + 1);
+ Disp_HDL_Node (Get_HDL_Node (N));
+ New_Line;
+ Disp_Header ("HDL_Index", Indent + 1);
+ Disp_Int32 (Get_HDL_Index (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_False =>
+ if not Full then
+ return;
+ end if;
+ null;
+ when N_True =>
+ if not Full then
+ return;
+ end if;
+ null;
+ when N_EOS =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("HDL_Index", Indent + 1);
+ Disp_Int32 (Get_HDL_Index (N));
+ New_Line;
+ Disp_Header ("Hash", Indent + 1);
+ Disp_Uns32 (Get_Hash (N));
+ New_Line;
+ Disp_Header ("Hash_Link", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Hash_Link (N), Indent + 1, Full);
+ null;
+ when N_Name =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Decl", Indent + 1);
+ New_Line;
+ Disp_Tree (Get_Decl (N), Indent + 1, Full);
+ null;
+ when N_Name_Decl =>
+ Disp_Header ("Identifier", Indent + 1);
+ Disp_Identifier (N);
+ if not Full then
+ return;
+ end if;
+ Disp_Tree (Get_Chain (N), Indent, Full);
+ null;
+ when N_Number =>
+ if not Full then
+ return;
+ end if;
+ Disp_Header ("Value", Indent + 1);
+ Disp_Uns32 (Get_Value (N));
+ New_Line;
+ null;
+ end case;
+ end Disp_Tree;
+
+ procedure Dump_Tree (N : Node; Full : Boolean := False) is
+ begin
+ Disp_Tree (N, 0, Full);
+ end Dump_Tree;
+
+end PSL.Dump_Tree;
diff --git a/src/psl/psl-dump_tree.ads b/src/psl/psl-dump_tree.ads
new file mode 100644
index 000000000..f8b2eb3ab
--- /dev/null
+++ b/src/psl/psl-dump_tree.ads
@@ -0,0 +1,9 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Dump_Tree is
+ procedure Dump_Tree (N : Node; Full : Boolean := False);
+
+ -- Procedure to dump an HDL node.
+ type Dump_Hdl_Node_Acc is access procedure (N : HDL_Node);
+ Dump_Hdl_Node : Dump_Hdl_Node_Acc := null;
+end PSL.Dump_Tree;
diff --git a/src/psl/psl-hash.adb b/src/psl/psl-hash.adb
new file mode 100644
index 000000000..62744b336
--- /dev/null
+++ b/src/psl/psl-hash.adb
@@ -0,0 +1,60 @@
+with GNAT.Table;
+
+package body PSL.Hash is
+
+ type Index_Type is new Natural;
+ No_Index : constant Index_Type := 0;
+
+ type Cell_Record is record
+ Res : Node;
+ Next : Index_Type;
+ end record;
+
+ Hash_Size : constant Index_Type := 127;
+
+ package Cells is new GNAT.Table
+ (Table_Component_Type => Cell_Record,
+ Table_Index_Type => Index_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 256,
+ Table_Increment => 100);
+
+ procedure Init is
+ begin
+ Cells.Set_Last (Hash_Size - 1);
+ for I in 0 .. Hash_Size - 1 loop
+ Cells.Table (I) := (Res => Null_Node, Next => No_Index);
+ end loop;
+ end Init;
+
+ function Get_PSL_Node (Hdl : Int32) return Node is
+ Idx : Index_Type := Index_Type (Hdl mod Int32 (Hash_Size));
+ N_Idx : Index_Type;
+ Res : Node;
+ begin
+ -- In the primary table.
+ Res := Cells.Table (Idx).Res;
+ if Res = Null_Node then
+ Res := Create_Node (N_HDL_Expr);
+ Set_HDL_Node (Res, Hdl);
+ Cells.Table (Idx).Res := Res;
+ return Res;
+ end if;
+
+ loop
+ if Get_HDL_Node (Res) = Hdl then
+ return Res;
+ end if;
+ -- Look in collisions chain
+ N_Idx := Cells.Table (Idx).Next;
+ exit when N_Idx = No_Index;
+ Idx := N_Idx;
+ Res := Cells.Table (Idx).Res;
+ end loop;
+ Res := Create_Node (N_HDL_Expr);
+ Set_HDL_Node (Res, Hdl);
+ Cells.Append ((Res => Res, Next => No_Index));
+ Cells.Table (Idx).Next := Cells.Last;
+ return Res;
+ end Get_PSL_Node;
+end PSL.Hash;
diff --git a/src/psl/psl-hash.ads b/src/psl/psl-hash.ads
new file mode 100644
index 000000000..d1a60c971
--- /dev/null
+++ b/src/psl/psl-hash.ads
@@ -0,0 +1,11 @@
+with Types; use Types;
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Hash is
+ -- Initialize the package.
+ procedure Init;
+
+ -- Get the PSL node for node HDL.
+ -- Only one PSL node is created for an HDL node.
+ function Get_PSL_Node (Hdl : Int32) return Node;
+end PSL.Hash;
diff --git a/src/psl/psl-nfas-utils.adb b/src/psl/psl-nfas-utils.adb
new file mode 100644
index 000000000..06601850d
--- /dev/null
+++ b/src/psl/psl-nfas-utils.adb
@@ -0,0 +1,330 @@
+with PSL.Errors; use PSL.Errors;
+
+package body PSL.NFAs.Utils is
+ generic
+ with function Get_First_Edge (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge;
+ with procedure Set_First_Edge (S : NFA_State; E : NFA_Edge);
+ with procedure Set_Next_Edge (E : NFA_Edge; N_E : NFA_Edge);
+ with function Get_Edge_State (E : NFA_Edge) return NFA_State;
+ package Sort_Edges is
+ procedure Sort_Edges (S : NFA_State);
+ procedure Sort_Edges (N : NFA);
+ end Sort_Edges;
+
+ package body Sort_Edges is
+ -- Use merge sort to sort a list of edges.
+ -- The first edge is START and the list has LEN edges.
+ -- RES is the head of the sorted list.
+ -- NEXT_EDGE is the LEN + 1 edge (not sorted).
+ procedure Edges_Merge_Sort (Start : NFA_Edge;
+ Len : Natural;
+ Res : out NFA_Edge;
+ Next_Edge : out NFA_Edge)
+ is
+ function Lt (L, R : NFA_Edge) return Boolean
+ is
+ L_Expr : constant Node := Get_Edge_Expr (L);
+ R_Expr : constant Node := Get_Edge_Expr (R);
+ begin
+ return L_Expr < R_Expr
+ or else (L_Expr = R_Expr
+ and then Get_Edge_State (L) < Get_Edge_State (R));
+ end Lt;
+
+ pragma Inline (Lt);
+
+ Half : constant Natural := Len / 2;
+ Left_Start, Right_Start : NFA_Edge;
+ Left_Next, Right_Next : NFA_Edge;
+ L, R : NFA_Edge;
+ Last, E : NFA_Edge;
+ begin
+ -- With less than 2 elements, the sort is trivial.
+ if Len < 2 then
+ if Len = 0 then
+ Next_Edge := Start;
+ else
+ Next_Edge := Get_Next_Edge (Start);
+ end if;
+ Res := Start;
+ return;
+ end if;
+
+ -- Sort each half.
+ Edges_Merge_Sort (Start, Half, Left_Start, Left_Next);
+ Edges_Merge_Sort (Left_Next, Len - Half, Right_Start, Right_Next);
+
+ -- Merge.
+ L := Left_Start;
+ R := Right_Start;
+ Last := No_Edge;
+ loop
+ -- Take from left iff:
+ -- * it is not empty
+ -- * right is empty or else (left < right)
+ if L /= Left_Next and then (R = Right_Next or else Lt (L, R)) then
+ E := L;
+ L := Get_Next_Edge (L);
+
+ -- Take from right if right is not empty.
+ elsif R /= Right_Next then
+ E := R;
+ R := Get_Next_Edge (R);
+
+ -- Both left are right are empty.
+ else
+ exit;
+ end if;
+
+ if Last = No_Edge then
+ Res := E;
+ else
+ Set_Next_Edge (Last, E);
+ end if;
+ Last := E;
+ end loop;
+ -- Let the link clean.
+ Next_Edge := Right_Next;
+ Set_Next_Edge (Last, Next_Edge);
+ end Edges_Merge_Sort;
+
+ procedure Sort_Edges (S : NFA_State)
+ is
+ Nbr_Edges : Natural;
+ First_E, E, Res : NFA_Edge;
+ begin
+ -- Count number of edges.
+ Nbr_Edges := 0;
+ First_E := Get_First_Edge (S);
+ E := First_E;
+ while E /= No_Edge loop
+ Nbr_Edges := Nbr_Edges + 1;
+ E := Get_Next_Edge (E);
+ end loop;
+
+ -- Sort edges by expression.
+ Edges_Merge_Sort (First_E, Nbr_Edges, Res, E);
+ pragma Assert (E = No_Edge);
+ Set_First_Edge (S, Res);
+
+ end Sort_Edges;
+
+ procedure Sort_Edges (N : NFA)
+ is
+ S : NFA_State;
+ begin
+ -- Iterate on states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+ Sort_Edges (S);
+ S := Get_Next_State (S);
+ end loop;
+ end Sort_Edges;
+ end Sort_Edges;
+
+ package Sort_Src_Edges_Pkg is new
+ Sort_Edges (Get_First_Edge => Get_First_Src_Edge,
+ Get_Next_Edge => Get_Next_Src_Edge,
+ Set_First_Edge => Set_First_Src_Edge,
+ Set_Next_Edge => Set_Next_Src_Edge,
+ Get_Edge_State => Get_Edge_Dest);
+
+ procedure Sort_Src_Edges (S : NFA_State) renames
+ Sort_Src_Edges_Pkg.Sort_Edges;
+ procedure Sort_Src_Edges (N : NFA) renames
+ Sort_Src_Edges_Pkg.Sort_Edges;
+
+ package Sort_Dest_Edges_Pkg is new
+ Sort_Edges (Get_First_Edge => Get_First_Dest_Edge,
+ Get_Next_Edge => Get_Next_Dest_Edge,
+ Set_First_Edge => Set_First_Dest_Edge,
+ Set_Next_Edge => Set_Next_Dest_Edge,
+ Get_Edge_State => Get_Edge_Src);
+
+ procedure Sort_Dest_Edges (S : NFA_State) renames
+ Sort_Dest_Edges_Pkg.Sort_Edges;
+ procedure Sort_Dest_Edges (N : NFA) renames
+ Sort_Dest_Edges_Pkg.Sort_Edges;
+
+ generic
+ with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge;
+ with function Get_First_Edge (S : NFA_State) return NFA_Edge;
+ with procedure Set_First_Edge (S : NFA_State; E : NFA_Edge);
+ with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge;
+ with procedure Set_Next_Edge (E : NFA_Edge; E1 : NFA_Edge);
+ with procedure Set_Edge_State (E : NFA_Edge; S : NFA_State);
+ procedure Merge_State (N : NFA; S : NFA_State; S1 : NFA_State);
+
+ procedure Merge_State (N : NFA; S : NFA_State; S1 : NFA_State)
+ is
+ E, First_E, Next_E : NFA_Edge;
+ begin
+ pragma Assert (S /= S1);
+
+ -- Discard outgoing edges of S1.
+ loop
+ E := Get_First_Edge_Reverse (S1);
+ exit when E = No_Edge;
+ Remove_Edge (E);
+ end loop;
+
+ -- Prepend incoming edges of S1 to S.
+ First_E := Get_First_Edge (S);
+ E := Get_First_Edge (S1);
+ while E /= No_Edge loop
+ Next_E := Get_Next_Edge (E);
+ Set_Next_Edge (E, First_E);
+ Set_Edge_State (E, S);
+ First_E := E;
+ E := Next_E;
+ end loop;
+ Set_First_Edge (S, First_E);
+ Set_First_Edge (S1, No_Edge);
+
+ Remove_State (N, S1);
+ end Merge_State;
+
+ procedure Merge_State_Dest_1 is new Merge_State
+ (Get_First_Edge_Reverse => Get_First_Src_Edge,
+ Get_First_Edge => Get_First_Dest_Edge,
+ Set_First_Edge => Set_First_Dest_Edge,
+ Get_Next_Edge => Get_Next_Dest_Edge,
+ Set_Next_Edge => Set_Next_Dest_Edge,
+ Set_Edge_State => Set_Edge_Dest);
+
+ procedure Merge_State_Dest (N : NFA; S : NFA_State; S1 : NFA_State) renames
+ Merge_State_Dest_1;
+
+ procedure Merge_State_Src_1 is new Merge_State
+ (Get_First_Edge_Reverse => Get_First_Dest_Edge,
+ Get_First_Edge => Get_First_Src_Edge,
+ Set_First_Edge => Set_First_Src_Edge,
+ Get_Next_Edge => Get_Next_Src_Edge,
+ Set_Next_Edge => Set_Next_Src_Edge,
+ Set_Edge_State => Set_Edge_Src);
+
+ procedure Merge_State_Src (N : NFA; S : NFA_State; S1 : NFA_State) renames
+ Merge_State_Src_1;
+
+ procedure Sort_Outgoing_Edges (N : NFA; Nbr_States : Natural)
+ is
+ Last_State : constant NFA_State := NFA_State (Nbr_States) - 1;
+ type Edge_Array is array (0 .. Last_State) of NFA_Edge;
+ Edges : Edge_Array := (others => No_Edge);
+ S, D : NFA_State;
+ E, Next_E : NFA_Edge;
+ First_Edge, Last_Edge : NFA_Edge;
+ begin
+ -- Iterate on states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+
+ -- Create an array of edges
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ Next_E := Get_Next_Dest_Edge (E);
+ D := Get_Edge_Dest (E);
+ if Edges (D) /= No_Edge then
+ -- TODO: merge edges.
+ raise Program_Error;
+ end if;
+ Edges (D) := E;
+ E := Next_E;
+ end loop;
+
+ -- Rebuild the edge list (sorted by destination).
+ Last_Edge := No_Edge;
+ First_Edge := No_Edge;
+ for I in Edge_Array'Range loop
+ E := Edges (I);
+ if E /= No_Edge then
+ Edges (I) := No_Edge;
+ if First_Edge = No_Edge then
+ First_Edge := E;
+ else
+ Set_Next_Dest_Edge (Last_Edge, E);
+ end if;
+ Last_Edge := E;
+ end if;
+ end loop;
+ Set_First_Dest_Edge (S, First_Edge);
+ S := Get_Next_State (S);
+ end loop;
+ end Sort_Outgoing_Edges;
+ pragma Unreferenced (Sort_Outgoing_Edges);
+
+ generic
+ with function Get_First_Edge (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge;
+ with function Get_State_Reverse (E : NFA_Edge) return NFA_State;
+ with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge_Reverse (E : NFA_Edge) return NFA_Edge;
+ procedure Check_Edges_Gen (N : NFA);
+
+ procedure Check_Edges_Gen (N : NFA)
+ is
+ S : NFA_State;
+ E : NFA_Edge;
+ R_S : NFA_State;
+ R_E : NFA_Edge;
+ begin
+ S := Get_First_State (N);
+ while S /= No_State loop
+ E := Get_First_Edge (S);
+ while E /= No_Edge loop
+ R_S := Get_State_Reverse (E);
+ R_E := Get_First_Edge_Reverse (R_S);
+ while R_E /= No_Edge and then R_E /= E loop
+ R_E := Get_Next_Edge_Reverse (R_E);
+ end loop;
+ if R_E /= E then
+ raise Program_Error;
+ end if;
+ E := Get_Next_Edge (E);
+ end loop;
+ S := Get_Next_State (S);
+ end loop;
+ end Check_Edges_Gen;
+
+ procedure Check_Edges_Src is new Check_Edges_Gen
+ (Get_First_Edge => Get_First_Src_Edge,
+ Get_Next_Edge => Get_Next_Src_Edge,
+ Get_State_Reverse => Get_Edge_Dest,
+ Get_First_Edge_Reverse => Get_First_Dest_Edge,
+ Get_Next_Edge_Reverse => Get_Next_Dest_Edge);
+
+ procedure Check_Edges_Dest is new Check_Edges_Gen
+ (Get_First_Edge => Get_First_Dest_Edge,
+ Get_Next_Edge => Get_Next_Dest_Edge,
+ Get_State_Reverse => Get_Edge_Src,
+ Get_First_Edge_Reverse => Get_First_Src_Edge,
+ Get_Next_Edge_Reverse => Get_Next_Src_Edge);
+
+ procedure Check_NFA (N : NFA) is
+ begin
+ Check_Edges_Src (N);
+ Check_Edges_Dest (N);
+ end Check_NFA;
+
+ function Has_EOS (N : Node) return Boolean is
+ begin
+ case Get_Kind (N) is
+ when N_EOS =>
+ return True;
+ when N_False
+ | N_True
+ | N_HDL_Expr =>
+ return False;
+ when N_Not_Bool =>
+ return Has_EOS (Get_Boolean (N));
+ when N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool =>
+ return Has_EOS (Get_Left (N)) or else Has_EOS (Get_Right (N));
+ when others =>
+ Error_Kind ("Has_EOS", N);
+ end case;
+ end Has_EOS;
+
+end PSL.NFAs.Utils;
diff --git a/src/psl/psl-nfas-utils.ads b/src/psl/psl-nfas-utils.ads
new file mode 100644
index 000000000..bdbc0d013
--- /dev/null
+++ b/src/psl/psl-nfas-utils.ads
@@ -0,0 +1,21 @@
+package PSL.NFAs.Utils is
+ -- Sort outgoing edges by expression.
+ procedure Sort_Src_Edges (S : NFA_State);
+ procedure Sort_Src_Edges (N : NFA);
+
+ procedure Sort_Dest_Edges (S : NFA_State);
+ procedure Sort_Dest_Edges (N : NFA);
+
+ -- Move incoming edges of S1 to S, remove S1 and its outgoing edges.
+ procedure Merge_State_Dest (N : NFA; S : NFA_State; S1 : NFA_State);
+
+ procedure Merge_State_Src (N : NFA; S : NFA_State; S1 : NFA_State);
+
+ -- Return True if N or a child of N is EOS.
+ -- N must be a boolean expression.
+ function Has_EOS (N : Node) return Boolean;
+
+ -- Raise Program_Error if N is not internally coherent.
+ procedure Check_NFA (N : NFA);
+end PSL.NFAs.Utils;
+
diff --git a/src/psl/psl-nfas.adb b/src/psl/psl-nfas.adb
new file mode 100644
index 000000000..da4866e53
--- /dev/null
+++ b/src/psl/psl-nfas.adb
@@ -0,0 +1,529 @@
+with GNAT.Table;
+
+package body PSL.NFAs is
+ -- Record that describes an NFA.
+ type NFA_Node is record
+ -- Chain of States.
+ First_State : NFA_State;
+ Last_State : NFA_State;
+
+ -- Start and final state.
+ Start : NFA_State;
+ Final : NFA_State;
+
+ -- If true there is an epsilon transition between the start and
+ -- the final state.
+ Epsilon : Boolean;
+ end record;
+
+ -- Record that describe a node.
+ type NFA_State_Node is record
+ -- States may be numbered.
+ Label : Int32;
+
+ -- Edges.
+ First_Src : NFA_Edge;
+ First_Dst : NFA_Edge;
+
+ -- State links.
+ Next_State : NFA_State;
+ Prev_State : NFA_State;
+
+ -- User fields.
+ User_Link : NFA_State;
+ User_Flag : Boolean;
+ end record;
+
+ -- Record that describe an edge between SRC and DEST.
+ type NFA_Edge_Node is record
+ Dest : NFA_State;
+ Src : NFA_State;
+ Expr : Node;
+
+ -- Links.
+ Next_Src : NFA_Edge;
+ Next_Dst : NFA_Edge;
+ end record;
+
+ -- Table of NFA.
+ package Nfat is new GNAT.Table
+ (Table_Component_Type => NFA_Node,
+ Table_Index_Type => NFA,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ -- List of free nodes.
+ Free_Nfas : NFA := No_NFA;
+
+ -- Table of States.
+ package Statet is new GNAT.Table
+ (Table_Component_Type => NFA_State_Node,
+ Table_Index_Type => NFA_State,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ -- List of free states.
+ Free_States : NFA_State := No_State;
+
+ -- Table of edges.
+ package Transt is new GNAT.Table
+ (Table_Component_Type => NFA_Edge_Node,
+ Table_Index_Type => NFA_Edge,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ -- List of free edges.
+ Free_Edges : NFA_Edge := No_Edge;
+
+ function Get_First_State (N : NFA) return NFA_State is
+ begin
+ return Nfat.Table (N).First_State;
+ end Get_First_State;
+
+ function Get_Last_State (N : NFA) return NFA_State is
+ begin
+ return Nfat.Table (N).Last_State;
+ end Get_Last_State;
+
+ procedure Set_First_State (N : NFA; S : NFA_State) is
+ begin
+ Nfat.Table (N).First_State := S;
+ end Set_First_State;
+
+ procedure Set_Last_State (N : NFA; S : NFA_State) is
+ begin
+ Nfat.Table (N).Last_State := S;
+ end Set_Last_State;
+
+ function Get_Next_State (S : NFA_State) return NFA_State is
+ begin
+ return Statet.Table (S).Next_State;
+ end Get_Next_State;
+
+ procedure Set_Next_State (S : NFA_State; N : NFA_State) is
+ begin
+ Statet.Table (S).Next_State := N;
+ end Set_Next_State;
+
+ function Get_Prev_State (S : NFA_State) return NFA_State is
+ begin
+ return Statet.Table (S).Prev_State;
+ end Get_Prev_State;
+
+ procedure Set_Prev_State (S : NFA_State; N : NFA_State) is
+ begin
+ Statet.Table (S).Prev_State := N;
+ end Set_Prev_State;
+
+ function Get_State_Label (S : NFA_State) return Int32 is
+ begin
+ return Statet.Table (S).Label;
+ end Get_State_Label;
+
+ procedure Set_State_Label (S : NFA_State; Label : Int32) is
+ begin
+ Statet.Table (S).Label := Label;
+ end Set_State_Label;
+
+ function Get_Epsilon_NFA (N : NFA) return Boolean is
+ begin
+ return Nfat.Table (N).Epsilon;
+ end Get_Epsilon_NFA;
+
+ procedure Set_Epsilon_NFA (N : NFA; Flag : Boolean) is
+ begin
+ Nfat.Table (N).Epsilon := Flag;
+ end Set_Epsilon_NFA;
+
+ function Add_State (N : NFA) return NFA_State is
+ Res : NFA_State;
+ Last : NFA_State;
+ begin
+ -- Get a new state.
+ if Free_States = No_State then
+ Statet.Increment_Last;
+ Res := Statet.Last;
+ else
+ Res := Free_States;
+ Free_States := Get_Next_State (Res);
+ end if;
+
+ -- Put it in N.
+ Last := Get_Last_State (N);
+ Statet.Table (Res) := (Label => 0,
+ First_Src => No_Edge,
+ First_Dst => No_Edge,
+ Next_State => No_State,
+ Prev_State => Last,
+ User_Link => No_State,
+ User_Flag => False);
+ if Last = No_State then
+ Nfat.Table (N).First_State := Res;
+ else
+ Statet.Table (Last).Next_State := Res;
+ end if;
+ Nfat.Table (N).Last_State := Res;
+ return Res;
+ end Add_State;
+
+ procedure Delete_Detached_State (S : NFA_State) is
+ begin
+ -- Put it in front of the free_states list.
+ Set_Next_State (S, Free_States);
+ Free_States := S;
+ end Delete_Detached_State;
+
+ function Create_NFA return NFA
+ is
+ Res : NFA;
+ begin
+ -- Allocate a node.
+ if Free_Nfas = No_NFA then
+ Nfat.Increment_Last;
+ Res := Nfat.Last;
+ else
+ Res := Free_Nfas;
+ Free_Nfas := NFA (Get_First_State (Res));
+ end if;
+
+ -- Fill it.
+ Nfat.Table (Res) := (First_State => No_State,
+ Last_State => No_State,
+ Start => No_State, Final => No_State,
+ Epsilon => False);
+ return Res;
+ end Create_NFA;
+
+ procedure Set_First_Src_Edge (N : NFA_State; T : NFA_Edge) is
+ begin
+ Statet.Table (N).First_Src := T;
+ end Set_First_Src_Edge;
+
+ function Get_First_Src_Edge (N : NFA_State) return NFA_Edge is
+ begin
+ return Statet.Table (N).First_Src;
+ end Get_First_Src_Edge;
+
+ procedure Set_First_Dest_Edge (N : NFA_State; T : NFA_Edge) is
+ begin
+ Statet.Table (N).First_Dst := T;
+ end Set_First_Dest_Edge;
+
+ function Get_First_Dest_Edge (N : NFA_State) return NFA_Edge is
+ begin
+ return Statet.Table (N).First_Dst;
+ end Get_First_Dest_Edge;
+
+ function Get_State_Flag (S : NFA_State) return Boolean is
+ begin
+ return Statet.Table (S).User_Flag;
+ end Get_State_Flag;
+
+ procedure Set_State_Flag (S : NFA_State; Val : Boolean) is
+ begin
+ Statet.Table (S).User_Flag := Val;
+ end Set_State_Flag;
+
+ function Get_State_User_Link (S : NFA_State) return NFA_State is
+ begin
+ return Statet.Table (S).User_Link;
+ end Get_State_User_Link;
+
+ procedure Set_State_User_Link (S : NFA_State; Link : NFA_State) is
+ begin
+ Statet.Table (S).User_Link := Link;
+ end Set_State_User_Link;
+
+ function Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node)
+ return NFA_Edge
+ is
+ Res : NFA_Edge;
+ begin
+ -- Allocate a note.
+ if Free_Edges /= No_Edge then
+ Res := Free_Edges;
+ Free_Edges := Get_Next_Dest_Edge (Res);
+ else
+ Transt.Increment_Last;
+ Res := Transt.Last;
+ end if;
+
+ -- Initialize it.
+ Transt.Table (Res) := (Dest => Dest,
+ Src => Src,
+ Expr => Expr,
+ Next_Src => Get_First_Src_Edge (Src),
+ Next_Dst => Get_First_Dest_Edge (Dest));
+ Set_First_Src_Edge (Src, Res);
+ Set_First_Dest_Edge (Dest, Res);
+ return Res;
+ end Add_Edge;
+
+ procedure Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node) is
+ Res : NFA_Edge;
+ pragma Unreferenced (Res);
+ begin
+ Res := Add_Edge (Src, Dest, Expr);
+ end Add_Edge;
+
+ procedure Delete_Empty_NFA (N : NFA) is
+ begin
+ pragma Assert (Get_First_State (N) = No_State);
+ pragma Assert (Get_Last_State (N) = No_State);
+
+ -- Put it in front of the free_nfas list.
+ Set_First_State (N, NFA_State (Free_Nfas));
+ Free_Nfas := N;
+ end Delete_Empty_NFA;
+
+ function Get_Start_State (N : NFA) return NFA_State is
+ begin
+ return Nfat.Table (N).Start;
+ end Get_Start_State;
+
+ procedure Set_Start_State (N : NFA; S : NFA_State) is
+ begin
+ Nfat.Table (N).Start := S;
+ end Set_Start_State;
+
+ function Get_Final_State (N : NFA) return NFA_State is
+ begin
+ return Nfat.Table (N).Final;
+ end Get_Final_State;
+
+ procedure Set_Final_State (N : NFA; S : NFA_State) is
+ begin
+ Nfat.Table (N).Final := S;
+ end Set_Final_State;
+
+ function Get_Next_Src_Edge (N : NFA_Edge) return NFA_Edge is
+ begin
+ return Transt.Table (N).Next_Src;
+ end Get_Next_Src_Edge;
+
+ procedure Set_Next_Src_Edge (E : NFA_Edge; N_E : NFA_Edge) is
+ begin
+ Transt.Table (E).Next_Src := N_E;
+ end Set_Next_Src_Edge;
+
+ function Get_Next_Dest_Edge (N : NFA_Edge) return NFA_Edge is
+ begin
+ return Transt.Table (N).Next_Dst;
+ end Get_Next_Dest_Edge;
+
+ procedure Set_Next_Dest_Edge (E : NFA_Edge; N_E : NFA_Edge) is
+ begin
+ Transt.Table (E).Next_Dst := N_E;
+ end Set_Next_Dest_Edge;
+
+ function Get_Edge_Dest (E : NFA_Edge) return NFA_State is
+ begin
+ return Transt.Table (E).Dest;
+ end Get_Edge_Dest;
+
+ procedure Set_Edge_Dest (E : NFA_Edge; D : NFA_State) is
+ begin
+ Transt.Table (E).Dest := D;
+ end Set_Edge_Dest;
+
+ function Get_Edge_Src (E : NFA_Edge) return NFA_State is
+ begin
+ return Transt.Table (E).Src;
+ end Get_Edge_Src;
+
+ procedure Set_Edge_Src (E : NFA_Edge; D : NFA_State) is
+ begin
+ Transt.Table (E).Src := D;
+ end Set_Edge_Src;
+
+ function Get_Edge_Expr (E : NFA_Edge) return Node is
+ begin
+ return Transt.Table (E).Expr;
+ end Get_Edge_Expr;
+
+ procedure Set_Edge_Expr (E : NFA_Edge; N : Node) is
+ begin
+ Transt.Table (E).Expr := N;
+ end Set_Edge_Expr;
+
+ procedure Remove_Unconnected_State (N : NFA; S : NFA_State) is
+ N_S : constant NFA_State := Get_Next_State (S);
+ P_S : constant NFA_State := Get_Prev_State (S);
+ begin
+ pragma Assert (Get_First_Src_Edge (S) = No_Edge);
+ pragma Assert (Get_First_Dest_Edge (S) = No_Edge);
+
+ if P_S = No_State then
+ Set_First_State (N, N_S);
+ else
+ Set_Next_State (P_S, N_S);
+ end if;
+ if N_S = No_State then
+ Set_Last_State (N, P_S);
+ else
+ Set_Prev_State (N_S, P_S);
+ end if;
+ Delete_Detached_State (S);
+ end Remove_Unconnected_State;
+
+ procedure Merge_NFA (L, R : NFA) is
+ Last_L : constant NFA_State := Get_Last_State (L);
+ First_R : constant NFA_State := Get_First_State (R);
+ Last_R : constant NFA_State := Get_Last_State (R);
+ begin
+ if First_R = No_State then
+ return;
+ end if;
+ if Last_L = No_State then
+ Set_First_State (L, First_R);
+ else
+ Set_Next_State (Last_L, First_R);
+ Set_Prev_State (First_R, Last_L);
+ end if;
+ Set_Last_State (L, Last_R);
+ Set_First_State (R, No_State);
+ Set_Last_State (R, No_State);
+ Delete_Empty_NFA (R);
+ end Merge_NFA;
+
+ procedure Redest_Edges (S : NFA_State; Dest : NFA_State) is
+ E, N_E : NFA_Edge;
+ Head : NFA_Edge;
+ begin
+ E := Get_First_Dest_Edge (S);
+ if E = No_Edge then
+ return;
+ end if;
+ Set_First_Dest_Edge (S, No_Edge);
+ Head := Get_First_Dest_Edge (Dest);
+ Set_First_Dest_Edge (Dest, E);
+ loop
+ N_E := Get_Next_Dest_Edge (E);
+ Set_Edge_Dest (E, Dest);
+ exit when N_E = No_Edge;
+ E := N_E;
+ end loop;
+ Set_Next_Dest_Edge (E, Head);
+ end Redest_Edges;
+
+ procedure Resource_Edges (S : NFA_State; Src : NFA_State) is
+ E, N_E : NFA_Edge;
+ Head : NFA_Edge;
+ begin
+ E := Get_First_Src_Edge (S);
+ if E = No_Edge then
+ return;
+ end if;
+ Set_First_Src_Edge (S, No_Edge);
+ Head := Get_First_Src_Edge (Src);
+ Set_First_Src_Edge (Src, E);
+ loop
+ N_E := Get_Next_Src_Edge (E);
+ Set_Edge_Src (E, Src);
+ exit when N_E = No_Edge;
+ E := N_E;
+ end loop;
+ Set_Next_Src_Edge (E, Head);
+ end Resource_Edges;
+
+ procedure Disconnect_Edge_Src (N : NFA_State; E : NFA_Edge) is
+ N_E : constant NFA_Edge := Get_Next_Src_Edge (E);
+ Prev, Cur : NFA_Edge;
+ begin
+ Cur := Get_First_Src_Edge (N);
+ if Cur = E then
+ Set_First_Src_Edge (N, N_E);
+ else
+ while Cur /= E loop
+ Prev := Cur;
+ Cur := Get_Next_Src_Edge (Prev);
+ pragma Assert (Cur /= No_Edge);
+ end loop;
+ Set_Next_Src_Edge (Prev, N_E);
+ end if;
+ end Disconnect_Edge_Src;
+
+ procedure Disconnect_Edge_Dest (N : NFA_State; E : NFA_Edge) is
+ N_E : constant NFA_Edge := Get_Next_Dest_Edge (E);
+ Prev, Cur : NFA_Edge;
+ begin
+ Cur := Get_First_Dest_Edge (N);
+ if Cur = E then
+ Set_First_Dest_Edge (N, N_E);
+ else
+ while Cur /= E loop
+ Prev := Cur;
+ Cur := Get_Next_Dest_Edge (Prev);
+ pragma Assert (Cur /= No_Edge);
+ end loop;
+ Set_Next_Dest_Edge (Prev, N_E);
+ end if;
+ end Disconnect_Edge_Dest;
+
+ procedure Remove_Edge (E : NFA_Edge) is
+ begin
+ Disconnect_Edge_Src (Get_Edge_Src (E), E);
+ Disconnect_Edge_Dest (Get_Edge_Dest (E), E);
+
+ -- Put it on the free list.
+ Set_Next_Dest_Edge (E, Free_Edges);
+ Free_Edges := E;
+ end Remove_Edge;
+
+ procedure Remove_State (N : NFA; S : NFA_State) is
+ E, N_E : NFA_Edge;
+ begin
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ N_E := Get_Next_Dest_Edge (E);
+ Remove_Edge (E);
+ E := N_E;
+ end loop;
+
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ N_E := Get_Next_Src_Edge (E);
+ Remove_Edge (E);
+ E := N_E;
+ end loop;
+
+ Remove_Unconnected_State (N, S);
+ end Remove_State;
+
+ procedure Labelize_States (N : NFA; Nbr_States : out Natural)
+ is
+ S, Start, Final : NFA_State;
+ begin
+ S := Get_First_State (N);
+ Start := Get_Start_State (N);
+ Final := Get_Final_State (N);
+ pragma Assert (Start /= No_State);
+ Set_State_Label (Start, 0);
+ Nbr_States := 1;
+ while S /= No_State loop
+ if S /= Start and then S /= Final then
+ Set_State_Label (S, Int32 (Nbr_States));
+ Nbr_States := Nbr_States + 1;
+ end if;
+ S := Get_Next_State (S);
+ end loop;
+ pragma Assert (Final /= No_State);
+ Set_State_Label (Final, Int32 (Nbr_States));
+ Nbr_States := Nbr_States + 1;
+ end Labelize_States;
+
+ procedure Labelize_States_Debug (N : NFA)
+ is
+ S : NFA_State;
+ begin
+ S := Get_First_State (N);
+ while S /= No_State loop
+ Set_State_Label (S, Int32 (S));
+ S := Get_Next_State (S);
+ end loop;
+ end Labelize_States_Debug;
+
+end PSL.NFAs;
diff --git a/src/psl/psl-nfas.ads b/src/psl/psl-nfas.ads
new file mode 100644
index 000000000..815acf223
--- /dev/null
+++ b/src/psl/psl-nfas.ads
@@ -0,0 +1,108 @@
+with Types; use Types;
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.NFAs is
+ -- Represents NFAs for PSL.
+ -- These NFAs have the following restrictions:
+ -- * 1 start state
+ -- * 1 final state (which can be the start state).
+ -- * possible epsilon transition between start and final state with the
+ -- meaning: A | eps
+
+ type NFA_State is new Nat32;
+ type NFA_Edge is new Nat32;
+
+ No_NFA : constant NFA := 0;
+ No_State : constant NFA_State := 0;
+ No_Edge : constant NFA_Edge := 0;
+
+ -- Create a new NFA.
+ function Create_NFA return NFA;
+
+ -- Add a new state to an NFA.
+ function Add_State (N : NFA) return NFA_State;
+
+ -- Add a transition.
+ procedure Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node);
+ function Add_Edge (Src : NFA_State; Dest : NFA_State; Expr : Node)
+ return NFA_Edge;
+
+ -- Disconnect and free edge E.
+ procedure Remove_Edge (E : NFA_Edge);
+
+ -- Return TRUE if there is an epsilon edge between start and final.
+ function Get_Epsilon_NFA (N : NFA) return Boolean;
+ procedure Set_Epsilon_NFA (N : NFA; Flag : Boolean);
+
+ -- Each NFA has one start and one final state.
+ function Get_Start_State (N : NFA) return NFA_State;
+ procedure Set_Start_State (N : NFA; S : NFA_State);
+
+ procedure Set_Final_State (N : NFA; S : NFA_State);
+ function Get_Final_State (N : NFA) return NFA_State;
+
+ -- Iterate on all states.
+ function Get_First_State (N : NFA) return NFA_State;
+ function Get_Next_State (S : NFA_State) return NFA_State;
+
+ -- Per state user flag.
+ -- Initialized set to false.
+ function Get_State_Flag (S : NFA_State) return Boolean;
+ procedure Set_State_Flag (S : NFA_State; Val : Boolean);
+
+ -- Per state user link.
+ function Get_State_User_Link (S : NFA_State) return NFA_State;
+ procedure Set_State_User_Link (S : NFA_State; Link : NFA_State);
+
+ -- Edges of a state.
+ -- A source edge is an edge whose source is the state.
+ function Get_First_Src_Edge (N : NFA_State) return NFA_Edge;
+ function Get_Next_Src_Edge (N : NFA_Edge) return NFA_Edge;
+
+ -- A dest edge is an edge whose destination is the state.
+ function Get_First_Dest_Edge (N : NFA_State) return NFA_Edge;
+ function Get_Next_Dest_Edge (N : NFA_Edge) return NFA_Edge;
+
+ function Get_State_Label (S : NFA_State) return Int32;
+ procedure Set_State_Label (S : NFA_State; Label : Int32);
+
+ function Get_Edge_Dest (E: NFA_Edge) return NFA_State;
+ function Get_Edge_Src (E : NFA_Edge) return NFA_State;
+ function Get_Edge_Expr (E : NFA_Edge) return Node;
+
+ -- Move States and edges of R to L.
+ procedure Merge_NFA (L, R : NFA);
+
+ -- All edges to S are redirected to DEST.
+ procedure Redest_Edges (S : NFA_State; Dest : NFA_State);
+
+ -- All edges from S are redirected from SRC.
+ procedure Resource_Edges (S : NFA_State; Src : NFA_State);
+
+ -- Remove a state. The state must be unconnected.
+ procedure Remove_Unconnected_State (N : NFA; S : NFA_State);
+
+ -- Deconnect and remove state S.
+ procedure Remove_State (N : NFA; S : NFA_State);
+
+ procedure Delete_Empty_NFA (N : NFA);
+
+ -- Set a label on the states of the NFA N.
+ -- Start state is has label 0.
+ -- Return the number of states.
+ procedure Labelize_States (N : NFA; Nbr_States : out Natural);
+
+ -- Set state index as state label.
+ -- Used to debug an NFA.
+ procedure Labelize_States_Debug (N : NFA);
+
+ procedure Set_Edge_Expr (E : NFA_Edge; N : Node);
+private
+ -- Low level procedures. Shouldn't be used directly.
+ procedure Set_First_Dest_Edge (N : NFA_State; T : NFA_Edge);
+ procedure Set_Next_Dest_Edge (E : NFA_Edge; N_E : NFA_Edge);
+ procedure Set_First_Src_Edge (N : NFA_State; T : NFA_Edge);
+ procedure Set_Next_Src_Edge (E : NFA_Edge; N_E : NFA_Edge);
+ procedure Set_Edge_Dest (E : NFA_Edge; D : NFA_State);
+ procedure Set_Edge_Src (E : NFA_Edge; D : NFA_State);
+end PSL.NFAs;
diff --git a/src/psl/psl-nodes.adb b/src/psl/psl-nodes.adb
new file mode 100644
index 000000000..a6482a142
--- /dev/null
+++ b/src/psl/psl-nodes.adb
@@ -0,0 +1,1231 @@
+-- This is in fact -*- Ada -*-
+with Ada.Unchecked_Conversion;
+with GNAT.Table;
+with PSL.Errors;
+with PSL.Hash;
+
+package body PSL.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.
+ --pragma Suppress (Index_Check);
+
+ type Format_Type is
+ (
+ Format_Short,
+ Format_Medium
+ );
+
+ pragma Unreferenced (Format_Type, Format_Short, Format_Medium);
+
+ -- Common fields are:
+ -- Flag1 : Boolean
+ -- Flag2 : Boolean
+ -- Flag3 : Boolean
+ -- Flag4 : Boolean
+ -- Flag5 : Boolean
+ -- Flag6 : Boolean
+ -- Nkind : Kind_Type
+ -- State1 : Bit2_Type
+ -- State2 : Bit2_Type
+ -- Location : Int32
+ -- Field1 : Int32
+ -- Field2 : Int32
+ -- Field3 : Int32
+ -- Field4 : Int32
+
+ -- Fields of Format_Short:
+ -- Field5 : Int32
+ -- Field6 : Int32
+
+ -- Fields of Format_Medium:
+ -- Odigit1 : Bit3_Type
+ -- Odigit2 : Bit3_Type
+ -- State3 : Bit2_Type
+ -- State4 : Bit2_Type
+ -- Field5 : Int32
+ -- Field6 : Int32
+ -- Field7 : Int32 (location)
+ -- Field8 : Int32 (field1)
+ -- Field9 : Int32 (field2)
+ -- Field10 : Int32 (field3)
+ -- Field11 : Int32 (field4)
+ -- Field12 : Int32 (field5)
+
+ type State_Type is range 0 .. 3;
+ type Bit3_Type is range 0 .. 7;
+
+ type Node_Record is record
+ Kind : Nkind;
+ Flag1 : Boolean;
+ Flag2 : Boolean;
+ Flag3 : Boolean;
+ Flag4 : Boolean;
+ Flag5 : Boolean;
+ Flag6 : Boolean;
+ Flag7 : Boolean;
+ Flag8 : Boolean;
+ Flag9 : Boolean;
+ Flag10 : Boolean;
+ Flag11 : Boolean;
+ Flag12 : Boolean;
+ Flag13 : Boolean;
+ Flag14 : Boolean;
+ Flag15 : Boolean;
+ Flag16 : Boolean;
+ State1 : State_Type;
+ B3_1 : Bit3_Type;
+ Flag17 : Boolean;
+ Flag18 : Boolean;
+ Flag19 : Boolean;
+
+ Location : Int32;
+ Field1 : Int32;
+ Field2 : Int32;
+ Field3 : Int32;
+ Field4 : Int32;
+ Field5 : Int32;
+ Field6 : Int32;
+ end record;
+ pragma Pack (Node_Record);
+ for Node_Record'Size use 8 * 32;
+
+ package Nodet is new GNAT.Table
+ (Table_Component_Type => Node_Record,
+ Table_Index_Type => Node,
+ Table_Low_Bound => 1,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ Init_Node : constant Node_Record := (Kind => N_Error,
+ Flag1 => False,
+ Flag2 => False,
+ State1 => 0,
+ B3_1 => 0,
+ Location => 0,
+ Field1 => 0,
+ Field2 => 0,
+ Field3 => 0,
+ Field4 => 0,
+ Field5 => 0,
+ Field6 => 0,
+ others => False);
+
+ Free_Nodes : Node := Null_Node;
+
+
+ function Get_Last_Node return Node is
+ begin
+ return Nodet.Last;
+ end Get_Last_Node;
+
+ function Int32_To_Uns32 is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => Uns32);
+
+ function Uns32_To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Uns32, Target => Int32);
+
+ function Int32_To_NFA is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => NFA);
+
+ function NFA_To_Int32 is new Ada.Unchecked_Conversion
+ (Source => NFA, Target => Int32);
+
+ procedure Set_Kind (N : Node; K : Nkind) is
+ begin
+ Nodet.Table (N).Kind := K;
+ end Set_Kind;
+
+ function Get_Kind (N : Node) return Nkind is
+ begin
+ return Nodet.Table (N).Kind;
+ end Get_Kind;
+
+
+ procedure Set_Flag1 (N : Node; Flag : Boolean) is
+ begin
+ Nodet.Table (N).Flag1 := Flag;
+ end Set_Flag1;
+
+ function Get_Flag1 (N : Node) return Boolean is
+ begin
+ return Nodet.Table (N).Flag1;
+ end Get_Flag1;
+
+ procedure Set_Flag2 (N : Node; Flag : Boolean) is
+ begin
+ Nodet.Table (N).Flag2 := Flag;
+ end Set_Flag2;
+
+ function Get_Flag2 (N : Node) return Boolean is
+ begin
+ return Nodet.Table (N).Flag2;
+ end Get_Flag2;
+
+
+ procedure Set_State1 (N : Node; S : State_Type) is
+ begin
+ Nodet.Table (N).State1 := S;
+ end Set_State1;
+
+ function Get_State1 (N : Node) return State_Type is
+ begin
+ return Nodet.Table (N).State1;
+ end Get_State1;
+
+
+ function Get_Location (N : Node) return Location_Type is
+ begin
+ return Location_Type (Nodet.Table (N).Location);
+ end Get_Location;
+
+ procedure Set_Location (N : Node; Loc : Location_Type) is
+ begin
+ Nodet.Table (N).Location := Int32 (Loc);
+ end Set_Location;
+
+
+ procedure Set_Field1 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field1 := V;
+ end Set_Field1;
+
+ function Get_Field1 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field1;
+ end Get_Field1;
+
+
+ procedure Set_Field2 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field2 := V;
+ end Set_Field2;
+
+ function Get_Field2 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field2;
+ end Get_Field2;
+
+
+ function Get_Field3 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field3;
+ end Get_Field3;
+
+ procedure Set_Field3 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field3 := V;
+ end Set_Field3;
+
+
+ function Get_Field4 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field4;
+ end Get_Field4;
+
+ procedure Set_Field4 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field4 := V;
+ end Set_Field4;
+
+
+ function Get_Field5 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field5;
+ end Get_Field5;
+
+ procedure Set_Field5 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field5 := V;
+ end Set_Field5;
+
+
+ function Get_Field6 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N).Field6;
+ end Get_Field6;
+
+ procedure Set_Field6 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N).Field6 := V;
+ end Set_Field6;
+
+ procedure Set_Field7 (N : Node; V : Int32) is
+ begin
+ Nodet.Table (N + 1).Field1 := V;
+ end Set_Field7;
+
+ function Get_Field7 (N : Node) return Int32 is
+ begin
+ return Nodet.Table (N + 1).Field1;
+ end Get_Field7;
+
+
+ function Create_Node (Kind : Nkind) return Node
+ is
+ Res : Node;
+ begin
+ if Free_Nodes /= Null_Node then
+ Res := Free_Nodes;
+ Free_Nodes := Node (Get_Field1 (Res));
+ else
+ Nodet.Increment_Last;
+ Res := Nodet.Last;
+ end if;
+ Nodet.Table (Res) := Init_Node;
+ Set_Kind (Res, Kind);
+ return Res;
+ end Create_Node;
+
+ procedure Free_Node (N : Node)
+ is
+ begin
+ Set_Kind (N, N_Error);
+ Set_Field1 (N, Int32 (Free_Nodes));
+ Free_Nodes := N;
+ end Free_Node;
+
+ procedure Failed (Msg : String; N : Node)
+ is
+ begin
+ Errors.Error_Kind (Msg, N);
+ end Failed;
+
+ procedure Init is
+ begin
+ Nodet.Init;
+ if Create_Node (N_False) /= False_Node then
+ raise Internal_Error;
+ end if;
+ if Create_Node (N_True) /= True_Node then
+ raise Internal_Error;
+ end if;
+ if Create_Node (N_Number) /= One_Node then
+ raise Internal_Error;
+ end if;
+ Set_Value (One_Node, 1);
+ if Create_Node (N_EOS) /= EOS_Node then
+ raise Internal_Error;
+ end if;
+ Set_Hash (EOS_Node, 0);
+ PSL.Hash.Init;
+ end Init;
+
+ function Get_Psl_Type (N : Node) return PSL_Types is
+ begin
+ case Get_Kind (N) is
+ when N_And_Prop
+ | N_Or_Prop
+ | N_Log_Imp_Prop
+ | N_Always
+ | N_Never
+ | N_Eventually
+ | N_Next
+ | N_Next_E
+ | N_Next_A
+ | N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Before
+ | N_Until
+ | N_Abort
+ | N_Strong
+ | N_Property_Parameter
+ | N_Property_Instance =>
+ return Type_Property;
+ when N_Braced_SERE
+ | N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Within_SERE
+ | N_Overlap_Imp_Seq
+ | N_Imp_Seq
+ | N_And_Seq
+ | N_Or_Seq
+ | N_Match_And_Seq
+ | N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Equal_Repeat_Seq
+ | N_Plus_Repeat_Seq
+ | N_Clock_Event
+ | N_Sequence_Instance
+ | N_Endpoint_Instance
+ | N_Sequence_Parameter =>
+ return Type_Sequence;
+ when N_Name =>
+ return Get_Psl_Type (Get_Decl (N));
+ when N_HDL_Expr =>
+ -- FIXME.
+ return Type_Boolean;
+ when N_Or_Bool
+ | N_And_Bool
+ | N_Not_Bool
+ | N_Imp_Bool
+ | N_False
+ | N_True
+ | N_Boolean_Parameter =>
+ return Type_Boolean;
+ when N_Number
+ | N_Const_Parameter =>
+ return Type_Numeric;
+ when N_Vmode
+ | N_Vunit
+ | N_Vprop
+ | N_Hdl_Mod_Name
+ | N_Assert_Directive
+ | N_Sequence_Declaration
+ | N_Endpoint_Declaration
+ | N_Property_Declaration
+ | N_Actual
+ | N_Name_Decl
+ | N_Error
+ | N_EOS =>
+ PSL.Errors.Error_Kind ("get_psl_type", N);
+ end case;
+ end Get_Psl_Type;
+
+ procedure Reference_Failed (Msg : String; N : Node) is
+ begin
+ Failed (Msg, N);
+ end Reference_Failed;
+ pragma Unreferenced (Reference_Failed);
+
+ pragma Unreferenced (Set_Field7, Get_Field7);
+ -- Subprograms.
+ procedure Check_Kind_For_Identifier (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Vmode
+ | N_Vunit
+ | N_Vprop
+ | N_Hdl_Mod_Name
+ | N_Property_Declaration
+ | N_Sequence_Declaration
+ | N_Endpoint_Declaration
+ | N_Const_Parameter
+ | N_Boolean_Parameter
+ | N_Property_Parameter
+ | N_Sequence_Parameter
+ | N_Name
+ | N_Name_Decl =>
+ null;
+ when others =>
+ Failed ("Get/Set_Identifier", N);
+ end case;
+ end Check_Kind_For_Identifier;
+
+ function Get_Identifier (N : Node) return Name_Id is
+ begin
+ Check_Kind_For_Identifier (N);
+ return Name_Id (Get_Field1 (N));
+ end Get_Identifier;
+
+ procedure Set_Identifier (N : Node; Id : Name_Id) is
+ begin
+ Check_Kind_For_Identifier (N);
+ Set_Field1 (N, Int32 (Id));
+ end Set_Identifier;
+
+ procedure Check_Kind_For_Chain (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Vmode
+ | N_Vunit
+ | N_Vprop
+ | N_Assert_Directive
+ | N_Property_Declaration
+ | N_Sequence_Declaration
+ | N_Endpoint_Declaration
+ | N_Const_Parameter
+ | N_Boolean_Parameter
+ | N_Property_Parameter
+ | N_Sequence_Parameter
+ | N_Actual
+ | N_Name_Decl =>
+ null;
+ when others =>
+ Failed ("Get/Set_Chain", N);
+ end case;
+ end Check_Kind_For_Chain;
+
+ function Get_Chain (N : Node) return Node is
+ begin
+ Check_Kind_For_Chain (N);
+ return Node (Get_Field2 (N));
+ end Get_Chain;
+
+ procedure Set_Chain (N : Node; Chain : Node) is
+ begin
+ Check_Kind_For_Chain (N);
+ Set_Field2 (N, Int32 (Chain));
+ end Set_Chain;
+
+ procedure Check_Kind_For_Instance (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Vmode
+ | N_Vunit
+ | N_Vprop =>
+ null;
+ when others =>
+ Failed ("Get/Set_Instance", N);
+ end case;
+ end Check_Kind_For_Instance;
+
+ function Get_Instance (N : Node) return Node is
+ begin
+ Check_Kind_For_Instance (N);
+ return Node (Get_Field3 (N));
+ end Get_Instance;
+
+ procedure Set_Instance (N : Node; Instance : Node) is
+ begin
+ Check_Kind_For_Instance (N);
+ Set_Field3 (N, Int32 (Instance));
+ end Set_Instance;
+
+ procedure Check_Kind_For_Item_Chain (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Vmode
+ | N_Vunit
+ | N_Vprop =>
+ null;
+ when others =>
+ Failed ("Get/Set_Item_Chain", N);
+ end case;
+ end Check_Kind_For_Item_Chain;
+
+ function Get_Item_Chain (N : Node) return Node is
+ begin
+ Check_Kind_For_Item_Chain (N);
+ return Node (Get_Field4 (N));
+ end Get_Item_Chain;
+
+ procedure Set_Item_Chain (N : Node; Item : Node) is
+ begin
+ Check_Kind_For_Item_Chain (N);
+ Set_Field4 (N, Int32 (Item));
+ end Set_Item_Chain;
+
+ procedure Check_Kind_For_Prefix (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Hdl_Mod_Name =>
+ null;
+ when others =>
+ Failed ("Get/Set_Prefix", N);
+ end case;
+ end Check_Kind_For_Prefix;
+
+ function Get_Prefix (N : Node) return Node is
+ begin
+ Check_Kind_For_Prefix (N);
+ return Node (Get_Field2 (N));
+ end Get_Prefix;
+
+ procedure Set_Prefix (N : Node; Prefix : Node) is
+ begin
+ Check_Kind_For_Prefix (N);
+ Set_Field2 (N, Int32 (Prefix));
+ end Set_Prefix;
+
+ procedure Check_Kind_For_Label (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Assert_Directive =>
+ null;
+ when others =>
+ Failed ("Get/Set_Label", N);
+ end case;
+ end Check_Kind_For_Label;
+
+ function Get_Label (N : Node) return Name_Id is
+ begin
+ Check_Kind_For_Label (N);
+ return Name_Id (Get_Field1 (N));
+ end Get_Label;
+
+ procedure Set_Label (N : Node; Id : Name_Id) is
+ begin
+ Check_Kind_For_Label (N);
+ Set_Field1 (N, Int32 (Id));
+ end Set_Label;
+
+ procedure Check_Kind_For_String (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Assert_Directive =>
+ null;
+ when others =>
+ Failed ("Get/Set_String", N);
+ end case;
+ end Check_Kind_For_String;
+
+ function Get_String (N : Node) return Node is
+ begin
+ Check_Kind_For_String (N);
+ return Node (Get_Field3 (N));
+ end Get_String;
+
+ procedure Set_String (N : Node; Str : Node) is
+ begin
+ Check_Kind_For_String (N);
+ Set_Field3 (N, Int32 (Str));
+ end Set_String;
+
+ procedure Check_Kind_For_Property (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Assert_Directive
+ | N_Property_Declaration
+ | N_Clock_Event
+ | N_Always
+ | N_Never
+ | N_Eventually
+ | N_Strong
+ | N_Imp_Seq
+ | N_Overlap_Imp_Seq
+ | N_Next
+ | N_Next_A
+ | N_Next_E
+ | N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Abort =>
+ null;
+ when others =>
+ Failed ("Get/Set_Property", N);
+ end case;
+ end Check_Kind_For_Property;
+
+ function Get_Property (N : Node) return Node is
+ begin
+ Check_Kind_For_Property (N);
+ return Node (Get_Field4 (N));
+ end Get_Property;
+
+ procedure Set_Property (N : Node; Property : Node) is
+ begin
+ Check_Kind_For_Property (N);
+ Set_Field4 (N, Int32 (Property));
+ end Set_Property;
+
+ procedure Check_Kind_For_NFA (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Assert_Directive =>
+ null;
+ when others =>
+ Failed ("Get/Set_NFA", N);
+ end case;
+ end Check_Kind_For_NFA;
+
+ function Get_NFA (N : Node) return NFA is
+ begin
+ Check_Kind_For_NFA (N);
+ return Int32_To_NFA (Get_Field5 (N));
+ end Get_NFA;
+
+ procedure Set_NFA (N : Node; P : NFA) is
+ begin
+ Check_Kind_For_NFA (N);
+ Set_Field5 (N, NFA_To_Int32 (P));
+ end Set_NFA;
+
+ procedure Check_Kind_For_Global_Clock (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Property_Declaration =>
+ null;
+ when others =>
+ Failed ("Get/Set_Global_Clock", N);
+ end case;
+ end Check_Kind_For_Global_Clock;
+
+ function Get_Global_Clock (N : Node) return Node is
+ begin
+ Check_Kind_For_Global_Clock (N);
+ return Node (Get_Field3 (N));
+ end Get_Global_Clock;
+
+ procedure Set_Global_Clock (N : Node; Clock : Node) is
+ begin
+ Check_Kind_For_Global_Clock (N);
+ Set_Field3 (N, Int32 (Clock));
+ end Set_Global_Clock;
+
+ procedure Check_Kind_For_Parameter_List (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Property_Declaration
+ | N_Sequence_Declaration
+ | N_Endpoint_Declaration =>
+ null;
+ when others =>
+ Failed ("Get/Set_Parameter_List", N);
+ end case;
+ end Check_Kind_For_Parameter_List;
+
+ function Get_Parameter_List (N : Node) return Node is
+ begin
+ Check_Kind_For_Parameter_List (N);
+ return Node (Get_Field5 (N));
+ end Get_Parameter_List;
+
+ procedure Set_Parameter_List (N : Node; E : Node) is
+ begin
+ Check_Kind_For_Parameter_List (N);
+ Set_Field5 (N, Int32 (E));
+ end Set_Parameter_List;
+
+ procedure Check_Kind_For_Sequence (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Sequence_Declaration
+ | N_Endpoint_Declaration
+ | N_Imp_Seq
+ | N_Overlap_Imp_Seq
+ | N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Plus_Repeat_Seq
+ | N_Equal_Repeat_Seq =>
+ null;
+ when others =>
+ Failed ("Get/Set_Sequence", N);
+ end case;
+ end Check_Kind_For_Sequence;
+
+ function Get_Sequence (N : Node) return Node is
+ begin
+ Check_Kind_For_Sequence (N);
+ return Node (Get_Field3 (N));
+ end Get_Sequence;
+
+ procedure Set_Sequence (N : Node; S : Node) is
+ begin
+ Check_Kind_For_Sequence (N);
+ Set_Field3 (N, Int32 (S));
+ end Set_Sequence;
+
+ procedure Check_Kind_For_Actual (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Const_Parameter
+ | N_Boolean_Parameter
+ | N_Property_Parameter
+ | N_Sequence_Parameter
+ | N_Actual =>
+ null;
+ when others =>
+ Failed ("Get/Set_Actual", N);
+ end case;
+ end Check_Kind_For_Actual;
+
+ function Get_Actual (N : Node) return Node is
+ begin
+ Check_Kind_For_Actual (N);
+ return Node (Get_Field3 (N));
+ end Get_Actual;
+
+ procedure Set_Actual (N : Node; E : Node) is
+ begin
+ Check_Kind_For_Actual (N);
+ Set_Field3 (N, Int32 (E));
+ end Set_Actual;
+
+ procedure Check_Kind_For_Declaration (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Sequence_Instance
+ | N_Endpoint_Instance
+ | N_Property_Instance =>
+ null;
+ when others =>
+ Failed ("Get/Set_Declaration", N);
+ end case;
+ end Check_Kind_For_Declaration;
+
+ function Get_Declaration (N : Node) return Node is
+ begin
+ Check_Kind_For_Declaration (N);
+ return Node (Get_Field1 (N));
+ end Get_Declaration;
+
+ procedure Set_Declaration (N : Node; Decl : Node) is
+ begin
+ Check_Kind_For_Declaration (N);
+ Set_Field1 (N, Int32 (Decl));
+ end Set_Declaration;
+
+ procedure Check_Kind_For_Association_Chain (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Sequence_Instance
+ | N_Endpoint_Instance
+ | N_Property_Instance =>
+ null;
+ when others =>
+ Failed ("Get/Set_Association_Chain", N);
+ end case;
+ end Check_Kind_For_Association_Chain;
+
+ function Get_Association_Chain (N : Node) return Node is
+ begin
+ Check_Kind_For_Association_Chain (N);
+ return Node (Get_Field2 (N));
+ end Get_Association_Chain;
+
+ procedure Set_Association_Chain (N : Node; Chain : Node) is
+ begin
+ Check_Kind_For_Association_Chain (N);
+ Set_Field2 (N, Int32 (Chain));
+ end Set_Association_Chain;
+
+ procedure Check_Kind_For_Formal (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Actual =>
+ null;
+ when others =>
+ Failed ("Get/Set_Formal", N);
+ end case;
+ end Check_Kind_For_Formal;
+
+ function Get_Formal (N : Node) return Node is
+ begin
+ Check_Kind_For_Formal (N);
+ return Node (Get_Field4 (N));
+ end Get_Formal;
+
+ procedure Set_Formal (N : Node; E : Node) is
+ begin
+ Check_Kind_For_Formal (N);
+ Set_Field4 (N, Int32 (E));
+ end Set_Formal;
+
+ procedure Check_Kind_For_Boolean (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Clock_Event
+ | N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Abort
+ | N_Not_Bool =>
+ null;
+ when others =>
+ Failed ("Get/Set_Boolean", N);
+ end case;
+ end Check_Kind_For_Boolean;
+
+ function Get_Boolean (N : Node) return Node is
+ begin
+ Check_Kind_For_Boolean (N);
+ return Node (Get_Field3 (N));
+ end Get_Boolean;
+
+ procedure Set_Boolean (N : Node; B : Node) is
+ begin
+ Check_Kind_For_Boolean (N);
+ Set_Field3 (N, Int32 (B));
+ end Set_Boolean;
+
+ procedure Check_Kind_For_Strong_Flag (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Next
+ | N_Next_A
+ | N_Next_E
+ | N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Until
+ | N_Before =>
+ null;
+ when others =>
+ Failed ("Get/Set_Strong_Flag", N);
+ end case;
+ end Check_Kind_For_Strong_Flag;
+
+ function Get_Strong_Flag (N : Node) return Boolean is
+ begin
+ Check_Kind_For_Strong_Flag (N);
+ return Get_Flag1 (N);
+ end Get_Strong_Flag;
+
+ procedure Set_Strong_Flag (N : Node; B : Boolean) is
+ begin
+ Check_Kind_For_Strong_Flag (N);
+ Set_Flag1 (N, B);
+ end Set_Strong_Flag;
+
+ procedure Check_Kind_For_Number (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Next
+ | N_Next_Event =>
+ null;
+ when others =>
+ Failed ("Get/Set_Number", N);
+ end case;
+ end Check_Kind_For_Number;
+
+ function Get_Number (N : Node) return Node is
+ begin
+ Check_Kind_For_Number (N);
+ return Node (Get_Field1 (N));
+ end Get_Number;
+
+ procedure Set_Number (N : Node; S : Node) is
+ begin
+ Check_Kind_For_Number (N);
+ Set_Field1 (N, Int32 (S));
+ end Set_Number;
+
+ procedure Check_Kind_For_Decl (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Name =>
+ null;
+ when others =>
+ Failed ("Get/Set_Decl", N);
+ end case;
+ end Check_Kind_For_Decl;
+
+ function Get_Decl (N : Node) return Node is
+ begin
+ Check_Kind_For_Decl (N);
+ return Node (Get_Field2 (N));
+ end Get_Decl;
+
+ procedure Set_Decl (N : Node; D : Node) is
+ begin
+ Check_Kind_For_Decl (N);
+ Set_Field2 (N, Int32 (D));
+ end Set_Decl;
+
+ procedure Check_Kind_For_Value (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Number =>
+ null;
+ when others =>
+ Failed ("Get/Set_Value", N);
+ end case;
+ end Check_Kind_For_Value;
+
+ function Get_Value (N : Node) return Uns32 is
+ begin
+ Check_Kind_For_Value (N);
+ return Int32_To_Uns32 (Get_Field1 (N));
+ end Get_Value;
+
+ procedure Set_Value (N : Node; Val : Uns32) is
+ begin
+ Check_Kind_For_Value (N);
+ Set_Field1 (N, Uns32_To_Int32 (Val));
+ end Set_Value;
+
+ procedure Check_Kind_For_SERE (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Braced_SERE =>
+ null;
+ when others =>
+ Failed ("Get/Set_SERE", N);
+ end case;
+ end Check_Kind_For_SERE;
+
+ function Get_SERE (N : Node) return Node is
+ begin
+ Check_Kind_For_SERE (N);
+ return Node (Get_Field1 (N));
+ end Get_SERE;
+
+ procedure Set_SERE (N : Node; S : Node) is
+ begin
+ Check_Kind_For_SERE (N);
+ Set_Field1 (N, Int32 (S));
+ end Set_SERE;
+
+ procedure Check_Kind_For_Left (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Log_Imp_Prop
+ | N_Until
+ | N_Before
+ | N_Or_Prop
+ | N_And_Prop
+ | N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Within_SERE
+ | N_Match_And_Seq
+ | N_And_Seq
+ | N_Or_Seq
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool =>
+ null;
+ when others =>
+ Failed ("Get/Set_Left", N);
+ end case;
+ end Check_Kind_For_Left;
+
+ function Get_Left (N : Node) return Node is
+ begin
+ Check_Kind_For_Left (N);
+ return Node (Get_Field1 (N));
+ end Get_Left;
+
+ procedure Set_Left (N : Node; S : Node) is
+ begin
+ Check_Kind_For_Left (N);
+ Set_Field1 (N, Int32 (S));
+ end Set_Left;
+
+ procedure Check_Kind_For_Right (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Log_Imp_Prop
+ | N_Until
+ | N_Before
+ | N_Or_Prop
+ | N_And_Prop
+ | N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Within_SERE
+ | N_Match_And_Seq
+ | N_And_Seq
+ | N_Or_Seq
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool =>
+ null;
+ when others =>
+ Failed ("Get/Set_Right", N);
+ end case;
+ end Check_Kind_For_Right;
+
+ function Get_Right (N : Node) return Node is
+ begin
+ Check_Kind_For_Right (N);
+ return Node (Get_Field2 (N));
+ end Get_Right;
+
+ procedure Set_Right (N : Node; S : Node) is
+ begin
+ Check_Kind_For_Right (N);
+ Set_Field2 (N, Int32 (S));
+ end Set_Right;
+
+ procedure Check_Kind_For_Low_Bound (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Next_A
+ | N_Next_E
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Equal_Repeat_Seq =>
+ null;
+ when others =>
+ Failed ("Get/Set_Low_Bound", N);
+ end case;
+ end Check_Kind_For_Low_Bound;
+
+ function Get_Low_Bound (N : Node) return Node is
+ begin
+ Check_Kind_For_Low_Bound (N);
+ return Node (Get_Field1 (N));
+ end Get_Low_Bound;
+
+ procedure Set_Low_Bound (N : Node; S : Node) is
+ begin
+ Check_Kind_For_Low_Bound (N);
+ Set_Field1 (N, Int32 (S));
+ end Set_Low_Bound;
+
+ procedure Check_Kind_For_High_Bound (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Next_A
+ | N_Next_E
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Equal_Repeat_Seq =>
+ null;
+ when others =>
+ Failed ("Get/Set_High_Bound", N);
+ end case;
+ end Check_Kind_For_High_Bound;
+
+ function Get_High_Bound (N : Node) return Node is
+ begin
+ Check_Kind_For_High_Bound (N);
+ return Node (Get_Field2 (N));
+ end Get_High_Bound;
+
+ procedure Set_High_Bound (N : Node; S : Node) is
+ begin
+ Check_Kind_For_High_Bound (N);
+ Set_Field2 (N, Int32 (S));
+ end Set_High_Bound;
+
+ procedure Check_Kind_For_Inclusive_Flag (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Until
+ | N_Before =>
+ null;
+ when others =>
+ Failed ("Get/Set_Inclusive_Flag", N);
+ end case;
+ end Check_Kind_For_Inclusive_Flag;
+
+ function Get_Inclusive_Flag (N : Node) return Boolean is
+ begin
+ Check_Kind_For_Inclusive_Flag (N);
+ return Get_Flag2 (N);
+ end Get_Inclusive_Flag;
+
+ procedure Set_Inclusive_Flag (N : Node; B : Boolean) is
+ begin
+ Check_Kind_For_Inclusive_Flag (N);
+ Set_Flag2 (N, B);
+ end Set_Inclusive_Flag;
+
+ procedure Check_Kind_For_Presence (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Not_Bool
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool
+ | N_HDL_Expr =>
+ null;
+ when others =>
+ Failed ("Get/Set_Presence", N);
+ end case;
+ end Check_Kind_For_Presence;
+
+ function Get_Presence (N : Node) return PSL_Presence_Kind is
+ begin
+ Check_Kind_For_Presence (N);
+ return PSL_Presence_Kind'Val(Get_State1 (N));
+ end Get_Presence;
+
+ procedure Set_Presence (N : Node; P : PSL_Presence_Kind) is
+ begin
+ Check_Kind_For_Presence (N);
+ Set_State1 (N, PSL_Presence_Kind'pos (P));
+ end Set_Presence;
+
+ procedure Check_Kind_For_HDL_Node (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_HDL_Expr =>
+ null;
+ when others =>
+ Failed ("Get/Set_HDL_Node", N);
+ end case;
+ end Check_Kind_For_HDL_Node;
+
+ function Get_HDL_Node (N : Node) return HDL_Node is
+ begin
+ Check_Kind_For_HDL_Node (N);
+ return Get_Field1 (N);
+ end Get_HDL_Node;
+
+ procedure Set_HDL_Node (N : Node; H : HDL_Node) is
+ begin
+ Check_Kind_For_HDL_Node (N);
+ Set_Field1 (N, H);
+ end Set_HDL_Node;
+
+ procedure Check_Kind_For_HDL_Index (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_HDL_Expr
+ | N_EOS =>
+ null;
+ when others =>
+ Failed ("Get/Set_HDL_Index", N);
+ end case;
+ end Check_Kind_For_HDL_Index;
+
+ function Get_HDL_Index (N : Node) return Int32 is
+ begin
+ Check_Kind_For_HDL_Index (N);
+ return Get_Field2 (N);
+ end Get_HDL_Index;
+
+ procedure Set_HDL_Index (N : Node; Idx : Int32) is
+ begin
+ Check_Kind_For_HDL_Index (N);
+ Set_Field2 (N, Idx);
+ end Set_HDL_Index;
+
+ procedure Check_Kind_For_Hash (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Not_Bool
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool
+ | N_HDL_Expr
+ | N_EOS =>
+ null;
+ when others =>
+ Failed ("Get/Set_Hash", N);
+ end case;
+ end Check_Kind_For_Hash;
+
+ function Get_Hash (N : Node) return Uns32 is
+ begin
+ Check_Kind_For_Hash (N);
+ return Int32_To_Uns32 (Get_Field5 (N));
+ end Get_Hash;
+
+ procedure Set_Hash (N : Node; E : Uns32) is
+ begin
+ Check_Kind_For_Hash (N);
+ Set_Field5 (N, Uns32_To_Int32 (E));
+ end Set_Hash;
+
+ procedure Check_Kind_For_Hash_Link (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Not_Bool
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool
+ | N_HDL_Expr
+ | N_EOS =>
+ null;
+ when others =>
+ Failed ("Get/Set_Hash_Link", N);
+ end case;
+ end Check_Kind_For_Hash_Link;
+
+ function Get_Hash_Link (N : Node) return Node is
+ begin
+ Check_Kind_For_Hash_Link (N);
+ return Node (Get_Field6 (N));
+ end Get_Hash_Link;
+
+ procedure Set_Hash_Link (N : Node; E : Node) is
+ begin
+ Check_Kind_For_Hash_Link (N);
+ Set_Field6 (N, Int32 (E));
+ end Set_Hash_Link;
+
+
+end PSL.Nodes;
+
diff --git a/src/psl/psl-nodes.ads b/src/psl/psl-nodes.ads
new file mode 100644
index 000000000..241091805
--- /dev/null
+++ b/src/psl/psl-nodes.ads
@@ -0,0 +1,563 @@
+with Types; use Types;
+
+package PSL.Nodes is
+ type Nkind is
+ (
+ N_Error,
+
+ N_Vmode,
+ N_Vunit,
+ N_Vprop,
+
+ N_Hdl_Mod_Name,
+
+ N_Assert_Directive,
+ N_Property_Declaration,
+ N_Sequence_Declaration,
+ N_Endpoint_Declaration,
+
+ -- Formal parameters
+ N_Const_Parameter,
+ N_Boolean_Parameter,
+ N_Property_Parameter,
+ N_Sequence_Parameter,
+
+ N_Sequence_Instance,
+ N_Endpoint_Instance,
+ N_Property_Instance,
+ N_Actual,
+
+ N_Clock_Event,
+
+ -- Properties
+ N_Always,
+ N_Never,
+ N_Eventually,
+ N_Strong, -- !
+ N_Imp_Seq, -- |=>
+ N_Overlap_Imp_Seq, -- |->
+ N_Log_Imp_Prop, -- ->
+ N_Next,
+ N_Next_A,
+ N_Next_E,
+ N_Next_Event,
+ N_Next_Event_A,
+ N_Next_Event_E,
+ N_Abort,
+ N_Until,
+ N_Before,
+ N_Or_Prop,
+ N_And_Prop,
+
+ -- Sequences/SERE.
+ N_Braced_SERE,
+ N_Concat_SERE,
+ N_Fusion_SERE,
+ N_Within_SERE,
+
+ N_Match_And_Seq, -- &&
+ N_And_Seq,
+ N_Or_Seq,
+
+ N_Star_Repeat_Seq,
+ N_Goto_Repeat_Seq,
+ N_Plus_Repeat_Seq, -- [+]
+ N_Equal_Repeat_Seq,
+
+ -- Boolean layer.
+ N_Not_Bool,
+ N_And_Bool,
+ N_Or_Bool,
+ N_Imp_Bool, -- ->
+ N_HDL_Expr,
+ N_False,
+ N_True,
+ N_EOS,
+
+ N_Name,
+ N_Name_Decl,
+ N_Number
+ );
+ for Nkind'Size use 8;
+
+ subtype N_Booleans is Nkind range N_Not_Bool .. N_True;
+ subtype N_Sequences is Nkind range N_Braced_SERE .. N_Equal_Repeat_Seq;
+
+ type PSL_Types is
+ (
+ Type_Unknown,
+ Type_Boolean,
+ Type_Bit,
+ Type_Bitvector,
+ Type_Numeric,
+ Type_String,
+ Type_Sequence,
+ Type_Property
+ );
+
+ -- Within CSE, it is useful to know which sub-expression already compose
+ -- an expression.
+ -- Eg: suppose we want to build A and B.
+ -- Each sub-expressions of B is marked either as Present_Pos or
+ -- Present_Neg.
+ -- If A is already present, return either B or FALSE.
+ -- Otherwise, build the node.
+ type PSL_Presence_Kind is
+ (
+ Present_Unknown,
+ Present_Pos,
+ Present_Neg
+ );
+
+ -- Start of nodes:
+
+ -- N_Error (Short)
+
+ -- N_Vmode (Short)
+ -- N_Vunit (Short)
+ -- N_Vprop (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Instance (Field3)
+ --
+ -- Get/Set_Item_Chain (Field4)
+
+ -- N_Hdl_Mod_Name (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Prefix (Field2)
+
+ -- N_Assert_Directive (Short)
+ --
+ -- Get/Set_Label (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_String (Field3)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_NFA (Field5)
+
+ -- N_Property_Declaration (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Global_Clock (Field3)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_Parameter_List (Field5)
+
+ -- N_Sequence_Declaration (Short)
+ -- N_Endpoint_Declaration (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Sequence (Field3)
+ --
+ -- Get/Set_Parameter_List (Field5)
+
+ -- N_Const_Parameter (Short)
+ -- N_Boolean_Parameter (Short)
+ -- N_Property_Parameter (Short)
+ -- N_Sequence_Parameter (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- -- Current actual parameter.
+ -- Get/Set_Actual (Field3)
+
+ -- N_Sequence_Instance (Short)
+ -- N_Endpoint_Instance (Short)
+ -- N_Property_Instance (Short)
+ --
+ -- Get/Set_Declaration (Field1) [Flat]
+ --
+ -- Get/Set_Association_Chain (Field2)
+
+ -- N_Actual (Short)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Actual (Field3)
+ --
+ -- Get/Set_Formal (Field4)
+
+ -- N_Clock_Event (Short)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_Boolean (Field3)
+
+ -- N_Always (Short)
+ -- N_Never (Short)
+ -- N_Eventually (Short)
+ -- N_Strong (Short)
+ --
+ -- Get/Set_Property (Field4)
+
+ -- N_Next (Short)
+ --
+ -- Get/Set_Strong_Flag (Flag1)
+ --
+ -- Get/Set_Number (Field1)
+ --
+ -- Get/Set_Property (Field4)
+
+ -- N_Name (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Decl (Field2)
+
+ -- N_Name_Decl (Short)
+ --
+ -- Get/Set_Identifier (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+
+ -- N_Number (Short)
+ --
+ -- Get/Set_Value (Field1)
+
+ -- N_Braced_SERE (Short)
+ --
+ -- Get/Set_SERE (Field1)
+
+ -- N_Concat_SERE (Short)
+ -- N_Fusion_SERE (Short)
+ -- N_Within_SERE (Short)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+
+ -- N_Star_Repeat_Seq (Short)
+ -- N_Goto_Repeat_Seq (Short)
+ -- N_Equal_Repeat_Seq (Short)
+ --
+ -- Note: can be null_node for star_repeat_seq.
+ -- Get/Set_Sequence (Field3)
+ --
+ -- Get/Set_Low_Bound (Field1)
+ --
+ -- Get/Set_High_Bound (Field2)
+
+ -- N_Plus_Repeat_Seq (Short)
+ --
+ -- Note: can be null_node.
+ -- Get/Set_Sequence (Field3)
+
+ -- N_Match_And_Seq (Short)
+ -- N_And_Seq (Short)
+ -- N_Or_Seq (Short)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+
+ -- N_Imp_Seq (Short)
+ -- N_Overlap_Imp_Seq (Short)
+ --
+ -- Get/Set_Sequence (Field3)
+ --
+ -- Get/Set_Property (Field4)
+
+ -- N_Log_Imp_Prop (Short)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+
+ -- N_Next_A (Short)
+ -- N_Next_E (Short)
+ --
+ -- Get/Set_Strong_Flag (Flag1)
+ --
+ -- Get/Set_Low_Bound (Field1)
+ --
+ -- Get/Set_High_Bound (Field2)
+ --
+ -- Get/Set_Property (Field4)
+
+ -- N_Next_Event (Short)
+ --
+ -- Get/Set_Strong_Flag (Flag1)
+ --
+ -- Get/Set_Number (Field1)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_Boolean (Field3)
+
+ -- N_Or_Prop (Short)
+ -- N_And_Prop (Short)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+
+ -- N_Until (Short)
+ -- N_Before (Short)
+ --
+ -- Get/Set_Strong_Flag (Flag1)
+ --
+ -- Get/Set_Inclusive_Flag (Flag2)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+
+ -- N_Next_Event_A (Short)
+ -- N_Next_Event_E (Short)
+ --
+ -- Get/Set_Strong_Flag (Flag1)
+ --
+ -- Get/Set_Low_Bound (Field1)
+ --
+ -- Get/Set_High_Bound (Field2)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_Boolean (Field3)
+
+ -- N_Abort (Short)
+ --
+ -- Get/Set_Property (Field4)
+ --
+ -- Get/Set_Boolean (Field3)
+
+
+ -- N_HDL_Expr (Short)
+ --
+ -- Get/Set_Presence (State1)
+ --
+ -- Get/Set_HDL_Node (Field1)
+ --
+ -- Get/Set_HDL_Index (Field2)
+ --
+ -- Get/Set_Hash (Field5)
+ --
+ -- Get/Set_Hash_Link (Field6)
+
+ -- N_Not_Bool (Short)
+ --
+ -- Get/Set_Presence (State1)
+ --
+ -- Get/Set_Boolean (Field3)
+ --
+ -- Get/Set_Hash (Field5)
+ --
+ -- Get/Set_Hash_Link (Field6)
+
+ -- N_And_Bool (Short)
+ -- N_Or_Bool (Short)
+ -- N_Imp_Bool (Short)
+ --
+ -- Get/Set_Presence (State1)
+ --
+ -- Get/Set_Left (Field1)
+ --
+ -- Get/Set_Right (Field2)
+ --
+ -- Get/Set_Hash (Field5)
+ --
+ -- Get/Set_Hash_Link (Field6)
+
+ -- N_True (Short)
+ -- N_False (Short)
+
+ -- N_EOS (Short)
+ -- End of simulation.
+ --
+ -- Get/Set_HDL_Index (Field2)
+ --
+ -- Get/Set_Hash (Field5)
+ --
+ -- Get/Set_Hash_Link (Field6)
+
+ -- End of nodes.
+
+ subtype Node is Types.PSL_Node;
+
+ Null_Node : constant Node := 0;
+ False_Node : constant Node := 1;
+ True_Node : constant Node := 2;
+ One_Node : constant Node := 3;
+ EOS_Node : constant Node := 4;
+
+ subtype NFA is Types.PSL_NFA;
+
+ subtype HDL_Node is Types.Int32;
+ HDL_Null : constant HDL_Node := 0;
+
+ procedure Init;
+
+ -- Get the number of the last node.
+ -- To be used to size lateral tables.
+ function Get_Last_Node return Node;
+
+ -- subtype Regs_Type_Node is Node range Reg_Type_Node .. Time_Type_Node;
+
+ function Create_Node (Kind : Nkind) return Node;
+ procedure Free_Node (N : Node);
+
+ -- Return the type of a node.
+ function Get_Psl_Type (N : Node) return PSL_Types;
+
+ -- Field: Location
+ function Get_Location (N : Node) return Location_Type;
+ procedure Set_Location (N : Node; Loc : Location_Type);
+
+ function Get_Kind (N : Node) return Nkind;
+ pragma Inline (Get_Kind);
+
+-- -- Disp: None
+-- -- Field: Field6
+-- function Get_Parent (N : Node) return Node;
+-- procedure Set_Parent (N : Node; Parent : Node);
+
+ -- Disp: Special
+ -- Field: Field1 (conv)
+ function Get_Identifier (N : Node) return Name_Id;
+ procedure Set_Identifier (N : Node; Id : Name_Id);
+
+ -- Disp: Special
+ -- Field: Field1 (conv)
+ function Get_Label (N : Node) return Name_Id;
+ procedure Set_Label (N : Node; Id : Name_Id);
+
+ -- Disp: Chain
+ -- Field: Field2 (conv)
+ function Get_Chain (N : Node) return Node;
+ procedure Set_Chain (N : Node; Chain : Node);
+
+ -- Field: Field3 (conv)
+ function Get_Instance (N : Node) return Node;
+ procedure Set_Instance (N : Node; Instance : Node);
+
+ -- Field: Field2 (conv)
+ function Get_Prefix (N : Node) return Node;
+ procedure Set_Prefix (N : Node; Prefix : Node);
+
+ -- Field: Field4 (conv)
+ function Get_Item_Chain (N : Node) return Node;
+ procedure Set_Item_Chain (N : Node; Item : Node);
+
+ -- Field: Field4 (conv)
+ function Get_Property (N : Node) return Node;
+ procedure Set_Property (N : Node; Property : Node);
+
+ -- Field: Field3 (conv)
+ function Get_String (N : Node) return Node;
+ procedure Set_String (N : Node; Str : Node);
+
+ -- Field: Field1 (conv)
+ function Get_SERE (N : Node) return Node;
+ procedure Set_SERE (N : Node; S : Node);
+
+ -- Field: Field1 (conv)
+ function Get_Left (N : Node) return Node;
+ procedure Set_Left (N : Node; S : Node);
+
+ -- Field: Field2 (conv)
+ function Get_Right (N : Node) return Node;
+ procedure Set_Right (N : Node; S : Node);
+
+ -- Field: Field3 (conv)
+ function Get_Sequence (N : Node) return Node;
+ procedure Set_Sequence (N : Node; S : Node);
+
+ -- Field: Flag1
+ function Get_Strong_Flag (N : Node) return Boolean;
+ procedure Set_Strong_Flag (N : Node; B : Boolean);
+
+ -- Field: Flag2
+ function Get_Inclusive_Flag (N : Node) return Boolean;
+ procedure Set_Inclusive_Flag (N : Node; B : Boolean);
+
+ -- Field: Field1 (conv)
+ function Get_Low_Bound (N : Node) return Node;
+ procedure Set_Low_Bound (N : Node; S : Node);
+
+ -- Field: Field2 (conv)
+ function Get_High_Bound (N : Node) return Node;
+ procedure Set_High_Bound (N : Node; S : Node);
+
+ -- Field: Field1 (conv)
+ function Get_Number (N : Node) return Node;
+ procedure Set_Number (N : Node; S : Node);
+
+ -- Field: Field1 (uc)
+ function Get_Value (N : Node) return Uns32;
+ procedure Set_Value (N : Node; Val : Uns32);
+
+ -- Field: Field3 (conv)
+ function Get_Boolean (N : Node) return Node;
+ procedure Set_Boolean (N : Node; B : Node);
+
+ -- Field: Field2 (conv)
+ function Get_Decl (N : Node) return Node;
+ procedure Set_Decl (N : Node; D : Node);
+
+ -- Field: Field1 (conv)
+ function Get_HDL_Node (N : Node) return HDL_Node;
+ procedure Set_HDL_Node (N : Node; H : HDL_Node);
+
+ -- Field: Field5 (uc)
+ function Get_Hash (N : Node) return Uns32;
+ procedure Set_Hash (N : Node; E : Uns32);
+ pragma Inline (Get_Hash);
+
+ -- Field: Field6 (conv)
+ function Get_Hash_Link (N : Node) return Node;
+ procedure Set_Hash_Link (N : Node; E : Node);
+ pragma Inline (Get_Hash_Link);
+
+ -- Field: Field2
+ function Get_HDL_Index (N : Node) return Int32;
+ procedure Set_HDL_Index (N : Node; Idx : Int32);
+
+ -- Field: State1 (pos)
+ function Get_Presence (N : Node) return PSL_Presence_Kind;
+ procedure Set_Presence (N : Node; P : PSL_Presence_Kind);
+
+ -- Field: Field5 (uc)
+ function Get_NFA (N : Node) return NFA;
+ procedure Set_NFA (N : Node; P : NFA);
+
+ -- Field: Field5 (conv)
+ function Get_Parameter_List (N : Node) return Node;
+ procedure Set_Parameter_List (N : Node; E : Node);
+
+ -- Field: Field3 (conv)
+ function Get_Actual (N : Node) return Node;
+ procedure Set_Actual (N : Node; E : Node);
+
+ -- Field: Field4 (conv)
+ function Get_Formal (N : Node) return Node;
+ procedure Set_Formal (N : Node; E : Node);
+
+ -- Field: Field1 (conv)
+ function Get_Declaration (N : Node) return Node;
+ procedure Set_Declaration (N : Node; Decl : Node);
+
+ -- Field: Field2 (conv)
+ function Get_Association_Chain (N : Node) return Node;
+ procedure Set_Association_Chain (N : Node; Chain : Node);
+
+ -- Field: Field3 (conv)
+ function Get_Global_Clock (N : Node) return Node;
+ procedure Set_Global_Clock (N : Node; Clock : Node);
+end PSL.Nodes;
diff --git a/src/psl/psl-optimize.adb b/src/psl/psl-optimize.adb
new file mode 100644
index 000000000..4ca62b89e
--- /dev/null
+++ b/src/psl/psl-optimize.adb
@@ -0,0 +1,460 @@
+with Types; use Types;
+with PSL.NFAs.Utils; use PSL.NFAs.Utils;
+with PSL.CSE;
+
+package body PSL.Optimize is
+ procedure Push (Head : in out NFA_State; S : NFA_State) is
+ begin
+ Set_State_User_Link (S, Head);
+ Head := S;
+ end Push;
+
+ procedure Pop (Head : in out NFA_State; S : out NFA_State) is
+ begin
+ S := Head;
+ Head := Get_State_User_Link (S);
+ end Pop;
+
+ procedure Remove_Unreachable_States (N : NFA)
+ is
+ Head : NFA_State;
+ Start, Final : NFA_State;
+ E : NFA_Edge;
+ S, N_S : NFA_State;
+ begin
+ -- Remove unreachable states, ie states that can't be reached from
+ -- start state.
+ Start := Get_Start_State (N);
+ Final := Get_Final_State (N);
+
+ Head := No_State;
+
+ -- The start state is reachable.
+ Push (Head, Start);
+ Set_State_Flag (Start, True);
+
+ -- Follow edges and mark reachable states.
+ while Head /= No_State loop
+ Pop (Head, S);
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ S := Get_Edge_Dest (E);
+ if not Get_State_Flag (S) then
+ Push (Head, S);
+ Set_State_Flag (S, True);
+ end if;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ end loop;
+
+ -- Remove unreachable states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+ N_S := Get_Next_State (S);
+ if Get_State_Flag (S) then
+ -- Clean-up.
+ Set_State_Flag (S, False);
+ elsif S = Final then
+ -- Do not remove final state!
+ -- FIXME: deconnect state?
+ null;
+ else
+ Remove_State (N, S);
+ end if;
+ S := N_S;
+ end loop;
+
+ -- Remove no-where states, ie states that can't reach the final state.
+ Head := No_State;
+
+ -- The final state can reach the final state.
+ Push (Head, Final);
+ Set_State_Flag (Final, True);
+
+ -- Follow edges and mark reachable states.
+ while Head /= No_State loop
+ Pop (Head, S);
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ S := Get_Edge_Src (E);
+ if not Get_State_Flag (S) then
+ Push (Head, S);
+ Set_State_Flag (S, True);
+ end if;
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+ end loop;
+
+ -- Remove unreachable states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+ N_S := Get_Next_State (S);
+ if Get_State_Flag (S) then
+ -- Clean-up.
+ Set_State_Flag (S, False);
+ elsif S = Start then
+ -- Do not remove start state!
+ -- FIXME: deconnect state?
+ null;
+ else
+ Remove_State (N, S);
+ end if;
+ S := N_S;
+ end loop;
+ end Remove_Unreachable_States;
+
+ procedure Remove_Simple_Prefix (N : NFA)
+ is
+ Start : NFA_State;
+ D : NFA_State;
+ T_Start, T_D, Next_T_D : NFA_Edge;
+ T_Expr : Node;
+ Clean : Boolean := False;
+ begin
+ Start := Get_Start_State (N);
+
+ -- Iterate on edges from the start state.
+ T_Start := Get_First_Src_Edge (Start);
+ while T_Start /= No_Edge loop
+ -- Edge destination.
+ D := Get_Edge_Dest (T_Start);
+ T_Expr := Get_Edge_Expr (T_Start);
+
+ -- Iterate on destination incoming edges.
+ T_D := Get_First_Dest_Edge (D);
+ while T_D /= No_Edge loop
+ Next_T_D := Get_Next_Dest_Edge (T_D);
+ -- Remove parallel edge.
+ if T_D /= T_Start
+ and then Get_Edge_Expr (T_D) = T_Expr
+ then
+ Remove_Edge (T_D);
+ Clean := True;
+ end if;
+ T_D := Next_T_D;
+ end loop;
+ T_Start := Get_Next_Src_Edge (T_Start);
+ end loop;
+ if Clean then
+ Remove_Unreachable_States (N);
+ end if;
+ end Remove_Simple_Prefix;
+
+ -- Return TRUE iff the outgoing or incoming edges of L and R are the same.
+ -- Outgoing edges must be sorted.
+ generic
+ with function Get_First_Edge (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge;
+ with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State;
+ function Are_States_Identical_Gen (L, R : NFA_State) return Boolean;
+
+ function Are_States_Identical_Gen (L, R : NFA_State) return Boolean
+ is
+ L_E, R_E : NFA_Edge;
+ L_S, R_S : NFA_State;
+ begin
+ L_E := Get_First_Edge (L);
+ R_E := Get_First_Edge (R);
+ loop
+ if L_E = No_Edge and then R_E = No_Edge then
+ -- End of chain for both L and R -> identical states.
+ return True;
+ elsif L_E = No_Edge or R_E = No_Edge then
+ -- End of chain for either L or R -> non identical states.
+ return False;
+ elsif Get_Edge_Expr (L_E) /= Get_Edge_Expr (R_E) then
+ -- Different edge (different expressions).
+ return False;
+ end if;
+ L_S := Get_Edge_State_Reverse (L_E);
+ R_S := Get_Edge_State_Reverse (R_E);
+ if L_S /= R_S and then (L_S /= L or else R_S /= R) then
+ -- Predecessors are differents and not loop.
+ return False;
+ end if;
+ L_E := Get_Next_Edge (L_E);
+ R_E := Get_Next_Edge (R_E);
+ end loop;
+ end Are_States_Identical_Gen;
+
+ generic
+ with procedure Sort_Edges (N : NFA);
+ with procedure Sort_Edges_Reverse (S : NFA_State);
+ with function Get_First_Edge (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge;
+ with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge;
+ with function Get_Next_Edge_Reverse (E : NFA_Edge) return NFA_Edge;
+ with function Get_Edge_State (E : NFA_Edge) return NFA_State;
+ with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State;
+ with procedure Merge_State_Reverse (N : NFA;
+ S : NFA_State; S1 : NFA_State);
+ procedure Merge_Identical_States_Gen (N : NFA);
+
+ procedure Merge_Identical_States_Gen (N : NFA)
+ is
+ function Are_States_Identical is new Are_States_Identical_Gen
+ (Get_First_Edge => Get_First_Edge,
+ Get_Next_Edge => Get_Next_Edge,
+ Get_Edge_State_Reverse => Get_Edge_State_Reverse);
+
+ S : NFA_State;
+ E : NFA_Edge;
+ E_State, Next_E_State : NFA_State;
+ Next_E, Next_Next_E : NFA_Edge;
+ begin
+ Sort_Edges (N);
+
+ -- Iterate on states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+ Sort_Edges_Reverse (S);
+
+ -- Iterate on incoming edges.
+ E := Get_First_Edge_Reverse (S);
+ while E /= No_Edge loop
+ E_State := Get_Edge_State (E);
+
+ -- Try to merge E with its successors.
+ Next_E := Get_Next_Edge_Reverse (E);
+ while Next_E /= No_Edge
+ and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E)
+ loop
+ Next_E_State := Get_Edge_State (Next_E);
+ Next_Next_E := Get_Next_Edge_Reverse (Next_E);
+ if Next_E_State = E_State then
+ -- Identical edge: remove the duplicate.
+ Remove_Edge (Next_E);
+ elsif Are_States_Identical (E_State, Next_E_State) then
+ Merge_State_Reverse (N, E_State, Next_E_State);
+ end if;
+ Next_E := Next_Next_E;
+ end loop;
+
+ E := Get_Next_Edge_Reverse (E);
+ end loop;
+
+ S := Get_Next_State (S);
+ end loop;
+ end Merge_Identical_States_Gen;
+
+ procedure Merge_Identical_States_Src is new Merge_Identical_States_Gen
+ (Sort_Edges => Sort_Src_Edges,
+ Sort_Edges_Reverse => Sort_Dest_Edges,
+ Get_First_Edge => Get_First_Src_Edge,
+ Get_Next_Edge => Get_Next_Src_Edge,
+ Get_First_Edge_Reverse => Get_First_Dest_Edge,
+ Get_Next_Edge_Reverse => Get_Next_Dest_Edge,
+ Get_Edge_State => Get_Edge_Src,
+ Get_Edge_State_Reverse => Get_Edge_Dest,
+ Merge_State_Reverse => Merge_State_Dest);
+
+ procedure Merge_Identical_States_Dest is new Merge_Identical_States_Gen
+ (Sort_Edges => Sort_Dest_Edges,
+ Sort_Edges_Reverse => Sort_Src_Edges,
+ Get_First_Edge => Get_First_Dest_Edge,
+ Get_Next_Edge => Get_Next_Dest_Edge,
+ Get_First_Edge_Reverse => Get_First_Src_Edge,
+ Get_Next_Edge_Reverse => Get_Next_Src_Edge,
+ Get_Edge_State => Get_Edge_Dest,
+ Get_Edge_State_Reverse => Get_Edge_Src,
+ Merge_State_Reverse => Merge_State_Src);
+
+ procedure Merge_Identical_States (N : NFA) is
+ begin
+ Merge_Identical_States_Src (N);
+ Merge_Identical_States_Dest (N);
+ end Merge_Identical_States;
+
+ procedure Merge_Edges (N : NFA)
+ is
+ use PSL.CSE;
+ Nbr_States : Natural;
+ begin
+ Labelize_States (N, Nbr_States);
+ declare
+ Last_State : constant Int32 := Int32 (Nbr_States) - 1;
+ type Edge_Array is array (0 .. Last_State) of NFA_Edge;
+ Edges : Edge_Array;
+ S, D : NFA_State;
+ L_D : Int32;
+ E, Next_E : NFA_Edge;
+ begin
+ -- Iterate on states.
+ S := Get_First_State (N);
+ while S /= No_State loop
+
+ Edges := (others => No_Edge);
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Next_E := Get_Next_Src_Edge (E);
+ D := Get_Edge_Dest (E);
+ L_D := Get_State_Label (D);
+ if Edges (L_D) /= No_Edge then
+ Set_Edge_Expr
+ (Edges (L_D),
+ Build_Bool_Or (Get_Edge_Expr (Edges (L_D)),
+ Get_Edge_Expr (E)));
+ -- FIXME: reduce expression.
+ Remove_Edge (E);
+ else
+ Edges (L_D) := E;
+ end if;
+ E := Next_E;
+ end loop;
+
+ S := Get_Next_State (S);
+ end loop;
+ end;
+ end Merge_Edges;
+
+ procedure Remove_Identical_Src_Edges (S : NFA_State)
+ is
+ Next_E, E : NFA_Edge;
+ begin
+ Sort_Src_Edges (S);
+ E := Get_First_Src_Edge (S);
+ if E = No_Edge then
+ return;
+ end if;
+ loop
+ Next_E := Get_Next_Src_Edge (E);
+ exit when Next_E = No_Edge;
+ if Get_Edge_Dest (E) = Get_Edge_Dest (Next_E)
+ and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E)
+ then
+ Remove_Edge (Next_E);
+ else
+ E := Next_E;
+ end if;
+ end loop;
+ end Remove_Identical_Src_Edges;
+
+ procedure Remove_Identical_Dest_Edges (S : NFA_State)
+ is
+ Next_E, E : NFA_Edge;
+ begin
+ Sort_Dest_Edges (S);
+ E := Get_First_Dest_Edge (S);
+ if E = No_Edge then
+ return;
+ end if;
+ loop
+ Next_E := Get_Next_Dest_Edge (E);
+ exit when Next_E = No_Edge;
+ if Get_Edge_Src (E) = Get_Edge_Src (Next_E)
+ and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E)
+ then
+ Remove_Edge (Next_E);
+ else
+ E := Next_E;
+ end if;
+ end loop;
+ end Remove_Identical_Dest_Edges;
+
+ procedure Find_Partitions (N : NFA; Nbr_States : Natural)
+ is
+ Last_State : constant NFA_State := NFA_State (Nbr_States) - 1;
+ type Part_Offset is new Int32 range -1 .. Nat32 (Nbr_States - 1);
+ type Part_Id is new Part_Offset range 0 .. Part_Offset'Last;
+
+ -- State to partition id.
+ State_Part : array (0 .. Last_State) of Part_Id;
+ pragma Unreferenced (State_Part);
+
+ -- Last partition index.
+ Last_Part : Part_Id;
+
+ -- Partitions content.
+
+ -- To get the states in a partition P, first get the offset OFF
+ -- (from Offsets) of P. States are in Parts (OFF ...). The
+ -- number of states is not known, but they all belong to P
+ -- (check with STATE_PART).
+ Parts : array (Part_Offset) of NFA_State;
+ type Offset_Array is array (Part_Id) of Part_Offset;
+ Start_Offsets : Offset_Array;
+ Last_Offsets : Offset_Array;
+
+ S, Final_State : NFA_State;
+ First_S : NFA_State;
+ Off, Last_Off : Part_Offset;
+
+ Stable, Stable1 : Boolean;
+
+ function Is_Equivalent (L, R : NFA_State) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Equivalent;
+ begin
+ -- Return now for trivial cases (0 or 1 state).
+ if Nbr_States < 2 then
+ return;
+ end if;
+
+ -- Partition 1 contains the final state.
+ -- Partition 0 contains the other states.
+ Final_State := Get_Final_State (N);
+ Last_Part := 1;
+ State_Part := (others => 0);
+ State_Part (Final_State) := 1;
+ S := Get_First_State (N);
+ Off := -1;
+ while S /= No_State loop
+ if S /= Last_State then
+ Off := Off + 1;
+ Parts (Off) := S;
+ end if;
+ S := Get_Next_State (S);
+ end loop;
+ Start_Offsets (0) := 0;
+ Last_Offsets (0) := Off;
+ Start_Offsets (1) := Off + 1;
+ Last_Offsets (1) := Off + 1;
+ Parts (Off + 1) := Final_State;
+
+ -- Now the hard work.
+ loop
+ Stable := True;
+ -- For every partition
+ for P in 0 .. Last_Part loop
+ Off := Start_Offsets (P);
+ First_S := Parts (Off);
+ Off := Off + 1;
+
+ -- For every S != First_S in P.
+ Last_Off := Last_Offsets (P);
+ Stable1 := True;
+ while Off <= Last_Off loop
+ S := Parts (Off);
+
+ if not Is_Equivalent (First_S, S) then
+ -- Swap S with the last element of the partition.
+ Parts (Off) := Parts (Last_Off);
+ Parts (Last_Off) := S;
+ -- Reduce partition size.
+ Last_Off := Last_Off - 1;
+ Last_Offsets (P) := Last_Off;
+
+ if Stable1 then
+ -- Create a new partition.
+ Last_Part := Last_Part + 1;
+ Last_Offsets (Last_Part) := Last_Off + 1;
+ Stable1 := False;
+ end if;
+ -- Put S in the new partition.
+ Start_Offsets (Last_Part) := Last_Off + 1;
+ State_Part (S) := Last_Part;
+ Stable := False;
+
+ -- And continue with the swapped state.
+ else
+ Off := Off + 1;
+ end if;
+ end loop;
+ end loop;
+ exit when Stable;
+ end loop;
+ end Find_Partitions;
+ pragma Unreferenced (Find_Partitions);
+end PSL.Optimize;
diff --git a/src/psl/psl-optimize.ads b/src/psl/psl-optimize.ads
new file mode 100644
index 000000000..5f36a0739
--- /dev/null
+++ b/src/psl/psl-optimize.ads
@@ -0,0 +1,24 @@
+with PSL.NFAs; use PSL.NFAs;
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Optimize is
+ -- Remove unreachable states, ie
+ -- * states that can't be reach from the start state.
+ -- * states that can't reach the final state.
+ -- O(N) algorithm.
+ procedure Remove_Unreachable_States (N : NFA);
+
+ -- Remove single prefix, ie edges to a state S that is also from start
+ -- to S.
+ -- O(M) algorithm.
+ procedure Remove_Simple_Prefix (N : NFA);
+
+ procedure Merge_Identical_States (N : NFA);
+
+ procedure Merge_Edges (N : NFA);
+
+ procedure Remove_Identical_Src_Edges (S : NFA_State);
+ procedure Remove_Identical_Dest_Edges (S : NFA_State);
+
+ --procedure Find_Partitions (N : NFA; Nbr_States : Natural);
+end PSL.Optimize;
diff --git a/src/psl/psl-prints.adb b/src/psl/psl-prints.adb
new file mode 100644
index 000000000..80da47dab
--- /dev/null
+++ b/src/psl/psl-prints.adb
@@ -0,0 +1,433 @@
+with Types; use Types;
+with PSL.Errors; use PSL.Errors;
+with Name_Table; use Name_Table;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body PSL.Prints is
+ function Get_Priority (N : Node) return Priority is
+ begin
+ case Get_Kind (N) is
+ when N_Never | N_Always =>
+ return Prio_FL_Invariance;
+ when N_Eventually
+ | N_Next
+ | N_Next_A
+ | N_Next_E
+ | N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E =>
+ return Prio_FL_Occurence;
+ when N_Braced_SERE =>
+ return Prio_SERE_Brace;
+ when N_Concat_SERE =>
+ return Prio_Seq_Concat;
+ when N_Fusion_SERE =>
+ return Prio_Seq_Fusion;
+ when N_Within_SERE =>
+ return Prio_Seq_Within;
+ when N_Match_And_Seq
+ | N_And_Seq =>
+ return Prio_Seq_And;
+ when N_Or_Seq =>
+ return Prio_Seq_Or;
+ when N_Until
+ | N_Before =>
+ return Prio_FL_Bounding;
+ when N_Abort =>
+ return Prio_FL_Abort;
+ when N_Or_Prop =>
+ return Prio_Seq_Or;
+ when N_And_Prop =>
+ return Prio_Seq_And;
+ when N_Imp_Seq
+ | N_Overlap_Imp_Seq
+ | N_Log_Imp_Prop
+ | N_Imp_Bool =>
+ return Prio_Bool_Imp;
+ when N_Name_Decl
+ | N_Number
+ | N_True
+ | N_False
+ | N_EOS
+ | N_HDL_Expr =>
+ return Prio_HDL;
+ when N_Or_Bool =>
+ return Prio_Seq_Or;
+ when N_And_Bool =>
+ return Prio_Seq_And;
+ when N_Not_Bool =>
+ return Prio_Bool_Not;
+ when N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Equal_Repeat_Seq
+ | N_Plus_Repeat_Seq =>
+ return Prio_SERE_Repeat;
+ when N_Strong =>
+ return Prio_Strong;
+ when others =>
+ Error_Kind ("get_priority", N);
+ end case;
+ end Get_Priority;
+
+ procedure Print_HDL_Expr (N : HDL_Node) is
+ begin
+ Put (Image (Get_Identifier (Node (N))));
+ end Print_HDL_Expr;
+
+ procedure Dump_Expr (N : Node)
+ is
+ begin
+ case Get_Kind (N) is
+ when N_HDL_Expr =>
+ if HDL_Expr_Printer = null then
+ Put ("Expr");
+ else
+ HDL_Expr_Printer.all (Get_HDL_Node (N));
+ end if;
+ when N_True =>
+ Put ("TRUE");
+ when N_False =>
+ Put ("FALSE");
+ when N_Not_Bool =>
+ Put ("!");
+ Dump_Expr (Get_Boolean (N));
+ when N_And_Bool =>
+ Put ("(");
+ Dump_Expr (Get_Left (N));
+ Put (" && ");
+ Dump_Expr (Get_Right (N));
+ Put (")");
+ when N_Or_Bool =>
+ Put ("(");
+ Dump_Expr (Get_Left (N));
+ Put (" || ");
+ Dump_Expr (Get_Right (N));
+ Put (")");
+ when others =>
+ PSL.Errors.Error_Kind ("dump_expr", N);
+ end case;
+ end Dump_Expr;
+
+ procedure Print_Expr (N : Node; Parent_Prio : Priority := Prio_Lowest)
+ is
+ Prio : Priority;
+ begin
+ if N = Null_Node then
+ Put (".");
+ return;
+ end if;
+ Prio := Get_Priority (N);
+ if Prio < Parent_Prio then
+ Put ("(");
+ end if;
+ case Get_Kind (N) is
+ when N_Number =>
+ declare
+ Str : constant String := Uns32'Image (Get_Value (N));
+ begin
+ Put (Str (2 .. Str'Last));
+ end;
+ when N_Name_Decl =>
+ Put (Image (Get_Identifier (N)));
+ when N_HDL_Expr =>
+ if HDL_Expr_Printer = null then
+ Put ("HDL_Expr");
+ else
+ HDL_Expr_Printer.all (Get_HDL_Node (N));
+ end if;
+ -- FIXME: this is true only when using the scanner.
+ -- Print_Expr (Node (Get_HDL_Node (N)));
+ when N_True =>
+ Put ("TRUE");
+ when N_False =>
+ Put ("FALSE");
+ when N_EOS =>
+ Put ("EOS");
+ when N_Not_Bool =>
+ Put ("!");
+ Print_Expr (Get_Boolean (N), Prio);
+ when N_And_Bool =>
+ Print_Expr (Get_Left (N), Prio);
+ Put (" && ");
+ Print_Expr (Get_Right (N), Prio);
+ when N_Or_Bool =>
+ Print_Expr (Get_Left (N), Prio);
+ Put (" || ");
+ Print_Expr (Get_Right (N), Prio);
+ when N_Imp_Bool =>
+ Print_Expr (Get_Left (N), Prio);
+ Put (" -> ");
+ Print_Expr (Get_Right (N), Prio);
+ when others =>
+ Error_Kind ("print_expr", N);
+ end case;
+ if Prio < Parent_Prio then
+ Put (")");
+ end if;
+ end Print_Expr;
+
+ procedure Print_Sequence (Seq : Node; Parent_Prio : Priority);
+
+ procedure Print_Count (N : Node) is
+ B : Node;
+ begin
+ B := Get_Low_Bound (N);
+ if B = Null_Node then
+ return;
+ end if;
+ Print_Expr (B);
+ B := Get_High_Bound (N);
+ if B = Null_Node then
+ return;
+ end if;
+ Put (":");
+ Print_Expr (B);
+ end Print_Count;
+
+ procedure Print_Binary_Sequence (Name : String; N : Node; Prio : Priority)
+ is
+ begin
+ Print_Sequence (Get_Left (N), Prio);
+ Put (Name);
+ Print_Sequence (Get_Right (N), Prio);
+ end Print_Binary_Sequence;
+
+ procedure Print_Repeat_Sequence (Name : String; N : Node) is
+ S : Node;
+ begin
+ S := Get_Sequence (N);
+ if S /= Null_Node then
+ Print_Sequence (S, Prio_SERE_Repeat);
+ end if;
+ Put (Name);
+ Print_Count (N);
+ Put ("]");
+ end Print_Repeat_Sequence;
+
+ procedure Print_Sequence (Seq : Node; Parent_Prio : Priority)
+ is
+ Prio : constant Priority := Get_Priority (Seq);
+ Add_Paren : constant Boolean := Prio < Parent_Prio
+ or else Parent_Prio <= Prio_FL_Paren;
+ begin
+ if Add_Paren then
+ Put ("{");
+ end if;
+ case Get_Kind (Seq) is
+ when N_Braced_SERE =>
+ Put ("{");
+ Print_Sequence (Get_SERE (Seq), Prio_Lowest);
+ Put ("}");
+ when N_Concat_SERE =>
+ Print_Binary_Sequence (";", Seq, Prio);
+ when N_Fusion_SERE =>
+ Print_Binary_Sequence (":", Seq, Prio);
+ when N_Within_SERE =>
+ Print_Binary_Sequence (" within ", Seq, Prio);
+ when N_Match_And_Seq =>
+ Print_Binary_Sequence (" && ", Seq, Prio);
+ when N_Or_Seq =>
+ Print_Binary_Sequence (" | ", Seq, Prio);
+ when N_And_Seq =>
+ Print_Binary_Sequence (" & ", Seq, Prio);
+ when N_Star_Repeat_Seq =>
+ Print_Repeat_Sequence ("[*", Seq);
+ when N_Goto_Repeat_Seq =>
+ Print_Repeat_Sequence ("[->", Seq);
+ when N_Equal_Repeat_Seq =>
+ Print_Repeat_Sequence ("[=", Seq);
+ when N_Plus_Repeat_Seq =>
+ Print_Sequence (Get_Sequence (Seq), Prio);
+ Put ("[+]");
+ when N_Booleans
+ | N_Name_Decl =>
+ Print_Expr (Seq);
+ when others =>
+ Error_Kind ("print_sequence", Seq);
+ end case;
+ if Add_Paren then
+ Put ("}");
+ end if;
+ end Print_Sequence;
+
+ procedure Print_Binary_Property (Name : String; N : Node; Prio : Priority)
+ is
+ begin
+ Print_Property (Get_Left (N), Prio);
+ Put (Name);
+ Print_Property (Get_Right (N), Prio);
+ end Print_Binary_Property;
+
+ procedure Print_Binary_Property_SI (Name : String;
+ N : Node; Prio : Priority)
+ is
+ begin
+ Print_Property (Get_Left (N), Prio);
+ Put (Name);
+ if Get_Strong_Flag (N) then
+ Put ('!');
+ end if;
+ if Get_Inclusive_Flag (N) then
+ Put ('_');
+ end if;
+ Put (' ');
+ Print_Property (Get_Right (N), Prio);
+ end Print_Binary_Property_SI;
+
+ procedure Print_Range_Property (Name : String; N : Node) is
+ begin
+ Put (Name);
+ Put ("[");
+ Print_Count (N);
+ Put ("](");
+ Print_Property (Get_Property (N), Prio_FL_Paren);
+ Put (")");
+ end Print_Range_Property;
+
+ procedure Print_Boolean_Range_Property (Name : String; N : Node) is
+ begin
+ Put (Name);
+ Put ("(");
+ Print_Expr (Get_Boolean (N));
+ Put (")[");
+ Print_Count (N);
+ Put ("](");
+ Print_Property (Get_Property (N), Prio_FL_Paren);
+ Put (")");
+ end Print_Boolean_Range_Property;
+
+ procedure Print_Property (Prop : Node;
+ Parent_Prio : Priority := Prio_Lowest)
+ is
+ Prio : constant Priority := Get_Priority (Prop);
+ begin
+ if Prio < Parent_Prio then
+ Put ("(");
+ end if;
+ case Get_Kind (Prop) is
+ when N_Never =>
+ Put ("never ");
+ Print_Property (Get_Property (Prop), Prio);
+ when N_Always =>
+ Put ("always (");
+ Print_Property (Get_Property (Prop), Prio);
+ Put (")");
+ when N_Eventually =>
+ Put ("eventually! (");
+ Print_Property (Get_Property (Prop), Prio);
+ Put (")");
+ when N_Strong =>
+ Print_Property (Get_Property (Prop), Prio);
+ Put ("!");
+ when N_Next =>
+ Put ("next");
+-- if Get_Strong_Flag (Prop) then
+-- Put ('!');
+-- end if;
+ Put (" (");
+ Print_Property (Get_Property (Prop), Prio);
+ Put (")");
+ when N_Next_A =>
+ Print_Range_Property ("next_a", Prop);
+ when N_Next_E =>
+ Print_Range_Property ("next_e", Prop);
+ when N_Next_Event =>
+ Put ("next_event");
+ Put ("(");
+ Print_Expr (Get_Boolean (Prop));
+ Put (")(");
+ Print_Property (Get_Property (Prop), Prio);
+ Put (")");
+ when N_Next_Event_A =>
+ Print_Boolean_Range_Property ("next_event_a", Prop);
+ when N_Next_Event_E =>
+ Print_Boolean_Range_Property ("next_event_e", Prop);
+ when N_Until =>
+ Print_Binary_Property_SI (" until", Prop, Prio);
+ when N_Abort =>
+ Print_Property (Get_Property (Prop), Prio);
+ Put (" abort ");
+ Print_Expr (Get_Boolean (Prop));
+ when N_Before =>
+ Print_Binary_Property_SI (" before", Prop, Prio);
+ when N_Or_Prop =>
+ Print_Binary_Property (" || ", Prop, Prio);
+ when N_And_Prop =>
+ Print_Binary_Property (" && ", Prop, Prio);
+ when N_Imp_Seq =>
+ Print_Property (Get_Sequence (Prop), Prio);
+ Put (" |=> ");
+ Print_Property (Get_Property (Prop), Prio);
+ when N_Overlap_Imp_Seq =>
+ Print_Property (Get_Sequence (Prop), Prio);
+ Put (" |-> ");
+ Print_Property (Get_Property (Prop), Prio);
+ when N_Log_Imp_Prop =>
+ Print_Binary_Property (" -> ", Prop, Prio);
+ when N_Booleans
+ | N_Name_Decl =>
+ Print_Expr (Prop);
+ when N_Sequences =>
+ Print_Sequence (Prop, Parent_Prio);
+ when others =>
+ Error_Kind ("print_property", Prop);
+ end case;
+ if Prio < Parent_Prio then
+ Put (")");
+ end if;
+ end Print_Property;
+
+ procedure Print_Assert (N : Node) is
+ Label : Name_Id;
+ begin
+ Put (" ");
+ Label := Get_Label (N);
+ if Label /= Null_Identifier then
+ Put (Image (Label));
+ Put (": ");
+ end if;
+ Put ("assert ");
+ Print_Property (Get_Property (N));
+ Put_Line (";");
+ end Print_Assert;
+
+ procedure Print_Property_Declaration (N : Node) is
+ begin
+ Put (" ");
+ Put ("property ");
+ Put (Image (Get_Identifier (N)));
+ Put (" = ");
+ Print_Property (Get_Property (N));
+ Put_Line (";");
+ end Print_Property_Declaration;
+
+ procedure Print_Unit (Unit : Node) is
+ Item : Node;
+ begin
+ case Get_Kind (Unit) is
+ when N_Vunit =>
+ Put ("vunit");
+ when others =>
+ Error_Kind ("disp_unit", Unit);
+ end case;
+ Put (' ');
+ Put (Image (Get_Identifier (Unit)));
+ Put_Line (" {");
+ Item := Get_Item_Chain (Unit);
+ while Item /= Null_Node loop
+ case Get_Kind (Item) is
+ when N_Name_Decl =>
+ null;
+ when N_Assert_Directive =>
+ Print_Assert (Item);
+ when N_Property_Declaration =>
+ Print_Property_Declaration (Item);
+ when others =>
+ Error_Kind ("disp_unit", Item);
+ end case;
+ Item := Get_Chain (Item);
+ end loop;
+ Put_Line ("}");
+ end Print_Unit;
+end PSL.Prints;
+
diff --git a/src/psl/psl-prints.ads b/src/psl/psl-prints.ads
new file mode 100644
index 000000000..18a36f78f
--- /dev/null
+++ b/src/psl/psl-prints.ads
@@ -0,0 +1,20 @@
+with PSL.Nodes; use PSL.Nodes;
+with PSL.Priorities; use PSL.Priorities;
+
+package PSL.Prints is
+ procedure Print_Unit (Unit : Node);
+ procedure Print_Property (Prop : Node;
+ Parent_Prio : Priority := Prio_Lowest);
+ procedure Print_Expr (N : Node; Parent_Prio : Priority := Prio_Lowest);
+
+ -- Procedure to display HDL_Expr nodes.
+ type HDL_Expr_Printer_Acc is access procedure (N : HDL_Node);
+ HDL_Expr_Printer : HDL_Expr_Printer_Acc;
+
+ procedure Print_HDL_Expr (N : HDL_Node);
+
+ -- Like Print_Expr but always put parenthesis.
+ procedure Dump_Expr (N : Node);
+
+end PSL.Prints;
+
diff --git a/src/psl/psl-priorities.ads b/src/psl/psl-priorities.ads
new file mode 100644
index 000000000..cb49239e4
--- /dev/null
+++ b/src/psl/psl-priorities.ads
@@ -0,0 +1,63 @@
+package PSL.Priorities is
+ -- Operator priorities, defined by PSL1.1 4.2.3.2
+ type Priority is
+ (
+ Prio_Lowest,
+
+ -- always, never, G
+ Prio_FL_Invariance,
+
+ -- ->, <->
+ Prio_Bool_Imp,
+
+ -- |->, |=>
+ Prio_Seq_Imp,
+
+ -- U, W, until*, before*
+ Prio_FL_Bounding,
+
+ -- next*, eventually!, X, X!, F
+ Prio_FL_Occurence,
+
+ -- abort
+ Prio_FL_Abort,
+
+ -- ( )
+ Prio_FL_Paren,
+
+ -- ;
+ Prio_Seq_Concat,
+
+ -- :
+ Prio_Seq_Fusion,
+
+ -- |
+ Prio_Seq_Or,
+
+ -- &, &&
+ Prio_Seq_And,
+
+ -- within
+ Prio_Seq_Within,
+
+ -- [*], [+], [=], [->]
+ Prio_SERE_Repeat,
+
+ -- { }
+ Prio_SERE_Brace,
+
+ -- @
+ Prio_Clock_Event,
+
+ -- !
+ Prio_Strong,
+
+ -- union
+ Prio_Union,
+
+ -- !
+ Prio_Bool_Not,
+
+ Prio_HDL
+ );
+end PSL.Priorities;
diff --git a/src/psl/psl-qm.adb b/src/psl/psl-qm.adb
new file mode 100644
index 000000000..f5b5e1db3
--- /dev/null
+++ b/src/psl/psl-qm.adb
@@ -0,0 +1,318 @@
+with Ada.Text_IO;
+with Types; use Types;
+with PSL.Errors; use PSL.Errors;
+with PSL.Prints;
+with PSL.CSE;
+
+package body PSL.QM is
+ procedure Reset is
+ begin
+ for I in 1 .. Nbr_Terms loop
+ Set_HDL_Index (Term_Assoc (I), 0);
+ end loop;
+ Nbr_Terms := 0;
+ Term_Assoc := (others => Null_Node);
+ end Reset;
+
+ function Term (P : Natural) return Vector_Type is
+ begin
+ return Shift_Left (1, P - 1);
+ end Term;
+
+ procedure Disp_Primes_Set (Ps : Primes_Set)
+ is
+ use Ada.Text_IO;
+ use PSL.Prints;
+ Prime : Prime_Type;
+ T : Vector_Type;
+ First_Term : Boolean;
+ begin
+ if Ps.Nbr = 0 then
+ Put ("FALSE");
+ return;
+ end if;
+ for I in 1 .. Ps.Nbr loop
+ Prime := Ps.Set (I);
+ if I /= 1 then
+ Put (" | ");
+ end if;
+ if Prime.Set = 0 then
+ Put ("TRUE");
+ else
+ First_Term := True;
+ for J in 1 .. Max_Terms loop
+ T := Term (J);
+ if (Prime.Set and T) /= 0 then
+ if First_Term then
+ First_Term := False;
+ else
+ Put ('.');
+ end if;
+ if (Prime.Val and T) = 0 then
+ Put ('!');
+ end if;
+ Print_Expr (Term_Assoc (J));
+ end if;
+ end loop;
+ end if;
+ end loop;
+ end Disp_Primes_Set;
+
+ -- Return TRUE iff L includes R, ie
+ -- for all x, x in L => x in R.
+ function Included (L, R : Prime_Type) return Boolean is
+ begin
+ return ((L.Set or R.Set) = L.Set)
+ and then ((L.Val and R.Set) = (R.Val and R.Set));
+ end Included;
+
+ -- Return TRUE iff L and R have the same don't care set
+ -- and L and R can be merged into a new prime with a new don't care.
+ function Is_One_Change_Same (L, R : Prime_Type) return Boolean
+ is
+ V : Vector_Type;
+ begin
+ if L.Set /= R.Set then
+ return False;
+ end if;
+ V := L.Val xor R.Val;
+ return (V and -V) = V;
+ end Is_One_Change_Same;
+
+ -- Return true iff L can add a new DC in R.
+ function Is_One_Change (L, R : Prime_Type) return Boolean
+ is
+ V : Vector_Type;
+ begin
+ if (L.Set or R.Set) /= R.Set then
+ return False;
+ end if;
+ V := (L.Val xor R.Val) and L.Set;
+ return (V and -V) = V;
+ end Is_One_Change;
+
+ procedure Merge (Ps : in out Primes_Set; P : Prime_Type)
+ is
+ Do_Append : Boolean := True;
+ T : Prime_Type;
+ begin
+ for I in 1 .. Ps.Nbr loop
+ T := Ps.Set (I);
+ if Included (P, T) then
+ -- Already in the set.
+ return;
+ end if;
+ if Included (T, P) then
+ Ps.Set (I) := P;
+ Do_Append := False;
+ else
+ if Is_One_Change_Same (P, T) then
+ declare
+ V : constant Vector_Type := T.Val xor P.Val;
+ begin
+ Ps.Set (I).Set := T.Set and not V;
+ Ps.Set (I).Val := T.Val and not V;
+ end;
+ Do_Append := False;
+ end if;
+ if Is_One_Change (P, T) then
+ declare
+ V : constant Vector_Type := (T.Val xor P.Val) and P.Set;
+ begin
+ Ps.Set (I).Set := T.Set and not V;
+ Ps.Set (I).Val := T.Val and not V;
+ end;
+ -- continue.
+ end if;
+ end if;
+ end loop;
+ if Do_Append then
+ Ps.Nbr := Ps.Nbr + 1;
+ Ps.Set (Ps.Nbr) := P;
+ end if;
+ end Merge;
+
+ function Build_Primes_And (L, R : Primes_Set) return Primes_Set
+ is
+ Res : Primes_Set (L.Nbr * R.Nbr);
+ L_P, R_P : Prime_Type;
+ P : Prime_Type;
+ begin
+ for I in 1 .. L.Nbr loop
+ L_P := L.Set (I);
+ for J in 1 .. R.Nbr loop
+ R_P := R.Set (J);
+ -- In case of conflict, discard.
+ if ((L_P.Val xor R_P.Val) and (L_P.Set and R_P.Set)) /= 0 then
+ null;
+ else
+ P.Set := L_P.Set or R_P.Set;
+ P.Val := (R_P.Set and R_P.Val)
+ or ((L_P.Set and not R_P.Set) and L_P.Val);
+ Merge (Res, P);
+ end if;
+ end loop;
+ end loop;
+
+ return Res;
+ end Build_Primes_And;
+
+
+ function Build_Primes_Or (L, R : Primes_Set) return Primes_Set
+ is
+ Res : Primes_Set (L.Nbr + R.Nbr);
+ L_P, R_P : Prime_Type;
+ begin
+ for I in 1 .. L.Nbr loop
+ L_P := L.Set (I);
+ Merge (Res, L_P);
+ end loop;
+ for J in 1 .. R.Nbr loop
+ R_P := R.Set (J);
+ Merge (Res, R_P);
+ end loop;
+
+ return Res;
+ end Build_Primes_Or;
+
+ function Build_Primes (N : Node; Negate : Boolean) return Primes_Set is
+ begin
+ case Get_Kind (N) is
+ when N_HDL_Expr
+ | N_EOS =>
+ declare
+ Res : Primes_Set (1);
+ Index : Int32;
+ T : Vector_Type;
+ begin
+ Index := Get_HDL_Index (N);
+ if Index = 0 then
+ Nbr_Terms := Nbr_Terms + 1;
+ if Nbr_Terms > Max_Terms then
+ raise Program_Error;
+ end if;
+ Term_Assoc (Nbr_Terms) := N;
+ Index := Int32 (Nbr_Terms);
+ Set_HDL_Index (N, Index);
+ else
+ if Index not in 1 .. Int32 (Nbr_Terms)
+ or else Term_Assoc (Natural (Index)) /= N
+ then
+ raise Internal_Error;
+ end if;
+ end if;
+ T := Term (Natural (Index));
+ Res.Nbr := 1;
+ Res.Set (1).Set := T;
+ if Negate then
+ Res.Set (1).Val := 0;
+ else
+ Res.Set (1).Val := T;
+ end if;
+ return Res;
+ end;
+ when N_False =>
+ declare
+ Res : Primes_Set (0);
+ begin
+ return Res;
+ end;
+ when N_True =>
+ declare
+ Res : Primes_Set (1);
+ begin
+ Res.Nbr := 1;
+ Res.Set (1).Set := 0;
+ Res.Set (1).Val := 0;
+ return Res;
+ end;
+ when N_Not_Bool =>
+ return Build_Primes (Get_Boolean (N), not Negate);
+ when N_And_Bool =>
+ if Negate then
+ -- !(a & b) <-> !a || !b
+ return Build_Primes_Or (Build_Primes (Get_Left (N), True),
+ Build_Primes (Get_Right (N), True));
+ else
+ return Build_Primes_And (Build_Primes (Get_Left (N), False),
+ Build_Primes (Get_Right (N), False));
+ end if;
+ when N_Or_Bool =>
+ if Negate then
+ -- !(a || b) <-> !a && !b
+ return Build_Primes_And (Build_Primes (Get_Left (N), True),
+ Build_Primes (Get_Right (N), True));
+ else
+ return Build_Primes_Or (Build_Primes (Get_Left (N), False),
+ Build_Primes (Get_Right (N), False));
+ end if;
+ when N_Imp_Bool =>
+ if not Negate then
+ -- a -> b <-> !a || b
+ return Build_Primes_Or (Build_Primes (Get_Left (N), True),
+ Build_Primes (Get_Right (N), False));
+ else
+ -- !(a -> b) <-> a && !b
+ return Build_Primes_And (Build_Primes (Get_Left (N), False),
+ Build_Primes (Get_Right (N), True));
+ end if;
+ when others =>
+ Error_Kind ("build_primes", N);
+ end case;
+ end Build_Primes;
+
+ function Build_Primes (N : Node) return Primes_Set is
+ begin
+ return Build_Primes (N, False);
+ end Build_Primes;
+
+ function Build_Node (P : Prime_Type) return Node
+ is
+ Res : Node := Null_Node;
+ N : Node;
+ S : Vector_Type := P.Set;
+ T : Vector_Type;
+ begin
+ if S = 0 then
+ return True_Node;
+ end if;
+ for I in Natural range 1 .. Vector_Type'Modulus loop
+ T := Term (I);
+ if (S and T) /= 0 then
+ N := Term_Assoc (I);
+ if (P.Val and T) = 0 then
+ N := PSL.CSE.Build_Bool_Not (N);
+ end if;
+ if Res = Null_Node then
+ Res := N;
+ else
+ Res := PSL.CSE.Build_Bool_And (Res, N);
+ end if;
+ S := S and not T;
+ exit when S = 0;
+ end if;
+ end loop;
+ return Res;
+ end Build_Node;
+
+ function Build_Node (Ps : Primes_Set) return Node
+ is
+ Res : Node;
+ begin
+ if Ps.Nbr = 0 then
+ return False_Node;
+ else
+ Res := Build_Node (Ps.Set (1));
+ for I in 2 .. Ps.Nbr loop
+ Res := PSL.CSE.Build_Bool_Or (Res, Build_Node (Ps.Set (I)));
+ end loop;
+ return Res;
+ end if;
+ end Build_Node;
+
+ -- FIXME: finish the work: do a real Quine-McKluskey minimization.
+ function Reduce (N : Node) return Node is
+ begin
+ return Build_Node (Build_Primes (N));
+ end Reduce;
+end PSL.QM;
diff --git a/src/psl/psl-qm.ads b/src/psl/psl-qm.ads
new file mode 100644
index 000000000..85f1e3cf4
--- /dev/null
+++ b/src/psl/psl-qm.ads
@@ -0,0 +1,49 @@
+with PSL.Nodes; use PSL.Nodes;
+with Interfaces; use Interfaces;
+
+package PSL.QM is
+ type Primes_Set (<>) is private;
+
+ function Build_Primes (N : Node) return Primes_Set;
+
+ function Build_Node (Ps : Primes_Set) return Node;
+
+ function Reduce (N : Node) return Node;
+
+ -- The maximum number of terms that this package can handle.
+ -- The algorithm is in O(2**n)
+ Max_Terms : constant Natural := 12;
+
+ type Term_Assoc_Type is array (1 .. Max_Terms) of Node;
+ Term_Assoc : Term_Assoc_Type := (others => Null_Node);
+ Nbr_Terms : Natural := 0;
+
+ procedure Reset;
+
+ procedure Disp_Primes_Set (Ps : Primes_Set);
+private
+ -- Scalar type used to represent a vector of booleans for terms.
+ subtype Vector_Type is Unsigned_16;
+ pragma Assert (Vector_Type'Modulus >= 2 ** Max_Terms);
+
+ -- States of a vector of term.
+ -- If SET is 0, this is a don't care: the term has no influence.
+ -- If SET is 1, the value of the term is in VAL.
+ type Prime_Type is record
+ Val : Unsigned_16;
+ Set : Unsigned_16;
+ end record;
+
+ subtype Len_Type is Natural range 0 .. 2 ** Max_Terms;
+
+ type Set_Type is array (Natural range <>) of Prime_Type;
+
+ -- A set of primes is a collection of at most MAX prime.
+ type Primes_Set (Max : Len_Type) is record
+ Nbr : Len_Type := 0;
+ Set : Set_Type (1 .. Max);
+ end record;
+end PSL.QM;
+
+
+
diff --git a/src/psl/psl-rewrites.adb b/src/psl/psl-rewrites.adb
new file mode 100644
index 000000000..6ba5b1026
--- /dev/null
+++ b/src/psl/psl-rewrites.adb
@@ -0,0 +1,604 @@
+with Types; use Types;
+with PSL.Errors; use PSL.Errors;
+with PSL.CSE; use PSL.CSE;
+
+package body PSL.Rewrites is
+-- procedure Location_Copy (Dst, Src : Node) is
+-- begin
+-- Set_Location (Dst, Get_Location (Src));
+-- end Location_Copy;
+
+ -- Return [*0]
+ function Build_Empty return Node is
+ Res, Tmp : Node;
+ begin
+ Res := Create_Node (N_Star_Repeat_Seq);
+ Tmp := Create_Node (N_Number);
+ Set_Value (Tmp, 0);
+ Set_Low_Bound (Res, Tmp);
+ return Res;
+ end Build_Empty;
+
+ -- Return N[*]
+ function Build_Star (N : Node) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node (N_Star_Repeat_Seq);
+ Set_Sequence (Res, N);
+ return Res;
+ end Build_Star;
+
+ -- Return N[+]
+ function Build_Plus (N : Node) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node (N_Plus_Repeat_Seq);
+ Set_Sequence (Res, N);
+ return Res;
+ end Build_Plus;
+
+ -- Return N!
+ function Build_Strong (N : Node) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node (N_Strong);
+ Set_Property (Res, N);
+ return Res;
+ end Build_Strong;
+
+ -- Return T[*]
+ function Build_True_Star return Node is
+ begin
+ return Build_Star (True_Node);
+ end Build_True_Star;
+
+ function Build_Binary (K : Nkind; L, R : Node) return Node is
+ Res : Node;
+ begin
+ Res := Create_Node (K);
+ Set_Left (Res, L);
+ Set_Right (Res, R);
+ return Res;
+ end Build_Binary;
+
+ function Build_Concat (L, R : Node) return Node is
+ begin
+ return Build_Binary (N_Concat_SERE, L, R);
+ end Build_Concat;
+
+ function Build_Repeat (N : Node; Cnt : Uns32) return Node is
+ Res : Node;
+ begin
+ if Cnt = 0 then
+ raise Internal_Error;
+ end if;
+ Res := N;
+ for I in 2 .. Cnt loop
+ Res := Build_Concat (Res, N);
+ end loop;
+ return Res;
+ end Build_Repeat;
+
+ function Build_Overlap_Imp_Seq (S : Node; P : Node) return Node
+ is
+ Res : Node;
+ begin
+ Res := Create_Node (N_Overlap_Imp_Seq);
+ Set_Sequence (Res, S);
+ Set_Property (Res, P);
+ return Res;
+ end Build_Overlap_Imp_Seq;
+
+ function Rewrite_Boolean (N : Node) return Node
+ is
+ Res : Node;
+ begin
+ case Get_Kind (N) is
+ when N_Name =>
+ Res := Get_Decl (N);
+ pragma Assert (Res /= Null_Node);
+ return Res;
+ when N_Not_Bool =>
+ Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N)));
+ return N;
+ when N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool =>
+ Set_Left (N, Rewrite_Boolean (Get_Left (N)));
+ Set_Right (N, Rewrite_Boolean (Get_Right (N)));
+ return N;
+ when N_HDL_Expr =>
+ return N;
+ when others =>
+ Error_Kind ("rewrite_boolean", N);
+ end case;
+ end Rewrite_Boolean;
+
+ function Rewrite_Star_Repeat_Seq (Seq : Node;
+ Lo, Hi : Uns32) return Node
+ is
+ Res : Node;
+ begin
+ pragma Assert (Lo <= Hi);
+
+ if Lo = Hi then
+
+ if Lo = 0 then
+ -- r[*0] --> [*0]
+ return Build_Empty;
+ elsif Lo = 1 then
+ -- r[*1] --> r
+ return Seq;
+ end if;
+ -- r[*c+] --> r;r;r...;r (c times)
+ return Build_Repeat (Seq, Lo);
+ end if;
+
+ -- r[*0:1] --> [*0] | r
+ -- r[*0:2] --> [*0] | r;{[*0]|r}
+
+ -- r[*0:n] --> [*0] | r;r[*0:n-1]
+ -- r[*l:h] --> r[*l] ; r[*0:h-l]
+ Res := Build_Binary (N_Or_Seq, Build_Empty, Seq);
+ for I in Lo + 2 .. Hi loop
+ Res := Build_Concat (Seq, Res);
+ Res := Build_Binary (N_Or_Seq, Build_Empty, Res);
+ end loop;
+ if Lo > 0 then
+ Res := Build_Concat (Build_Repeat (Seq, Lo), Res);
+ end if;
+
+ return Res;
+ end Rewrite_Star_Repeat_Seq;
+
+ function Rewrite_Star_Repeat_Seq (Seq : Node;
+ Lo, Hi : Node) return Node
+ is
+ Cnt_Lo : Uns32;
+ Cnt_Hi : Uns32;
+ begin
+ if Lo = Null_Node then
+ -- r[*]
+ raise Program_Error;
+ end if;
+
+ Cnt_Lo := Get_Value (Lo);
+ if Hi = Null_Node then
+ Cnt_Hi := Cnt_Lo;
+ else
+ Cnt_Hi := Get_Value (Hi);
+ end if;
+ return Rewrite_Star_Repeat_Seq (Seq, Cnt_Lo, Cnt_Hi);
+ end Rewrite_Star_Repeat_Seq;
+
+ function Rewrite_Star_Repeat_Seq (N : Node) return Node
+ is
+ Seq : constant Node := Get_Sequence (N);
+ Lo : constant Node := Get_Low_Bound (N);
+ begin
+ if Lo = Null_Node then
+ -- r[*] --> r[*]
+ return N;
+ else
+ return Rewrite_Star_Repeat_Seq (Seq, Lo, Get_High_Bound (N));
+ end if;
+ end Rewrite_Star_Repeat_Seq;
+
+ function Rewrite_Goto_Repeat_Seq (Seq : Node;
+ Lo, Hi : Node) return Node is
+ Res : Node;
+ begin
+ -- b[->] --> {(~b)[*];b}
+ Res := Build_Concat (Build_Star (Build_Bool_Not (Seq)), Seq);
+
+ if Lo = Null_Node then
+ return Res;
+ end if;
+
+ -- b[->l:h] --> {b[->]}[*l:h]
+ return Rewrite_Star_Repeat_Seq (Res, Lo, Hi);
+ end Rewrite_Goto_Repeat_Seq;
+
+ function Rewrite_Goto_Repeat_Seq (Seq : Node;
+ Lo, Hi : Uns32) return Node is
+ Res : Node;
+ begin
+ -- b[->] --> {(~b)[*];b}
+ Res := Build_Concat (Build_Star (Build_Bool_Not (Seq)), Seq);
+
+ -- b[->l:h] --> {b[->]}[*l:h]
+ return Rewrite_Star_Repeat_Seq (Res, Lo, Hi);
+ end Rewrite_Goto_Repeat_Seq;
+
+ function Rewrite_Equal_Repeat_Seq (N : Node) return Node
+ is
+ Seq : constant Node := Get_Sequence (N);
+ Lo : constant Node := Get_Low_Bound (N);
+ Hi : constant Node := Get_High_Bound (N);
+ begin
+ -- b[=l:h] --> {b[->l:h]};(~b)[*]
+ return Build_Concat (Rewrite_Goto_Repeat_Seq (Seq, Lo, Hi),
+ Build_Star (Build_Bool_Not (Seq)));
+ end Rewrite_Equal_Repeat_Seq;
+
+ function Rewrite_Within (N : Node) return Node is
+ Res : Node;
+ begin
+ Res := Build_Concat (Build_Concat (Build_True_Star, Get_Left (N)),
+ Build_True_Star);
+ return Build_Binary (N_Match_And_Seq, Res, Get_Right (N));
+ end Rewrite_Within;
+
+ function Rewrite_And_Seq (L : Node; R : Node) return Node is
+ begin
+ return Build_Binary (N_Or_Seq,
+ Build_Binary (N_Match_And_Seq,
+ L,
+ Build_Concat (R, Build_True_Star)),
+ Build_Binary (N_Match_And_Seq,
+ Build_Concat (L, Build_True_Star),
+ R));
+ end Rewrite_And_Seq;
+ pragma Unreferenced (Rewrite_And_Seq);
+
+ procedure Rewrite_Instance (N : Node)
+ is
+ Assoc : Node := Get_Association_Chain (N);
+ begin
+ while Assoc /= Null_Node loop
+ case Get_Kind (Get_Formal (Assoc)) is
+ when N_Const_Parameter =>
+ null;
+ when N_Boolean_Parameter =>
+ Set_Actual (Assoc, Rewrite_Boolean (Get_Actual (Assoc)));
+ when N_Sequence_Parameter =>
+ Set_Actual (Assoc, Rewrite_SERE (Get_Actual (Assoc)));
+ when N_Property_Parameter =>
+ Set_Actual (Assoc, Rewrite_Property (Get_Actual (Assoc)));
+ when others =>
+ Error_Kind ("rewrite_instance",
+ Get_Formal (Assoc));
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Rewrite_Instance;
+
+ function Rewrite_SERE (N : Node) return Node is
+ S : Node;
+ begin
+ case Get_Kind (N) is
+ when N_Star_Repeat_Seq =>
+ S := Get_Sequence (N);
+ if S = Null_Node then
+ S := True_Node;
+ else
+ S := Rewrite_SERE (S);
+ end if;
+ Set_Sequence (N, S);
+ return Rewrite_Star_Repeat_Seq (N);
+ when N_Plus_Repeat_Seq =>
+ S := Get_Sequence (N);
+ if S = Null_Node then
+ S := True_Node;
+ else
+ S := Rewrite_SERE (S);
+ end if;
+ Set_Sequence (N, S);
+ return N;
+ when N_Goto_Repeat_Seq =>
+ return Rewrite_Goto_Repeat_Seq
+ (Rewrite_SERE (Get_Sequence (N)),
+ Get_Low_Bound (N), Get_High_Bound (N));
+ when N_Equal_Repeat_Seq =>
+ Set_Sequence (N, Rewrite_SERE (Get_Sequence (N)));
+ return Rewrite_Equal_Repeat_Seq (N);
+ when N_Braced_SERE =>
+ return Rewrite_SERE (Get_SERE (N));
+ when N_Within_SERE =>
+ Set_Left (N, Rewrite_SERE (Get_Left (N)));
+ Set_Right (N, Rewrite_SERE (Get_Right (N)));
+ return Rewrite_Within (N);
+-- when N_And_Seq =>
+-- return Rewrite_And_Seq (Rewrite_SERE (Get_Left (N)),
+-- Rewrite_SERE (Get_Right (N)));
+ when N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Match_And_Seq
+ | N_And_Seq
+ | N_Or_Seq =>
+ Set_Left (N, Rewrite_SERE (Get_Left (N)));
+ Set_Right (N, Rewrite_SERE (Get_Right (N)));
+ return N;
+ when N_Booleans =>
+ return Rewrite_Boolean (N);
+ when N_Name =>
+ return Get_Decl (N);
+ when N_Sequence_Instance
+ | N_Endpoint_Instance =>
+ Rewrite_Instance (N);
+ return N;
+ when N_Boolean_Parameter
+ | N_Sequence_Parameter
+ | N_Const_Parameter =>
+ return N;
+ when others =>
+ Error_Kind ("rewrite_SERE", N);
+ end case;
+ end Rewrite_SERE;
+
+ function Rewrite_Until (N : Node) return Node
+ is
+ Res : Node;
+ B : Node;
+ L : Node;
+ S : Node;
+ begin
+ if Get_Inclusive_Flag (N) then
+ -- B1 until_ B2 --> {B1[+]:B2}
+ Res := Build_Binary (N_Fusion_SERE,
+ Build_Plus (Rewrite_Boolean (Get_Left (N))),
+ Rewrite_Boolean (Get_Right (N)));
+ if Get_Strong_Flag (N) then
+ Res := Build_Strong (Res);
+ end if;
+ else
+ -- P until B --> {(!B)[+]} |-> P
+ B := Rewrite_Boolean (Get_Right (N));
+ L := Build_Plus (Build_Bool_Not (B));
+ Res := Build_Overlap_Imp_Seq (L, Rewrite_Property (Get_Left (N)));
+
+ if Get_Strong_Flag (N) then
+ -- p until! b --> (p until b) && ({b[->]}!)
+ S := Build_Strong
+ (Rewrite_Goto_Repeat_Seq (B, Null_Node, Null_Node));
+ Res := Build_Binary (N_And_Prop, Res, S);
+ end if;
+ end if;
+ return Res;
+ end Rewrite_Until;
+
+ function Rewrite_Next_Event_A (B : Node;
+ Lo, Hi : Uns32;
+ P : Node;
+ Strong : Boolean) return Node
+ is
+ Res : Node;
+ begin
+ Res := Rewrite_Goto_Repeat_Seq (B, Lo, Hi);
+ Res := Build_Overlap_Imp_Seq (Res, P);
+
+ if Strong then
+ Res := Build_Binary
+ (N_And_Prop,
+ Res,
+ Build_Strong (Rewrite_Goto_Repeat_Seq (B, Lo, Lo)));
+ end if;
+
+ return Res;
+ end Rewrite_Next_Event_A;
+
+ function Rewrite_Next_Event (B : Node;
+ N : Uns32;
+ P : Node;
+ Strong : Boolean) return Node is
+ begin
+ return Rewrite_Next_Event_A (B, N, N, P, Strong);
+ end Rewrite_Next_Event;
+
+ function Rewrite_Next_Event (B : Node;
+ Num : Node;
+ P : Node;
+ Strong : Boolean) return Node
+ is
+ N : Uns32;
+ begin
+ if Num = Null_Node then
+ N := 1;
+ else
+ N := Get_Value (Num);
+ end if;
+ return Rewrite_Next_Event (B, N, P, Strong);
+ end Rewrite_Next_Event;
+
+ function Rewrite_Next (Num : Node; P : Node; Strong : Boolean) return Node
+ is
+ N : Uns32;
+ begin
+ if Num = Null_Node then
+ N := 1;
+ else
+ N := Get_Value (Num);
+ end if;
+ return Rewrite_Next_Event (True_Node, N + 1, P, Strong);
+ end Rewrite_Next;
+
+ function Rewrite_Next_A (Lo, Hi : Uns32;
+ P : Node; Strong : Boolean) return Node
+ is
+ begin
+ return Rewrite_Next_Event_A (True_Node, Lo + 1, Hi + 1, P, Strong);
+ end Rewrite_Next_A;
+
+ function Rewrite_Next_Event_E (B1 : Node;
+ Lo, Hi : Uns32;
+ B2 : Node; Strong : Boolean) return Node
+ is
+ Res : Node;
+ begin
+ Res := Build_Binary (N_Fusion_SERE,
+ Rewrite_Goto_Repeat_Seq (B1, Lo, Hi),
+ B2);
+ if Strong then
+ Res := Build_Strong (Res);
+ end if;
+ return Res;
+ end Rewrite_Next_Event_E;
+
+ function Rewrite_Next_E (Lo, Hi : Uns32;
+ B : Node; Strong : Boolean) return Node
+ is
+ begin
+ return Rewrite_Next_Event_E (True_Node, Lo + 1, Hi + 1, B, Strong);
+ end Rewrite_Next_E;
+
+ function Rewrite_Before (N : Node) return Node
+ is
+ Res : Node;
+ R : Node;
+ B1, B2 : Node;
+ N_B2 : Node;
+ begin
+ B1 := Rewrite_Boolean (Get_Left (N));
+ B2 := Rewrite_Boolean (Get_Right (N));
+ N_B2 := Build_Bool_Not (B2);
+ Res := Build_Star (Build_Bool_And (Build_Bool_Not (B1), N_B2));
+
+ if Get_Inclusive_Flag (N) then
+ R := B2;
+ else
+ R := Build_Bool_And (B1, N_B2);
+ end if;
+ Res := Build_Concat (Res, R);
+ if Get_Strong_Flag (N) then
+ Res := Build_Strong (Res);
+ end if;
+ return Res;
+ end Rewrite_Before;
+
+ function Rewrite_Or (L, R : Node) return Node
+ is
+ B, P : Node;
+ begin
+ if Get_Kind (L) in N_Booleans then
+ if Get_Kind (R) in N_Booleans then
+ return Build_Bool_Or (L, R);
+ else
+ B := L;
+ P := R;
+ end if;
+ elsif Get_Kind (R) in N_Booleans then
+ B := R;
+ P := L;
+ else
+ -- Not in the simple subset.
+ raise Program_Error;
+ end if;
+
+ -- B || P --> (~B) -> P
+ return Build_Binary (N_Log_Imp_Prop, Build_Bool_Not (B), P);
+ end Rewrite_Or;
+
+ function Rewrite_Property (N : Node) return Node is
+ begin
+ case Get_Kind (N) is
+ when N_Star_Repeat_Seq
+ | N_Plus_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Sequence_Instance
+ | N_Endpoint_Instance
+ | N_Braced_SERE =>
+ return Rewrite_SERE (N);
+ when N_Imp_Seq
+ | N_Overlap_Imp_Seq =>
+ Set_Sequence (N, Rewrite_Property (Get_Sequence (N)));
+ Set_Property (N, Rewrite_Property (Get_Property (N)));
+ return N;
+ when N_Log_Imp_Prop =>
+ -- b -> p --> {b} |-> p
+ return Build_Overlap_Imp_Seq
+ (Rewrite_Boolean (Get_Left (N)),
+ Rewrite_Property (Get_Right (N)));
+ when N_Eventually =>
+ return Build_Strong
+ (Build_Binary (N_Fusion_SERE,
+ Build_Plus (True_Node),
+ Rewrite_SERE (Get_Property (N))));
+ when N_Until =>
+ return Rewrite_Until (N);
+ when N_Next =>
+ return Rewrite_Next (Get_Number (N),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Next_Event =>
+ return Rewrite_Next_Event (Rewrite_Boolean (Get_Boolean (N)),
+ Get_Number (N),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Next_A =>
+ return Rewrite_Next_A (Get_Value (Get_Low_Bound (N)),
+ Get_Value (Get_High_Bound (N)),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Next_Event_A =>
+ return Rewrite_Next_Event_A
+ (Rewrite_Boolean (Get_Boolean (N)),
+ Get_Value (Get_Low_Bound (N)),
+ Get_Value (Get_High_Bound (N)),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Next_E =>
+ return Rewrite_Next_E (Get_Value (Get_Low_Bound (N)),
+ Get_Value (Get_High_Bound (N)),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Next_Event_E =>
+ return Rewrite_Next_Event_E
+ (Rewrite_Boolean (Get_Boolean (N)),
+ Get_Value (Get_Low_Bound (N)),
+ Get_Value (Get_High_Bound (N)),
+ Rewrite_Property (Get_Property (N)),
+ Get_Strong_Flag (N));
+ when N_Before =>
+ return Rewrite_Before (N);
+ when N_Booleans =>
+ return Rewrite_Boolean (N);
+ when N_Name =>
+ return Get_Decl (N);
+ when N_Never
+ | N_Always
+ | N_Strong =>
+ -- Fully handled by psl.build
+ Set_Property (N, Rewrite_Property (Get_Property (N)));
+ return N;
+ when N_Clock_Event =>
+ Set_Property (N, Rewrite_Property (Get_Property (N)));
+ Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N)));
+ return N;
+ when N_And_Prop =>
+ Set_Left (N, Rewrite_Property (Get_Left (N)));
+ Set_Right (N, Rewrite_Property (Get_Right (N)));
+ return N;
+ when N_Or_Prop =>
+ return Rewrite_Or (Rewrite_Property (Get_Left (N)),
+ Rewrite_Property (Get_Right (N)));
+ when N_Abort =>
+ Set_Boolean (N, Rewrite_Boolean (Get_Boolean (N)));
+ Set_Property (N, Rewrite_Property (Get_Property (N)));
+ return N;
+ when N_Property_Instance =>
+ Rewrite_Instance (N);
+ return N;
+ when others =>
+ Error_Kind ("rewrite_property", N);
+ end case;
+ end Rewrite_Property;
+
+ procedure Rewrite_Unit (N : Node) is
+ Item : Node;
+ begin
+ Item := Get_Item_Chain (N);
+ while Item /= Null_Node loop
+ case Get_Kind (Item) is
+ when N_Name_Decl =>
+ null;
+ when N_Assert_Directive =>
+ Set_Property (Item, Rewrite_Property (Get_Property (Item)));
+ when N_Property_Declaration =>
+ Set_Property (Item, Rewrite_Property (Get_Property (Item)));
+ when others =>
+ Error_Kind ("rewrite_unit", Item);
+ end case;
+ Item := Get_Chain (Item);
+ end loop;
+ end Rewrite_Unit;
+end PSL.Rewrites;
diff --git a/src/psl/psl-rewrites.ads b/src/psl/psl-rewrites.ads
new file mode 100644
index 000000000..ac76b7805
--- /dev/null
+++ b/src/psl/psl-rewrites.ads
@@ -0,0 +1,7 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Rewrites is
+ function Rewrite_SERE (N : Node) return Node;
+ function Rewrite_Property (N : Node) return Node;
+ procedure Rewrite_Unit (N : Node);
+end PSL.Rewrites;
diff --git a/src/psl/psl-subsets.adb b/src/psl/psl-subsets.adb
new file mode 100644
index 000000000..f322eafda
--- /dev/null
+++ b/src/psl/psl-subsets.adb
@@ -0,0 +1,177 @@
+with PSL.Errors; use PSL.Errors;
+with Types; use Types;
+
+package body PSL.Subsets is
+ procedure Check_Simple (N : Node)
+ is
+ begin
+ case Get_Kind (N) is
+ when N_Not_Bool =>
+ if Get_Psl_Type (Get_Boolean (N)) /= Type_Boolean then
+ Error_Msg_Sem
+ ("operand of a negation operator must be a boolean", N);
+ end if;
+ when N_Never =>
+ case Get_Psl_Type (Get_Property (N)) is
+ when Type_Sequence | Type_Boolean =>
+ null;
+ when others =>
+ Error_Msg_Sem ("operand of a 'never' operator must be "
+ & "a boolean or a sequence", N);
+ end case;
+ when N_Eventually =>
+ case Get_Psl_Type (Get_Property (N)) is
+ when Type_Sequence | Type_Boolean =>
+ null;
+ when others =>
+ Error_Msg_Sem ("operand of an 'eventually!' operator must be"
+ & " a boolean or a sequence", N);
+ end case;
+ when N_And_Bool =>
+ if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then
+ Error_Msg_Sem ("left-hand side operand of logical 'and' must be"
+ & " a boolean", N);
+ end if;
+ when N_Or_Bool =>
+ if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then
+ Error_Msg_Sem ("left-hand side operand of logical 'or' must be"
+ & " a boolean", N);
+ end if;
+ when N_Log_Imp_Prop =>
+ if Get_Psl_Type (Get_Left (N)) /= Type_Boolean then
+ Error_Msg_Sem ("left-hand side operand of logical '->' must be"
+ & " a boolean", N);
+ end if;
+ -- FIXME: <->
+ when N_Until =>
+ if not Get_Inclusive_Flag (N) then
+ if Get_Psl_Type (Get_Right (N)) /= Type_Boolean then
+ Error_Msg_Sem ("right-hand side of a non-overlapping "
+ & "'until*' operator must be a boolean", N);
+ end if;
+ else
+ if Get_Psl_Type (Get_Right (N)) /= Type_Boolean
+ or else Get_Psl_Type (Get_Left (N)) /= Type_Boolean
+ then
+ Error_Msg_Sem ("both operands of an overlapping 'until*'"
+ & " operator are boolean", N);
+ end if;
+ end if;
+ when N_Before =>
+ if Get_Psl_Type (Get_Right (N)) /= Type_Boolean
+ or else Get_Psl_Type (Get_Left (N)) /= Type_Boolean
+ then
+ Error_Msg_Sem ("both operands of a 'before*'"
+ & " operator are boolean", N);
+ end if;
+ when others =>
+ null;
+ end case;
+
+ -- Recursion.
+ case Get_Kind (N) is
+ when N_Error =>
+ null;
+ when N_Hdl_Mod_Name =>
+ null;
+ when N_Vunit
+ | N_Vmode
+ | N_Vprop =>
+ declare
+ Item : Node;
+ begin
+ Item := Get_Item_Chain (N);
+ while Item /= Null_Node loop
+ Check_Simple (Item);
+ Item := Get_Chain (Item);
+ end loop;
+ end;
+ when N_Name_Decl =>
+ null;
+ when N_Assert_Directive
+ | N_Property_Declaration =>
+ Check_Simple (Get_Property (N));
+ when N_Endpoint_Declaration
+ | N_Sequence_Declaration =>
+ Check_Simple (Get_Sequence (N));
+ when N_Clock_Event =>
+ Check_Simple (Get_Property (N));
+ Check_Simple (Get_Boolean (N));
+ when N_Always
+ | N_Never
+ | N_Eventually
+ | N_Strong =>
+ Check_Simple (Get_Property (N));
+ when N_Braced_SERE =>
+ Check_Simple (Get_SERE (N));
+ when N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Within_SERE =>
+ Check_Simple (Get_Left (N));
+ Check_Simple (Get_Right (N));
+ when N_Name =>
+ null;
+ when N_Star_Repeat_Seq
+ | N_Goto_Repeat_Seq
+ | N_Equal_Repeat_Seq =>
+ declare
+ N2 : constant Node := Get_Sequence (N);
+ begin
+ if N2 /= Null_Node then
+ Check_Simple (N2);
+ end if;
+ end;
+ when N_Plus_Repeat_Seq =>
+ Check_Simple (Get_Sequence (N));
+ when N_Match_And_Seq
+ | N_And_Seq
+ | N_Or_Seq =>
+ Check_Simple (Get_Left (N));
+ Check_Simple (Get_Right (N));
+ when N_Imp_Seq
+ | N_Overlap_Imp_Seq =>
+ Check_Simple (Get_Sequence (N));
+ Check_Simple (Get_Property (N));
+ when N_Log_Imp_Prop
+ | N_Until
+ | N_Before
+ | N_Or_Prop
+ | N_And_Prop
+ | N_And_Bool
+ | N_Or_Bool
+ | N_Imp_Bool =>
+ Check_Simple (Get_Left (N));
+ Check_Simple (Get_Right (N));
+ when N_Next
+ | N_Next_A
+ | N_Next_E =>
+ Check_Simple (Get_Property (N));
+ when N_Next_Event
+ | N_Next_Event_A
+ | N_Next_Event_E
+ | N_Abort =>
+ Check_Simple (Get_Boolean (N));
+ Check_Simple (Get_Property (N));
+ when N_Not_Bool =>
+ Check_Simple (Get_Boolean (N));
+ when N_Const_Parameter
+ | N_Sequence_Parameter
+ | N_Boolean_Parameter
+ | N_Property_Parameter =>
+ null;
+ when N_Actual =>
+ null;
+ when N_Sequence_Instance
+ | N_Endpoint_Instance
+ | N_Property_Instance =>
+ null;
+ when N_True
+ | N_False
+ | N_Number
+ | N_EOS
+ | N_HDL_Expr =>
+ null;
+ end case;
+ end Check_Simple;
+end PSL.Subsets;
+
diff --git a/src/psl/psl-subsets.ads b/src/psl/psl-subsets.ads
new file mode 100644
index 000000000..c3bae09ef
--- /dev/null
+++ b/src/psl/psl-subsets.ads
@@ -0,0 +1,23 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Subsets is
+ -- Check that N (a property) follows the simple subset rules from
+ -- PSL v1.1 4.4.4 Simple subset.
+ -- Ie:
+ -- - The operand of a negation operator is a Boolean.
+ -- - The operand of a 'never' operator is a Boolean or a Sequence.
+ -- - The operand of an 'eventually!' operator is a Boolean or a Sequence.
+ -- - The left-hand side operand of a logical 'and' operator is a Boolean.
+ -- - The left-hand side operand of a logical 'or' operator is a Boolean.
+ -- - The left-hand side operand of a logical implication '->' operator
+ -- is a Boolean.
+ -- - Both operands of a logical iff '<->' operator are Boolean.
+ -- - The right-hand side operand of a non-overlapping 'until*' operator is
+ -- a Boolean.
+ -- - Both operands of an overlapping 'until*' operator are Boolean.
+ -- - Both operands of a 'before*' operator are Boolean.
+ --
+ -- All other operators not mentioned above are supported in the simple
+ -- subset without restriction.
+ procedure Check_Simple (N : Node);
+end PSL.Subsets;
diff --git a/src/psl/psl-tprint.adb b/src/psl/psl-tprint.adb
new file mode 100644
index 000000000..eabe8bd28
--- /dev/null
+++ b/src/psl/psl-tprint.adb
@@ -0,0 +1,255 @@
+with Types; use Types;
+with PSL.Errors; use PSL.Errors;
+with PSL.Prints;
+with Ada.Text_IO; use Ada.Text_IO;
+with Name_Table; use Name_Table;
+
+package body PSL.Tprint is
+ procedure Disp_Expr (N : Node) is
+ begin
+ case Get_Kind (N) is
+ when N_Number =>
+ declare
+ Str : constant String := Uns32'Image (Get_Value (N));
+ begin
+ Put (Str (2 .. Str'Last));
+ end;
+ when others =>
+ Error_Kind ("disp_expr", N);
+ end case;
+ end Disp_Expr;
+
+ procedure Disp_Count (N : Node) is
+ B : Node;
+ begin
+ B := Get_Low_Bound (N);
+ if B = Null_Node then
+ return;
+ end if;
+ Disp_Expr (B);
+ B := Get_High_Bound (N);
+ if B = Null_Node then
+ return;
+ end if;
+ Put (":");
+ Disp_Expr (B);
+ end Disp_Count;
+
+ procedure Put_Node (Prefix : String; Name : String) is
+ begin
+ Put (Prefix);
+ Put ("-+ ");
+ Put (Name);
+ end Put_Node;
+
+ procedure Put_Node_Line (Prefix : String; Name : String) is
+ begin
+ Put_Node (Prefix, Name);
+ New_Line;
+ end Put_Node_Line;
+
+ function Down (Str : String) return String is
+ L : constant Natural := Str'Last;
+ begin
+ if Str (L) = '\' then
+ return Str (Str'First .. L - 1) & " \";
+ elsif Str (L) = '/' then
+ return Str (Str'First .. L - 1) & "| \";
+ else
+ raise Program_Error;
+ end if;
+ end Down;
+
+ function Up (Str : String) return String is
+ L : constant Natural := Str'Last;
+ begin
+ if Str (L) = '/' then
+ return Str (Str'First .. L - 1) & " /";
+ elsif Str (L) = '\' then
+ return Str (Str'First .. L - 1) & "| /";
+ else
+ raise Program_Error;
+ end if;
+ end Up;
+
+ procedure Disp_Repeat_Sequence (Prefix : String; Name : String; N : Node) is
+ S : Node;
+ begin
+ Put_Node (Prefix, Name);
+ Disp_Count (N);
+ Put_Line ("]");
+ S := Get_Sequence (N);
+ if S /= Null_Node then
+ Disp_Property (Down (Prefix), S);
+ end if;
+ end Disp_Repeat_Sequence;
+
+ procedure Disp_Binary_Sequence (Prefix : String; Name : String; N : Node) is
+ begin
+ Disp_Property (Up (Prefix), Get_Left (N));
+ Put_Node_Line (Prefix, Name);
+ Disp_Property (Down (Prefix), Get_Right (N));
+ end Disp_Binary_Sequence;
+
+ procedure Disp_Range_Property (Prefix : String; Name : String; N : Node) is
+ begin
+ Put_Node (Prefix, Name);
+ Put ("[");
+ Disp_Count (N);
+ Put_Line ("]");
+ Disp_Property (Down (Prefix), Get_Property (N));
+ end Disp_Range_Property;
+
+ procedure Disp_Boolean_Range_Property (Prefix : String;
+ Name : String; N : Node) is
+ begin
+ Disp_Property (Up (Prefix), Get_Boolean (N));
+ Put_Node (Prefix, Name);
+ Put ("[");
+ Disp_Count (N);
+ Put_Line ("]");
+ Disp_Property (Down (Prefix), Get_Property (N));
+ end Disp_Boolean_Range_Property;
+
+ procedure Disp_Property (Prefix : String; Prop : Node) is
+ begin
+ case Get_Kind (Prop) is
+ when N_Never =>
+ Put_Node_Line (Prefix, "never");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Always =>
+ Put_Node_Line (Prefix, "always");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Eventually =>
+ Put_Node_Line (Prefix, "eventually!");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Next =>
+ Put_Node_Line (Prefix, "next");
+-- if Get_Strong_Flag (Prop) then
+-- Put ('!');
+-- end if;
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Next_A =>
+ Disp_Range_Property (Prefix, "next_a", Prop);
+ when N_Next_E =>
+ Disp_Range_Property (Prefix, "next_e", Prop);
+ when N_Next_Event =>
+ Disp_Property (Up (Prefix), Get_Boolean (Prop));
+ Put_Node_Line (Prefix, "next_event");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Next_Event_A =>
+ Disp_Boolean_Range_Property (Prefix, "next_event_a", Prop);
+ when N_Next_Event_E =>
+ Disp_Boolean_Range_Property (Prefix, "next_event_e", Prop);
+ when N_Braced_SERE =>
+ Put_Node_Line (Prefix, "{} (braced_SERE)");
+ Disp_Property (Down (Prefix), Get_SERE (Prop));
+ when N_Concat_SERE =>
+ Disp_Binary_Sequence (Prefix, "; (concat)", Prop);
+ when N_Fusion_SERE =>
+ Disp_Binary_Sequence (Prefix, ": (fusion)", Prop);
+ when N_Within_SERE =>
+ Disp_Binary_Sequence (Prefix, "within", Prop);
+ when N_Match_And_Seq =>
+ Disp_Binary_Sequence (Prefix, "&& (sequence matching len)", Prop);
+ when N_Or_Seq =>
+ Disp_Binary_Sequence (Prefix, "| (sequence or)", Prop);
+ when N_And_Seq =>
+ Disp_Binary_Sequence (Prefix, "& (sequence and)", Prop);
+ when N_Imp_Seq =>
+ Disp_Property (Up (Prefix), Get_Sequence (Prop));
+ Put_Node_Line (Prefix, "|=> (sequence implication)");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Overlap_Imp_Seq =>
+ Disp_Property (Up (Prefix), Get_Sequence (Prop));
+ Put_Node_Line (Prefix, "|->");
+ Disp_Property (Down (Prefix), Get_Property (Prop));
+ when N_Or_Prop =>
+ Disp_Binary_Sequence (Prefix, "|| (property or)", Prop);
+ when N_And_Prop =>
+ Disp_Binary_Sequence (Prefix, "&& (property and)", Prop);
+ when N_Log_Imp_Prop =>
+ Disp_Binary_Sequence (Prefix, "-> (property impliciation)", Prop);
+ when N_Until =>
+ Disp_Binary_Sequence (Prefix, "until", Prop);
+ when N_Before =>
+ Disp_Binary_Sequence (Prefix, "before", Prop);
+ when N_Abort =>
+ Disp_Property (Up (Prefix), Get_Property (Prop));
+ Put_Node_Line (Prefix, "abort");
+ Disp_Property (Down (Prefix), Get_Boolean (Prop));
+ when N_Not_Bool =>
+ Put_Node_Line (Prefix, "! (boolean not)");
+ Disp_Property (Down (Prefix), Get_Boolean (Prop));
+ when N_Or_Bool =>
+ Disp_Binary_Sequence (Prefix, "|| (boolean or)", Prop);
+ when N_And_Bool =>
+ Disp_Binary_Sequence (Prefix, "&& (boolean and)", Prop);
+ when N_Name_Decl =>
+ Put_Node_Line (Prefix,
+ "Name_Decl: " & Image (Get_Identifier (Prop)));
+ when N_Name =>
+ Put_Node_Line (Prefix, "Name: " & Image (Get_Identifier (Prop)));
+ Disp_Property (Down (Prefix), Get_Decl (Prop));
+ when N_True =>
+ Put_Node_Line (Prefix, "TRUE");
+ when N_False =>
+ Put_Node_Line (Prefix, "FALSE");
+ when N_HDL_Expr =>
+ Put_Node (Prefix, "HDL_Expr: ");
+ PSL.Prints.HDL_Expr_Printer.all (Get_HDL_Node (Prop));
+ New_Line;
+ when N_Star_Repeat_Seq =>
+ Disp_Repeat_Sequence (Prefix, "[*", Prop);
+ when N_Goto_Repeat_Seq =>
+ Disp_Repeat_Sequence (Prefix, "[->", Prop);
+ when N_Equal_Repeat_Seq =>
+ Disp_Repeat_Sequence (Prefix, "[=", Prop);
+ when N_Plus_Repeat_Seq =>
+ Put_Node_Line (Prefix, "[+]");
+ Disp_Property (Down (Prefix), Get_Sequence (Prop));
+ when others =>
+ Error_Kind ("disp_property", Prop);
+ end case;
+ end Disp_Property;
+
+ procedure Disp_Assert (N : Node) is
+ Label : constant Name_Id := Get_Label (N);
+ begin
+ Put (" ");
+ if Label /= Null_Identifier then
+ Put (Image (Label));
+ Put (": ");
+ end if;
+ Put_Line ("assert ");
+ Disp_Property (" \", Get_Property (N));
+ end Disp_Assert;
+
+ procedure Disp_Unit (Unit : Node) is
+ Item : Node;
+ begin
+ case Get_Kind (Unit) is
+ when N_Vunit =>
+ Put ("vunit");
+ when others =>
+ Error_Kind ("disp_unit", Unit);
+ end case;
+ Put (' ');
+ Put (Image (Get_Identifier (Unit)));
+ Put_Line (" {");
+ Item := Get_Item_Chain (Unit);
+ while Item /= Null_Node loop
+ case Get_Kind (Item) is
+ when N_Assert_Directive =>
+ Disp_Assert (Item);
+ when N_Name_Decl =>
+ null;
+ when others =>
+ Error_Kind ("disp_unit", Item);
+ end case;
+ Item := Get_Chain (Item);
+ end loop;
+ Put_Line ("}");
+ end Disp_Unit;
+end PSL.Tprint;
+
diff --git a/src/psl/psl-tprint.ads b/src/psl/psl-tprint.ads
new file mode 100644
index 000000000..1b06ebf1a
--- /dev/null
+++ b/src/psl/psl-tprint.ads
@@ -0,0 +1,6 @@
+with PSL.Nodes; use PSL.Nodes;
+
+package PSL.Tprint is
+ procedure Disp_Unit (Unit : Node);
+ procedure Disp_Property (Prefix : String; Prop : Node);
+end PSL.Tprint;
diff --git a/src/psl/psl.ads b/src/psl/psl.ads
new file mode 100644
index 000000000..a2f4bdce0
--- /dev/null
+++ b/src/psl/psl.ads
@@ -0,0 +1,3 @@
+package PSL is
+ pragma Pure (PSL);
+end PSL;
diff --git a/src/scanner-scan_literal.adb b/src/scanner-scan_literal.adb
new file mode 100644
index 000000000..74acf44d5
--- /dev/null
+++ b/src/scanner-scan_literal.adb
@@ -0,0 +1,651 @@
+-- Lexical analysis for numbers.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR 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;
+
+separate (Scanner)
+
+-- scan a decimal literal or a based literal.
+--
+-- LRM93 13.4.1
+-- DECIMAL_LITERAL ::= INTEGER [ . INTEGER ] [ EXPONENT ]
+-- EXPONENT ::= E [ + ] INTEGER | E - INTEGER
+--
+-- LRM93 13.4.2
+-- BASED_LITERAL ::= BASE # BASED_INTEGER [ . BASED_INTEGER ] # EXPONENT
+-- BASE ::= INTEGER
+procedure Scan_Literal is
+ -- The base of an E_NUM is 2**16.
+ -- Type Uint16 is the type of a digit.
+ type Uint16 is mod 2 ** 16;
+
+ type Uint32 is mod 2 ** 32;
+
+ -- Type of the exponent.
+ type Sint16 is range -2 ** 15 .. 2 ** 15 - 1;
+
+ -- Number of digits in a E_NUM.
+ -- We want at least 64bits of precision, so at least 5 digits of 16 bits
+ -- are required.
+ Nbr_Digits : constant Sint16 := 5;
+ subtype Digit_Range is Sint16 range 0 .. Nbr_Digits - 1;
+
+ type Uint16_Array is array (Sint16 range <>) of Uint16;
+
+ -- The value of an E_NUM is (S(N-1)|S(N-2) .. |S(0))* 2**(16*E)
+ -- where '|' is concatenation.
+ type E_Num is record
+ S : Uint16_Array (Digit_Range);
+ E : Sint16;
+ end record;
+
+ E_Zero : constant E_Num := (S => (others => 0), E => 0);
+ E_One : constant E_Num := (S => (0 => 1, others => 0), E => 0);
+
+ -- Compute RES = E * B + V.
+ -- RES and E can be the same object.
+ procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16);
+
+ -- Convert to integer.
+ procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num);
+
+ -- RES := A * B
+ -- RES can be A or B.
+ procedure Mul (Res : out E_Num; A, B : E_Num);
+
+ -- RES := A / B.
+ -- RES can be A.
+ -- May raise constraint error.
+ procedure Div (Res : out E_Num; A, B: E_Num);
+
+ -- Convert V to an E_Num.
+ function To_E_Num (V : Uint16) return E_Num;
+
+ -- Convert E to RES.
+ procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num);
+
+ procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16)
+ is
+ -- The carry.
+ C : Uint32;
+ begin
+ -- Only consider V if E is not scaled (otherwise V is not significant).
+ if E.E = 0 then
+ C := Uint32 (V);
+ else
+ C := 0;
+ end if;
+
+ -- Multiply and propagate the carry.
+ for I in Digit_Range loop
+ C := Uint32 (E.S (I)) * Uint32 (B) + C;
+ Res.S (I) := Uint16 (C mod Uint16'Modulus);
+ C := C / Uint16'Modulus;
+ end loop;
+
+ -- There is a carry, shift.
+ if C /= 0 then
+ -- ERR: Possible overflow.
+ Res.E := E.E + 1;
+ for I in 0 .. Nbr_Digits - 2 loop
+ Res.S (I) := Res.S (I + 1);
+ end loop;
+ Res.S (Nbr_Digits - 1) := Uint16 (C);
+ else
+ Res.E := E.E;
+ end if;
+ end Bmul;
+
+ type Uint64 is mod 2 ** 64;
+ function Shift_Left (Value : Uint64; Amount: Natural) return Uint64;
+ function Shift_Left (Value : Uint16; Amount: Natural) return Uint16;
+ pragma Import (Intrinsic, Shift_Left);
+
+ function Shift_Right (Value : Uint16; Amount: Natural) return Uint16;
+ pragma Import (Intrinsic, Shift_Right);
+
+ function Unchecked_Conversion is new Ada.Unchecked_Conversion
+ (Source => Uint64, Target => Iir_Int64);
+
+ procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num)
+ is
+ R : Uint64;
+ M : Sint16;
+ begin
+ -- Find the most significant digit.
+ M := -1;
+ for I in reverse Digit_Range loop
+ if E.S (I) /= 0 then
+ M := I;
+ exit;
+ end if;
+ end loop;
+
+ -- Handle the easy 0 case.
+ -- The case M = -1 is handled below, in the normal flow.
+ if M + E.E < 0 then
+ Res := 0;
+ Ok := True;
+ return;
+ end if;
+
+ -- Handle overflow.
+ -- 4 is the number of uint16 in a uint64.
+ if M + E.E >= 4 then
+ Ok := False;
+ return;
+ end if;
+
+ -- Convert
+ R := 0;
+ for I in 0 .. M loop
+ R := R or Shift_Left (Uint64 (E.S (I)), 16 * Natural (E.E + I));
+ end loop;
+ -- Check the sign bit is 0.
+ if (R and Shift_Left (1, 63)) /= 0 then
+ Ok := False;
+ else
+ Ok := True;
+ Res := Unchecked_Conversion (R);
+ end if;
+ end Fix;
+
+ -- Return the position of the most non-null digit, -1 if V is 0.
+ function First_Digit (V : E_Num) return Sint16 is
+ begin
+ for I in reverse Digit_Range loop
+ if V.S (I) /= 0 then
+ return I;
+ end if;
+ end loop;
+ return -1;
+ end First_Digit;
+
+ procedure Mul (Res : out E_Num; A, B : E_Num)
+ is
+ T : Uint16_Array (0 .. 2 * Nbr_Digits - 1);
+ V : Uint32;
+ Max : Sint16;
+ begin
+ V := 0;
+ for I in 0 .. Nbr_Digits - 1 loop
+ for J in 0 .. I loop
+ V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J));
+ end loop;
+ T (I) := Uint16 (V mod Uint16'Modulus);
+ V := V / Uint16'Modulus;
+ end loop;
+ for I in Nbr_Digits .. 2 * Nbr_Digits - 2 loop
+ for J in I - Nbr_Digits + 1 .. Nbr_Digits - 1 loop
+ V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J));
+ end loop;
+ T (I) := Uint16 (V mod Uint16'Modulus);
+ V := V / Uint16'Modulus;
+ end loop;
+ T (T'Last) := Uint16 (V);
+ -- Search the leading non-nul.
+ Max := -1;
+ for I in reverse T'Range loop
+ if T (I) /= 0 then
+ Max := I;
+ exit;
+ end if;
+ end loop;
+ if Max > Nbr_Digits - 1 then
+ -- Loss of precision.
+ -- Round.
+ if T (Max - Nbr_Digits) >= Uint16 (Uint16'Modulus / 2) then
+ V := 1;
+ for I in Max - (Nbr_Digits - 1) .. Max loop
+ V := V + Uint32 (T (I));
+ T (I) := Uint16 (V mod Uint16'Modulus);
+ V := V / Uint16'Modulus;
+ exit when V = 0;
+ end loop;
+ if V /= 0 then
+ Max := Max + 1;
+ T (Max) := Uint16 (V);
+ end if;
+ end if;
+ Res.S := T (Max - (Nbr_Digits - 1) .. Max);
+ -- This may overflow.
+ Res.E := A.E + B.E + Max - (Nbr_Digits - 1);
+ else
+ Res.S (0 .. Max) := T (0 .. Max);
+ Res.S (Max + 1 .. Nbr_Digits - 1) := (others => 0);
+ -- This may overflow.
+ Res.E := A.E + B.E;
+ end if;
+ end Mul;
+
+ procedure Div (Res : out E_Num; A, B: E_Num)
+ is
+ Dividend : Uint16_Array (0 .. Nbr_Digits);
+ A_F : constant Sint16 := First_Digit (A);
+ B_F : constant Sint16 := First_Digit (B);
+
+ -- Digit corresponding to the first digit of B.
+ Doff : constant Sint16 := Dividend'Last - B_F;
+ Q : Uint16;
+ C, N_C : Uint16;
+ begin
+ -- Check for division by 0.
+ if B_F < 0 then
+ raise Constraint_Error;
+ end if;
+
+ -- Copy and shift dividend.
+ -- Bit 15 of the most significant digit of A becomes bit 0 of the
+ -- most significant digit of DIVIDEND. Therefore we are sure
+ -- DIVIDEND < B (after realignment).
+ C := 0;
+ for K in 0 .. A_F loop
+ N_C := Shift_Right (A.S (K), 15);
+ Dividend (Dividend'Last - A_F - 1 + K)
+ := Shift_Left (A.S (K), 1) or C;
+ C := N_C;
+ end loop;
+ Dividend (Nbr_Digits) := C;
+ Dividend (0 .. Dividend'last - 2 - A_F) := (others => 0);
+
+ -- Algorithm is the same as division by hand.
+ C := 0;
+ for I in reverse Digit_Range loop
+ Q := 0;
+ for J in 0 .. 15 loop
+ declare
+ Borrow : Uint32;
+ Tmp : Uint16_Array (0 .. B_F);
+ V : Uint32;
+ V16 : Uint16;
+ begin
+ -- Compute TMP := dividend - B;
+ Borrow := 0;
+ for K in 0 .. B_F loop
+ V := Uint32 (B.S (K)) + Borrow;
+ V16 := Uint16 (V mod Uint16'Modulus);
+ if V16 > Dividend (Doff + K) then
+ Borrow := 1;
+ else
+ Borrow := 0;
+ end if;
+ Tmp (K) := Dividend (Doff + K) - V16;
+ end loop;
+
+ -- If the last shift creates a carry, we are sure Dividend > B
+ if C /= 0 then
+ Borrow := 0;
+ end if;
+
+ Q := Q * 2;
+ -- Begin of : Dividend = Dividend * 2
+ C := 0;
+ for K in 0 .. Doff - 1 loop
+ N_C := Shift_Right (Dividend (K), 15);
+ Dividend (K) := Shift_Left (Dividend (K), 1) or C;
+ C := N_C;
+ end loop;
+
+ if Borrow = 0 then
+ -- Dividend > B
+ Q := Q + 1;
+ -- Dividend = Tmp * 2
+ -- = (Dividend - B) * 2
+ for K in Doff .. Nbr_Digits loop
+ N_C := Shift_Right (Tmp (K - Doff), 15);
+ Dividend (K) := Shift_Left (Tmp (K - Doff), 1) or C;
+ C := N_C;
+ end loop;
+ else
+ -- Dividend = Dividend * 2
+ for K in Doff .. Nbr_Digits loop
+ N_C := Shift_Right (Dividend (K), 15);
+ Dividend (K) := Shift_Left (Dividend (K), 1) or C;
+ C := N_C;
+ end loop;
+ end if;
+ end;
+ end loop;
+ Res.S (I) := Q;
+ end loop;
+ Res.E := A.E - B.E + (A_F - B_F) - (Nbr_Digits - 1);
+ end Div;
+
+ procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num)
+ is
+ V : Iir_Fp64;
+ P : Iir_Fp64;
+ begin
+ Res := 0.0;
+ P := Iir_Fp64'Scaling (1.0, 16 * E.E);
+ for I in Digit_Range loop
+ V := Iir_Fp64 (E.S (I)) * P;
+ P := Iir_Fp64'Scaling (P, 16);
+ Res := Res + V;
+ end loop;
+ Ok := True;
+ end To_Float;
+
+ function To_E_Num (V : Uint16) return E_Num
+ is
+ Res : E_Num;
+ begin
+ Res.E := 0;
+ Res.S := (0 => V, others => 0);
+ return Res;
+ end To_E_Num;
+
+ -- Numbers of digits.
+ Scale : Integer;
+ Res : E_Num;
+
+ -- LRM 13.4.1
+ -- INTEGER ::= DIGIT { [ UNDERLINE ] DIGIT }
+ --
+ -- Update SCALE, RES.
+ -- The first character must be a digit.
+ procedure Scan_Integer
+ is
+ C : Character;
+ begin
+ C := Source (Pos);
+ loop
+ -- C is a digit.
+ Bmul (Res, Res, Character'Pos (C) - Character'Pos ('0'), 10);
+ Scale := Scale + 1;
+
+ Pos := Pos + 1;
+ C := Source (Pos);
+ if C = '_' then
+ loop
+ Pos := Pos + 1;
+ C := Source (Pos);
+ exit when C /= '_';
+ Error_Msg_Scan ("double underscore in number");
+ end loop;
+ if C not in '0' .. '9' then
+ Error_Msg_Scan ("underscore must be followed by a digit");
+ end if;
+ end if;
+ exit when C not in '0' .. '9';
+ end loop;
+ end Scan_Integer;
+
+ C : Character;
+ D : Uint16;
+ Ok : Boolean;
+ Has_Dot : Boolean;
+ Exp : Integer;
+ Exp_Neg : Boolean;
+ Base : Uint16;
+begin
+ -- Start with a simple and fast conversion.
+ C := Source (Pos);
+ D := 0;
+ loop
+ D := D * 10 + Character'Pos (C) - Character'Pos ('0');
+
+ Pos := Pos + 1;
+ C := Source (Pos);
+ if C = '_' then
+ loop
+ Pos := Pos + 1;
+ C := Source (Pos);
+ exit when C /= '_';
+ Error_Msg_Scan ("double underscore in number");
+ end loop;
+ if C not in '0' .. '9' then
+ Error_Msg_Scan ("underscore must be followed by a digit");
+ end if;
+ end if;
+ if C not in '0' .. '9' then
+ if C = '.' or else C = '#' or else (C = 'e' or C = 'E' or C = ':')
+ then
+ -- Continue scanning.
+ Res := To_E_Num (D);
+ exit;
+ end if;
+
+ -- Finished.
+ -- a universal integer.
+ Current_Token := Tok_Integer;
+ -- No possible overflow.
+ Current_Context.Int64 := Iir_Int64 (D);
+ return;
+ elsif D >= 6552 then
+ -- Number may be greather than the uint16 limit.
+ Scale := 0;
+ Res := To_E_Num (D);
+ Scan_Integer;
+ exit;
+ end if;
+ end loop;
+
+ Has_Dot := False;
+ Base := 10;
+
+ C := Source (Pos);
+ if C = '.' then
+ -- Decimal integer.
+ Has_Dot := True;
+ Scale := 0;
+ Pos := Pos + 1;
+ C := Source (Pos);
+ if C not in '0' .. '9' then
+ Error_Msg_Scan ("a dot must be followed by a digit");
+ return;
+ end if;
+ Scan_Integer;
+ elsif C = '#'
+ or else (C = ':' and then (Source (Pos + 1) in '0' .. '9'
+ or else Source (Pos + 1) in 'a' .. 'f'
+ or else Source (Pos + 1) in 'A' .. 'F'))
+ then
+ -- LRM 13.10
+ -- The number sign (#) of a based literal can be replaced by colon (:),
+ -- provided that the replacement is done for both occurrences.
+ -- GHDL: correctly handle 'variable v : integer range 0 to 7:= 3'.
+ -- Is there any other places where a digit can be followed
+ -- by a colon ? (See IR 1093).
+
+ -- Based integer.
+ declare
+ Number_Sign : constant Character := C;
+ Res_Int : Iir_Int64;
+ begin
+ Fix (Res_Int, Ok, Res);
+ if not Ok or else Res_Int > 16 then
+ -- LRM 13.4.2
+ -- The base must be [...] at most sixteen.
+ Error_Msg_Scan ("base must be at most 16");
+ -- Fallback.
+ Base := 16;
+ elsif Res_Int < 2 then
+ -- LRM 13.4.2
+ -- The base must be at least two [...].
+ Error_Msg_Scan ("base must be at least 2");
+ -- Fallback.
+ Base := 2;
+ else
+ Base := Uint16 (Res_Int);
+ end if;
+
+ Pos := Pos + 1;
+ Res := E_Zero;
+ C := Source (Pos);
+ loop
+ if C >= '0' and C <= '9' then
+ D := Character'Pos (C) - Character'Pos ('0');
+ elsif C >= 'A' and C <= 'F' then
+ D := Character'Pos (C) - Character'Pos ('A') + 10;
+ elsif C >= 'a' and C <= 'f' then
+ D := Character'Pos (C) - Character'Pos ('a') + 10;
+ else
+ Error_Msg_Scan ("bad extended digit");
+ exit;
+ end if;
+
+ if D >= Base then
+ -- LRM 13.4.2
+ -- The conventional meaning of base notation is
+ -- assumed; in particular the value of each extended
+ -- digit of a based literal must be less then the base.
+ Error_Msg_Scan ("digit beyond base");
+ D := 1;
+ end if;
+ Pos := Pos + 1;
+ Bmul (Res, Res, D, Base);
+ Scale := Scale + 1;
+
+ C := Source (Pos);
+ if C = '_' then
+ loop
+ Pos := Pos + 1;
+ C := Source (Pos);
+ exit when C /= '_';
+ Error_Msg_Scan ("double underscore in based integer");
+ end loop;
+ elsif C = '.' then
+ if Has_Dot then
+ Error_Msg_Scan ("double dot ignored");
+ else
+ Has_Dot := True;
+ Scale := 0;
+ end if;
+ Pos := Pos + 1;
+ C := Source (Pos);
+ elsif C = Number_Sign then
+ Pos := Pos + 1;
+ exit;
+ elsif C = '#' or C = ':' then
+ Error_Msg_Scan ("bad number sign replacement character");
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+ C := Source (Pos);
+ Exp := 0;
+ if C = 'E' or else C = 'e' then
+ Pos := Pos + 1;
+ C := Source (Pos);
+ Exp_Neg := False;
+ if C = '+' then
+ Pos := Pos + 1;
+ C := Source (Pos);
+ elsif C = '-' then
+ if Has_Dot then
+ Exp_Neg := True;
+ else
+ -- LRM 13.4.1
+ -- An exponent for an integer literal must not have a minus sign.
+ --
+ -- LRM 13.4.2
+ -- An exponent for a based integer literal must not have a minus
+ -- sign.
+ Error_Msg_Scan
+ ("negative exponent not allowed for integer literal");
+ end if;
+ Pos := Pos + 1;
+ C := Source (Pos);
+ end if;
+ if C not in '0' .. '9' then
+ Error_Msg_Scan ("digit expected after exponent");
+ else
+ loop
+ -- C is a digit.
+ Exp := Exp * 10 + (Character'Pos (C) - Character'Pos ('0'));
+
+ Pos := Pos + 1;
+ C := Source (Pos);
+ if C = '_' then
+ loop
+ Pos := Pos + 1;
+ C := Source (Pos);
+ exit when C /= '_';
+ Error_Msg_Scan ("double underscore not allowed in integer");
+ end loop;
+ if C not in '0' .. '9' then
+ Error_Msg_Scan ("digit expected after underscore");
+ exit;
+ end if;
+ elsif C not in '0' .. '9' then
+ exit;
+ end if;
+ end loop;
+ end if;
+ if Exp_Neg then
+ Exp := -Exp;
+ end if;
+ end if;
+
+ if Has_Dot then
+ Scale := Scale - Exp;
+ else
+ Scale := -Exp;
+ end if;
+ if Scale /= 0 then
+ declare
+ Scale_Neg : Boolean;
+ Val_Exp : E_Num;
+ Val_Pow : E_Num;
+ begin
+ if Scale > 0 then
+ Scale_Neg := True;
+ else
+ Scale_Neg := False;
+ Scale := -Scale;
+ end if;
+
+ Val_Pow := To_E_Num (Base);
+ Val_Exp := E_One;
+ while Scale /= 0 loop
+ if Scale mod 2 = 1 then
+ Mul (Val_Exp, Val_Exp, Val_Pow);
+ end if;
+ Scale := Scale / 2;
+ Mul (Val_Pow, Val_Pow, Val_Pow);
+ end loop;
+ if Scale_Neg then
+ Div (Res, Res, Val_Exp);
+ else
+ Mul (Res, Res, Val_Exp);
+ end if;
+ end;
+ end if;
+
+ if Has_Dot then
+ -- a universal real.
+ Current_Token := Tok_Real;
+ -- Set to a valid literal, in case of constraint error.
+ To_Float (Current_Context.Fp64, Ok, Res);
+ if not Ok then
+ Error_Msg_Scan ("literal beyond real bounds");
+ end if;
+ else
+ -- a universal integer.
+ Current_Token := Tok_Integer;
+ -- Set to a valid literal, in case of constraint error.
+ Fix (Current_Context.Int64, Ok, Res);
+ if not Ok then
+ Error_Msg_Scan ("literal beyond integer bounds");
+ end if;
+ end if;
+exception
+ when Constraint_Error =>
+ Error_Msg_Scan ("literal overflow");
+end Scan_Literal;
diff --git a/src/scanner.adb b/src/scanner.adb
new file mode 100644
index 000000000..260bd7c8f
--- /dev/null
+++ b/src/scanner.adb
@@ -0,0 +1,1621 @@
+-- VHDL lexical scanner.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR 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.Characters.Latin_1; use Ada.Characters.Latin_1;
+with Ada.Characters.Handling;
+with Errorout; use Errorout;
+with Name_Table;
+with Files_Map; use Files_Map;
+with Std_Names;
+with Str_Table;
+with Flags; use Flags;
+
+package body Scanner is
+
+ -- This classification is a simplification of the categories of LRM93 13.1
+ -- LRM93 13.1
+ -- The only characters allowed in the text of a VHDL description are the
+ -- graphic characters and format effector.
+
+ type Character_Kind_Type is
+ (
+ -- Neither a format effector nor a graphic character.
+ Invalid,
+ Format_Effector,
+ Upper_Case_Letter,
+ Digit,
+ Special_Character,
+ Space_Character,
+ Lower_Case_Letter,
+ Other_Special_Character);
+
+ -- LRM93 13.1
+ -- BASIC_GRAPHIC_CHARACTER ::=
+ -- UPPER_CASE_LETTER | DIGIT | SPECIAL_CHARACTER | SPACE_CHARACTER
+ --subtype Basic_Graphic_Character is
+ -- Character_Kind_Type range Upper_Case_Letter .. Space_Character;
+
+ -- LRM93 13.1
+ -- GRAPHIC_CHARACTER ::=
+ -- BASIC_GRAPHIC_CHARACTER | LOWER_CASE_LETTER | OTHER_SPECIAL_CHARACTER
+ -- Note: There is 191 graphic character.
+ subtype Graphic_Character is
+ Character_Kind_Type range Upper_Case_Letter .. Other_Special_Character;
+
+ -- LRM93 13.1
+ -- The characters included in each of the categories of basic graphic
+ -- characters are defined as follows:
+ type Character_Array is array (Character) of Character_Kind_Type;
+ Characters_Kind : constant Character_Array :=
+ (NUL .. BS => Invalid,
+
+ -- Format effectors are the ISO (and ASCII) characters called horizontal
+ -- tabulation, vertical tabulation, carriage return, line feed, and form
+ -- feed.
+ HT | LF | VT | FF | CR => Format_Effector,
+
+ SO .. US => Invalid,
+
+ -- 1. upper case letters
+ 'A' .. 'Z' | UC_A_Grave .. UC_O_Diaeresis |
+ UC_O_Oblique_Stroke .. UC_Icelandic_Thorn => Upper_Case_Letter,
+
+ -- 2. digits
+ '0' .. '9' => Digit,
+
+ -- 3. special characters
+ Quotation | '#' | '&' | ''' | '(' | ')' | '+' | ',' | '-' | '.' | '/'
+ | ':' | ';' | '<' | '=' | '>' | '[' | ']'
+ | '_' | '|' | '*' => Special_Character,
+
+ -- 4. the space characters
+ ' ' | No_Break_Space => Space_Character,
+
+ -- 5. lower case letters
+ 'a' .. 'z' | LC_German_Sharp_S .. LC_O_Diaeresis |
+ LC_O_Oblique_Stroke .. LC_Y_Diaeresis => Lower_Case_Letter,
+
+ -- 6. other special characters
+ '!' | '$' | '%' | '@' | '?' | '\' | '^' | '`' | '{' | '}' | '~'
+ | Inverted_Exclamation .. Inverted_Question | Multiplication_Sign |
+ Division_Sign => Other_Special_Character,
+
+ -- '¡' -- INVERTED EXCLAMATION MARK
+ -- '¢' -- CENT SIGN
+ -- '£' -- POUND SIGN
+ -- '¤' -- CURRENCY SIGN
+ -- '¥' -- YEN SIGN
+ -- '¦' -- BROKEN BAR
+ -- '§' -- SECTION SIGN
+ -- '¨' -- DIAERESIS
+ -- '©' -- COPYRIGHT SIGN
+ -- 'ª' -- FEMININE ORDINAL INDICATOR
+ -- '«' -- LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+ -- '¬' -- NOT SIGN
+ -- '' -- SOFT HYPHEN
+ -- '®' -- REGISTERED SIGN
+ -- '¯' -- MACRON
+ -- '°' -- DEGREE SIGN
+ -- '±' -- PLUS-MINUS SIGN
+ -- '²' -- SUPERSCRIPT TWO
+ -- '³' -- SUPERSCRIPT THREE
+ -- '´' -- ACUTE ACCENT
+ -- 'µ' -- MICRO SIGN
+ -- '¶' -- PILCROW SIGN
+ -- '·' -- MIDDLE DOT
+ -- '¸' -- CEDILLA
+ -- '¹' -- SUPERSCRIPT ONE
+ -- 'º' -- MASCULINE ORDINAL INDICATOR
+ -- '»' -- RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+ -- '¼' -- VULGAR FRACTION ONE QUARTER
+ -- '½' -- VULGAR FRACTION ONE HALF
+ -- '¾' -- VULGAR FRACTION THREE QUARTERS
+ -- '¿' -- INVERTED QUESTION MARK
+ -- '×' -- MULTIPLICATION SIGN
+ -- '÷' -- DIVISION SIGN
+
+ DEL .. APC => Invalid);
+
+ -- The context contains the whole internal state of the scanner, ie
+ -- it can be used to push/pop a lexical analysis, to restart the
+ -- scanner from a context marking a previous point.
+ type Scan_Context is record
+ Source: File_Buffer_Acc;
+ Source_File: Source_File_Entry;
+ Line_Number: Natural;
+ Line_Pos: Source_Ptr;
+ Pos: Source_Ptr;
+ Token_Pos: Source_Ptr;
+ File_Len: Source_Ptr;
+ File_Name: Name_Id;
+ Token: Token_Type;
+ Prev_Token: Token_Type;
+ Str_Id : String_Id;
+ Str_Len : Nat32;
+ Identifier: Name_Id;
+ Int64: Iir_Int64;
+ Fp64: Iir_Fp64;
+ end record;
+
+ -- The current context.
+ -- Default value is an invalid context.
+ Current_Context: Scan_Context := (Source => null,
+ Source_File => No_Source_File_Entry,
+ Line_Number => 0,
+ Line_Pos => 0,
+ Pos => 0,
+ Token_Pos => 0,
+ File_Len => 0,
+ File_Name => Null_Identifier,
+ Token => Tok_Invalid,
+ Prev_Token => Tok_Invalid,
+ Identifier => Null_Identifier,
+ Str_Id => Null_String,
+ Str_Len => 0,
+ Int64 => 0,
+ Fp64 => 0.0);
+
+ Source: File_Buffer_Acc renames Current_Context.Source;
+ Pos: Source_Ptr renames Current_Context.Pos;
+
+ -- When CURRENT_TOKEN is an identifier, its name_id is stored into
+ -- this global variable.
+ -- Function current_text can be used to convert it into an iir.
+ function Current_Identifier return Name_Id is
+ begin
+ return Current_Context.Identifier;
+ end Current_Identifier;
+
+ procedure Invalidate_Current_Identifier is
+ begin
+ Current_Context.Identifier := Null_Identifier;
+ end Invalidate_Current_Identifier;
+
+ procedure Invalidate_Current_Token is
+ begin
+ if Current_Token /= Tok_Invalid then
+ Current_Context.Prev_Token := Current_Token;
+ Current_Token := Tok_Invalid;
+ end if;
+ end Invalidate_Current_Token;
+
+ function Current_String_Id return String_Id is
+ begin
+ return Current_Context.Str_Id;
+ end Current_String_Id;
+
+ function Current_String_Length return Nat32 is
+ begin
+ return Current_Context.Str_Len;
+ end Current_String_Length;
+
+ function Current_Iir_Int64 return Iir_Int64 is
+ begin
+ return Current_Context.Int64;
+ end Current_Iir_Int64;
+
+ function Current_Iir_Fp64 return Iir_Fp64 is
+ begin
+ return Current_Context.Fp64;
+ end Current_Iir_Fp64;
+
+ function Get_Current_File return Name_Id is
+ begin
+ return Current_Context.File_Name;
+ end Get_Current_File;
+
+ function Get_Current_Source_File return Source_File_Entry is
+ begin
+ return Current_Context.Source_File;
+ end Get_Current_Source_File;
+
+ function Get_Current_Line return Natural is
+ begin
+ return Current_Context.Line_Number;
+ end Get_Current_Line;
+
+ function Get_Current_Column return Natural
+ is
+ Col : Natural;
+ Name : Name_Id;
+ begin
+ Coord_To_Position
+ (Current_Context.Source_File,
+ Current_Context.Line_Pos,
+ Integer (Current_Context.Pos - Current_Context.Line_Pos),
+ Name, Col);
+ return Col;
+ end Get_Current_Column;
+
+ function Get_Token_Column return Natural
+ is
+ Col : Natural;
+ Name : Name_Id;
+ begin
+ Coord_To_Position
+ (Current_Context.Source_File,
+ Current_Context.Line_Pos,
+ Integer (Current_Context.Token_Pos - Current_Context.Line_Pos),
+ Name, Col);
+ return Col;
+ end Get_Token_Column;
+
+ function Get_Token_Position return Source_Ptr is
+ begin
+ return Current_Context.Token_Pos;
+ end Get_Token_Position;
+
+ function Get_Position return Source_Ptr is
+ begin
+ return Current_Context.Pos;
+ end Get_Position;
+
+ procedure Set_File (Source_File : Source_File_Entry)
+ is
+ N_Source: File_Buffer_Acc;
+ begin
+ if Current_Context.Source /= null then
+ raise Internal_Error;
+ end if;
+ if Source_File = No_Source_File_Entry then
+ raise Internal_Error;
+ end if;
+ N_Source := Get_File_Source (Source_File);
+ Current_Context :=
+ (Source => N_Source,
+ Source_File => Source_File,
+ Line_Number => 1,
+ Line_Pos => 0,
+ Pos => N_Source'First,
+ Token_Pos => 0, -- should be invalid,
+ File_Len => Get_File_Length (Source_File),
+ File_Name => Get_File_Name (Source_File),
+ Token => Tok_Invalid,
+ Prev_Token => Tok_Invalid,
+ Identifier => Null_Identifier,
+ Str_Id => Null_String,
+ Str_Len => 0,
+ Int64 => -1,
+ Fp64 => 0.0);
+ Current_Token := Tok_Invalid;
+ end Set_File;
+
+ procedure Set_Current_Position (Position: Source_Ptr)
+ is
+ Loc : Location_Type;
+ Offset: Natural;
+ File_Entry : Source_File_Entry;
+ begin
+ if Current_Context.Source = null then
+ raise Internal_Error;
+ end if;
+ Current_Token := Tok_Invalid;
+ Current_Context.Pos := Position;
+ Loc := File_Pos_To_Location (Current_Context.Source_File,
+ Current_Context.Pos);
+ Location_To_Coord (Loc,
+ File_Entry, Current_Context.Line_Pos,
+ Current_Context.Line_Number, Offset);
+ end Set_Current_Position;
+
+ procedure Close_File is
+ begin
+ Current_Context.Source := null;
+ end Close_File;
+
+ -- Emit an error when a character above 128 was found.
+ -- This must be called only in vhdl87.
+ procedure Error_8bit is
+ begin
+ Error_Msg_Scan ("8 bits characters not allowed in vhdl87");
+ end Error_8bit;
+
+ -- Emit an error when a separator is expected.
+ procedure Error_Separator is
+ begin
+ Error_Msg_Scan ("a separator is required here");
+ end Error_Separator;
+
+ -- scan a decimal literal or a based literal.
+ --
+ -- LRM93 13.4.1
+ -- DECIMAL_LITERAL ::= INTEGER [ . INTEGER ] [ EXPONENT ]
+ -- EXPONENT ::= E [ + ] INTEGER | E - INTEGER
+ --
+ -- LRM93 13.4.2
+ -- BASED_LITERAL ::= BASE # BASED_INTEGER [ . BASED_INTEGER ] # EXPONENT
+ -- BASE ::= INTEGER
+ procedure Scan_Literal is separate;
+
+ -- Scan a string literal.
+ --
+ -- LRM93 13.6
+ -- A string literal is formed by a sequence of graphic characters
+ -- (possibly none) enclosed between two quotation marks used as string
+ -- brackets.
+ -- STRING_LITERAL ::= " { GRAPHIC_CHARACTER } "
+ --
+ -- IN: for a string, at the call of this procedure, the current character
+ -- must be either '"' or '%'.
+ procedure Scan_String
+ is
+ -- The quotation character (can be " or %).
+ Mark: Character;
+ -- Current character.
+ C : Character;
+ -- Current length.
+ Length : Nat32;
+ begin
+ Mark := Source (Pos);
+ if Mark /= Quotation and then Mark /= '%' then
+ raise Internal_Error;
+ end if;
+ Pos := Pos + 1;
+ Length := 0;
+ Current_Context.Str_Id := Str_Table.Start;
+ loop
+ C := Source (Pos);
+ if C = Mark then
+ -- LRM93 13.6
+ -- If a quotation mark value is to be represented in the sequence
+ -- of character values, then a pair of adjacent quoatation
+ -- characters marks must be written at the corresponding place
+ -- within the string literal.
+ -- LRM93 13.10
+ -- Any pourcent sign within the sequence of characters must then
+ -- be doubled, and each such doubled percent sign is interpreted
+ -- as a single percent sign value.
+ -- The same replacement is allowed for a bit string literal,
+ -- provieded that both bit string brackets are replaced.
+ Pos := Pos + 1;
+ exit when Source (Pos) /= Mark;
+ end if;
+
+ case Characters_Kind (C) is
+ when Format_Effector =>
+ Error_Msg_Scan ("format effector not allowed in a string");
+ exit;
+ when Invalid =>
+ Error_Msg_Scan
+ ("invalid character not allowed, even in a string");
+ when Graphic_Character =>
+ if Vhdl_Std = Vhdl_87 and then C > Character'Val (127) then
+ Error_8bit;
+ end if;
+ end case;
+
+ if C = Quotation and Mark = '%' then
+ -- LRM93 13.10
+ -- The quotation marks (") used as string brackets at both ends of
+ -- a string literal can be replaced by percent signs (%), provided
+ -- that the enclosed sequence of characters constains no quotation
+ -- marks, and provided that both string brackets are replaced.
+ Error_Msg_Scan
+ ("'""' cannot be used in a string delimited with '%'");
+ end if;
+
+ Length := Length + 1;
+ Str_Table.Append (C);
+ Pos := Pos + 1;
+ end loop;
+
+ Str_Table.Finish;
+
+ Current_Token := Tok_String;
+ Current_Context.Str_Len := Length;
+ end Scan_String;
+
+ -- Scan a bit string literal.
+ --
+ -- LRM93 13.7
+ -- A bit string literal is formed by a sequence of extended digits
+ -- (possibly none) enclosed between two quotations used as bit string
+ -- brackets, preceded by a base specifier.
+ -- BIT_STRING_LITERAL ::= BASE_SPECIFIER " [ BIT_VALUE ] "
+ -- BIT_VALUE ::= EXTENDED_DIGIT { [ UNDERLINE ] EXTENDED_DIGIT }
+ --
+ -- The current character must be a base specifier, followed by '"' or '%'.
+ -- The base must be valid.
+ procedure Scan_Bit_String
+ is
+ -- The base specifier.
+ Base_Len : Nat32 range 1 .. 4;
+ -- The quotation character (can be " or %).
+ Mark: Character;
+ -- Current character.
+ C : Character;
+ -- Current length.
+ Length : Nat32;
+ -- Digit value.
+ V : Natural;
+ begin
+ case Source (Pos) is
+ when 'x' | 'X' =>
+ Base_Len := 4;
+ when 'o' | 'O' =>
+ Base_Len := 3;
+ when 'b' | 'B' =>
+ Base_Len := 1;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Pos := Pos + 1;
+ Mark := Source (Pos);
+ if Mark /= Quotation and then Mark /= '%' then
+ raise Internal_Error;
+ end if;
+ Pos := Pos + 1;
+ Length := 0;
+ Current_Context.Str_Id := Str_Table.Start;
+ loop
+ << Again >> null;
+ C := Source (Pos);
+ Pos := Pos + 1;
+ exit when C = Mark;
+
+ -- LRM93 13.7
+ -- If the base specifier is 'B', the extended digits in the bit
+ -- value are restricted to 0 and 1.
+ -- If the base specifier is 'O', the extended digits int the bit
+ -- value are restricted to legal digits in the octal number
+ -- system, ie, the digits 0 through 7.
+ -- If the base specifier is 'X', the extended digits are all digits
+ -- together with the letters A through F.
+ case C is
+ when '0' .. '9' =>
+ V := Character'Pos (C) - Character'Pos ('0');
+ when 'A' .. 'F' =>
+ V := Character'Pos (C) - Character'Pos ('A') + 10;
+ when 'a' .. 'f' =>
+ V := Character'Pos (C) - Character'Pos ('a') + 10;
+ when '_' =>
+ if Source (Pos) = '_' then
+ Error_Msg_Scan
+ ("double underscore not allowed in a bit string");
+ end if;
+ if Source (Pos - 2) = Mark then
+ Error_Msg_Scan
+ ("underscore not allowed at the start of a bit string");
+ elsif Source (Pos) = Mark then
+ Error_Msg_Scan
+ ("underscore not allowed at the end of a bit string");
+ end if;
+ goto Again;
+ when '"' =>
+ pragma Assert (Mark = '%');
+ Error_Msg_Scan
+ ("'""' cannot close a bit string opened by '%'");
+ exit;
+ when '%' =>
+ pragma Assert (Mark = '"');
+ Error_Msg_Scan
+ ("'%' cannot close a bit string opened by '""'");
+ exit;
+ when others =>
+ Error_Msg_Scan ("bit string not terminated");
+ Pos := Pos - 1;
+ exit;
+ end case;
+
+ case Base_Len is
+ when 1 =>
+ if V > 1 then
+ Error_Msg_Scan ("invalid character in a binary bit string");
+ end if;
+ Str_Table.Append (C);
+ when 2 =>
+ raise Internal_Error;
+ when 3 =>
+ if V > 7 then
+ Error_Msg_Scan ("invalid character in a octal bit string");
+ end if;
+ for I in 1 .. 3 loop
+ if (V / 4) = 1 then
+ Str_Table.Append ('1');
+ else
+ Str_Table.Append ('0');
+ end if;
+ V := (V mod 4) * 2;
+ end loop;
+ when 4 =>
+ for I in 1 .. 4 loop
+ if (V / 8) = 1 then
+ Str_Table.Append ('1');
+ else
+ Str_Table.Append ('0');
+ end if;
+ V := (V mod 8) * 2;
+ end loop;
+ end case;
+ Length := Length + Base_Len;
+ end loop;
+
+ Str_Table.Finish;
+
+ if Length = 0 then
+ Error_Msg_Scan ("empty bit string is not allowed");
+ end if;
+ Current_Token := Tok_Bit_String;
+ Current_Context.Int64 := Iir_Int64 (Base_Len);
+ Current_Context.Str_Len := Length;
+ end Scan_Bit_String;
+
+ -- LRM93 13.3.1
+ -- Basic Identifiers
+ -- A basic identifier consists only of letters, digits, and underlines.
+ -- BASIC_IDENTIFIER ::= LETTER { [ UNDERLINE ] LETTER_OR_DIGIT }
+ -- LETTER_OR_DIGIT ::= LETTER | DIGIT
+ -- LETTER ::= UPPER_CASE_LETTER | LOWER_CASE_LETTER
+ --
+ -- NB: At the call of this procedure, the current character must be a legal
+ -- character for a basic identifier.
+ procedure Scan_Identifier
+ is
+ use Name_Table;
+ C : Character;
+ Len : Natural;
+ begin
+ -- This is an identifier or a key word.
+ Len := 0;
+ loop
+ -- source (pos) is correct.
+ -- LRM93 13.3.1
+ -- All characters if a basic identifier are signifiant, including
+ -- any underline character inserted between a letter or digit and
+ -- an adjacent letter or digit.
+ -- Basic identifiers differing only in the use of the corresponding
+ -- upper and lower case letters are considered as the same.
+ -- This is achieved by converting all upper case letters into
+ -- equivalent lower case letters.
+ -- The opposite (converting in lower case letters) is not possible,
+ -- because two characters have no upper-case equivalent.
+ C := Source (Pos);
+ case Characters_Kind (C) is
+ when Upper_Case_Letter =>
+ if Vhdl_Std = Vhdl_87 and C > 'Z' then
+ Error_8bit;
+ end if;
+ Len := Len + 1;
+ Name_Buffer (Len) := Ada.Characters.Handling.To_Lower (C);
+ when Lower_Case_Letter | Digit =>
+ if Vhdl_Std = Vhdl_87 and C > 'z' then
+ Error_8bit;
+ end if;
+ Len := Len + 1;
+ Name_Buffer (Len) := C;
+ when Special_Character =>
+ -- The current character is legal in an identifier.
+ if C = '_' then
+ if Source (Pos + 1) = '_' then
+ Error_Msg_Scan ("two underscores can't be consecutive");
+ end if;
+ Len := Len + 1;
+ Name_Buffer (Len) := C;
+ else
+ exit;
+ end if;
+ when others =>
+ exit;
+ end case;
+ Pos := Pos + 1;
+ end loop;
+
+ if Source (Pos - 1) = '_' then
+ if not Flag_Psl then
+ -- Some PSL reserved words finish with '_'. This case is handled
+ -- later.
+ Error_Msg_Scan ("identifier cannot finish with '_'");
+ end if;
+ Pos := Pos - 1;
+ Len := Len - 1;
+ C := '_';
+ end if;
+
+ -- LRM93 13.2
+ -- At least one separator is required between an identifier or an
+ -- abstract literal and an adjacent identifier or abstract literal.
+ case Characters_Kind (C) is
+ when Digit
+ | Upper_Case_Letter
+ | Lower_Case_Letter =>
+ raise Internal_Error;
+ when Other_Special_Character =>
+ if Vhdl_Std /= Vhdl_87 and then C = '\' then
+ Error_Separator;
+ end if;
+ when Invalid
+ | Format_Effector
+ | Space_Character
+ | Special_Character =>
+ null;
+ end case;
+ Name_Length := Len;
+
+ -- Hash it.
+ Current_Context.Identifier := Name_Table.Get_Identifier;
+ if Current_Identifier in Std_Names.Name_Id_Keywords then
+ -- LRM93 13.9
+ -- The identifiers listed below are called reserved words and are
+ -- reserved for signifiances in the language.
+ -- IN: this is also achieved in packages std_names and tokens.
+ Current_Token := Token_Type'Val
+ (Token_Type'Pos (Tok_First_Keyword)
+ + Current_Identifier - Std_Names.Name_First_Keyword);
+ case Current_Identifier is
+ when Std_Names.Name_Id_AMS_Reserved_Words =>
+ if not AMS_Vhdl then
+ if Flags.Warn_Reserved_Word then
+ Warning_Msg_Scan
+ ("using """ & Name_Buffer (1 .. Name_Length)
+ & """ AMS-VHDL reserved word as an identifier");
+ end if;
+ Current_Token := Tok_Identifier;
+ end if;
+ when Std_Names.Name_Id_Vhdl00_Reserved_Words =>
+ if Vhdl_Std < Vhdl_00 then
+ if Flags.Warn_Reserved_Word then
+ Warning_Msg_Scan
+ ("using """ & Name_Buffer (1 .. Name_Length)
+ & """ vhdl00 reserved word as an identifier");
+ end if;
+ Current_Token := Tok_Identifier;
+ end if;
+ when Std_Names.Name_Id_Vhdl93_Reserved_Words =>
+ if Vhdl_Std = Vhdl_87 then
+ if Flags.Warn_Reserved_Word then
+ Warning_Msg_Scan
+ ("using """ & Name_Buffer (1 .. Name_Length)
+ & """ vhdl93 reserved word as a vhdl87 identifier");
+ Warning_Msg_Scan
+ ("(use option --std=93 to compile as vhdl93)");
+ end if;
+ Current_Token := Tok_Identifier;
+ end if;
+ when Std_Names.Name_Id_Vhdl87_Reserved_Words =>
+ null;
+ when others =>
+ raise Program_Error;
+ end case;
+ elsif Flag_Psl then
+ case Current_Identifier is
+ when Std_Names.Name_Clock =>
+ Current_Token := Tok_Psl_Clock;
+ when Std_Names.Name_Const =>
+ Current_Token := Tok_Psl_Const;
+ when Std_Names.Name_Boolean =>
+ Current_Token := Tok_Psl_Boolean;
+ when Std_Names.Name_Sequence =>
+ Current_Token := Tok_Psl_Sequence;
+ when Std_Names.Name_Property =>
+ Current_Token := Tok_Psl_Property;
+ when Std_Names.Name_Inf =>
+ Current_Token := Tok_Inf;
+ when Std_Names.Name_Within =>
+ Current_Token := Tok_Within;
+ when Std_Names.Name_Abort =>
+ Current_Token := Tok_Abort;
+ when Std_Names.Name_Before =>
+ Current_Token := Tok_Before;
+ when Std_Names.Name_Always =>
+ Current_Token := Tok_Always;
+ when Std_Names.Name_Never =>
+ Current_Token := Tok_Never;
+ when Std_Names.Name_Eventually =>
+ Current_Token := Tok_Eventually;
+ when Std_Names.Name_Next_A =>
+ Current_Token := Tok_Next_A;
+ when Std_Names.Name_Next_E =>
+ Current_Token := Tok_Next_E;
+ when Std_Names.Name_Next_Event =>
+ Current_Token := Tok_Next_Event;
+ when Std_Names.Name_Next_Event_A =>
+ Current_Token := Tok_Next_Event_A;
+ when Std_Names.Name_Next_Event_E =>
+ Current_Token := Tok_Next_Event_E;
+ when Std_Names.Name_Until =>
+ Current_Token := Tok_Until;
+ when others =>
+ Current_Token := Tok_Identifier;
+ if C = '_' then
+ Error_Msg_Scan ("identifiers cannot finish with '_'");
+ end if;
+ end case;
+ else
+ Current_Token := Tok_Identifier;
+ end if;
+ end Scan_Identifier;
+
+ -- LRM93 13.3.2
+ -- EXTENDED_IDENTIFIER ::= \ GRAPHIC_CHARACTER { GRAPHIC_CHARACTER } \
+ --
+ -- Create an (extended) indentifier.
+ -- Extended identifiers are stored as they appear (leading and tailing
+ -- backslashes, doubling backslashes inside).
+ procedure Scan_Extended_Identifier
+ is
+ use Name_Table;
+ begin
+ -- LRM93 13.3.2
+ -- Moreover, every extended identifiers is distinct from any basic
+ -- identifier.
+ -- This is satisfied by storing '\' in the name table.
+ Name_Length := 1;
+ Name_Buffer (1) := '\';
+ loop
+ -- Next character.
+ Pos := Pos + 1;
+
+ if Source (Pos) = '\' then
+ -- LRM93 13.3.2
+ -- If a backslash is to be used as one of the graphic characters
+ -- of an extended literal, it must be doubled.
+ -- LRM93 13.3.2
+ -- (a doubled backslash couting as one character)
+ Name_Length := Name_Length + 1;
+ Name_Buffer (Name_Length) := '\';
+
+ Pos := Pos + 1;
+
+ exit when Source (Pos) /= '\';
+ end if;
+
+ -- source (pos) is correct.
+ case Characters_Kind (Source (Pos)) is
+ when Format_Effector =>
+ Error_Msg_Scan ("format effector in extended identifier");
+ exit;
+ when Graphic_Character =>
+ null;
+ when Invalid =>
+ Error_Msg_Scan ("invalid character in extended identifier");
+ end case;
+ Name_Length := Name_Length + 1;
+ -- LRM93 13.3.2
+ -- Extended identifiers differing only in the use of corresponding
+ -- upper and lower case letters are distinct.
+ Name_Buffer (Name_Length) := Source (Pos);
+ end loop;
+
+ if Name_Length <= 2 then
+ Error_Msg_Scan ("empty extended identifier is not allowed");
+ end if;
+
+ -- LRM93 13.2
+ -- At least one separator is required between an identifier or an
+ -- abstract literal and an adjacent identifier or abstract literal.
+ case Characters_Kind (Source (Pos)) is
+ when Digit
+ | Upper_Case_Letter
+ | Lower_Case_Letter =>
+ Error_Separator;
+ when Invalid
+ | Format_Effector
+ | Space_Character
+ | Special_Character
+ | Other_Special_Character =>
+ null;
+ end case;
+
+ -- Hash it.
+ Current_Context.Identifier := Name_Table.Get_Identifier;
+ Current_Token := Tok_Identifier;
+ end Scan_Extended_Identifier;
+
+ procedure Convert_Identifier
+ is
+ procedure Error_Bad is
+ begin
+ Error_Msg_Option ("bad character in identifier");
+ end Error_Bad;
+
+ procedure Error_8bit is
+ begin
+ Error_Msg_Option ("8 bits characters not allowed in vhdl87");
+ end Error_8bit;
+
+ use Name_Table;
+ C : Character;
+ begin
+ if Name_Length = 0 then
+ Error_Msg_Option ("identifier required");
+ return;
+ end if;
+
+ if Name_Buffer (1) = '\' then
+ -- Extended identifier.
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Option ("extended identifiers not allowed in vhdl87");
+ return;
+ end if;
+
+ if Name_Length < 3 then
+ Error_Msg_Option ("extended identifier is too short");
+ return;
+ end if;
+ if Name_Buffer (Name_Length) /= '\' then
+ Error_Msg_Option ("extended identifier must finish with a '\'");
+ return;
+ end if;
+ for I in 2 .. Name_Length - 1 loop
+ C := Name_Buffer (I);
+ case Characters_Kind (C) is
+ when Format_Effector =>
+ Error_Msg_Option ("format effector in extended identifier");
+ return;
+ when Graphic_Character =>
+ if C = '\' then
+ if Name_Buffer (I + 1) /= '\'
+ or else I = Name_Length - 1
+ then
+ Error_Msg_Option ("anti-slash must be doubled "
+ & "in extended identifier");
+ return;
+ end if;
+ end if;
+ when Invalid =>
+ Error_Bad;
+ end case;
+ end loop;
+ else
+ -- Identifier
+ for I in 1 .. Name_Length loop
+ C := Name_Buffer (I);
+ case Characters_Kind (C) is
+ when Upper_Case_Letter =>
+ if Vhdl_Std = Vhdl_87 and C > 'Z' then
+ Error_8bit;
+ end if;
+ Name_Buffer (I) := Ada.Characters.Handling.To_Lower (C);
+ when Lower_Case_Letter | Digit =>
+ if Vhdl_Std = Vhdl_87 and C > 'z' then
+ Error_8bit;
+ end if;
+ when Special_Character =>
+ -- The current character is legal in an identifier.
+ if C = '_' then
+ if I = 1 then
+ Error_Msg_Option
+ ("identifier cannot start with an underscore");
+ return;
+ end if;
+ if Name_Buffer (I - 1) = '_' then
+ Error_Msg_Option
+ ("two underscores can't be consecutive");
+ return;
+ end if;
+ if I = Name_Length then
+ Error_Msg_Option
+ ("identifier cannot finish with an underscore");
+ return;
+ end if;
+ else
+ Error_Bad;
+ end if;
+ when others =>
+ Error_Bad;
+ end case;
+ end loop;
+ end if;
+ end Convert_Identifier;
+
+ -- Scan an identifier within a comment. Only lower case letters are
+ -- allowed.
+ function Scan_Comment_Identifier return Boolean
+ is
+ use Name_Table;
+ Len : Natural;
+ C : Character;
+ begin
+ -- Skip spaces.
+ while Source (Pos) = ' ' or Source (Pos) = HT loop
+ Pos := Pos + 1;
+ end loop;
+
+ -- The identifier shall start with a lower case letter.
+ if Source (Pos) not in 'a' .. 'z' then
+ return False;
+ end if;
+
+ -- Scan the identifier (in lower cases).
+ Len := 0;
+ loop
+ C := Source (Pos);
+ exit when C not in 'a' .. 'z' and C /= '_';
+ Len := Len + 1;
+ Name_Buffer (Len) := C;
+ Pos := Pos + 1;
+ end loop;
+
+ -- Shall be followed by a space or a new line.
+ case C is
+ when ' ' | HT | LF | CR =>
+ null;
+ when others =>
+ return False;
+ end case;
+
+ Name_Length := Len;
+ return True;
+ end Scan_Comment_Identifier;
+
+ -- Scan tokens within a comment. Return TRUE if Current_Token was set,
+ -- return FALSE to discard the comment (ie treat it like a real comment).
+ function Scan_Comment return Boolean
+ is
+ use Std_Names;
+ Id : Name_Id;
+ begin
+ if not Scan_Comment_Identifier then
+ return False;
+ end if;
+
+ -- Hash it.
+ Id := Name_Table.Get_Identifier;
+
+ case Id is
+ when Name_Psl =>
+ -- Scan first identifier after '-- psl'.
+ if not Scan_Comment_Identifier then
+ return False;
+ end if;
+ Id := Name_Table.Get_Identifier;
+ case Id is
+ when Name_Property =>
+ Current_Token := Tok_Psl_Property;
+ when Name_Sequence =>
+ Current_Token := Tok_Psl_Sequence;
+ when Name_Endpoint =>
+ Current_Token := Tok_Psl_Endpoint;
+ when Name_Assert =>
+ Current_Token := Tok_Psl_Assert;
+ when Name_Cover =>
+ Current_Token := Tok_Psl_Cover;
+ when Name_Default =>
+ Current_Token := Tok_Psl_Default;
+ when others =>
+ return False;
+ end case;
+ Flag_Scan_In_Comment := True;
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Scan_Comment;
+
+ function Scan_Exclam_Mark return Boolean is
+ begin
+ if Source (Pos) = '!' then
+ Pos := Pos + 1;
+ return True;
+ else
+ return False;
+ end if;
+ end Scan_Exclam_Mark;
+
+ function Scan_Underscore return Boolean is
+ begin
+ if Source (Pos) = '_' then
+ Pos := Pos + 1;
+ return True;
+ else
+ return False;
+ end if;
+ end Scan_Underscore;
+
+ -- The Scan_Next_Line procedure must be called after each end-of-line to
+ -- register to next line number. This is called by Scan_CR_Newline and
+ -- Scan_LF_Newline.
+ procedure Scan_Next_Line is
+ begin
+ Current_Context.Line_Number := Current_Context.Line_Number + 1;
+ Current_Context.Line_Pos := Pos;
+ File_Add_Line_Number
+ (Current_Context.Source_File, Current_Context.Line_Number, Pos);
+ end Scan_Next_Line;
+
+ -- Scan a CR end-of-line.
+ procedure Scan_CR_Newline is
+ begin
+ -- Accept CR or CR+LF as line separator.
+ if Source (Pos + 1) = LF then
+ Pos := Pos + 2;
+ else
+ Pos := Pos + 1;
+ end if;
+ Scan_Next_Line;
+ end Scan_CR_Newline;
+
+ -- Scan a LF end-of-line.
+ procedure Scan_LF_Newline is
+ begin
+ -- Accept LF or LF+CR as line separator.
+ if Source (Pos + 1) = CR then
+ Pos := Pos + 2;
+ else
+ Pos := Pos + 1;
+ end if;
+ Scan_Next_Line;
+ end Scan_LF_Newline;
+
+ -- Get a new token.
+ procedure Scan is
+ begin
+ if Current_Token /= Tok_Invalid then
+ Current_Context.Prev_Token := Current_Token;
+ end if;
+
+ << Again >> null;
+
+ -- Skip commonly used separators.
+ while Source(Pos) = ' ' or Source(Pos) = HT loop
+ Pos := Pos + 1;
+ end loop;
+
+ Current_Context.Token_Pos := Pos;
+ Current_Context.Identifier := Null_Identifier;
+
+ case Source (Pos) is
+ when HT | ' ' =>
+ -- Must have already been skipped just above.
+ raise Internal_Error;
+ when NBSP =>
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Scan ("NBSP character not allowed in vhdl87");
+ end if;
+ Pos := Pos + 1;
+ goto Again;
+ when VT | FF =>
+ Pos := Pos + 1;
+ goto Again;
+ when LF =>
+ Scan_LF_Newline;
+ if Flag_Newline then
+ Current_Token := Tok_Newline;
+ return;
+ end if;
+ goto Again;
+ when CR =>
+ Scan_CR_Newline;
+ if Flag_Newline then
+ Current_Token := Tok_Newline;
+ return;
+ end if;
+ goto Again;
+ when '-' =>
+ if Source (Pos + 1) = '-' then
+ -- This is a comment.
+ -- LRM93 13.8
+ -- A comment starts with two adjacent hyphens and extends up
+ -- to the end of the line.
+ -- A comment can appear on any line line of a VHDL
+ -- description.
+ -- The presence or absence of comments has no influence on
+ -- wether a description is legal or illegal.
+ -- Futhermore, comments do not influence the execution of a
+ -- simulation module; their sole purpose is the enlightenment
+ -- of the human reader.
+ -- GHDL note: As a consequence, an obfruscating comment
+ -- is out of purpose, and a warning could be reported :-)
+ Pos := Pos + 2;
+
+ -- Scan inside a comment. So we just ignore the two dashes.
+ if Flag_Scan_In_Comment then
+ goto Again;
+ end if;
+
+ -- Handle keywords in comment (PSL).
+ if Flag_Comment_Keyword
+ and then Scan_Comment
+ then
+ return;
+ end if;
+
+ -- LRM93 13.2
+ -- In any case, a sequence of one or more format
+ -- effectors other than horizontal tabulation must
+ -- cause at least one end of line.
+ while Source (Pos) /= CR and Source (Pos) /= LF and
+ Source (Pos) /= VT and Source (Pos) /= FF and
+ Source (Pos) /= Files_Map.EOT
+ loop
+ if not Flags.Mb_Comment
+ and then Characters_Kind (Source (Pos)) = Invalid
+ then
+ Error_Msg_Scan ("invalid character, even in a comment");
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ if Flag_Comment then
+ Current_Token := Tok_Comment;
+ return;
+ end if;
+ goto Again;
+ elsif Flag_Psl and then Source (Pos + 1) = '>' then
+ Current_Token := Tok_Minus_Greater;
+ Pos := Pos + 2;
+ return;
+ else
+ Current_Token := Tok_Minus;
+ Pos := Pos + 1;
+ return;
+ end if;
+ when '+' =>
+ Current_Token := Tok_Plus;
+ Pos := Pos + 1;
+ return;
+ when '*' =>
+ if Source (Pos + 1) = '*' then
+ Current_Token := Tok_Double_Star;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Star;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '/' =>
+ if Source (Pos + 1) = '=' then
+ Current_Token := Tok_Not_Equal;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '*' then
+ -- LRM08 15.9 Comments
+ -- A delimited comment start with a solidus (slash) character
+ -- immediately followed by an asterisk character and extends up
+ -- to the first subsequent occurrence of an asterisk character
+ -- immediately followed by a solidus character.
+ if Vhdl_Std < Vhdl_08 then
+ Error_Msg_Scan
+ ("block comment are not allowed before vhdl 2008");
+ end if;
+
+ -- Skip '/*'.
+ Pos := Pos + 2;
+
+ loop
+ case Source (Pos) is
+ when '/' =>
+ -- LRM08 15.9
+ -- Moreover, an occurrence of a solidus character
+ -- immediately followed by an asterisk character
+ -- within a delimited comment is not interpreted as
+ -- the start of a nested delimited comment.
+ if Source (Pos + 1) = '*' then
+ Warning_Msg_Scan
+ ("'/*' found within a block comment");
+ end if;
+ Pos := Pos + 1;
+ when '*' =>
+ if Source (Pos + 1) = '/' then
+ Pos := Pos + 2;
+ exit;
+ else
+ Pos := Pos + 1;
+ end if;
+ when CR =>
+ Scan_CR_Newline;
+ when LF =>
+ Scan_LF_Newline;
+ when Files_Map.EOT =>
+ if Pos >= Current_Context.File_Len then
+ -- Point at the start of the comment.
+ Error_Msg_Scan
+ ("block comment not terminated at end of file",
+ File_Pos_To_Location
+ (Current_Context.Source_File,
+ Current_Context.Token_Pos));
+ exit;
+ end if;
+ Pos := Pos + 1;
+ when others =>
+ Pos := Pos + 1;
+ end case;
+ end loop;
+ if Flag_Comment then
+ Current_Token := Tok_Comment;
+ return;
+ end if;
+ goto Again;
+ else
+ Current_Token := Tok_Slash;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '(' =>
+ Current_Token := Tok_Left_Paren;
+ Pos := Pos + 1;
+ return;
+ when ')' =>
+ Current_Token := Tok_Right_Paren;
+ Pos := Pos + 1;
+ return;
+ when '|' =>
+ if Flag_Psl then
+ if Source (Pos + 1) = '|' then
+ Current_Token := Tok_Bar_Bar;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '-'
+ and then Source (Pos + 2) = '>'
+ then
+ Current_Token := Tok_Bar_Arrow;
+ Pos := Pos + 3;
+ elsif Source (Pos + 1) = '='
+ and then Source (Pos + 2) = '>'
+ then
+ Current_Token := Tok_Bar_Double_Arrow;
+ Pos := Pos + 3;
+ else
+ Current_Token := Tok_Bar;
+ Pos := Pos + 1;
+ end if;
+ else
+ Current_Token := Tok_Bar;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '!' =>
+ if Flag_Psl then
+ Current_Token := Tok_Exclam_Mark;
+ else
+ -- LRM93 13.10
+ -- A vertical line (|) can be replaced by an exclamation
+ -- mark (!) where used as a delimiter.
+ Current_Token := Tok_Bar;
+ end if;
+ Pos := Pos + 1;
+ return;
+ when ':' =>
+ if Source (Pos + 1) = '=' then
+ Current_Token := Tok_Assign;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Colon;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when ';' =>
+ Current_Token := Tok_Semi_Colon;
+ Pos := Pos + 1;
+ return;
+ when ',' =>
+ Current_Token := Tok_Comma;
+ Pos := Pos + 1;
+ return;
+ when '.' =>
+ if Source (Pos + 1) = '.' then
+ -- Be Ada friendly...
+ Error_Msg_Scan ("'..' is invalid in vhdl, replaced by 'to'");
+ Current_Token := Tok_To;
+ Pos := Pos + 2;
+ return;
+ end if;
+ Current_Token := Tok_Dot;
+ Pos := Pos + 1;
+ return;
+ when '&' =>
+ if Flag_Psl and then Source (Pos + 1) = '&' then
+ Current_Token := Tok_And_And;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Ampersand;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '<' =>
+ if Source (Pos + 1) = '=' then
+ Current_Token := Tok_Less_Equal;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '>' then
+ Current_Token := Tok_Box;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Less;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '>' =>
+ if Source (Pos + 1) = '=' then
+ Current_Token := Tok_Greater_Equal;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Greater;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '=' =>
+ if Source (Pos + 1) = '=' then
+ if AMS_Vhdl then
+ Current_Token := Tok_Equal_Equal;
+ else
+ Error_Msg_Scan
+ ("'==' is not the vhdl equality, replaced by '='");
+ Current_Token := Tok_Equal;
+ end if;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '>' then
+ Current_Token := Tok_Double_Arrow;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Equal;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when ''' =>
+ -- Handle cases such as character'('a')
+ -- FIXME: what about f ()'length ? or .all'length
+ if Current_Context.Prev_Token /= Tok_Identifier
+ and then Current_Context.Prev_Token /= Tok_Character
+ and then Source (Pos + 2) = '''
+ then
+ -- LRM93 13.5
+ -- A character literal is formed by enclosing one of the 191
+ -- graphic character (...) between two apostrophe characters.
+ -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
+ if Characters_Kind (Source (Pos + 1)) not in Graphic_Character
+ then
+ Error_Msg_Scan
+ ("a character literal can only be a graphic character");
+ elsif Vhdl_Std = Vhdl_87
+ and then Source (Pos + 1) > Character'Val (127)
+ then
+ Error_8bit;
+ end if;
+ Current_Token := Tok_Character;
+ Current_Context.Identifier :=
+ Name_Table.Get_Identifier (Source (Pos + 1));
+ Pos := Pos + 3;
+ return;
+ else
+ Current_Token := Tok_Tick;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when '0' .. '9' =>
+ Scan_Literal;
+
+ -- LRM 13.2
+ -- At least one separator is required between an identifier or
+ -- an abstract literal and an adjacent identifier or abstract
+ -- literal.
+ case Characters_Kind (Source (Pos)) is
+ when Digit =>
+ raise Internal_Error;
+ when Upper_Case_Letter
+ | Lower_Case_Letter =>
+ -- Could call Error_Separator, but use a clearer message
+ -- for this common case.
+ -- Note: the term "unit name" is not correct here, since it
+ -- can be any identifier or even a keyword; however it is
+ -- probably the most common case (eg 10ns).
+ Error_Msg_Scan
+ ("space is required between number and unit name");
+ when Other_Special_Character =>
+ if Vhdl_Std /= Vhdl_87 and then Source (Pos) = '\' then
+ Error_Separator;
+ end if;
+ when Invalid
+ | Format_Effector
+ | Space_Character
+ | Special_Character =>
+ null;
+ end case;
+ return;
+ when '#' =>
+ Error_Msg_Scan ("'#' is used for based literals and "
+ & "must be preceded by a base");
+ -- Cannot easily continue.
+ raise Compilation_Error;
+ when Quotation | '%' =>
+ Scan_String;
+ return;
+ when '[' =>
+ if Flag_Psl then
+ if Source (Pos + 1) = '*' then
+ Current_Token := Tok_Brack_Star;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '+'
+ and then Source (Pos + 2) = ']'
+ then
+ Current_Token := Tok_Brack_Plus_Brack;
+ Pos := Pos + 3;
+ elsif Source (Pos + 1) = '-'
+ and then Source (Pos + 2) = '>'
+ then
+ Current_Token := Tok_Brack_Arrow;
+ Pos := Pos + 3;
+ elsif Source (Pos + 1) = '=' then
+ Current_Token := Tok_Brack_Equal;
+ Pos := Pos + 2;
+ else
+ Current_Token := Tok_Left_Bracket;
+ Pos := Pos + 1;
+ end if;
+ else
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Scan
+ ("'[' is an invalid character in vhdl87, replaced by '('");
+ Current_Token := Tok_Left_Paren;
+ else
+ Current_Token := Tok_Left_Bracket;
+ end if;
+ Pos := Pos + 1;
+ end if;
+ return;
+ when ']' =>
+ if Vhdl_Std = Vhdl_87 and not Flag_Psl then
+ Error_Msg_Scan
+ ("']' is an invalid character in vhdl87, replaced by ')'");
+ Current_Token := Tok_Right_Paren;
+ else
+ Current_Token := Tok_Right_Bracket;
+ end if;
+ Pos := Pos + 1;
+ return;
+ when '{' =>
+ if Flag_Psl then
+ Current_Token := Tok_Left_Curly;
+ else
+ Error_Msg_Scan ("'{' is an invalid character, replaced by '('");
+ Current_Token := Tok_Left_Paren;
+ end if;
+ Pos := Pos + 1;
+ return;
+ when '}' =>
+ if Flag_Psl then
+ Current_Token := Tok_Right_Curly;
+ else
+ Error_Msg_Scan ("'}' is an invalid character, replaced by ')'");
+ Current_Token := Tok_Right_Paren;
+ end if;
+ Pos := Pos + 1;
+ return;
+ when '\' =>
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Scan
+ ("extended identifiers are not allowed in vhdl87");
+ end if;
+ Scan_Extended_Identifier;
+ return;
+ when '^' =>
+ Error_Msg_Scan ("'^' is not a VHDL operator, use 'xor'");
+ Pos := Pos + 1;
+ Current_Token := Tok_Xor;
+ return;
+ when '~' =>
+ Error_Msg_Scan ("'~' is not a VHDL operator, use 'not'");
+ Pos := Pos + 1;
+ Current_Token := Tok_Not;
+ return;
+ when '?' =>
+ if Vhdl_Std < Vhdl_08 then
+ Error_Msg_Scan ("'?' can only be used in strings or comments");
+ Pos := Pos + 1;
+ goto Again;
+ else
+ if Source (Pos + 1) = '<' then
+ if Source (Pos + 2) = '=' then
+ Current_Token := Tok_Match_Less_Equal;
+ Pos := Pos + 3;
+ else
+ Current_Token := Tok_Match_Less;
+ Pos := Pos + 2;
+ end if;
+ elsif Source (Pos + 1) = '>' then
+ if Source (Pos + 2) = '=' then
+ Current_Token := Tok_Match_Greater_Equal;
+ Pos := Pos + 3;
+ else
+ Current_Token := Tok_Match_Greater;
+ Pos := Pos + 2;
+ end if;
+ elsif Source (Pos + 1) = '?' then
+ Current_Token := Tok_Condition;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '=' then
+ Current_Token := Tok_Match_Equal;
+ Pos := Pos + 2;
+ elsif Source (Pos + 1) = '/'
+ and then Source (Pos + 2) = '='
+ then
+ Current_Token := Tok_Match_Not_Equal;
+ Pos := Pos + 3;
+ else
+ Error_Msg_Scan ("unknown matching operator");
+ Pos := Pos + 1;
+ goto Again;
+ end if;
+ end if;
+ return;
+ when '$' | '`'
+ | Inverted_Exclamation .. Inverted_Question
+ | Multiplication_Sign | Division_Sign =>
+ Error_Msg_Scan ("character """ & Source (Pos)
+ & """ can only be used in strings or comments");
+ Pos := Pos + 1;
+ goto Again;
+ when '@' =>
+ if Flag_Psl then
+ Current_Token := Tok_Arobase;
+ Pos := Pos + 1;
+ return;
+ else
+ Error_Msg_Scan
+ ("character """ & Source (Pos)
+ & """ can only be used in strings or comments");
+ Pos := Pos + 1;
+ goto Again;
+ end if;
+ when '_' =>
+ Error_Msg_Scan ("an identifier can't start with '_'");
+ Pos := Pos + 1;
+ goto Again;
+ when 'B' | 'b' | 'O' | 'o' | 'X' | 'x' =>
+ if Source (Pos + 1) = Quotation or else Source (Pos + 1) = '%' then
+ -- LRM93 13.7
+ -- BASE_SPECIFIER ::= B | O | X
+ -- A letter in a bit string literal (either an extended digit or
+ -- the base specifier) can be written either in lower case or
+ -- in upper case, with the same meaning.
+ Scan_Bit_String;
+ else
+ Scan_Identifier;
+ end if;
+ return;
+ when 'A' | 'C' .. 'N' | 'P' .. 'W' | 'Y'| 'Z'
+ | 'a' | 'c' .. 'n' | 'p' .. 'w' | 'y'| 'z' =>
+ Scan_Identifier;
+ return;
+ when UC_A_Grave .. UC_O_Diaeresis
+ | UC_O_Oblique_Stroke .. UC_Icelandic_Thorn =>
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Scan
+ ("upper case letters above 128 are not allowed in vhdl87");
+ end if;
+ Scan_Identifier;
+ return;
+ when LC_German_Sharp_S .. LC_O_Diaeresis
+ | LC_O_Oblique_Stroke .. LC_Y_Diaeresis =>
+ if Vhdl_Std = Vhdl_87 then
+ Error_Msg_Scan
+ ("lower case letters above 128 are not allowed in vhdl87");
+ end if;
+ Scan_Identifier;
+ return;
+ when NUL .. ETX | ENQ .. BS | SO .. US | DEL .. APC =>
+ Error_Msg_Scan
+ ("control character that is not CR, LF, FF, HT or VT " &
+ "is not allowed");
+ Pos := Pos + 1;
+ goto Again;
+ when Files_Map.EOT =>
+ if Pos >= Current_Context.File_Len then
+ -- FIXME: should conditionnaly emit a warning if the file
+ -- is not terminated by an end of line.
+ Current_Token := Tok_Eof;
+ else
+ Error_Msg_Scan ("EOT is not allowed inside the file");
+ Pos := Pos + 1;
+ goto Again;
+ end if;
+ return;
+ end case;
+ end Scan;
+
+ function Get_Token_Location return Location_Type is
+ begin
+ return File_Pos_To_Location
+ (Current_Context.Source_File, Current_Context.Token_Pos);
+ end Get_Token_Location;
+end Scanner;
diff --git a/src/scanner.ads b/src/scanner.ads
new file mode 100644
index 000000000..ddc0d1819
--- /dev/null
+++ b/src/scanner.ads
@@ -0,0 +1,120 @@
+-- VHDL lexical scanner.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR 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 Tokens; use Tokens;
+
+package Scanner is
+ -- Global variables
+ -- The token that was just scanned.
+ -- When the token was eaten, you can call invalidate_current_token to
+ -- set it to tok_invalid.
+ -- Current_token should not be written outside of scan package.
+ -- It can be replaced by a function call.
+ Current_Token: Token_Type := Tok_Invalid;
+
+ -- Simply set current_token to tok_invalid.
+ procedure Invalidate_Current_Token;
+ pragma Inline (Invalidate_Current_Token);
+
+ -- When CURRENT_TOKEN is an tok_identifier, tok_char or tok_string,
+ -- its name_id can be got via this function.
+ function Current_Identifier return Name_Id;
+ pragma Inline (Current_Identifier);
+
+ -- Get current string identifier and length.
+ function Current_String_Id return String_Id;
+ function Current_String_Length return Nat32;
+ pragma Inline (Current_String_Id);
+ pragma Inline (Current_String_Length);
+
+ -- Set Current_identifier to null_identifier.
+ -- Can be used to catch bugs.
+ procedure Invalidate_Current_Identifier;
+ pragma Inline (Invalidate_Current_Identifier);
+
+ -- When CURRENT_TOKEN is tok_integer, returns the value.
+ -- When CURRENT_TOKEN is tok_bit_string, returns the base.
+ function Current_Iir_Int64 return Iir_Int64;
+ pragma Inline (Current_Iir_Int64);
+
+ -- When CURRENT_TOKEN is tok_real, it returns the value.
+ function Current_Iir_Fp64 return Iir_Fp64;
+ pragma Inline (Current_Iir_Fp64);
+
+ -- Advances the lexical analyser. Put a new token into current_token.
+ procedure Scan;
+
+ -- Initialize the scanner with file SOURCE_FILE.
+ procedure Set_File (Source_File : Source_File_Entry);
+
+ procedure Set_Current_Position (Position: Source_Ptr);
+
+ -- Finalize the scanner.
+ procedure Close_File;
+
+ -- If true comments are reported as a token.
+ Flag_Comment : Boolean := False;
+
+ -- If true newlines are reported as a token.
+ Flag_Newline : Boolean := False;
+
+ -- If true also scan PSL tokens.
+ Flag_Psl : Boolean := False;
+
+ -- If true handle PSL embedded in comments: '-- psl' is ignored.
+ Flag_Psl_Comment : Boolean := False;
+
+ -- If true, ignore '--'. This is automatically set when Flag_Psl_Comment
+ -- is true and a starting PSL keyword has been identified.
+ -- Must be reset to false by the parser.
+ Flag_Scan_In_Comment : Boolean := False;
+
+ -- If true scan for keywords in comments. Must be enabled if
+ -- Flag_Psl_Comment is true.
+ Flag_Comment_Keyword : Boolean := False;
+
+ -- If the next character is '!', eat it and return True, otherwise return
+ -- False (used by PSL).
+ function Scan_Exclam_Mark return Boolean;
+
+ -- If the next character is '_', eat it and return True, otherwise return
+ -- False (used by PSL).
+ function Scan_Underscore return Boolean;
+
+ -- Get the current location, or the location of the current token.
+ -- Since a token cannot spread over lines, file and line of the current
+ -- token are the same as those of the current position.
+ function Get_Current_File return Name_Id;
+ function Get_Current_Source_File return Source_File_Entry;
+ function Get_Current_Line return Natural;
+ function Get_Current_Column return Natural;
+ function Get_Token_Location return Location_Type;
+ function Get_Token_Column return Natural;
+ function Get_Token_Position return Source_Ptr;
+ function Get_Position return Source_Ptr;
+
+ -- Convert (canonicalize) an identifier stored in name_buffer/name_length.
+ -- Upper case letters are converted into lower case.
+ -- Lexical checks are performed.
+ -- This procedure is not used by Scan, but should be used for identifiers
+ -- given in the command line.
+ -- Errors are directly reported through error_msg_option.
+ -- Also, Vhdl_Std should be set.
+ procedure Convert_Identifier;
+
+end Scanner;
diff --git a/src/sem.adb b/src/sem.adb
new file mode 100644
index 000000000..e82bd72b7
--- /dev/null
+++ b/src/sem.adb
@@ -0,0 +1,2749 @@
+-- Semantic analysis 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 Ada.Unchecked_Conversion;
+with Errorout; use Errorout;
+with Std_Package; use Std_Package;
+with Ieee.Std_Logic_1164;
+with Libraries;
+with Std_Names;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Expr; use Sem_Expr;
+with Sem_Names; use Sem_Names;
+with Sem_Specs; use Sem_Specs;
+with Sem_Decls; use Sem_Decls;
+with Sem_Assocs; use Sem_Assocs;
+with Sem_Inst;
+with Iirs_Utils; use Iirs_Utils;
+with Flags; use Flags;
+with Name_Table;
+with Str_Table;
+with Sem_Stmts; use Sem_Stmts;
+with Iir_Chains;
+with Xrefs; use Xrefs;
+
+package body Sem is
+ -- Forward declarations.
+ procedure Sem_Context_Clauses (Design_Unit: Iir_Design_Unit);
+ procedure Sem_Block_Configuration
+ (Block_Conf : Iir_Block_Configuration; Father: Iir);
+ procedure Sem_Component_Configuration
+ (Conf : Iir_Component_Configuration; Father : Iir);
+
+ procedure Add_Dependence (Unit : Iir)
+ is
+ Targ : constant Iir := Get_Current_Design_Unit;
+ begin
+ -- During normal analysis, there is a current design unit. But not
+ -- during debugging outside of any context.
+ if Targ = Null_Iir then
+ return;
+ end if;
+
+ Add_Dependence (Targ, Unit);
+ end Add_Dependence;
+
+ -- LRM 1.1 Entity declaration.
+ procedure Sem_Entity_Declaration (Entity: Iir_Entity_Declaration) is
+ begin
+ Xrefs.Xref_Decl (Entity);
+ Sem_Scopes.Add_Name (Entity);
+ Set_Visible_Flag (Entity, True);
+
+ Set_Is_Within_Flag (Entity, True);
+
+ -- LRM 10.1
+ -- 1. An entity declaration, together with a corresponding architecture
+ -- body.
+ Open_Declarative_Region;
+
+ -- Sem generics.
+ Sem_Interface_Chain (Get_Generic_Chain (Entity), Generic_Interface_List);
+
+ -- Sem ports.
+ Sem_Interface_Chain (Get_Port_Chain (Entity), Port_Interface_List);
+
+ -- Entity declarative part and concurrent statements.
+ Sem_Block (Entity, True);
+
+ Close_Declarative_Region;
+ Set_Is_Within_Flag (Entity, False);
+ end Sem_Entity_Declaration;
+
+ -- Get the entity unit for LIBRARY_UNIT (an architecture or a
+ -- configuration declaration).
+ -- Return NULL_IIR in case of error (not found, bad library).
+ function Sem_Entity_Name (Library_Unit : Iir) return Iir
+ is
+ Name : Iir;
+ Library : Iir_Library_Declaration;
+ Entity : Iir;
+ begin
+ -- Get the library of architecture/configuration.
+ Library := Get_Library
+ (Get_Design_File (Get_Design_Unit (Library_Unit)));
+
+ -- Resolve the name.
+
+ Name := Get_Entity_Name (Library_Unit);
+ if Get_Kind (Name) = Iir_Kind_Simple_Name then
+ -- LRM93 10.1 Declarative Region
+ -- LRM08 12.1 Declarative Region
+ -- a) An entity declaration, tohether with a corresponding
+ -- architecture body.
+ --
+ -- GHDL: simple name needs to be handled specially. Because
+ -- architecture body is in the declarative region of its entity,
+ -- the entity name is directly visible. But we cannot really use
+ -- that rule as is, as we don't know which is the entity.
+ Entity := Libraries.Load_Primary_Unit
+ (Library, Get_Identifier (Name), Library_Unit);
+ if Entity = Null_Iir then
+ Error_Msg_Sem ("entity " & Disp_Node (Name) & " was not analysed",
+ Library_Unit);
+ return Null_Iir;
+ end if;
+ Entity := Get_Library_Unit (Entity);
+ Set_Named_Entity (Name, Entity);
+ Xrefs.Xref_Ref (Name, Entity);
+ else
+ -- Certainly an expanded name. Use the standard name analysis.
+ Name := Sem_Denoting_Name (Name);
+ Set_Entity_Name (Library_Unit, Name);
+ Entity := Get_Named_Entity (Name);
+ end if;
+
+ if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then
+ Error_Class_Match (Name, "entity");
+ return Null_Iir;
+ end if;
+
+ -- LRM 1.2 Architecture bodies
+ -- For a given design entity, both the entity declaration and the
+ -- associated architecture body must reside in the same library.
+
+ -- LRM 1.3 Configuration Declarations
+ -- For a configuration of a given design entity, both the
+ -- configuration declaration and the corresponding entity
+ -- declaration must reside in the same library.
+ if Get_Library (Get_Design_File (Get_Design_Unit (Entity))) /= Library
+ then
+ Error_Msg_Sem
+ (Disp_Node (Entity) & " does not reside in "
+ & Disp_Node (Library), Library_Unit);
+ return Null_Iir;
+ end if;
+
+ return Entity;
+ end Sem_Entity_Name;
+
+ -- LRM 1.2 Architecture bodies.
+ procedure Sem_Architecture_Body (Arch: Iir_Architecture_Body)
+ is
+ Entity_Unit : Iir_Design_Unit;
+ Entity_Library : Iir_Entity_Declaration;
+ begin
+ Xrefs.Xref_Decl (Arch);
+ -- First, find the entity.
+ Entity_Library := Sem_Entity_Name (Arch);
+ if Entity_Library = Null_Iir then
+ return;
+ end if;
+ Entity_Unit := Get_Design_Unit (Entity_Library);
+
+ -- LRM93 11.4
+ -- In each case, the second unit depends on the first unit.
+ -- GHDL: an architecture depends on its entity.
+ Add_Dependence (Entity_Unit);
+
+ Add_Context_Clauses (Entity_Unit);
+
+ Set_Is_Within_Flag (Arch, True);
+ Set_Is_Within_Flag (Entity_Library, True);
+
+ -- Makes the entity name visible.
+ -- FIXME: quote LRM.
+ Sem_Scopes.Add_Name
+ (Entity_Library, Get_Identifier (Entity_Library), False);
+
+ -- LRM 10.1 Declarative Region
+ -- 1. An entity declaration, together with a corresponding architecture
+ -- body.
+ Open_Declarative_Region;
+ Sem_Scopes.Add_Entity_Declarations (Entity_Library);
+
+ -- LRM02 1.2 Architecture bodies
+ -- For the purpose of interpreting the scope and visibility of the
+ -- identifier (see 10.2 and 10.3), the declaration of the identifier is
+ -- considered to occur after the final declarative item of the entity
+ -- declarative part of the corresponding entity declaration.
+ --
+ -- FIXME: before VHDL-02, an architecture is not a declaration.
+ Sem_Scopes.Add_Name (Arch, Get_Identifier (Arch), True);
+ Set_Visible_Flag (Arch, True);
+
+ -- LRM02 10.1 Declarative region
+ -- The declarative region associated with an architecture body is
+ -- considered to occur immediatly within the declarative region
+ -- associated with the entity declaration corresponding to the given
+ -- architecture body.
+ if Vhdl_Std >= Vhdl_02 then
+ Open_Declarative_Region;
+ end if;
+ Sem_Block (Arch, True);
+ if Vhdl_Std >= Vhdl_02 then
+ Close_Declarative_Region;
+ end if;
+
+ Close_Declarative_Region;
+ Set_Is_Within_Flag (Arch, False);
+ Set_Is_Within_Flag (Entity_Library, False);
+ end Sem_Architecture_Body;
+
+ -- Return the real resolver used for (sub) object OBJ.
+ -- Return NULL_IIR if none.
+ function Get_Resolver (Obj : Iir) return Iir
+ is
+ Obj_Type : Iir;
+ Res : Iir;
+ begin
+ case Get_Kind (Obj) is
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element =>
+ Res := Get_Resolver (Get_Prefix (Obj));
+ if Res /= Null_Iir then
+ return Res;
+ end if;
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ null;
+ when Iir_Kind_Object_Alias_Declaration =>
+ return Get_Resolver (Get_Name (Obj));
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Get_Resolver (Get_Named_Entity (Obj));
+ when others =>
+ Error_Kind ("get_resolved", Obj);
+ end case;
+
+ Obj_Type := Get_Type (Obj);
+ if Get_Kind (Obj_Type) in Iir_Kinds_Subtype_Definition then
+ return Get_Resolution_Indication (Obj_Type);
+ else
+ return Null_Iir;
+ end if;
+ end Get_Resolver;
+
+ -- Return TRUE iff the actual of ASSOC can be the formal.
+ -- ASSOC must be an association_element_by_expression.
+ function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean
+ is
+ Actual : Iir;
+ Actual_Res : Iir;
+ Formal_Res : Iir;
+ Formal_Base : Iir;
+ Actual_Base : Iir;
+ begin
+ -- If there is a conversion, signals types are not necessarily
+ -- the same, and sharing is not possible.
+ -- FIXME: optimize type conversions
+ -- (unsigned <-> signed <-> std_ulogic_vector <-> ...)
+ if Get_In_Conversion (Assoc) /= Null_Iir
+ or else Get_Out_Conversion (Assoc) /= Null_Iir
+ then
+ return False;
+ end if;
+
+ -- Here we may assume formal and actual have the same type and the
+ -- same lengths. This is caught at elaboration time.
+
+ Actual := Name_To_Object (Get_Actual (Assoc));
+ if Actual = Null_Iir then
+ -- This is an expression.
+ return False;
+ end if;
+
+ Formal_Base := Get_Object_Prefix (Formal);
+ Actual_Base := Get_Object_Prefix (Actual);
+
+ -- If the formal is of mode IN, then it has no driving value, and its
+ -- effective value is the effective value of the actual.
+ -- Always collapse in this case.
+ if Get_Mode (Formal_Base) = Iir_In_Mode then
+ return True;
+ end if;
+
+ -- Otherwise, these rules are applied:
+ --
+ -- In this table, E means element, S means signal.
+ -- Er means the element is resolved,
+ -- Sr means the signal is resolved (at the signal level).
+ --
+ -- Actual
+ -- | E,S | Er,S | E,Sr | Er,Sr |
+ -- ------+-------+-------+-------+-------+
+ -- E,S |collap | no(3) | no(3) | no(3) |
+ -- ------+-------+-------+-------+-------+
+ -- Er,S | no(1) |if same| no(2) | no(2) |
+ -- Formal ------+-------+-------+-------+-------+
+ -- E,Sr | no(1) | no(2) |if same| no(4) |
+ -- ------+-------+-------+-------+-------+
+ -- Er,Sr | no(1) | no(2) | no(4) |if same|
+ -- ------+-------+-------+-------+-------+
+ --
+ -- Notes: (1): formal may have several sources.
+ -- (2): resolver is not the same.
+ -- (3): this prevents to catch several sources error in instance.
+ -- (4): resolver is not the same, because the types are not the
+ -- same.
+ --
+ -- Furthermore, signals cannot be collapsed if the kind (none, bus or
+ -- register) is not the same.
+ --
+ -- Default value: default value is the effective value.
+
+ -- Resolution function.
+ Actual_Res := Get_Resolver (Actual);
+ Formal_Res := Get_Resolver (Formal);
+
+ -- If the resolutions are not the same, signals cannot be collapsed.
+ if Actual_Res /= Formal_Res then
+ return False;
+ end if;
+
+ -- If neither the actual nor the formal is resolved, then collapsing is
+ -- possible.
+ -- (this is case ES/ES).
+ if Actual_Res = Null_Iir and Formal_Res = Null_Iir then
+ return True;
+ end if;
+
+ -- If the formal can have sources and is guarded, but the actual is
+ -- not guarded (or has not the same kind of guard), signals cannot
+ -- be collapsed.
+ if Get_Signal_Kind (Formal_Base) /= Get_Signal_Kind (Actual_Base) then
+ return False;
+ end if;
+
+ return True;
+ end Can_Collapse_Signals;
+
+ -- INTER_PARENT contains generics interfaces;
+ -- ASSOC_PARENT constains generic aspects.
+ function Sem_Generic_Association_Chain
+ (Inter_Parent : Iir; Assoc_Parent : Iir) return Boolean
+ is
+ El : Iir;
+ Match : Boolean;
+ Assoc_Chain : Iir;
+ Inter_Chain : Iir;
+ Miss : Missing_Type;
+ begin
+ -- LRM08 6.5.6.2 Generic clauses
+ -- If no such actual is specified for a given formal generic constant
+ -- (either because the formal generic is unassociated or because the
+ -- actual is open), and if a default expression is specified for that
+ -- generic, the value of this expression is the value of the generic.
+ -- It is an error if no actual is specified for a given formal generic
+ -- constant and no default expression is present in the corresponding
+ -- interface element.
+
+ -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
+ -- true if parent is a component instantiation.
+ case Get_Kind (Assoc_Parent) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ -- LRM 9.6 Component Instantiation Statement
+ -- Each local generic (or subelement or slice thereof) must be
+ -- associated {VHDL87: exactly}{VHDL93: at most} once.
+ -- ...
+ -- Each local port (or subelement or slice therof) must be
+ -- associated {VHDL87: exactly}{VHDL93: at most} once.
+
+ -- GHDL: for a direct instantiation, follow rules of
+ -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
+ if Flags.Vhdl_Std = Vhdl_87
+ or else Get_Kind (Inter_Parent) = Iir_Kind_Entity_Declaration
+ then
+ Miss := Missing_Generic;
+ else
+ Miss := Missing_Allowed;
+ end if;
+ when Iir_Kind_Binding_Indication =>
+ -- LRM 5.2.1.2 Generic map and port map aspects
+ Miss := Missing_Allowed;
+ when Iir_Kind_Block_Header =>
+ Miss := Missing_Generic;
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ -- LRM08 4.9
+ -- Each formal generic (or member thereof) shall be associated
+ -- at most once.
+ Miss := Missing_Generic;
+ when others =>
+ Error_Kind ("sem_generic_association_list", Assoc_Parent);
+ end case;
+
+ -- The generics
+ Inter_Chain := Get_Generic_Chain (Inter_Parent);
+ Assoc_Chain := Get_Generic_Map_Aspect_Chain (Assoc_Parent);
+
+ -- Extract non-object associations, as the actual cannot be analyzed
+ -- as an expression.
+ Assoc_Chain := Extract_Non_Object_Association (Assoc_Chain, Inter_Chain);
+ Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
+
+ if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
+ return False;
+ end if;
+
+ Sem_Association_Chain
+ (Inter_Chain, Assoc_Chain, True, Miss, Assoc_Parent, Match);
+ Set_Generic_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
+ if not Match then
+ return False;
+ end if;
+
+ -- LRM 5.2.1.2 Generic map and port map aspects
+ -- An actual associated with a formal generic map aspect must be an
+ -- expression or the reserved word open;
+ El := Assoc_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ Check_Read (Get_Actual (El));
+ when Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Package =>
+ null;
+ when others =>
+ Error_Kind ("sem_generic_map_association_chain(1)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ return True;
+ end Sem_Generic_Association_Chain;
+
+ procedure Sem_Generic_Association_Chain
+ (Inter_Parent : Iir; Assoc_Parent : Iir)
+ is
+ Res : Boolean;
+ pragma Unreferenced (Res);
+ begin
+ Res := Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
+ end Sem_Generic_Association_Chain;
+
+ -- INTER_PARENT contains ports interfaces;
+ -- ASSOC_PARENT constains ports map aspects.
+ procedure Sem_Port_Association_Chain
+ (Inter_Parent : Iir; Assoc_Parent : Iir)
+ is
+ El : Iir;
+ Actual : Iir;
+ Prefix : Iir;
+ Object : Iir;
+ Match : Boolean;
+ Assoc_Chain : Iir;
+ Miss : Missing_Type;
+ Inter : Iir;
+ Formal : Iir;
+ Formal_Base : Iir;
+ begin
+ -- Note: CHECK_MATCH argument of sem_subprogram_arguments must be
+ -- true if parent is a component instantiation.
+ case Get_Kind (Assoc_Parent) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ -- LRM 9.6 Component Instantiation Statement
+ -- Each local generic (or subelement or slice thereof) must be
+ -- associated {VHDL87: exactly}{VHDL93: at most} once.
+ -- ...
+ -- Each local port (or subelement or slice therof) must be
+ -- associated {VHDL87: exactly}{VHDL93: at most} once.
+
+ -- GHDL: for a direct instantiation, follow rules of
+ -- LRM 1.1.1.1 Generic and LRM 1.1.1.2 Ports.
+ if Flags.Vhdl_Std = Vhdl_87
+ or else Get_Kind (Inter_Parent) = Iir_Kind_Entity_Declaration
+ then
+ Miss := Missing_Port;
+ else
+ Miss := Missing_Allowed;
+ end if;
+ when Iir_Kind_Binding_Indication =>
+ -- LRM 5.2.1.2 Generic map and port map aspects
+ Miss := Missing_Allowed;
+ when Iir_Kind_Block_Header =>
+ -- FIXME: it is possible to have port unassociated ?
+ Miss := Missing_Port;
+ when others =>
+ Error_Kind ("sem_port_association_list", Assoc_Parent);
+ end case;
+
+ -- The ports
+ Assoc_Chain := Get_Port_Map_Aspect_Chain (Assoc_Parent);
+ if not Sem_Actual_Of_Association_Chain (Assoc_Chain) then
+ return;
+ end if;
+ Sem_Association_Chain (Get_Port_Chain (Inter_Parent), Assoc_Chain,
+ True, Miss, Assoc_Parent, Match);
+ Set_Port_Map_Aspect_Chain (Assoc_Parent, Assoc_Chain);
+ if not Match then
+ return;
+ end if;
+
+ -- LRM 5.2.1.2 Generic map and port map aspects
+ -- [...]; an actual associated with a formal port in a port map aspect
+ -- must be a signal, an expression, or the reserved word open.
+ --
+ -- Certain restriction apply to the actual associated with a formal in
+ -- a port map aspect; these restrictions are described in 1.1.1.2
+
+ -- LRM93 1.1.1.2
+ -- The actual, if a port or signal, must be denoted by a static name.
+ -- The actual, if an expression, must be a globally static expression.
+ El := Assoc_Chain;
+ Inter := Get_Port_Chain (Inter_Parent);
+ while El /= Null_Iir loop
+ Formal := Get_Formal (El);
+
+ if Formal = Null_Iir then
+ -- No formal: use association by position.
+ Formal := Inter;
+ Formal_Base := Inter;
+ Inter := Get_Chain (Inter);
+ else
+ Inter := Null_Iir;
+ Formal_Base := Get_Association_Interface (El);
+ end if;
+
+ if Get_Kind (El) = Iir_Kind_Association_Element_By_Expression then
+ Actual := Get_Actual (El);
+ -- There has been an error, exit from the loop.
+ exit when Actual = Null_Iir;
+ Object := Name_To_Object (Actual);
+ if Object = Null_Iir then
+ Prefix := Actual;
+ else
+ Prefix := Get_Object_Prefix (Object);
+ end if;
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kinds_Signal_Attribute =>
+ -- Port or signal.
+ Set_Collapse_Signal_Flag
+ (El, Can_Collapse_Signals (El, Formal));
+ if Get_Name_Staticness (Object) < Globally then
+ Error_Msg_Sem ("actual must be a static name", Actual);
+ end if;
+ if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration
+ then
+ declare
+ P : Boolean;
+ pragma Unreferenced (P);
+ begin
+ P := Check_Port_Association_Restriction
+ (Formal_Base, Prefix, El);
+ end;
+ end if;
+ when others =>
+ -- Expression.
+ Set_Collapse_Signal_Flag (El, False);
+
+ -- If there is an IN conversion, re-integrate it into
+ -- the actual.
+ declare
+ In_Conv : Iir;
+ begin
+ In_Conv := Get_In_Conversion (El);
+ if In_Conv /= Null_Iir then
+ Set_In_Conversion (El, Null_Iir);
+ Set_Expr_Staticness
+ (In_Conv, Get_Expr_Staticness (Actual));
+ Actual := In_Conv;
+ Set_Actual (El, Actual);
+ end if;
+ end;
+ if Flags.Vhdl_Std >= Vhdl_93c then
+ -- LRM93 1.1.1.2 Ports
+ -- Moreover, the ports of a block may be associated
+ -- with an expression, in order to provide these ports
+ -- with constant driving values; such ports must be
+ -- of mode in.
+ if Get_Mode (Formal_Base) /= Iir_In_Mode then
+ Error_Msg_Sem ("only 'in' ports may be associated "
+ & "with expression", El);
+ end if;
+
+ -- LRM93 1.1.1.2 Ports
+ -- The actual, if an expression, must be a globally
+ -- static expression.
+ if Get_Expr_Staticness (Actual) < Globally then
+ Error_Msg_Sem
+ ("actual expression must be globally static",
+ Actual);
+ end if;
+ else
+ Error_Msg_Sem
+ ("cannot associate ports with expression in vhdl87",
+ El);
+ end if;
+ end case;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Sem_Port_Association_Chain;
+
+ -- INTER_PARENT contains generics and ports interfaces;
+ -- ASSOC_PARENT constains generics and ports map aspects.
+ procedure Sem_Generic_Port_Association_Chain
+ (Inter_Parent : Iir; Assoc_Parent : Iir)
+ is
+ Res : Boolean;
+ pragma Unreferenced (Res);
+ begin
+ Sem_Generic_Association_Chain (Inter_Parent, Assoc_Parent);
+ Sem_Port_Association_Chain (Inter_Parent, Assoc_Parent);
+ end Sem_Generic_Port_Association_Chain;
+
+ -- LRM 1.3 Configuration Declarations.
+ procedure Sem_Configuration_Declaration (Decl: Iir)
+ is
+ Entity: Iir_Entity_Declaration;
+ Entity_Unit : Iir_Design_Unit;
+ begin
+ Xref_Decl (Decl);
+
+ -- LRM 1.3
+ -- The entity name identifies the name of the entity declaration that
+ -- defines the design entity at the apex of the design hierarchy.
+ Entity := Sem_Entity_Name (Decl);
+ if Entity = Null_Iir then
+ return;
+ end if;
+ Entity_Unit := Get_Design_Unit (Entity);
+
+ -- LRM 11.4
+ -- A primary unit whose name is referenced within a given design unit
+ -- must be analyzed prior to the analysis of the given design unit.
+ Add_Dependence (Entity_Unit);
+
+ Sem_Scopes.Add_Name (Decl);
+
+ Set_Visible_Flag (Decl, True);
+
+ -- LRM 10.1 Declarative Region
+ -- 2. A configuration declaration.
+ Open_Declarative_Region;
+
+ -- LRM93 10.2
+ -- In addition to the above rules, the scope of any declaration that
+ -- includes the end of the declarative part of a given block (wether
+ -- it be an external block defined by a design entity or an internal
+ -- block defined by a block statement) extends into a configuration
+ -- declaration that configures the given block.
+ Add_Context_Clauses (Entity_Unit);
+ Sem_Scopes.Add_Entity_Declarations (Entity);
+
+ Sem_Declaration_Chain (Decl);
+ -- GHDL: no need to check for missing subprogram bodies, since they are
+ -- not allowed in configuration declarations.
+
+ Sem_Block_Configuration (Get_Block_Configuration (Decl), Decl);
+ Close_Declarative_Region;
+ end Sem_Configuration_Declaration;
+
+ -- LRM 1.3.1 Block Configuration.
+ -- FATHER is the block_configuration, configuration_declaration,
+ -- component_configuration containing the block_configuration BLOCK_CONF.
+ procedure Sem_Block_Configuration
+ (Block_Conf : Iir_Block_Configuration; Father: Iir)
+ is
+ El : Iir;
+ Block : Iir;
+ begin
+ case Get_Kind (Father) is
+ when Iir_Kind_Configuration_Declaration =>
+ -- LRM93 1.3.1
+ -- If a block configuration appears immediately within a
+ -- configuration declaration, then the block specification of that
+ -- block configuration must be an architecture name, and that
+ -- architecture name must denote a design entity body whose
+ -- interface is defined by the entity declaration denoted by the
+ -- entity name of the enclosing configuration declaration.
+ declare
+ Block_Spec : Iir;
+ Arch : Iir_Architecture_Body;
+ Design: Iir_Design_Unit;
+ begin
+ Block_Spec := Get_Block_Specification (Block_Conf);
+ -- FIXME: handle selected name.
+ if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem ("architecture name expected", Block_Spec);
+ return;
+ end if;
+ -- LRM 10.3 rule b)
+ -- For an architecture body associated with a given entity
+ -- declaration: at the place of the block specification in a
+ -- block configuration for an external block whose interface
+ -- is defined by that entity declaration.
+ Design := Libraries.Load_Secondary_Unit
+ (Get_Design_Unit (Get_Entity (Father)),
+ Get_Identifier (Block_Spec),
+ Block_Conf);
+ if Design = Null_Iir then
+ Error_Msg_Sem
+ ("no architecture '" & Image_Identifier (Block_Spec) & "'",
+ Block_Conf);
+ return;
+ end if;
+ Arch := Get_Library_Unit (Design);
+ Xref_Ref (Block_Spec, Arch);
+ Free_Iir (Block_Spec);
+ Set_Block_Specification (Block_Conf, Arch);
+ Block := Arch;
+ Add_Dependence (Design);
+ end;
+
+ when Iir_Kind_Component_Configuration =>
+ -- LRM93 1.3.1
+ -- If a block configuration appears immediately within a component
+ -- configuration, then the corresponding components must be
+ -- fully bound, the block specification of that block
+ -- configuration must be an architecture name, and that
+ -- architecture name must denote the same architecture body as
+ -- that to which the corresponding components are bound.
+ declare
+ Block_Spec : Iir;
+ Arch : Iir_Architecture_Body;
+ Design: Iir_Design_Unit;
+ Entity_Aspect : Iir;
+ Comp_Arch : Iir;
+ begin
+ Entity_Aspect :=
+ Get_Entity_Aspect (Get_Binding_Indication (Father));
+ if Entity_Aspect = Null_Iir or else
+ Get_Kind (Entity_Aspect) /= Iir_Kind_Entity_Aspect_Entity
+ then
+ Error_Msg_Sem ("corresponding component not fully bound",
+ Block_Conf);
+ end if;
+
+ Block_Spec := Get_Block_Specification (Block_Conf);
+ -- FIXME: handle selected name.
+ if Get_Kind (Block_Spec) /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem ("architecture name expected", Block_Spec);
+ return;
+ end if;
+
+ Comp_Arch := Get_Architecture (Entity_Aspect);
+ if Comp_Arch /= Null_Iir then
+ if Get_Kind (Comp_Arch) /= Iir_Kind_Simple_Name then
+ raise Internal_Error;
+ end if;
+ if Get_Identifier (Comp_Arch) /= Get_Identifier (Block_Spec)
+ then
+ Error_Msg_Sem
+ ("block specification name is different from "
+ & "component architecture name", Block_Spec);
+ return;
+ end if;
+ end if;
+
+ Design := Libraries.Load_Secondary_Unit
+ (Get_Design_Unit (Get_Entity (Entity_Aspect)),
+ Get_Identifier (Block_Spec),
+ Block_Conf);
+ if Design = Null_Iir then
+ Error_Msg_Sem
+ ("no architecture '" & Image_Identifier (Block_Spec) & "'",
+ Block_Conf);
+ return;
+ end if;
+ Arch := Get_Library_Unit (Design);
+ Xref_Ref (Block_Spec, Arch);
+ Free_Iir (Block_Spec);
+ Set_Block_Specification (Block_Conf, Arch);
+ Block := Arch;
+ end;
+
+ when Iir_Kind_Block_Configuration =>
+ -- LRM93 1.3.1
+ -- If a block configuration appears immediately within another
+ -- block configuration, then the block specification of the
+ -- contained block configuration must be a block statement or
+ -- generate statement label, and the label must denote a block
+ -- statement or generate statement that is contained immediatly
+ -- within the block denoted by the block specification of the
+ -- containing block configuration.
+ declare
+ Block_Spec : Iir;
+ Block_Name : Iir;
+ Block_Stmts : Iir;
+ Block_Spec_Kind : Iir_Kind;
+ Prev : Iir_Block_Configuration;
+ begin
+ Block_Spec := Get_Block_Specification (Block_Conf);
+ -- Remember the kind of BLOCK_SPEC, since the node can be free
+ -- by find_declaration if it is a simple name.
+ Block_Spec_Kind := Get_Kind (Block_Spec);
+ case Block_Spec_Kind is
+ when Iir_Kind_Simple_Name =>
+ Block_Name := Block_Spec;
+ when Iir_Kind_Parenthesis_Name =>
+ Block_Name := Get_Prefix (Block_Spec);
+ when Iir_Kind_Slice_Name =>
+ Block_Name := Get_Prefix (Block_Spec);
+ when others =>
+ Error_Msg_Sem ("label expected", Block_Spec);
+ return;
+ end case;
+ Block_Name := Sem_Denoting_Name (Block_Name);
+ Block := Get_Named_Entity (Block_Name);
+ case Get_Kind (Block) is
+ when Iir_Kind_Block_Statement =>
+ if Block_Spec_Kind /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem
+ ("label does not denote a generate statement",
+ Block_Spec);
+ end if;
+ Prev := Get_Block_Block_Configuration (Block);
+ if Prev /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (Block) & " was already configured at "
+ & Disp_Location (Prev),
+ Block_Conf);
+ return;
+ end if;
+ Set_Block_Block_Configuration (Block, Block_Conf);
+ when Iir_Kind_Generate_Statement =>
+ if Block_Spec_Kind /= Iir_Kind_Simple_Name
+ and then Get_Kind (Get_Generation_Scheme (Block))
+ /= Iir_Kind_Iterator_Declaration
+ then
+ -- LRM93 1.3
+ -- If the block specification of a block configuration
+ -- contains a generate statement label, and if this
+ -- label contains an index specification, then it is
+ -- an error if the generate statement denoted by the
+ -- label does not have a generation scheme including
+ -- the reserved word for.
+ Error_Msg_Sem ("generate statement does not has a for",
+ Block_Spec);
+ return;
+ end if;
+ Set_Prev_Block_Configuration
+ (Block_Conf, Get_Generate_Block_Configuration (Block));
+ Set_Generate_Block_Configuration (Block, Block_Conf);
+ when others =>
+ Error_Msg_Sem ("block statement label expected",
+ Block_Conf);
+ return;
+ end case;
+ Block_Stmts := Get_Concurrent_Statement_Chain
+ (Get_Block_From_Block_Specification
+ (Get_Block_Specification (Father)));
+ if not Is_In_Chain (Block_Stmts, Block) then
+ Error_Msg_Sem
+ ("label does not denotes an inner block statement",
+ Block_Conf);
+ return;
+ end if;
+
+ if Block_Spec_Kind = Iir_Kind_Parenthesis_Name then
+ Block_Spec := Sem_Index_Specification
+ (Block_Spec, Get_Type (Get_Generation_Scheme (Block)));
+ if Block_Spec /= Null_Iir then
+ Set_Prefix (Block_Spec, Block_Name);
+ Set_Block_Specification (Block_Conf, Block_Spec);
+ Block_Spec_Kind := Get_Kind (Block_Spec);
+ end if;
+ end if;
+
+ case Block_Spec_Kind is
+ when Iir_Kind_Simple_Name =>
+ Set_Block_Specification (Block_Conf, Block_Name);
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name =>
+ null;
+ when Iir_Kind_Parenthesis_Name =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when others =>
+ Error_Kind ("sem_block_configuration", Father);
+ end case;
+
+ -- LRM93 �10.1
+ -- 10. A block configuration
+ Sem_Scopes.Open_Scope_Extension;
+
+ -- LRM 10.3
+ -- In addition, any declaration that is directly visible at the end of
+ -- the declarative part of a given block is directly visible in a block
+ -- configuration that configure the given block. This rule holds unless
+ -- a use clause that makes a homograph of the declaration potentially
+ -- visible (see 10.4) appears in the corresponding configuration
+ -- declaration, and if the scope of that use clause encompasses all or
+ -- part of those configuration items. If such a use clase appears, then
+ -- the declaration will be directly visible within the corresponding
+ -- configuration items, except at hose places that fall within the scope
+ -- of the additional use clause. At such places, neither name will be
+ -- directly visible.
+ -- FIXME: handle use clauses.
+ Sem_Scopes.Extend_Scope_Of_Block_Declarations (Block);
+
+ declare
+ El : Iir;
+ begin
+ El := Get_Declaration_Chain (Block_Conf);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause =>
+ Sem_Use_Clause (El);
+ when others =>
+ -- Parse checks there are only use clauses.
+ raise Internal_Error;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end;
+
+ -- VHDL 87: do not remove configuration specification in generate stmts.
+ Clear_Instantiation_Configuration (Block, False);
+
+ El := Get_Configuration_Item_Chain (Block_Conf);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Block_Configuration =>
+ Sem_Block_Configuration (El, Block_Conf);
+ when Iir_Kind_Component_Configuration =>
+ Sem_Component_Configuration (El, Block_Conf);
+ when others =>
+ Error_Kind ("sem_block_configuration(2)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ Sem_Scopes.Close_Scope_Extension;
+ end Sem_Block_Configuration;
+
+ -- LRM 1.3.2
+ procedure Sem_Component_Configuration
+ (Conf : Iir_Component_Configuration; Father : Iir)
+ is
+ Block : Iir;
+ Configured_Block : Iir;
+ Binding : Iir;
+ Entity : Iir_Design_Unit;
+ Comp : Iir_Component_Declaration;
+ Primary_Entity_Aspect : Iir;
+ begin
+ -- LRM 10.1 Declarative Region
+ -- 11. A component configuration.
+ Open_Declarative_Region;
+
+ -- LRM93 �10.2
+ -- If a component configuration appears as a configuration item
+ -- immediatly within a block configuration that configures a given
+ -- block, and the scope of a given declaration includes the end of the
+ -- declarative part of that block, then the scope of the given
+ -- declaration extends from the beginning to the end of the
+ -- declarative region associated with the given component configuration.
+ -- GHDL: this is for labels of component instantiation statements, and
+ -- for local ports and generics of the component.
+ if Get_Kind (Father) = Iir_Kind_Block_Configuration then
+ Configured_Block := Get_Block_Specification (Father);
+ if Get_Kind (Configured_Block) = Iir_Kind_Design_Unit then
+ raise Internal_Error;
+ end if;
+ Configured_Block :=
+ Get_Block_From_Block_Specification (Configured_Block);
+ Sem_Scopes.Extend_Scope_Of_Block_Declarations (Configured_Block);
+ else
+ -- Can a component configuration not be just inside a block
+ -- configuration ?
+ raise Internal_Error;
+ end if;
+ -- FIXME: this is wrong (all declarations should be considered).
+ Sem_Component_Specification
+ (Configured_Block, Conf, Primary_Entity_Aspect);
+
+ Comp := Get_Named_Entity (Get_Component_Name (Conf));
+ if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
+ -- There has been an error in sem_component_specification.
+ -- Leave here.
+ Close_Declarative_Region;
+ return;
+ end if;
+
+ -- FIXME: (todo)
+ -- If a given component instance is unbound in the corresponding block,
+ -- then any explicit component configuration for that instance that does
+ -- not contain an explicit binding indication will contain an implicit,
+ -- default binding indication (see 5.2.2). Similarly, if a given
+ -- component instance is unbound in the corresponding block, then any
+ -- implicit component configuration for that instance will contain an
+ -- implicit, default binding indication.
+ Open_Declarative_Region;
+ Sem_Scopes.Add_Component_Declarations (Comp);
+ Binding := Get_Binding_Indication (Conf);
+ if Binding /= Null_Iir then
+ Sem_Binding_Indication (Binding, Comp, Conf, Primary_Entity_Aspect);
+
+ if Primary_Entity_Aspect /= Null_Iir then
+ -- LRM93 5.2.1 Binding Indication
+ -- It is an error if a formal port appears in the port map aspect
+ -- of the incremental binding indication and it is a formal
+ -- port that is associated with an actual other than OPEN in one
+ -- of the primary binding indications.
+ declare
+ Inst : Iir;
+ Primary_Binding : Iir;
+ F_Chain : Iir;
+ F_El, S_El : Iir;
+ Formal : Iir;
+ begin
+ Inst := Get_Concurrent_Statement_Chain (Configured_Block);
+ while Inst /= Null_Iir loop
+ if Get_Kind (Inst)
+ = Iir_Kind_Component_Instantiation_Statement
+ and then Get_Component_Configuration (Inst) = Conf
+ then
+ -- Check here.
+ Primary_Binding := Get_Binding_Indication
+ (Get_Configuration_Specification (Inst));
+ F_Chain := Get_Port_Map_Aspect_Chain (Primary_Binding);
+ S_El := Get_Port_Map_Aspect_Chain (Binding);
+ while S_El /= Null_Iir loop
+ -- Find S_EL formal in F_CHAIN.
+ Formal := Get_Association_Interface (S_El);
+ F_El := F_Chain;
+ while F_El /= Null_Iir loop
+ exit when Get_Association_Interface (F_El) = Formal;
+ F_El := Get_Chain (F_El);
+ end loop;
+ if F_El /= Null_Iir
+ and then Get_Kind (F_El)
+ /= Iir_Kind_Association_Element_Open
+ then
+ Error_Msg_Sem
+ (Disp_Node (Formal)
+ & " already associated in primary binding",
+ S_El);
+ end if;
+ S_El := Get_Chain (S_El);
+ end loop;
+ end if;
+ Inst := Get_Chain (Inst);
+ end loop;
+ end;
+ end if;
+ elsif Primary_Entity_Aspect = Null_Iir then
+ -- LRM93 5.2.1
+ -- If the generic map aspect or port map aspect of a primary binding
+ -- indication is not present, then the default rules as described
+ -- in 5.2.2 apply.
+
+ -- Create a default binding indication.
+ Entity := Get_Visible_Entity_Declaration (Comp);
+ Binding := Sem_Create_Default_Binding_Indication
+ (Comp, Entity, Conf, False);
+
+ if Binding /= Null_Iir then
+ -- Remap to defaults.
+ Set_Default_Entity_Aspect (Binding, Get_Entity_Aspect (Binding));
+ Set_Entity_Aspect (Binding, Null_Iir);
+
+ Set_Default_Generic_Map_Aspect_Chain
+ (Binding, Get_Generic_Map_Aspect_Chain (Binding));
+ Set_Generic_Map_Aspect_Chain (Binding, Null_Iir);
+
+ Set_Default_Port_Map_Aspect_Chain
+ (Binding, Get_Port_Map_Aspect_Chain (Binding));
+ Set_Port_Map_Aspect_Chain (Binding, Null_Iir);
+
+ Set_Binding_Indication (Conf, Binding);
+ end if;
+ end if;
+ Close_Declarative_Region;
+
+ -- External block.
+ Block := Get_Block_Configuration (Conf);
+ if Block /= Null_Iir and then Binding /= Null_Iir then
+ Sem_Block_Configuration (Block, Conf);
+ end if;
+ Close_Declarative_Region;
+ end Sem_Component_Configuration;
+
+ function Are_Trees_Chain_Equal (Left, Right : Iir) return Boolean
+ is
+ El_Left, El_Right : Iir;
+ begin
+ if Left = Right then
+ return True;
+ end if;
+ El_Left := Left;
+ El_Right := Right;
+ loop
+ if El_Left = Null_Iir and El_Right = Null_Iir then
+ return True;
+ end if;
+ if El_Left = Null_Iir or El_Right = Null_Iir then
+ return False;
+ end if;
+ if not Are_Trees_Equal (El_Left, El_Right) then
+ return False;
+ end if;
+ El_Left := Get_Chain (El_Left);
+ El_Right := Get_Chain (El_Right);
+ end loop;
+ end Are_Trees_Chain_Equal;
+
+ -- Return TRUE iff LEFT and RIGHT are (in depth) equal.
+ -- This corresponds to conformance rules, LRM93 2.7
+ function Are_Trees_Equal (Left, Right : Iir) return Boolean
+ is
+ El_Left, El_Right : Iir;
+ begin
+ -- Short-cut to speed up.
+ if Left = Right then
+ return True;
+ end if;
+
+ -- Handle null_iir.
+ if Left = Null_Iir or Right = Null_Iir then
+ -- Note: LEFT *xor* RIGHT is null_iir.
+ return False;
+ end if;
+
+ -- LRM 2.7 Conformance Rules
+ -- A simple name can be replaced by an expanded name in which this
+ -- simple name is the selector, if and only if at both places the
+ -- meaning of the simple name is given by the same declaration.
+ case Get_Kind (Left) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ case Get_Kind (Right) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Are_Trees_Equal (Get_Named_Entity (Left),
+ Get_Named_Entity (Right));
+ when others =>
+ return False;
+ end case;
+ when others =>
+ null;
+ end case;
+
+ -- If nodes are not of the same kind, then they are not equals!
+ if Get_Kind (Left) /= Get_Kind (Right) then
+ return False;
+ end if;
+
+ case Get_Kind (Left) is
+ when Iir_Kinds_Procedure_Declaration =>
+ return Are_Trees_Chain_Equal
+ (Get_Interface_Declaration_Chain (Left),
+ Get_Interface_Declaration_Chain (Right));
+ when Iir_Kinds_Function_Declaration =>
+ if not Are_Trees_Equal (Get_Return_Type (Left),
+ Get_Return_Type (Right))
+ then
+ return False;
+ end if;
+ if Get_Pure_Flag (Left) /= Get_Pure_Flag (Right) then
+ return False;
+ end if;
+ if not Are_Trees_Chain_Equal
+ (Get_Interface_Declaration_Chain (Left),
+ Get_Interface_Declaration_Chain (Right))
+ then
+ return False;
+ end if;
+ return True;
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ if Get_Identifier (Left) /= Get_Identifier (Right) then
+ return False;
+ end if;
+ if Get_Lexical_Layout (Left) /= Get_Lexical_Layout (Right)
+ or else Get_Mode (Left) /= Get_Mode (Right)
+ then
+ return False;
+ end if;
+ if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then
+ return False;
+ end if;
+ El_Left := Get_Default_Value (Left);
+ El_Right := Get_Default_Value (Right);
+ if (El_Left = Null_Iir) xor (El_Right = Null_Iir) then
+ return False;
+ end if;
+ if El_Left /= Null_Iir
+ and then Are_Trees_Equal (El_Left, El_Right) = False
+ then
+ return False;
+ end if;
+ return True;
+
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ if Get_Base_Type (Left) /= Get_Base_Type (Right) then
+ return False;
+ end if;
+ if Get_Type_Declarator (Left) /= Get_Type_Declarator (Right) then
+ return False;
+ end if;
+ if not Are_Trees_Equal (Get_Resolution_Indication (Left),
+ Get_Resolution_Indication (Right))
+ then
+ return False;
+ end if;
+ if Are_Trees_Equal (Get_Range_Constraint (Left),
+ Get_Range_Constraint (Right)) = False
+ then
+ return False;
+ end if;
+ return True;
+ when Iir_Kind_Array_Subtype_Definition =>
+ if Get_Base_Type (Left) /= Get_Base_Type (Right) then
+ return False;
+ end if;
+ if not Are_Trees_Equal (Get_Resolution_Indication (Left),
+ Get_Resolution_Indication (Right))
+ then
+ return False;
+ end if;
+ declare
+ L_Left, L_Right : Iir_List;
+ begin
+ L_Left := Get_Index_Subtype_List (Left);
+ L_Right := Get_Index_Subtype_List (Right);
+ for I in Natural loop
+ El_Left := Get_Nth_Element (L_Left, I);
+ El_Right := Get_Nth_Element (L_Right, I);
+ exit when El_Left = Null_Iir;
+ if not Are_Trees_Equal (El_Left, El_Right) then
+ return False;
+ end if;
+ end loop;
+ end;
+ return True;
+ when Iir_Kind_Record_Subtype_Definition =>
+ if Get_Base_Type (Left) /= Get_Base_Type (Right) then
+ return False;
+ end if;
+ if not Are_Trees_Equal (Get_Resolution_Indication (Left),
+ Get_Resolution_Indication (Right))
+ then
+ return False;
+ end if;
+ declare
+ L_Left, L_Right : Iir_List;
+ begin
+ L_Left := Get_Elements_Declaration_List (Left);
+ L_Right := Get_Elements_Declaration_List (Right);
+ for I in Natural loop
+ El_Left := Get_Nth_Element (L_Left, I);
+ El_Right := Get_Nth_Element (L_Right, I);
+ exit when El_Left = Null_Iir;
+ if not Are_Trees_Equal (El_Left, El_Right) then
+ return False;
+ end if;
+ end loop;
+ end;
+ return True;
+
+ when Iir_Kind_Integer_Literal =>
+ if Get_Value (Left) /= Get_Value (Right) then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Literal_Origin (Left),
+ Get_Literal_Origin (Right));
+ when Iir_Kind_Enumeration_Literal =>
+ if Get_Enum_Pos (Left) /= Get_Enum_Pos (Right) then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Literal_Origin (Left),
+ Get_Literal_Origin (Right));
+ when Iir_Kind_Physical_Int_Literal =>
+ if Get_Value (Left) /= Get_Value (Right)
+ or else not Are_Trees_Equal (Get_Unit_Name (Left),
+ Get_Unit_Name (Right))
+ then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Literal_Origin (Left),
+ Get_Literal_Origin (Right));
+ when Iir_Kind_Physical_Fp_Literal =>
+ if Get_Fp_Value (Left) /= Get_Fp_Value (Right)
+ or else Get_Unit_Name (Left) /= Get_Unit_Name (Right)
+ then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Literal_Origin (Left),
+ Get_Literal_Origin (Right));
+ when Iir_Kind_Floating_Point_Literal =>
+ if Get_Fp_Value (Left) /= Get_Fp_Value (Right) then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Literal_Origin (Left),
+ Get_Literal_Origin (Right));
+
+ when Iir_Kinds_Dyadic_Operator =>
+ return Are_Trees_Equal (Get_Left (Left), Get_Left (Right))
+ and then Are_Trees_Equal (Get_Right (Left), Get_Right (Right));
+ when Iir_Kinds_Monadic_Operator =>
+ return Are_Trees_Equal (Get_Operand (Left), Get_Operand (Right));
+
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_File_Type_Definition =>
+ return Left = Right;
+
+ when Iir_Kind_Range_Expression =>
+ if Get_Type (Left) /= Get_Type (Right)
+ or else Get_Direction (Left) /= Get_Direction (Right)
+ then
+ return False;
+ end if;
+ if not Are_Trees_Equal (Get_Left_Limit (Left),
+ Get_Left_Limit (Right))
+ or else not Are_Trees_Equal (Get_Right_Limit (Left),
+ Get_Right_Limit (Right))
+ then
+ return False;
+ end if;
+ return True;
+
+ when Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute =>
+ return Are_Trees_Equal (Get_Prefix (Left), Get_Prefix (Right));
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ if Get_Kind (Left) = Iir_Kind_Bit_String_Literal
+ and then Get_Bit_String_Base (Left)
+ /= Get_Bit_String_Base (Right)
+ then
+ return False;
+ end if;
+ declare
+ use Str_Table;
+ Len : Nat32;
+ L_Ptr : String_Fat_Acc;
+ R_Ptr : String_Fat_Acc;
+ begin
+ Len := Get_String_Length (Left);
+ if Get_String_Length (Right) /= Len then
+ return False;
+ end if;
+ L_Ptr := Get_String_Fat_Acc (Get_String_Id (Left));
+ R_Ptr := Get_String_Fat_Acc (Get_String_Id (Right));
+ for I in 1 .. Len loop
+ if L_Ptr (I) /= R_Ptr (I) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end;
+
+ when Iir_Kind_Aggregate =>
+ if not Are_Trees_Equal (Get_Type (Left), Get_Type (Right)) then
+ return False;
+ end if;
+ declare
+ El_L, El_R : Iir;
+ begin
+ El_L := Get_Association_Choices_Chain (Left);
+ El_R := Get_Association_Choices_Chain (Right);
+ loop
+ exit when El_L = Null_Iir and El_R = Null_Iir;
+ if not Are_Trees_Equal (El_L, El_R) then
+ return False;
+ end if;
+ El_L := Get_Chain (El_L);
+ El_R := Get_Chain (El_R);
+ end loop;
+ return True;
+ end;
+
+ when Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Others =>
+ return Are_Trees_Equal (Get_Associated_Expr (Left),
+ Get_Associated_Expr (Right));
+ when Iir_Kind_Choice_By_Name =>
+ if not Are_Trees_Equal (Get_Choice_Name (Left),
+ Get_Choice_Name (Right))
+ then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Associated_Expr (Left),
+ Get_Associated_Expr (Right));
+ when Iir_Kind_Choice_By_Expression =>
+ if not Are_Trees_Equal (Get_Choice_Expression (Left),
+ Get_Choice_Expression (Right)) then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Associated_Expr (Left),
+ Get_Associated_Expr (Right));
+ when Iir_Kind_Choice_By_Range =>
+ if not Are_Trees_Equal (Get_Choice_Range (Left),
+ Get_Choice_Range (Right)) then
+ return False;
+ end if;
+ return Are_Trees_Equal (Get_Associated_Expr (Left),
+ Get_Associated_Expr (Right));
+ when Iir_Kind_Character_Literal =>
+ return Are_Trees_Equal (Get_Named_Entity (Left),
+ Get_Named_Entity (Right));
+ when others =>
+ Error_Kind ("are_trees_equal", Left);
+ end case;
+ end Are_Trees_Equal;
+
+ -- LRM 2.7 Conformance Rules.
+ procedure Check_Conformance_Rules (Subprg, Spec: Iir) is
+ begin
+ if not Are_Trees_Equal (Subprg, Spec) then
+ -- FIXME: should explain why it does not conform ?
+ Error_Msg_Sem ("body of " & Disp_Node (Subprg)
+ & " does not conform with specification at "
+ & Disp_Location (Spec), Subprg);
+ end if;
+ end Check_Conformance_Rules;
+
+ -- Return the specification corresponding to a declaration DECL, or
+ -- null_Iir if none.
+ -- FIXME: respect rules of LRM93 2.7
+ function Find_Subprogram_Specification (Decl: Iir) return Iir
+ is
+ Interpretation : Name_Interpretation_Type;
+ Decl1: Iir;
+ Hash : Iir_Int32;
+ Kind : Iir_Kind;
+ begin
+ Hash := Get_Subprogram_Hash (Decl);
+ Interpretation := Get_Interpretation (Get_Identifier (Decl));
+ while Valid_Interpretation (Interpretation) loop
+ if not Is_In_Current_Declarative_Region (Interpretation) then
+ -- The declaration does not belong to the current declarative
+ -- region, neither will the following one. So, we do not found
+ -- it.
+ return Null_Iir;
+ end if;
+ Decl1 := Get_Declaration (Interpretation);
+ Kind := Get_Kind (Decl1);
+ -- Should be sure DECL1 and DECL belongs to the same declarative
+ -- region, ie DECL1 was not made visible via a USE clause.
+ --
+ -- Also, only check for explicitly subprograms (and not
+ -- implicit one).
+ if (Kind = Iir_Kind_Function_Declaration
+ or Kind = Iir_Kind_Procedure_Declaration)
+ and then not Is_Potentially_Visible (Interpretation)
+ and then Get_Subprogram_Hash (Decl1) = Hash
+ and then Is_Same_Profile (Decl, Decl1)
+ then
+ return Decl1;
+ end if;
+ Interpretation := Get_Next_Interpretation (Interpretation);
+ end loop;
+ return Null_Iir;
+ end Find_Subprogram_Specification;
+
+ procedure Set_Subprogram_Overload_Number (Decl : Iir)
+ is
+ Id : constant Name_Id := Get_Identifier (Decl);
+ Inter : Name_Interpretation_Type;
+ Prev : Iir;
+ Num : Iir_Int32;
+ begin
+ Inter := Get_Interpretation (Id);
+ while Valid_Interpretation (Inter)
+ and then Is_In_Current_Declarative_Region (Inter)
+ loop
+ -- There is a previous declaration with the same name in the
+ -- current declarative region.
+ Prev := Get_Declaration (Inter);
+ case Get_Kind (Prev) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- The previous declaration is a user subprogram.
+ Num := Get_Overload_Number (Prev) + 1;
+ if Num = 1
+ and then Get_Parent (Prev) = Get_Parent (Decl)
+ then
+ -- The previous was not (yet) overloaded. Mark it as
+ -- overloaded.
+ -- Do not mark it if it is not in the same declarative part.
+ -- (ie, do not change a subprogram declaration in the
+ -- package while analyzing the body).
+ Set_Overload_Number (Prev, 1);
+ Num := 2;
+ end if;
+ Set_Overload_Number (Decl, Num);
+ return;
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ -- Implicit declarations aren't taken into account (as they
+ -- are mangled differently).
+ Inter := Get_Next_Interpretation (Inter);
+ when Iir_Kind_Enumeration_Literal =>
+ -- Enumeration literal are ignored for overload number.
+ Inter := Get_Next_Interpretation (Inter);
+ when others =>
+ -- An error ?
+ Set_Overload_Number (Decl, 0);
+ return;
+ end case;
+ end loop;
+ -- No previous declaration in the current declarative region.
+ Set_Overload_Number (Decl, 0);
+ end Set_Subprogram_Overload_Number;
+
+ -- Check requirements on number of interfaces for subprogram specification
+ -- SUBPRG. Requirements only concern operators, and are defined in
+ -- LRM 2.3.1
+ procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir)
+ is
+ use Std_Names;
+
+ Nbr_Interfaces : Natural;
+ Is_Method : Boolean;
+ begin
+ Nbr_Interfaces := Iir_Chains.Get_Chain_Length
+ (Get_Interface_Declaration_Chain (Subprg));
+
+ -- For vhdl-02, the protected variable is an implicit parameter.
+ if Flags.Vhdl_Std >= Vhdl_02
+ and then Is_Subprogram_Method (Subprg)
+ then
+ Nbr_Interfaces := Nbr_Interfaces + 1;
+ else
+ Is_Method := False;
+ end if;
+
+ case Id is
+ when Name_Abs
+ | Name_Not =>
+ -- LRM93 2.3.1
+ -- The subprogram specification of a unary operator must have a
+ -- single parameter.
+
+ -- LRM02 2.3.1
+ -- ..., unless the subprogram specification is a method (see
+ -- 3.5.1) of a protected type. In this latter case, the
+ -- subprogram specification must have no parameters.
+ if Nbr_Interfaces = 1 then
+ return;
+ end if;
+ Error_Msg_Sem ("unary operator must have a single parameter",
+ Subprg);
+ when Name_Mod
+ | Name_Rem
+ | Name_Op_Mul
+ | Name_Op_Div
+ | Name_Relational_Operators
+ | Name_Op_Concatenation
+ | Name_Shift_Operators
+ | Name_Op_Exp =>
+ -- LRM93 2.3.1
+ -- The subprogram specification of a binary operator must have
+ -- two parameters.
+
+ -- LRM02 2.3.1
+ -- ..., unless the subprogram specification is a method of a
+ -- protected type, in which case, the subprogram specification
+ -- must have a single parameter.
+ if Nbr_Interfaces = 2 then
+ return;
+ end if;
+ Error_Msg_Sem
+ ("binary operators must have two parameters", Subprg);
+ when Name_Logical_Operators
+ | Name_Xnor =>
+ -- LRM08 4.5.2 Operator overloading
+ -- For each of the "+", "-", "and", "or", "xor", "nand", "nor"
+ -- and "xnor", overloading is allowed both as a unary operator
+ -- and as a binary operator.
+ if Nbr_Interfaces = 2 then
+ return;
+ end if;
+ if Nbr_Interfaces = 1 then
+ if Vhdl_Std >= Vhdl_08 then
+ return;
+ end if;
+ Error_Msg_Sem
+ ("logical operators must have two parameters before vhdl08",
+ Subprg);
+ else
+ Error_Msg_Sem
+ ("logical operators must have two parameters", Subprg);
+ end if;
+ when Name_Op_Plus
+ | Name_Op_Minus =>
+ -- LRM93 2.3.1
+ -- For each of the operators "+" and "-", overloading is allowed
+ -- both as a unary operator and as a binary operator.
+ if Nbr_Interfaces in 1 .. 2 then
+ return;
+ end if;
+ Error_Msg_Sem
+ ("""+"" and ""-"" operators must have 1 or 2 parameters",
+ Subprg);
+ when others =>
+ return;
+ end case;
+ if Is_Method then
+ Error_Msg_Sem
+ (" (the protected object is an implicit parameter of methods)",
+ Subprg);
+ end if;
+ end Check_Operator_Requirements;
+
+ procedure Compute_Subprogram_Hash (Subprg : Iir)
+ is
+ type Hash_Type is mod 2**32;
+ function To_Hash is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Hash_Type);
+ function To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Hash_Type, Target => Iir_Int32);
+
+ Kind : Iir_Kind;
+ Hash : Hash_Type;
+ Sig : Hash_Type;
+ Inter : Iir;
+ Itype : Iir;
+ begin
+ Kind := Get_Kind (Subprg);
+ if Kind in Iir_Kinds_Function_Declaration
+ or else Kind = Iir_Kind_Enumeration_Literal
+ then
+ Itype := Get_Base_Type (Get_Return_Type (Subprg));
+ Hash := To_Hash (Itype);
+ Sig := 8;
+ else
+ Sig := 1;
+ Hash := 0;
+ end if;
+
+ if Kind /= Iir_Kind_Enumeration_Literal then
+ Inter := Get_Interface_Declaration_Chain (Subprg);
+ while Inter /= Null_Iir loop
+ Itype := Get_Base_Type (Get_Type (Inter));
+ Sig := Sig + 1;
+ Hash := Hash * 7 + To_Hash (Itype);
+ Hash := Hash + Hash / 2**28;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end if;
+ Set_Subprogram_Hash (Subprg, To_Int32 (Hash + Sig));
+ end Compute_Subprogram_Hash;
+
+ -- LRM 2.1 Subprogram Declarations.
+ procedure Sem_Subprogram_Declaration (Subprg: Iir)
+ is
+ Spec: Iir;
+ Interface_Chain : Iir;
+ Subprg_Body : Iir;
+ Return_Type : Iir;
+ begin
+ -- Set depth.
+ declare
+ Parent : constant Iir := Get_Parent (Subprg);
+ begin
+ case Get_Kind (Parent) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ raise Internal_Error;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Set_Subprogram_Depth
+ (Subprg,
+ Get_Subprogram_Depth
+ (Get_Subprogram_Specification (Parent)) + 1);
+ when others =>
+ Set_Subprogram_Depth (Subprg, 0);
+ end case;
+ end;
+
+ -- LRM 10.1 Declarative Region
+ -- 3. A subprogram declaration, together with the corresponding
+ -- subprogram body.
+ Open_Declarative_Region;
+
+ -- Sem interfaces.
+ Interface_Chain := Get_Interface_Declaration_Chain (Subprg);
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ Sem_Interface_Chain
+ (Interface_Chain, Function_Parameter_Interface_List);
+ Return_Type := Get_Return_Type_Mark (Subprg);
+ Return_Type := Sem_Type_Mark (Return_Type);
+ Set_Return_Type_Mark (Subprg, Return_Type);
+ Set_Return_Type (Subprg, Get_Type (Return_Type));
+ Set_All_Sensitized_State (Subprg, Unknown);
+ when Iir_Kind_Procedure_Declaration =>
+ Sem_Interface_Chain
+ (Interface_Chain, Procedure_Parameter_Interface_List);
+ -- Unless the body is analyzed, the procedure purity is unknown.
+ Set_Purity_State (Subprg, Unknown);
+ -- Check if the procedure is passive.
+ Set_Passive_Flag (Subprg, True);
+ Set_All_Sensitized_State (Subprg, Unknown);
+ declare
+ Inter : Iir;
+ begin
+ Inter := Interface_Chain;
+ while Inter /= Null_Iir loop
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
+ and then Get_Mode (Inter) /= Iir_In_Mode
+ then
+ -- There is a driver for this signal interface.
+ Set_Passive_Flag (Subprg, False);
+ exit;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end;
+ when others =>
+ Error_Kind ("sem_subprogram_declaration", Subprg);
+ end case;
+
+ Check_Operator_Requirements (Get_Identifier (Subprg), Subprg);
+
+ Compute_Subprogram_Hash (Subprg);
+
+ -- The specification has been semantized, close the declarative region
+ -- now.
+ Close_Declarative_Region;
+
+ -- Look if there is an associated body (the next node).
+ Subprg_Body := Get_Chain (Subprg);
+ if Subprg_Body /= Null_Iir
+ and then (Get_Kind (Subprg_Body) = Iir_Kind_Function_Body
+ or else Get_Kind (Subprg_Body) = Iir_Kind_Procedure_Body)
+ then
+ Spec := Find_Subprogram_Specification (Subprg);
+ else
+ Spec := Null_Iir;
+ end if;
+
+ if Spec /= Null_Iir then
+ -- SUBPRG is the body of the specification SPEC.
+ Check_Conformance_Rules (Subprg, Spec);
+ Xref_Body (Subprg, Spec);
+ Set_Subprogram_Body (Subprg, Subprg_Body);
+ Set_Subprogram_Specification (Subprg_Body, Spec);
+ Set_Subprogram_Body (Spec, Subprg_Body);
+ else
+ -- Forward declaration or specification followed by body.
+ Set_Subprogram_Overload_Number (Subprg);
+ Sem_Scopes.Add_Name (Subprg);
+ Name_Visible (Subprg);
+ Xref_Decl (Subprg);
+ end if;
+ end Sem_Subprogram_Declaration;
+
+ procedure Add_Analysis_Checks_List (El : Iir)
+ is
+ Design : constant Iir := Get_Current_Design_Unit;
+ List : Iir_List;
+ begin
+ List := Get_Analysis_Checks_List (Design);
+ if List = Null_Iir_List then
+ List := Create_Iir_List;
+ Set_Analysis_Checks_List (Design, List);
+ end if;
+ Add_Element (List, El);
+ end Add_Analysis_Checks_List;
+
+ procedure Sem_Subprogram_Body (Subprg : Iir)
+ is
+ Spec : Iir;
+ El : Iir;
+ begin
+ Spec := Get_Subprogram_Specification (Subprg);
+ Set_Impure_Depth (Subprg, Iir_Depth_Pure);
+
+ -- LRM 10.1 Declarative regions
+ -- 3. A subprogram declaration, together with the corresponding
+ -- subprogram body.
+ Open_Declarative_Region;
+ Set_Is_Within_Flag (Spec, True);
+
+ -- Add the interface names into the current declarative region.
+ El := Get_Interface_Declaration_Chain (Spec);
+ while El /= Null_Iir loop
+ Add_Name (El, Get_Identifier (El), False);
+ if Get_Kind (El) = Iir_Kind_Interface_Signal_Declaration then
+ Set_Has_Active_Flag (El, False);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ Sem_Sequential_Statements (Spec, Subprg);
+
+ Set_Is_Within_Flag (Spec, False);
+ Close_Declarative_Region;
+
+ case Get_Kind (Spec) is
+ when Iir_Kind_Procedure_Declaration =>
+ -- Update purity state of procedure if there are no callees.
+ case Get_Purity_State (Spec) is
+ when Pure
+ | Maybe_Impure =>
+ -- We can't know this yet.
+ raise Internal_Error;
+ when Impure =>
+ null;
+ when Unknown =>
+ if Get_Callees_List (Subprg) = Null_Iir_List then
+ -- Since there are no callees, purity state can
+ -- be updated.
+ if Get_Impure_Depth (Subprg) = Iir_Depth_Pure then
+ Set_Purity_State (Spec, Pure);
+ else
+ Set_Purity_State (Spec, Maybe_Impure);
+ end if;
+ end if;
+ end case;
+
+ -- Update wait state if the state of all callees is known.
+ if Get_Wait_State (Spec) = Unknown then
+ declare
+ Callees : Iir_List;
+ Callee : Iir;
+ State : Tri_State_Type;
+ begin
+ Callees := Get_Callees_List (Subprg);
+ -- Per default, has no wait.
+ Set_Wait_State (Spec, False);
+ if Callees /= Null_Iir_List then
+ for I in Natural loop
+ Callee := Get_Nth_Element (Callees, I);
+ exit when Callee = Null_Iir;
+ case Get_Kind (Callee) is
+ when Iir_Kinds_Function_Declaration =>
+ null;
+ when Iir_Kind_Procedure_Declaration =>
+ State := Get_Wait_State (Callee);
+ case State is
+ when False =>
+ null;
+ when Unknown =>
+ -- Yet unknown, but can be TRUE.
+ Set_Wait_State (Spec, Unknown);
+ when True =>
+ -- Can this happen ?
+ raise Internal_Error;
+ --Set_Wait_State (Spec, True);
+ --exit;
+ end case;
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("sem_subprogram_body(2)", Callee);
+ end case;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Set All_Sensitized_State in trivial cases.
+ if Get_All_Sensitized_State (Spec) = Unknown
+ and then Get_Callees_List (Subprg) = Null_Iir_List
+ then
+ Set_All_Sensitized_State (Spec, No_Signal);
+ end if;
+
+ -- Do not add to Analysis_Check_List as procedures can't
+ -- generate purity/wait/all-sensitized errors by themselves.
+
+ when Iir_Kind_Function_Declaration =>
+ if Get_Callees_List (Subprg) /= Null_Iir_List then
+ -- Purity calls to be checked later.
+ -- No wait statements in procedures called.
+ Add_Analysis_Checks_List (Spec);
+ end if;
+ when others =>
+ Error_Kind ("sem_subprogram_body", Spec);
+ end case;
+ end Sem_Subprogram_Body;
+
+ -- Status of Update_And_Check_Pure_Wait.
+ type Update_Pure_Status is
+ (
+ -- The purity/wait/all-sensitized are computed and known.
+ Update_Pure_Done,
+ -- A missing body prevents from computing the purity/wait/all-sensitized
+ Update_Pure_Missing,
+ -- Purity/wait/all-sensitized is unknown (recursion).
+ Update_Pure_Unknown
+ );
+
+ function Update_And_Check_Pure_Wait (Subprg : Iir) return Update_Pure_Status
+ is
+ procedure Error_Wait (Caller : Iir; Callee : Iir) is
+ begin
+ Error_Msg_Sem
+ (Disp_Node (Caller) & " must not contain wait statement, but calls",
+ Caller);
+ Error_Msg_Sem
+ (Disp_Node (Callee) & " which has (indirectly) a wait statement",
+ Callee);
+ end Error_Wait;
+
+ -- Kind of subprg.
+ type Caller_Kind is (K_Function, K_Process, K_Procedure);
+ Kind : Caller_Kind;
+
+ Callees_List : Iir_List;
+ Callees_List_Holder : Iir;
+ Callee : Iir;
+ Callee_Orig : Iir;
+ Callee_Bod : Iir;
+ Subprg_Depth : Iir_Int32;
+ Subprg_Bod : Iir;
+ -- Current purity depth of SUBPRG.
+ Depth : Iir_Int32;
+ Depth_Callee : Iir_Int32;
+ Has_Wait_Errors : Boolean := False;
+ Npos : Natural;
+ Res, Res1 : Update_Pure_Status;
+ begin
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ Kind := K_Function;
+ Subprg_Bod := Get_Subprogram_Body (Subprg);
+ Subprg_Depth := Get_Subprogram_Depth (Subprg);
+ Callees_List_Holder := Subprg_Bod;
+ if Get_Pure_Flag (Subprg) then
+ Depth := Iir_Depth_Pure;
+ else
+ Depth := Iir_Depth_Impure;
+ end if;
+
+ when Iir_Kind_Procedure_Declaration =>
+ Kind := K_Procedure;
+ Subprg_Bod := Get_Subprogram_Body (Subprg);
+ if Get_Purity_State (Subprg) = Impure
+ and then Get_Wait_State (Subprg) /= Unknown
+ and then Get_All_Sensitized_State (Subprg) /= Unknown
+ then
+ -- No need to go further.
+ if Get_All_Sensitized_State (Subprg) = No_Signal
+ or else Vhdl_Std < Vhdl_08
+ then
+ Callees_List := Get_Callees_List (Subprg_Bod);
+ Destroy_Iir_List (Callees_List);
+ Set_Callees_List (Subprg_Bod, Null_Iir_List);
+ end if;
+ return Update_Pure_Done;
+ end if;
+ Subprg_Depth := Get_Subprogram_Depth (Subprg);
+ Depth := Get_Impure_Depth (Subprg_Bod);
+ Callees_List_Holder := Subprg_Bod;
+
+ when Iir_Kind_Sensitized_Process_Statement =>
+ Kind := K_Process;
+ Subprg_Bod := Null_Iir;
+ Subprg_Depth := Iir_Depth_Top;
+ Depth := Iir_Depth_Impure;
+ Callees_List_Holder := Subprg;
+
+ when others =>
+ Error_Kind ("update_and_check_pure_wait(1)", Subprg);
+ end case;
+
+ -- If the subprogram has no callee list, there is nothing to do.
+ Callees_List := Get_Callees_List (Callees_List_Holder);
+ if Callees_List = Null_Iir_List then
+ -- There are two reasons why a callees_list is null:
+ -- * either because SUBPRG does not call any procedure
+ -- in this case, the status are already known and we should have
+ -- returned in the above case.
+ -- * or because of a recursion
+ -- in this case the status are still unknown here.
+ return Update_Pure_Unknown;
+ end if;
+
+ -- By default we don't know the status.
+ Res := Update_Pure_Unknown;
+
+ -- This subprogram is being considered.
+ -- To avoid infinite loop, suppress its callees list.
+ Set_Callees_List (Callees_List_Holder, Null_Iir_List);
+
+ -- First loop: check without recursion.
+ -- Second loop: recurse if necessary.
+ for J in 0 .. 1 loop
+ Npos := 0;
+ for I in Natural loop
+ Callee := Get_Nth_Element (Callees_List, I);
+ exit when Callee = Null_Iir;
+
+ -- Note:
+ -- Pure functions should not be in the list.
+ -- Impure functions must have directly set Purity_State.
+
+ -- Check pure.
+ Callee_Bod := Get_Subprogram_Body (Callee);
+
+ if Callee_Bod = Null_Iir then
+ -- The body of subprograms may not be set for instances.
+ -- Use the body from the generic (if any).
+ Callee_Orig := Sem_Inst.Get_Origin (Callee);
+ if Callee_Orig /= Null_Iir then
+ Callee_Bod := Get_Subprogram_Body (Callee_Orig);
+ Set_Subprogram_Body (Callee, Callee_Bod);
+ end if;
+ end if;
+
+ if Callee_Bod = Null_Iir then
+ -- No body yet for the subprogram called.
+ -- Nothing can be extracted from it, postpone the checks until
+ -- elaboration.
+ Res := Update_Pure_Missing;
+ else
+ -- Second loop: recurse if a state is not known.
+ if J = 1
+ and then
+ ((Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
+ and then Get_Purity_State (Callee) = Unknown)
+ or else Get_Wait_State (Callee) = Unknown
+ or else Get_All_Sensitized_State (Callee) = Unknown)
+ then
+ Res1 := Update_And_Check_Pure_Wait (Callee);
+ if Res1 = Update_Pure_Missing then
+ Res := Update_Pure_Missing;
+ end if;
+ end if;
+
+ -- Check purity only if the subprogram is not impure.
+ if Depth /= Iir_Depth_Impure then
+ Depth_Callee := Get_Impure_Depth (Callee_Bod);
+
+ -- Check purity depth.
+ if Depth_Callee < Subprg_Depth then
+ -- The call is an impure call because it calls an outer
+ -- subprogram (or an impure subprogram).
+ -- FIXME: check the compare.
+ Depth_Callee := Iir_Depth_Impure;
+ if Kind = K_Function then
+ -- FIXME: report call location
+ Error_Pure (Subprg_Bod, Callee, Null_Iir);
+ end if;
+ end if;
+
+ -- Update purity depth.
+ if Depth_Callee < Depth then
+ Depth := Depth_Callee;
+ if Kind = K_Procedure then
+ -- Update for recursivity.
+ Set_Impure_Depth (Subprg_Bod, Depth);
+ if Depth = Iir_Depth_Impure then
+ Set_Purity_State (Subprg, Impure);
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Check wait.
+ if Has_Wait_Errors = False
+ and then Get_Wait_State (Callee) = True
+ then
+ if Kind = K_Procedure then
+ Set_Wait_State (Subprg, True);
+ else
+ Error_Wait (Subprg, Callee);
+ Has_Wait_Errors := True;
+ end if;
+ end if;
+
+ if Get_All_Sensitized_State (Callee) = Invalid_Signal then
+ case Kind is
+ when K_Function | K_Procedure =>
+ Set_All_Sensitized_State (Subprg, Invalid_Signal);
+ when K_Process =>
+ -- LRM08 11.3
+ --
+ -- It is an error if a process statement with the
+ -- reserved word ALL as its process sensitivity list
+ -- is the parent of a subprogram declared in a design
+ -- unit other than that containing the process statement
+ -- and the subprogram reads an explicitly declared
+ -- signal that is not a formal signal parameter or
+ -- member of a formal signal parameter of the
+ -- subprogram or of any of its parents. Similarly,
+ -- it is an error if such subprogram reads an implicit
+ -- signal whose explicit ancestor is not a formal signal
+ -- parameter or member of a formal parameter of
+ -- the subprogram or of any of its parents.
+ Error_Msg_Sem
+ ("all-sensitized " & Disp_Node (Subprg)
+ & " can't call " & Disp_Node (Callee), Subprg);
+ Error_Msg_Sem
+ (" (as this subprogram reads (indirectly) a signal)",
+ Subprg);
+ end case;
+ end if;
+
+ -- Keep in list.
+ if Callee_Bod = Null_Iir
+ or else
+ (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration
+ and then Get_Purity_State (Callee) = Unknown
+ and then Depth /= Iir_Depth_Impure)
+ or else
+ (Get_Wait_State (Callee) = Unknown
+ and then (Kind /= K_Procedure
+ or else Get_Wait_State (Subprg) = Unknown))
+ or else
+ (Vhdl_Std >= Vhdl_08
+ and then
+ (Get_All_Sensitized_State (Callee) = Unknown
+ or else Get_All_Sensitized_State (Callee) = Read_Signal))
+ then
+ Replace_Nth_Element (Callees_List, Npos, Callee);
+ Npos := Npos + 1;
+ end if;
+ end loop;
+
+ -- End of callee loop.
+ if Npos = 0 then
+ Destroy_Iir_List (Callees_List);
+ Callees_List := Null_Iir_List;
+ if Kind = K_Procedure then
+ if Get_Purity_State (Subprg) = Unknown then
+ Set_Purity_State (Subprg, Maybe_Impure);
+ end if;
+ if Get_Wait_State (Subprg) = Unknown then
+ Set_Wait_State (Subprg, False);
+ end if;
+ end if;
+ if Kind = K_Procedure or Kind = K_Function then
+ if Get_All_Sensitized_State (Subprg) = Unknown then
+ Set_All_Sensitized_State (Subprg, No_Signal);
+ end if;
+ end if;
+ Res := Update_Pure_Done;
+ exit;
+ else
+ Set_Nbr_Elements (Callees_List, Npos);
+ end if;
+ end loop;
+
+ Set_Callees_List (Callees_List_Holder, Callees_List);
+
+ return Res;
+ end Update_And_Check_Pure_Wait;
+
+ -- Check pure/wait/all-sensitized issues for SUBPRG (subprogram or
+ -- process). Return False if the analysis is incomplete (and must
+ -- be deferred).
+ function Root_Update_And_Check_Pure_Wait (Subprg : Iir) return Boolean
+ is
+ Res : Update_Pure_Status;
+ begin
+ Res := Update_And_Check_Pure_Wait (Subprg);
+ case Res is
+ when Update_Pure_Done =>
+ return True;
+ when Update_Pure_Missing =>
+ return False;
+ when Update_Pure_Unknown =>
+ -- The purity/wait is unknown, but all callee were walked.
+ -- This means there are recursive calls but without violations.
+ if Get_Kind (Subprg) = Iir_Kind_Procedure_Declaration then
+ if Get_Purity_State (Subprg) = Unknown then
+ Set_Purity_State (Subprg, Maybe_Impure);
+ end if;
+ if Get_Wait_State (Subprg) = Unknown then
+ Set_Wait_State (Subprg, False);
+ end if;
+ end if;
+ if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then
+ if Get_All_Sensitized_State (Subprg) = Unknown then
+ Set_All_Sensitized_State (Subprg, No_Signal);
+ end if;
+ end if;
+ return True;
+ end case;
+ end Root_Update_And_Check_Pure_Wait;
+
+ procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit;
+ Emit_Warnings : Boolean)
+ is
+ List : Iir_List := Get_Analysis_Checks_List (Unit);
+ El : Iir;
+ Npos : Natural;
+ Keep : Boolean;
+ Callees : Iir_List;
+ Callee : Iir;
+ begin
+ if List = Null_Iir_List then
+ -- Return now if there is nothing to check.
+ return;
+ end if;
+
+ Npos := 0;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Keep := False;
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration =>
+ -- FIXME: remove from list if fully tested ?
+ if not Root_Update_And_Check_Pure_Wait (El) then
+ Keep := True;
+ if Emit_Warnings then
+ Callees := Get_Callees_List (El);
+ pragma Assert (Callees /= Null_Iir_List);
+ Warning_Msg_Sem
+ ("can't assert that all calls in " & Disp_Node (El)
+ & " are pure or have not wait; "
+ & "will be checked at elaboration", El);
+ Callee := Get_Nth_Element (Callees, 0);
+ -- FIXME: could improve this message by displaying the
+ -- chain of calls until the first subprograms in
+ -- unknown state.
+ Warning_Msg_Sem
+ ("(first such call is to " & Disp_Node (Callee) & ")",
+ Callee);
+ end if;
+ end if;
+ when Iir_Kind_Sensitized_Process_Statement =>
+ if not Root_Update_And_Check_Pure_Wait (El) then
+ Keep := True;
+ if Emit_Warnings then
+ Warning_Msg_Sem
+ ("can't assert that " & Disp_Node (El)
+ & " has not wait; will be checked at elaboration", El);
+ end if;
+ end if;
+ when others =>
+ Error_Kind ("sem_analysis_checks_list", El);
+ end case;
+ if Keep then
+ Replace_Nth_Element (List, Npos, El);
+ Npos := Npos + 1;
+ end if;
+ end loop;
+ if Npos = 0 then
+ Destroy_Iir_List (List);
+ Set_Analysis_Checks_List (Unit, Null_Iir_List);
+ else
+ Set_Nbr_Elements (List, Npos);
+ end if;
+ end Sem_Analysis_Checks_List;
+
+ -- Return true if package declaration DECL needs a body.
+ -- Ie, it contains subprogram specification or deferred constants.
+ function Package_Need_Body_P (Decl: Iir_Package_Declaration)
+ return Boolean
+ is
+ El: Iir;
+ Def : Iir;
+ begin
+ El := Get_Declaration_Chain (Decl);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when Iir_Kind_Constant_Declaration =>
+ if Get_Default_Value (El) = Null_Iir then
+ return True;
+ end if;
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when Iir_Kind_Type_Declaration =>
+ Def := Get_Type_Definition (El);
+ if Def /= Null_Iir
+ and then Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration
+ then
+ return True;
+ end if;
+ when Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ null;
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Attribute_Specification =>
+ null;
+ when Iir_Kind_Disconnection_Specification =>
+ null;
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Component_Declaration =>
+ null;
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+ when Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration =>
+ null;
+ when Iir_Kind_Terminal_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("package_need_body_p", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ return False;
+ end Package_Need_Body_P;
+
+ -- LRM 2.5 Package Declarations.
+ procedure Sem_Package_Declaration (Decl: Iir_Package_Declaration)
+ is
+ Unit : Iir_Design_Unit;
+ Implicit : Implicit_Signal_Declaration_Type;
+ Header : constant Iir := Get_Package_Header (Decl);
+ begin
+ Unit := Get_Design_Unit (Decl);
+ Sem_Scopes.Add_Name (Decl);
+ Set_Visible_Flag (Decl, True);
+ Xref_Decl (Decl);
+
+ -- Identify IEEE.Std_Logic_1164 for VHDL08.
+ if Get_Identifier (Decl) = Std_Names.Name_Std_Logic_1164
+ and then (Get_Identifier (Get_Library (Get_Design_File (Unit)))
+ = Std_Names.Name_Ieee)
+ then
+ Ieee.Std_Logic_1164.Std_Logic_1164_Pkg := Decl;
+ end if;
+
+ -- LRM93 10.1 Declarative Region
+ -- 4. A package declaration, together with the corresponding
+ -- body (if any).
+ Open_Declarative_Region;
+
+ Push_Signals_Declarative_Part (Implicit, Decl);
+
+ if Header /= Null_Iir then
+ Sem_Interface_Chain
+ (Get_Generic_Chain (Header), Generic_Interface_List);
+ if Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir then
+ -- FIXME: todo
+ raise Internal_Error;
+ end if;
+ end if;
+
+ Sem_Declaration_Chain (Decl);
+ -- GHDL: subprogram bodies appear in package body.
+
+ Pop_Signals_Declarative_Part (Implicit);
+ Close_Declarative_Region;
+ Set_Need_Body (Decl, Package_Need_Body_P (Decl));
+ end Sem_Package_Declaration;
+
+ -- LRM 2.6 Package Bodies.
+ procedure Sem_Package_Body (Decl: Iir)
+ is
+ Package_Ident: Name_Id;
+ Design_Unit: Iir_Design_Unit;
+ Package_Decl: Iir;
+ begin
+ -- First, find the package declaration.
+ Package_Ident := Get_Identifier (Decl);
+ Design_Unit := Libraries.Load_Primary_Unit
+ (Get_Library (Get_Design_File (Get_Current_Design_Unit)),
+ Package_Ident, Decl);
+ if Design_Unit = Null_Iir then
+ Error_Msg_Sem ("package '" & Name_Table.Image (Package_Ident)
+ & "' was not analysed",
+ Decl);
+ return;
+ end if;
+ Package_Decl := Get_Library_Unit (Design_Unit);
+ if Get_Kind (Package_Decl) /= Iir_Kind_Package_Declaration then
+ Error_Msg_Sem
+ ("primary unit '" & Name_Table.Image (Package_Ident)
+ & "' is not a package", Decl);
+ return;
+ end if;
+
+ -- Emit a warning is a body is not necessary.
+ if not Get_Need_Body (Package_Decl) then
+ Warning_Msg_Sem
+ (Disp_Node (Package_Decl) & " does not require a body", Decl);
+ end if;
+
+ Set_Package (Decl, Package_Decl);
+ Xref_Body (Decl, Package_Decl);
+ Set_Package_Body (Package_Decl, Decl);
+ Add_Dependence (Design_Unit);
+
+ Add_Name (Design_Unit);
+
+ -- Add the context clauses from the primary unit.
+ Add_Context_Clauses (Design_Unit);
+
+ -- LRM93 10.1 Declarative Region
+ -- 4. A package declaration, together with the corresponding
+ -- body (if any).
+ Open_Declarative_Region;
+
+ Sem_Scopes.Add_Package_Declarations (Package_Decl);
+
+ Sem_Declaration_Chain (Decl);
+ Check_Full_Declaration (Decl, Decl);
+ Check_Full_Declaration (Package_Decl, Decl);
+
+ Close_Declarative_Region;
+ end Sem_Package_Body;
+
+ function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir
+ is
+ Name : Iir;
+ Pkg : Iir;
+ begin
+ Name := Sem_Denoting_Name (Get_Uninstantiated_Package_Name (Decl));
+ Set_Uninstantiated_Package_Name (Decl, Name);
+ Pkg := Get_Named_Entity (Name);
+ if Get_Kind (Pkg) /= Iir_Kind_Package_Declaration then
+ Error_Class_Match (Name, "package");
+
+ -- What could be done ?
+ return Null_Iir;
+ elsif not Is_Uninstantiated_Package (Pkg) then
+ Error_Msg_Sem
+ (Disp_Node (Pkg) & " is not an uninstantiated package", Name);
+
+ -- What could be done ?
+ return Null_Iir;
+ end if;
+
+ return Pkg;
+ end Sem_Uninstantiated_Package_Name;
+
+ -- LRM08 4.9 Package Instantiation Declaration
+ procedure Sem_Package_Instantiation_Declaration (Decl : Iir)
+ is
+ Hdr : Iir;
+ Pkg : Iir;
+ Bod : Iir_Design_Unit;
+ begin
+ Sem_Scopes.Add_Name (Decl);
+ Set_Visible_Flag (Decl, True);
+ Xref_Decl (Decl);
+
+ -- LRM08 4.9
+ -- The uninstantiated package name shall denote an uninstantiated
+ -- package declared in a package declaration.
+ Pkg := Sem_Uninstantiated_Package_Name (Decl);
+ if Pkg = Null_Iir then
+ -- What could be done ?
+ return;
+ end if;
+
+ -- LRM08 4.9
+ -- The generic map aspect, if present, optionally associates a single
+ -- actual with each formal generic (or member thereof) in the
+ -- corresponding package declaration. Each formal generic (or member
+ -- thereof) shall be associated at most once.
+
+ -- GHDL: the generics are first instantiated (ie copied) and then
+ -- the actuals are associated with the instantiated formal.
+ -- FIXME: do it in Instantiate_Package_Declaration ?
+ Hdr := Get_Package_Header (Pkg);
+ if Sem_Generic_Association_Chain (Hdr, Decl) then
+ Sem_Inst.Instantiate_Package_Declaration (Decl, Pkg);
+ else
+ -- FIXME: stop analysis here ?
+ null;
+ end if;
+
+ -- FIXME: unless the parent is a package declaration library unit, the
+ -- design unit depends on the body.
+ Bod := Libraries.Load_Secondary_Unit
+ (Get_Design_Unit (Pkg), Null_Identifier, Decl);
+ if Bod /= Null_Iir then
+ Add_Dependence (Bod);
+ end if;
+ end Sem_Package_Instantiation_Declaration;
+
+ -- LRM 10.4 Use Clauses.
+ procedure Sem_Use_Clause (Clauses: Iir_Use_Clause)
+ is
+ Clause : Iir_Use_Clause;
+ Name: Iir;
+ Prefix: Iir;
+ Name_Prefix : Iir;
+ begin
+ Clause := Clauses;
+ loop
+ -- LRM93 10.4
+ -- A use clause achieves direct visibility of declarations that are
+ -- visible by selection.
+ -- Each selected name is a use clause identifies one or more
+ -- declarations that will potentialy become directly visible.
+
+ Name := Get_Selected_Name (Clause);
+ case Get_Kind (Name) is
+ when Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Selected_Name =>
+ Name_Prefix := Get_Prefix (Name);
+ when others =>
+ Error_Msg_Sem ("use clause allows only selected name", Name);
+ return;
+ end case;
+
+ Name_Prefix := Sem_Denoting_Name (Name_Prefix);
+ Set_Prefix (Name, Name_Prefix);
+ Prefix := Get_Named_Entity (Name_Prefix);
+ if Is_Error (Prefix) then
+ -- FIXME: continue with the clauses
+ return;
+ end if;
+
+ -- LRM 10.4 Use Clauses
+ --
+ -- If the suffix of the selected name is [...], then the
+ -- selected name identifies only the declaration(s) of that
+ -- [...] contained within the package or library denoted by
+ -- the prefix of the selected name.
+ --
+ -- If the suffix is the reserved word ALL, then the selected name
+ -- identifies all declarations that are contained within the package
+ -- or library denoted by the prefix of the selected name.
+ --
+ -- GHDL: therefore, the suffix must be either a package or a library.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Library_Declaration =>
+ null;
+ when Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Interface_Package_Declaration =>
+ null;
+ when Iir_Kind_Package_Declaration =>
+ -- LRM08 12.4 Use clauses
+ -- It is an error if the prefix of a selected name in a use
+ -- clause denotes an uninstantiated package.
+ if Is_Uninstantiated_Package (Prefix) then
+ Error_Msg_Sem
+ ("use of uninstantiated package is not allowed",
+ Name_Prefix);
+ return;
+ end if;
+ when others =>
+ Error_Msg_Sem
+ ("prefix must designate a package or a library", Prefix);
+ return;
+ end case;
+
+ case Get_Kind (Name) is
+ when Iir_Kind_Selected_Name =>
+ Sem_Name (Name);
+ case Get_Kind (Get_Named_Entity (Name)) is
+ when Iir_Kind_Error =>
+ -- Continue in case of error.
+ null;
+ when Iir_Kind_Overload_List =>
+ -- Analyze is correct as is.
+ null;
+ when others =>
+ Name := Finish_Sem_Name (Name);
+ Set_Selected_Name (Clause, Name);
+ end case;
+ when Iir_Kind_Selected_By_All_Name =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Clause := Get_Use_Clause_Chain (Clause);
+ exit when Clause = Null_Iir;
+ end loop;
+
+ -- LRM 10.4
+ -- For each use clause, there is a certain region of text called the
+ -- scope of the use clause. This region starts immediatly after the
+ -- use clause.
+ Sem_Scopes.Add_Use_Clause (Clauses);
+ end Sem_Use_Clause;
+
+ -- LRM 11.2 Design Libraries.
+ procedure Sem_Library_Clause (Decl: Iir_Library_Clause)
+ is
+ Ident : Name_Id;
+ Lib: Iir;
+ begin
+ -- GHDL: 'redeclaration' is handled in sem_scopes.
+
+ Ident := Get_Identifier (Decl);
+ Lib := Libraries.Get_Library (Ident, Get_Location (Decl));
+ if Lib = Null_Iir then
+ Error_Msg_Sem
+ ("no resource library """ & Name_Table.Image (Ident) & """", Decl);
+ else
+ Set_Library_Declaration (Decl, Lib);
+ Sem_Scopes.Add_Name (Lib, Ident, False);
+ Set_Visible_Flag (Lib, True);
+ Xref_Ref (Decl, Lib);
+ end if;
+ end Sem_Library_Clause;
+
+ -- LRM 11.3 Context Clauses.
+ procedure Sem_Context_Clauses (Design_Unit: Iir_Design_Unit)
+ is
+ El: Iir;
+ begin
+ El := Get_Context_Items (Design_Unit);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause =>
+ Sem_Use_Clause (El);
+ when Iir_Kind_Library_Clause =>
+ Sem_Library_Clause (El);
+ when others =>
+ Error_Kind ("sem_context_clauses", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Sem_Context_Clauses;
+
+ -- Access to the current design unit. This is set, saved, restored, cleared
+ -- by the procedure semantic.
+ Current_Design_Unit: Iir_Design_Unit := Null_Iir;
+
+ function Get_Current_Design_Unit return Iir_Design_Unit is
+ begin
+ return Current_Design_Unit;
+ end Get_Current_Design_Unit;
+
+ -- LRM 11.1 Design units.
+ procedure Semantic (Design_Unit: Iir_Design_Unit)
+ is
+ El: Iir;
+ Old_Design_Unit: Iir_Design_Unit;
+ Implicit : Implicit_Signal_Declaration_Type;
+ begin
+ -- Sanity check: can analyze either previously analyzed unit or just
+ -- parsed unit.
+ case Get_Date (Design_Unit) is
+ when Date_Parsed =>
+ Set_Date (Design_Unit, Date_Analyzing);
+ when Date_Valid =>
+ null;
+ when Date_Obsolete =>
+ -- This happens only when design files are added into the library
+ -- and keeping obsolete units (eg: to pretty print a file).
+ Set_Date (Design_Unit, Date_Analyzing);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Save and set current_design_unit.
+ Old_Design_Unit := Current_Design_Unit;
+ Current_Design_Unit := Design_Unit;
+ Push_Signals_Declarative_Part (Implicit, Null_Iir);
+
+ -- Be sure the name table is empty.
+ -- It is empty at start-up, or saved before recursing.
+ pragma Debug (Name_Table.Assert_No_Infos);
+
+ -- LRM02 10.1 Declarative Region.
+ -- In addition to the above declarative region, there is a root
+ -- declarative region, not associated with a portion of the text of the
+ -- description, but encompassing any given primary unit. At the
+ -- beginning of the analysis of a given primary unit, there are no
+ -- declarations whose scopes (see 10.2) are within the root declarative
+ -- region. Moreover, the root declarative region associated with any
+ -- given secondary unit is the root declarative region of the
+ -- corresponding primary unit.
+ -- GHDL: for any revision of VHDL, a root declarative region is created,
+ -- due to reasons given by LCS 3 (VHDL Issue # 1028).
+ Open_Declarative_Region;
+
+ -- Set_Dependence_List (Design_Unit,
+-- Create_Iir (Iir_Kind_Design_Unit_List));
+
+ -- LRM 11.2
+ -- Every design unit is assumed to contain the following implicit
+ -- context items as part of its context clause:
+ -- library STD, WORK; use STD.STANDARD.all;
+ Sem_Scopes.Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False);
+ Sem_Scopes.Add_Name (Get_Library (Get_Design_File (Design_Unit)),
+ Std_Names.Name_Work,
+ False);
+ Sem_Scopes.Use_All_Names (Standard_Package);
+ if Get_Dependence_List (Design_Unit) = Null_Iir_List then
+ Set_Dependence_List (Design_Unit, Create_Iir_List);
+ end if;
+ Add_Dependence (Std_Standard_Unit);
+
+ -- Semantic on context clauses.
+ Sem_Context_Clauses (Design_Unit);
+
+ -- semantic on the library unit.
+ El := Get_Library_Unit (Design_Unit);
+ case Get_Kind (El) is
+ when Iir_Kind_Entity_Declaration =>
+ Sem_Entity_Declaration (El);
+ when Iir_Kind_Architecture_Body =>
+ Sem_Architecture_Body (El);
+ when Iir_Kind_Package_Declaration =>
+ Sem_Package_Declaration (El);
+ when Iir_Kind_Package_Body =>
+ Sem_Package_Body (El);
+ when Iir_Kind_Configuration_Declaration =>
+ Sem_Configuration_Declaration (El);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Sem_Package_Instantiation_Declaration (El);
+ when others =>
+ Error_Kind ("semantic", El);
+ end case;
+
+ Close_Declarative_Region;
+
+ if Get_Date (Design_Unit) = Date_Analyzing then
+ Set_Date (Design_Unit, Date_Analyzed);
+ end if;
+
+ if Get_Analysis_Checks_List (Design_Unit) /= Null_Iir_List then
+ Sem_Analysis_Checks_List (Design_Unit, False);
+ end if;
+
+ -- Restore current_design_unit.
+ Current_Design_Unit := Old_Design_Unit;
+ Pop_Signals_Declarative_Part (Implicit);
+ end Semantic;
+end Sem;
diff --git a/src/sem.ads b/src/sem.ads
new file mode 100644
index 000000000..5586483a1
--- /dev/null
+++ b/src/sem.ads
@@ -0,0 +1,82 @@
+-- Semantic analysis 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;
+with Types; use Types;
+
+package Sem is
+ -- Semantic analysis for chapters 1, 2, 10 (uses clauses) and 11.
+
+ -- Do the semantic analysis of design unit DESIGN_UNIT.
+ -- Also add a few node or change some nodes, when for exemple an
+ -- identifier is changed into an access to the type.
+ procedure Semantic (Design_Unit: Iir_Design_Unit);
+
+ -- Get the current design unit, ie, the parameter of the procedure semantic.
+ function Get_Current_Design_Unit return Iir_Design_Unit;
+
+ -- Makes the current design unit depends on UNIT.
+ -- UNIT must be either an entity_aspect or a design_unit.
+ procedure Add_Dependence (Unit : Iir);
+
+ -- Add EL in the current design unit list of items to be checked later.
+ procedure Add_Analysis_Checks_List (El : Iir);
+
+ -- INTER_PARENT contains generics and ports interfaces;
+ -- ASSOC_PARENT constains generics and ports map aspects.
+ procedure Sem_Generic_Port_Association_Chain
+ (Inter_Parent : Iir; Assoc_Parent : Iir);
+
+ -- Return TRUE iff the actual of ASSOC can be the formal FORMAL.
+ -- ASSOC must be an association_element_by_expression.
+ function Can_Collapse_Signals (Assoc : Iir; Formal : Iir) return Boolean;
+
+ -- Return TRUE iff LEFT and RIGHT are (in depth) equal.
+ -- This corresponds to conformance rules, LRM 2.7
+ function Are_Trees_Equal (Left, Right : Iir) return Boolean;
+
+ -- Check requirements on number of interfaces for subprogram specification
+ -- SUBPRG for a symbol operator ID. Requirements only concern operators,
+ -- and are defined in LRM 2.3.1.
+ -- If ID is not an operator name, this subprogram does no checks.
+ -- ID might be different from the identifier of SUBPRG when non object
+ -- aliases are checked.
+ procedure Check_Operator_Requirements (Id : Name_Id; Subprg : Iir);
+
+ -- Semantize an use clause.
+ -- This may adds use clauses to the chain.
+ procedure Sem_Use_Clause (Clauses : Iir_Use_Clause);
+
+ -- Compute and set the hash profile of a subprogram or enumeration clause.
+ procedure Compute_Subprogram_Hash (Subprg : Iir);
+
+ -- LRM 2.1 Subprogram Declarations.
+ procedure Sem_Subprogram_Declaration (Subprg: Iir);
+
+ -- LRM 2.2 Subprogram Bodies.
+ procedure Sem_Subprogram_Body (Subprg: Iir);
+
+ -- Do late analysis checks (pure rules).
+ procedure Sem_Analysis_Checks_List (Unit : Iir_Design_Unit;
+ Emit_Warnings : Boolean);
+
+ -- Analyze the uninstantiated package name of DECL, and return the
+ -- package declaration. Return Null_Iir if the name doesn't denote an
+ -- uninstantiated package.
+ function Sem_Uninstantiated_Package_Name (Decl : Iir) return Iir;
+
+end Sem;
diff --git a/src/sem_assocs.adb b/src/sem_assocs.adb
new file mode 100644
index 000000000..96e660875
--- /dev/null
+++ b/src/sem_assocs.adb
@@ -0,0 +1,1903 @@
+-- Semantic analysis.
+-- 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 Evaluation; use Evaluation;
+with Errorout; use Errorout;
+with Flags; use Flags;
+with Types; use Types;
+with Iirs_Utils; use Iirs_Utils;
+with Sem_Names; use Sem_Names;
+with Sem_Expr; use Sem_Expr;
+with Iir_Chains; use Iir_Chains;
+with Xrefs;
+
+package body Sem_Assocs is
+ function Rewrite_Non_Object_Association (Assoc : Iir; Inter : Iir)
+ return Iir
+ is
+ N_Assoc : Iir;
+ begin
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Package_Declaration =>
+ N_Assoc := Create_Iir (Iir_Kind_Association_Element_Package);
+ when others =>
+ Error_Kind ("rewrite_non_object_association", Inter);
+ end case;
+ Location_Copy (N_Assoc, Assoc);
+ Set_Formal (N_Assoc, Get_Formal (Assoc));
+ Set_Actual (N_Assoc, Get_Actual (Assoc));
+ Set_Chain (N_Assoc, Get_Chain (Assoc));
+ Set_Associated_Interface (N_Assoc, Inter);
+ Set_Whole_Association_Flag (N_Assoc, True);
+ Free_Iir (Assoc);
+ return N_Assoc;
+ end Rewrite_Non_Object_Association;
+
+ function Extract_Non_Object_Association
+ (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir
+ is
+ Inter : Iir;
+ Assoc : Iir;
+ -- N_Assoc : Iir;
+ Prev_Assoc : Iir;
+ Formal : Iir;
+ Res : Iir;
+ begin
+ Inter := Inter_Chain;
+ Assoc := Assoc_Chain;
+ Prev_Assoc := Null_Iir;
+ Res := Null_Iir;
+
+ -- Common case: only objects in interfaces.
+ while Inter /= Null_Iir loop
+ exit when Get_Kind (Inter)
+ not in Iir_Kinds_Interface_Object_Declaration;
+ Inter := Get_Chain (Inter);
+ end loop;
+ if Inter = Null_Iir then
+ return Assoc_Chain;
+ end if;
+
+ loop
+ -- Don't try to detect errors.
+ if Assoc = Null_Iir then
+ return Res;
+ end if;
+
+ Formal := Get_Formal (Assoc);
+ if Formal = Null_Iir then
+ -- Positional association.
+
+ if Inter = Null_Iir then
+ -- But after a named one. Be silent on that error.
+ null;
+ elsif Get_Kind (Inter)
+ not in Iir_Kinds_Interface_Object_Declaration
+ then
+ Assoc := Rewrite_Non_Object_Association (Assoc, Inter);
+ end if;
+ else
+ if Get_Kind (Formal) = Iir_Kind_Simple_Name then
+ -- A candidate. Search the corresponding interface.
+ Inter := Find_Name_In_Chain
+ (Inter_Chain, Get_Identifier (Formal));
+ if Inter /= Null_Iir
+ and then
+ Get_Kind (Inter) not in Iir_Kinds_Interface_Object_Declaration
+ then
+ Assoc := Rewrite_Non_Object_Association (Assoc, Inter);
+ end if;
+ end if;
+
+ -- No more association by position.
+ Inter := Null_Iir;
+ end if;
+
+ if Prev_Assoc = Null_Iir then
+ Res := Assoc;
+ else
+ Set_Chain (Prev_Assoc, Assoc);
+ end if;
+ Prev_Assoc := Assoc;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Extract_Non_Object_Association;
+
+ -- Semantize all arguments of ASSOC_CHAIN
+ -- Return TRUE if no error.
+ function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir)
+ return Boolean
+ is
+ Has_Named : Boolean;
+ Ok : Boolean;
+ Assoc : Iir;
+ Res : Iir;
+ Formal : Iir;
+ begin
+ -- Semantize all arguments
+ -- OK is false if there is an error during semantic of one of the
+ -- argument, but continue semantisation.
+ Has_Named := False;
+ Ok := True;
+ Assoc := Assoc_Chain;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ if Formal /= Null_Iir then
+ Has_Named := True;
+ -- FIXME: check FORMAL is well composed.
+ elsif Has_Named then
+ -- FIXME: do the check in parser.
+ Error_Msg_Sem ("positional argument after named argument", Assoc);
+ Ok := False;
+ end if;
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression then
+ Res := Sem_Expression_Ov (Get_Actual (Assoc), Null_Iir);
+ if Res = Null_Iir then
+ Ok := False;
+ else
+ Set_Actual (Assoc, Res);
+ end if;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ return Ok;
+ end Sem_Actual_Of_Association_Chain;
+
+ procedure Check_Parameter_Association_Restriction
+ (Inter : Iir; Base_Actual : Iir; Loc : Iir)
+ is
+ Act_Mode : Iir_Mode;
+ For_Mode : Iir_Mode;
+ begin
+ Act_Mode := Get_Mode (Base_Actual);
+ For_Mode := Get_Mode (Inter);
+ case Get_Mode (Inter) is
+ when Iir_In_Mode =>
+ if Act_Mode in Iir_In_Modes or Act_Mode = Iir_Buffer_Mode then
+ return;
+ end if;
+ when Iir_Out_Mode =>
+ -- FIXME: should buffer also be accepted ?
+ if Act_Mode in Iir_Out_Modes or Act_Mode = Iir_Buffer_Mode then
+ return;
+ end if;
+ when Iir_Inout_Mode =>
+ if Act_Mode = Iir_Inout_Mode then
+ return;
+ end if;
+ when others =>
+ Error_Kind ("check_parameter_association_restriction", Inter);
+ end case;
+ Error_Msg_Sem
+ ("cannot associate an " & Get_Mode_Name (Act_Mode)
+ & " object with " & Get_Mode_Name (For_Mode) & " "
+ & Disp_Node (Inter), Loc);
+ end Check_Parameter_Association_Restriction;
+
+ procedure Check_Subprogram_Associations
+ (Inter_Chain : Iir; Assoc_Chain : Iir)
+ is
+ Assoc : Iir;
+ Formal : Iir;
+ Formal_Inter : Iir;
+ Actual : Iir;
+ Prefix : Iir;
+ Object : Iir;
+ Inter : Iir;
+ begin
+ Assoc := Assoc_Chain;
+ Inter := Inter_Chain;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ if Formal = Null_Iir then
+ -- Association by position.
+ Formal_Inter := Inter;
+ Inter := Get_Chain (Inter);
+ else
+ -- Association by name.
+ Formal_Inter := Get_Association_Interface (Assoc);
+ Inter := Null_Iir;
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ if Get_Default_Value (Formal_Inter) = Null_Iir then
+ Error_Msg_Sem
+ ("no parameter for " & Disp_Node (Formal_Inter), Assoc);
+ end if;
+ when Iir_Kind_Association_Element_By_Expression =>
+ Actual := Get_Actual (Assoc);
+ Object := Name_To_Object (Actual);
+ if Object /= Null_Iir then
+ Prefix := Get_Object_Prefix (Object);
+ else
+ Prefix := Actual;
+ end if;
+
+ case Get_Kind (Formal_Inter) is
+ when Iir_Kind_Interface_Signal_Declaration =>
+ -- LRM93 2.1.1
+ -- In a subprogram call, the actual designator
+ -- associated with a formal parameter of class
+ -- signal must be a signal.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kinds_Signal_Attribute =>
+ -- LRM93 2.1.1.2
+ -- If an actual signal is associated with
+ -- a signal parameter of any mode, the actual
+ -- must be denoted by a static signal name.
+ if Get_Name_Staticness (Object) < Globally then
+ Error_Msg_Sem
+ ("actual signal must be a static name",
+ Actual);
+ else
+ -- Inherit has_active_flag.
+ Set_Has_Active_Flag
+ (Prefix, Get_Has_Active_Flag (Formal_Inter));
+ end if;
+ when others =>
+ Error_Msg_Sem
+ ("signal parameter requires a signal expression",
+ Assoc);
+ end case;
+
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Interface_Signal_Declaration =>
+ Check_Parameter_Association_Restriction
+ (Formal_Inter, Prefix, Assoc);
+ when Iir_Kind_Guard_Signal_Declaration =>
+ if Get_Mode (Formal_Inter) /= Iir_In_Mode then
+ Error_Msg_Sem
+ ("cannot associate a guard signal with "
+ & Get_Mode_Name (Get_Mode (Formal_Inter))
+ & " " & Disp_Node (Formal_Inter), Assoc);
+ end if;
+ when Iir_Kinds_Signal_Attribute =>
+ if Get_Mode (Formal_Inter) /= Iir_In_Mode then
+ Error_Msg_Sem
+ ("cannot associate a signal attribute with "
+ & Get_Mode_Name (Get_Mode (Formal_Inter))
+ & " " & Disp_Node (Formal_Inter), Assoc);
+ end if;
+ when others =>
+ null;
+ end case;
+
+ -- LRM 2.1.1.2 Signal parameters
+ -- It is an error if a conversion function or type
+ -- conversion appears in either the formal part or the
+ -- actual part of an association element that associates
+ -- an actual signal with a formal signal parameter.
+ if Get_In_Conversion (Assoc) /= Null_Iir
+ or Get_Out_Conversion (Assoc) /= Null_Iir
+ then
+ Error_Msg_Sem ("conversion are not allowed for "
+ & "signal parameters", Assoc);
+ end if;
+ when Iir_Kind_Interface_Variable_Declaration =>
+ -- LRM93 2.1.1
+ -- The actual designator associated with a formal of
+ -- class variable must be a variable.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Interface_Variable_Declaration =>
+ Check_Parameter_Association_Restriction
+ (Formal_Inter, Prefix, Assoc);
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ null;
+ when Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_File_Declaration =>
+ -- LRM87 4.3.1.4
+ -- Such an object is a member of the variable
+ -- class of objects;
+ if Flags.Vhdl_Std >= Vhdl_93 then
+ Error_Msg_Sem ("in vhdl93, variable parameter "
+ & "cannot be a file", Assoc);
+ end if;
+ when others =>
+ Error_Msg_Sem
+ ("variable parameter must be a variable", Assoc);
+ end case;
+ when Iir_Kind_Interface_File_Declaration =>
+ -- LRM93 2.1.1
+ -- The actual designator associated with a formal
+ -- of class file must be a file.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_File_Declaration =>
+ null;
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration =>
+ if Flags.Vhdl_Std >= Vhdl_93 then
+ Error_Msg_Sem ("in vhdl93, file parameter "
+ & "must be a file", Assoc);
+ end if;
+ when others =>
+ Error_Msg_Sem
+ ("file parameter must be a file", Assoc);
+ end case;
+
+ -- LRM 2.1.1.3 File parameters
+ -- It is an error if an association element associates
+ -- an actual with a formal parameter of a file type and
+ -- that association element contains a conversion
+ -- function or type conversion.
+ if Get_In_Conversion (Assoc) /= Null_Iir
+ or Get_Out_Conversion (Assoc) /= Null_Iir
+ then
+ Error_Msg_Sem ("conversion are not allowed for "
+ & "file parameters", Assoc);
+ end if;
+ when Iir_Kind_Interface_Constant_Declaration =>
+ -- LRM93 2.1.1
+ -- The actual designator associated with a formal of
+ -- class constant must be an expression.
+ Check_Read (Actual);
+ when others =>
+ Error_Kind
+ ("check_subprogram_association(3)", Formal_Inter);
+ end case;
+ when Iir_Kind_Association_Element_By_Individual =>
+ null;
+ when others =>
+ Error_Kind ("check_subprogram_associations", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Check_Subprogram_Associations;
+
+ -- Assocs_Right_Map (FORMAL_MODE, ACTUAL_MODE) is true iff it is allowed
+ -- to associate a formal port of mode FORMAL_MODE with an actual port of
+ -- mode ACTUAL_MODE.
+ subtype Iir_Known_Mode is Iir_Mode range Iir_Linkage_Mode .. Iir_In_Mode;
+ type Assocs_Right_Map is array (Iir_Known_Mode, Iir_Known_Mode) of Boolean;
+
+ Vhdl93_Assocs_Map : constant Assocs_Right_Map :=
+ (Iir_Linkage_Mode => (others => True),
+ Iir_Buffer_Mode => (Iir_Buffer_Mode => True, others => False),
+ Iir_Out_Mode => (Iir_Out_Mode | Iir_Inout_Mode => True,
+ others => False),
+ Iir_Inout_Mode => (Iir_Inout_Mode => True,
+ others => False),
+ Iir_In_Mode => (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True,
+ others => False));
+
+ Vhdl02_Assocs_Map : constant Assocs_Right_Map :=
+ (Iir_Linkage_Mode => (others => True),
+ Iir_Buffer_Mode => (Iir_Out_Mode | Iir_Inout_Mode
+ | Iir_Buffer_Mode => True,
+ others => False),
+ Iir_Out_Mode => (Iir_Out_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True,
+ others => False),
+ Iir_Inout_Mode => (Iir_Inout_Mode | Iir_Buffer_Mode => True,
+ others => False),
+ Iir_In_Mode => (Iir_In_Mode | Iir_Inout_Mode | Iir_Buffer_Mode => True,
+ others => False));
+
+ -- Check for restrictions in LRM 1.1.1.2
+ -- Return FALSE in case of error.
+ function Check_Port_Association_Restriction
+ (Formal : Iir_Interface_Signal_Declaration;
+ Actual : Iir_Interface_Signal_Declaration;
+ Assoc : Iir)
+ return Boolean
+ is
+ Fmode : constant Iir_Mode := Get_Mode (Formal);
+ Amode : constant Iir_Mode := Get_Mode (Actual);
+ begin
+ pragma Assert (Fmode /= Iir_Unknown_Mode);
+ pragma Assert (Amode /= Iir_Unknown_Mode);
+
+ if Flags.Vhdl_Std < Vhdl_02 then
+ if Vhdl93_Assocs_Map (Fmode, Amode) then
+ return True;
+ end if;
+ else
+ if Vhdl02_Assocs_Map (Fmode, Amode) then
+ return True;
+ end if;
+ end if;
+
+ if Assoc /= Null_Iir then
+ Error_Msg_Sem
+ ("cannot associate " & Get_Mode_Name (Fmode) & " "
+ & Disp_Node (Formal) & " with actual port of mode "
+ & Get_Mode_Name (Amode), Assoc);
+ end if;
+ return False;
+ end Check_Port_Association_Restriction;
+
+ -- Handle indexed name
+ -- FORMAL is the formal name to be handled.
+ -- SUB_ASSOC is an association_by_individual in which the formal will be
+ -- inserted.
+ -- Update SUB_ASSOC so that it designates FORMAL.
+ procedure Add_Individual_Assoc_Indexed_Name
+ (Sub_Assoc : in out Iir; Formal : Iir)
+ is
+ Choice : Iir;
+ Last_Choice : Iir;
+ Index_List : Iir_List;
+ Index : Iir;
+ Nbr : Natural;
+ begin
+ -- Find element.
+ Index_List := Get_Index_List (Formal);
+ Nbr := Get_Nbr_Elements (Index_List);
+ for I in 0 .. Nbr - 1 loop
+ Index := Get_Nth_Element (Index_List, I);
+
+ -- Evaluate index.
+ Index := Eval_Expr (Index);
+ Replace_Nth_Element (Index_List, I, Index);
+
+ -- Find index in choice list.
+ Last_Choice := Null_Iir;
+ Choice := Get_Individual_Association_Chain (Sub_Assoc);
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Expression =>
+ if Eval_Pos (Get_Choice_Expression (Choice))
+ = Eval_Pos (Index)
+ then
+ goto Found;
+ end if;
+ when Iir_Kind_Choice_By_Range =>
+ declare
+ Choice_Range : constant Iir := Get_Choice_Range (Choice);
+ begin
+ if Get_Expr_Staticness (Choice_Range) = Locally
+ and then
+ Eval_Int_In_Range (Eval_Pos (Index), Choice_Range)
+ then
+ -- FIXME: overlap.
+ raise Internal_Error;
+ end if;
+ end;
+ when others =>
+ Error_Kind ("add_individual_assoc_index_name", Choice);
+ end case;
+ Last_Choice := Choice;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ -- If not found, append it.
+ Choice := Create_Iir (Iir_Kind_Choice_By_Expression);
+ Set_Choice_Expression (Choice, Index);
+ Location_Copy (Choice, Formal);
+ if Last_Choice = Null_Iir then
+ Set_Individual_Association_Chain (Sub_Assoc, Choice);
+ else
+ Set_Chain (Last_Choice, Choice);
+ end if;
+
+ << Found >> null;
+
+ if I < Nbr - 1 then
+ Sub_Assoc := Get_Associated_Expr (Choice);
+ if Sub_Assoc = Null_Iir then
+ Sub_Assoc := Create_Iir
+ (Iir_Kind_Association_Element_By_Individual);
+ Location_Copy (Sub_Assoc, Index);
+ Set_Associated_Expr (Choice, Sub_Assoc);
+ end if;
+ else
+ Sub_Assoc := Choice;
+ end if;
+ end loop;
+ end Add_Individual_Assoc_Indexed_Name;
+
+ procedure Add_Individual_Assoc_Slice_Name
+ (Sub_Assoc : in out Iir; Formal : Iir)
+ is
+ Choice : Iir;
+ Index : Iir;
+ begin
+ -- FIXME: handle cases such as param(5 to 6)(5)
+
+ -- Find element.
+ Index := Get_Suffix (Formal);
+
+ -- Evaluate index.
+ if Get_Expr_Staticness (Index) = Locally then
+ Index := Eval_Range (Index);
+ Set_Suffix (Formal, Index);
+ end if;
+
+ Choice := Create_Iir (Iir_Kind_Choice_By_Range);
+ Location_Copy (Choice, Formal);
+ Set_Choice_Range (Choice, Index);
+ Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc));
+ Set_Individual_Association_Chain (Sub_Assoc, Choice);
+
+ Sub_Assoc := Choice;
+ end Add_Individual_Assoc_Slice_Name;
+
+ procedure Add_Individual_Assoc_Selected_Name
+ (Sub_Assoc : in out Iir; Formal : Iir)
+ is
+ Choice : Iir;
+ begin
+ Choice := Create_Iir (Iir_Kind_Choice_By_Name);
+ Location_Copy (Choice, Formal);
+ Set_Choice_Name (Choice, Get_Selected_Element (Formal));
+ Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc));
+ Set_Individual_Association_Chain (Sub_Assoc, Choice);
+
+ Sub_Assoc := Choice;
+ end Add_Individual_Assoc_Selected_Name;
+
+ procedure Add_Individual_Association_1 (Iassoc : in out Iir; Formal : Iir)
+ is
+ Sub : Iir;
+ Formal_Object : Iir;
+ begin
+ -- Recurse.
+ Formal_Object := Name_To_Object (Formal);
+ case Get_Kind (Formal_Object) is
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element =>
+ Add_Individual_Association_1 (Iassoc, Get_Prefix (Formal_Object));
+ when Iir_Kinds_Interface_Object_Declaration =>
+ return;
+ when others =>
+ Error_Kind ("add_individual_association_1", Formal);
+ end case;
+
+ case Get_Kind (Iassoc) is
+ when Iir_Kind_Association_Element_By_Individual =>
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ Sub := Get_Associated_Expr (Iassoc);
+ if Sub = Null_Iir then
+ Sub := Create_Iir (Iir_Kind_Association_Element_By_Individual);
+ Location_Copy (Sub, Formal);
+ Set_Formal (Sub, Iassoc);
+ Set_Associated_Expr (Iassoc, Sub);
+ Iassoc := Sub;
+ else
+ case Get_Kind (Sub) is
+ when Iir_Kind_Association_Element_By_Individual =>
+ Iassoc := Sub;
+ when others =>
+ Error_Msg_Sem
+ ("individual association of "
+ & Disp_Node (Get_Association_Interface (Iassoc))
+ & " conflicts with that at " & Disp_Location (Sub),
+ Formal);
+ return;
+ end case;
+ end if;
+ when others =>
+ Error_Kind ("add_individual_association_1(2)", Iassoc);
+ end case;
+
+ case Get_Kind (Formal_Object) is
+ when Iir_Kind_Indexed_Name =>
+ Add_Individual_Assoc_Indexed_Name (Iassoc, Formal_Object);
+ when Iir_Kind_Slice_Name =>
+ Add_Individual_Assoc_Slice_Name (Iassoc, Formal_Object);
+ when Iir_Kind_Selected_Element =>
+ Add_Individual_Assoc_Selected_Name (Iassoc, Formal_Object);
+ when others =>
+ Error_Kind ("add_individual_association_1(3)", Formal);
+ end case;
+ end Add_Individual_Association_1;
+
+ -- Insert ASSOC into the tree of individual assoc rooted by IASSOC.
+ procedure Add_Individual_Association (Iassoc : Iir; Assoc : Iir)
+ is
+ Formal : Iir;
+ Iass : Iir;
+ Prev : Iir;
+ begin
+ Formal := Get_Formal (Assoc);
+ Iass := Iassoc;
+ Add_Individual_Association_1 (Iass, Formal);
+ Prev := Get_Associated_Expr (Iass);
+ if Prev /= Null_Iir then
+ Error_Msg_Sem ("individual association of "
+ & Disp_Node (Get_Association_Interface (Assoc))
+ & " conflicts with that at " & Disp_Location (Prev),
+ Assoc);
+ else
+ Set_Associated_Expr (Iass, Assoc);
+ end if;
+ end Add_Individual_Association;
+
+ procedure Finish_Individual_Assoc_Array_Subtype
+ (Assoc : Iir; Atype : Iir; Dim : Positive)
+ is
+ Index_Tlist : constant Iir_List := Get_Index_Subtype_List (Atype);
+ Nbr_Dims : constant Natural := Get_Nbr_Elements (Index_Tlist);
+ Index_Type : Iir;
+ Low, High : Iir;
+ Chain : Iir;
+ El : Iir;
+ begin
+ Index_Type := Get_Nth_Element (Index_Tlist, Dim - 1);
+ Chain := Get_Individual_Association_Chain (Assoc);
+ Sem_Choices_Range
+ (Chain, Index_Type, False, False, Get_Location (Assoc), Low, High);
+ Set_Individual_Association_Chain (Assoc, Chain);
+ if Dim < Nbr_Dims then
+ El := Chain;
+ while El /= Null_Iir loop
+ pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Expression);
+ Finish_Individual_Assoc_Array_Subtype
+ (Get_Associated_Expr (El), Atype, Dim + 1);
+ El := Get_Chain (El);
+ end loop;
+ end if;
+ end Finish_Individual_Assoc_Array_Subtype;
+
+ procedure Finish_Individual_Assoc_Array
+ (Actual : Iir; Assoc : Iir; Dim : Natural)
+ is
+ Actual_Type : Iir;
+ Actual_Index : Iir;
+ Base_Type : Iir;
+ Base_Index : Iir;
+ Low, High : Iir;
+ Chain : Iir;
+ begin
+ Actual_Type := Get_Actual_Type (Actual);
+ Actual_Index := Get_Nth_Element (Get_Index_Subtype_List (Actual_Type),
+ Dim - 1);
+ if Actual_Index /= Null_Iir then
+ Base_Index := Actual_Index;
+ else
+ Base_Type := Get_Base_Type (Actual_Type);
+ Base_Index := Get_Index_Type (Base_Type, Dim - 1);
+ end if;
+ Chain := Get_Individual_Association_Chain (Assoc);
+ Sem_Choices_Range
+ (Chain, Base_Index, True, False, Get_Location (Assoc), Low, High);
+ Set_Individual_Association_Chain (Assoc, Chain);
+ if Actual_Index = Null_Iir then
+ declare
+ Index_Constraint : Iir;
+ Index_Subtype_Constraint : Iir;
+ begin
+ -- Create an index subtype.
+ case Get_Kind (Base_Index) is
+ when Iir_Kind_Integer_Subtype_Definition =>
+ Actual_Index :=
+ Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Actual_Index :=
+ Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when others =>
+ Error_Kind ("finish_individual_assoc_array", Base_Index);
+ end case;
+ Location_Copy (Actual_Index, Actual);
+ Set_Base_Type (Actual_Index, Get_Base_Type (Base_Index));
+ Index_Constraint := Get_Range_Constraint (Base_Index);
+
+ Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Index_Subtype_Constraint, Actual);
+ Set_Range_Constraint (Actual_Index, Index_Subtype_Constraint);
+ Set_Type_Staticness (Actual_Index, Locally);
+ Set_Direction (Index_Subtype_Constraint,
+ Get_Direction (Index_Constraint));
+
+ case Get_Direction (Index_Constraint) is
+ when Iir_To =>
+ Set_Left_Limit (Index_Subtype_Constraint, Low);
+ Set_Right_Limit (Index_Subtype_Constraint, High);
+ when Iir_Downto =>
+ Set_Left_Limit (Index_Subtype_Constraint, High);
+ Set_Right_Limit (Index_Subtype_Constraint, Low);
+ end case;
+ Set_Expr_Staticness (Index_Subtype_Constraint, Locally);
+ Append_Element (Get_Index_Subtype_List (Actual_Type),
+ Actual_Index);
+ end;
+ else
+ declare
+ Act_High, Act_Low : Iir;
+ begin
+ Get_Low_High_Limit (Get_Range_Constraint (Actual_Type),
+ Act_Low, Act_High);
+ if Eval_Pos (Act_Low) /= Eval_Pos (Low)
+ or Eval_Pos (Act_High) /= Eval_Pos (High)
+ then
+ Error_Msg_Sem ("indexes of individual association mismatch",
+ Assoc);
+ end if;
+ end;
+ end if;
+ end Finish_Individual_Assoc_Array;
+
+ procedure Finish_Individual_Assoc_Record (Assoc : Iir; Atype : Iir)
+ is
+ Base_Type : constant Iir_Record_Type_Definition := Get_Base_Type (Atype);
+ El_List : constant Iir_List := Get_Elements_Declaration_List (Base_Type);
+ Matches : Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1);
+ Ch : Iir;
+ Pos : Natural;
+ Rec_El : Iir;
+ begin
+ Matches := (others => Null_Iir);
+ Ch := Get_Individual_Association_Chain (Assoc);
+ while Ch /= Null_Iir loop
+ Rec_El := Get_Choice_Name (Ch);
+ Pos := Natural (Get_Element_Position (Rec_El));
+ if Matches (Pos) /= Null_Iir then
+ Error_Msg_Sem ("individual " & Disp_Node (Rec_El)
+ & " already associated at "
+ & Disp_Location (Matches (Pos)), Ch);
+ else
+ Matches (Pos) := Ch;
+ end if;
+ Ch := Get_Chain (Ch);
+ end loop;
+ for I in Matches'Range loop
+ Rec_El := Get_Nth_Element (El_List, I);
+ if Matches (I) = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Rec_El) & " not associated", Assoc);
+ end if;
+ end loop;
+ Set_Actual_Type (Assoc, Atype);
+ end Finish_Individual_Assoc_Record;
+
+ -- Called by sem_individual_association to finish the semantization of
+ -- individual association ASSOC.
+ procedure Finish_Individual_Association (Assoc : Iir)
+ is
+ Formal : Iir;
+ Atype : Iir;
+ begin
+ -- Guard.
+ if Assoc = Null_Iir then
+ return;
+ end if;
+
+ Formal := Get_Association_Interface (Assoc);
+ Atype := Get_Type (Formal);
+
+ case Get_Kind (Atype) is
+ when Iir_Kind_Array_Subtype_Definition =>
+ Finish_Individual_Assoc_Array_Subtype (Assoc, Atype, 1);
+ Set_Actual_Type (Assoc, Atype);
+ when Iir_Kind_Array_Type_Definition =>
+ Atype := Create_Array_Subtype (Atype, Get_Location (Assoc));
+ Set_Index_Constraint_Flag (Atype, True);
+ Set_Constraint_State (Atype, Fully_Constrained);
+ Set_Actual_Type (Assoc, Atype);
+ Finish_Individual_Assoc_Array (Assoc, Assoc, 1);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Finish_Individual_Assoc_Record (Assoc, Atype);
+ when others =>
+ Error_Kind ("finish_individual_association", Atype);
+ end case;
+ end Finish_Individual_Association;
+
+ -- Sem individual associations of ASSOCS:
+ -- Add an Iir_Kind_Association_Element_By_Individual before each
+ -- group of individual association for the same formal, and call
+ -- Finish_Individual_Association with each of these added nodes.
+ procedure Sem_Individual_Association (Assoc_Chain : in out Iir)
+ is
+ Assoc : Iir;
+ Prev_Assoc : Iir;
+ Iassoc : Iir_Association_Element_By_Individual;
+ Cur_Iface : Iir;
+ Formal : Iir;
+ begin
+ Iassoc := Null_Iir;
+ Cur_Iface := Null_Iir;
+ Prev_Assoc := Null_Iir;
+ Assoc := Assoc_Chain;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ if Formal /= Null_Iir then
+ Formal := Get_Object_Prefix (Formal);
+ end if;
+ if Formal = Null_Iir or else Formal /= Cur_Iface then
+ -- New formal name, sem the current assoc.
+ Finish_Individual_Association (Iassoc);
+ Cur_Iface := Formal;
+ Iassoc := Null_Iir;
+ end if;
+ if Get_Whole_Association_Flag (Assoc) = False then
+ -- New individual association.
+ if Iassoc = Null_Iir then
+ Iassoc :=
+ Create_Iir (Iir_Kind_Association_Element_By_Individual);
+ Location_Copy (Iassoc, Assoc);
+ if Cur_Iface = Null_Iir then
+ raise Internal_Error;
+ end if;
+ Set_Formal (Iassoc, Cur_Iface);
+ -- Insert IASSOC.
+ if Prev_Assoc = Null_Iir then
+ Assoc_Chain := Iassoc;
+ else
+ Set_Chain (Prev_Assoc, Iassoc);
+ end if;
+ Set_Chain (Iassoc, Assoc);
+ end if;
+ Add_Individual_Association (Iassoc, Assoc);
+ end if;
+ Prev_Assoc := Assoc;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ -- There is maybe a remaining iassoc.
+ Finish_Individual_Association (Iassoc);
+ end Sem_Individual_Association;
+
+ function Is_Conversion_Function (Assoc_Chain : Iir) return Boolean
+ is
+ begin
+ -- [...] whose single parameter of the function [...]
+ if not Is_Chain_Length_One (Assoc_Chain) then
+ return False;
+ end if;
+ if Get_Kind (Assoc_Chain) /= Iir_Kind_Association_Element_By_Expression
+ then
+ return False;
+ end if;
+ -- FIXME: unfortunatly, the formal may already be set with the
+ -- interface.
+-- if Get_Formal (Assoc_Chain) /= Null_Iir then
+-- return Null_Iir;
+-- end if;
+ return True;
+ end Is_Conversion_Function;
+
+ function Is_Expanded_Name (Name : Iir) return Boolean
+ is
+ Pfx : Iir;
+ begin
+ Pfx := Name;
+ loop
+ case Get_Kind (Pfx) is
+ when Iir_Kind_Simple_Name =>
+ return True;
+ when Iir_Kind_Selected_Name =>
+ Pfx := Get_Prefix (Pfx);
+ when others =>
+ return False;
+ end case;
+ end loop;
+ end Is_Expanded_Name;
+
+ function Extract_Type_Of_Conversions (Convs : Iir) return Iir
+ is
+ -- Return TRUE iff FUNC is valid as a conversion function/type.
+ function Extract_Type_Of_Conversion (Func : Iir) return Iir is
+ begin
+ case Get_Kind (Func) is
+ when Iir_Kinds_Function_Declaration =>
+ if Is_Chain_Length_One (Get_Interface_Declaration_Chain (Func))
+ then
+ return Get_Type (Func);
+ else
+ return Null_Iir;
+ end if;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ return Null_Iir;
+ end if;
+ return Get_Type (Func);
+ when others =>
+ return Null_Iir;
+ end case;
+ end Extract_Type_Of_Conversion;
+
+ Res_List : Iir_List;
+ Ov_List : Iir_List;
+ El : Iir;
+ Conv_Type : Iir;
+ begin
+ if not Is_Overload_List (Convs) then
+ return Extract_Type_Of_Conversion (Convs);
+ else
+ Ov_List := Get_Overload_List (Convs);
+ Res_List := Create_Iir_List;
+ for I in Natural loop
+ El := Get_Nth_Element (Ov_List, I);
+ exit when El = Null_Iir;
+ Conv_Type := Extract_Type_Of_Conversion (El);
+ if Conv_Type /= Null_Iir then
+ Add_Element (Res_List, Conv_Type);
+ end if;
+ end loop;
+ return Simplify_Overload_List (Res_List);
+ end if;
+ end Extract_Type_Of_Conversions;
+
+ -- ASSOC is an association element not semantized and whose formal is a
+ -- parenthesis name. Try to extract a conversion function/type. In case
+ -- of success, return a new association element. In case of failure,
+ -- return NULL_IIR.
+ function Sem_Formal_Conversion (Assoc : Iir) return Iir
+ is
+ Formal : constant Iir := Get_Formal (Assoc);
+ Assoc_Chain : constant Iir := Get_Association_Chain (Formal);
+ Res : Iir;
+ Conv : Iir;
+ Name : Iir;
+ Conv_Func : Iir;
+ Conv_Type : Iir;
+ begin
+ -- Nothing to do if the formal isn't a conversion.
+ if not Is_Conversion_Function (Assoc_Chain) then
+ return Null_Iir;
+ end if;
+
+ -- Both the conversion function and the formal name must be names.
+ Conv := Get_Prefix (Formal);
+ -- FIXME: what about operator names (such as "not").
+ if Get_Kind (Conv) /= Iir_Kind_Simple_Name
+ and then not Is_Expanded_Name (Conv)
+ then
+ return Null_Iir;
+ end if;
+ Name := Get_Actual (Assoc_Chain);
+ if Get_Kind (Name) not in Iir_Kinds_Name then
+ return Null_Iir;
+ end if;
+
+ Sem_Name_Soft (Conv);
+ Conv_Func := Get_Named_Entity (Conv);
+ if Get_Kind (Conv_Func) = Iir_Kind_Error then
+ Conv_Type := Null_Iir;
+ else
+ Conv_Type := Extract_Type_Of_Conversions (Conv_Func);
+ end if;
+ if Conv_Type = Null_Iir then
+ Sem_Name_Clean (Conv);
+ return Null_Iir;
+ end if;
+ Set_Type (Conv, Conv_Type);
+
+ -- Create a new association with a conversion function.
+ Res := Create_Iir (Iir_Kind_Association_Element_By_Expression);
+ Set_Out_Conversion (Res, Conv);
+ Set_Formal (Res, Name);
+ Set_Actual (Res, Get_Actual (Assoc));
+ return Res;
+ end Sem_Formal_Conversion;
+
+ -- NAME is the formal name of an association, without any conversion
+ -- function or type.
+ -- Try to semantize NAME with INTERFACE.
+ -- In case of success, set PREFIX to the most prefix of NAME and NAME_TYPE
+ -- to the type of NAME.
+ -- In case of failure, set NAME_TYPE to NULL_IIR.
+ procedure Sem_Formal_Name (Name : Iir;
+ Inter : Iir;
+ Prefix : out Iir;
+ Name_Type : out Iir)
+ is
+ Base_Type : Iir;
+ Rec_El : Iir;
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name =>
+ if Get_Identifier (Name) = Get_Identifier (Inter) then
+ Prefix := Name;
+ Name_Type := Get_Type (Inter);
+ else
+ Name_Type := Null_Iir;
+ end if;
+ return;
+ when Iir_Kind_Selected_Name =>
+ Sem_Formal_Name (Get_Prefix (Name), Inter, Prefix, Name_Type);
+ if Name_Type = Null_Iir then
+ return;
+ end if;
+ Base_Type := Get_Base_Type (Name_Type);
+ if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then
+ Name_Type := Null_Iir;
+ return;
+ end if;
+ Rec_El := Find_Name_In_List
+ (Get_Elements_Declaration_List (Base_Type),
+ Get_Identifier (Name));
+ if Rec_El = Null_Iir then
+ Name_Type := Null_Iir;
+ return;
+ end if;
+ Name_Type := Get_Type (Rec_El);
+ return;
+ when Iir_Kind_Parenthesis_Name =>
+ -- More difficult: slice or indexed array.
+ Sem_Formal_Name (Get_Prefix (Name), Inter, Prefix, Name_Type);
+ if Name_Type = Null_Iir then
+ return;
+ end if;
+ Base_Type := Get_Base_Type (Name_Type);
+ if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then
+ Name_Type := Null_Iir;
+ return;
+ end if;
+ declare
+ Chain : Iir;
+ Index_List : Iir_List;
+ Idx : Iir;
+ begin
+ Chain := Get_Association_Chain (Name);
+ Index_List := Get_Index_Subtype_List (Base_Type);
+ -- Check for matching length.
+ if Get_Chain_Length (Chain) /= Get_Nbr_Elements (Index_List)
+ then
+ Name_Type := Null_Iir;
+ return;
+ end if;
+ if Get_Kind (Chain)
+ /= Iir_Kind_Association_Element_By_Expression
+ then
+ Name_Type := Null_Iir;
+ return;
+ end if;
+ Idx := Get_Actual (Chain);
+ if (not Is_Chain_Length_One (Chain))
+ or else (Get_Kind (Idx) /= Iir_Kind_Range_Expression
+ and then not Is_Range_Attribute_Name (Idx))
+ -- FIXME: what about subtype !
+ then
+ -- Indexed name.
+ Name_Type := Get_Element_Subtype (Base_Type);
+ return;
+ end if;
+ -- Slice.
+ return;
+ end;
+ when others =>
+ Error_Kind ("sem_formal_name", Name);
+ end case;
+ end Sem_Formal_Name;
+
+ -- Return a type or a list of types for a formal expression FORMAL
+ -- corresponding to INTERFACE. Possible cases are:
+ -- * FORMAL is the simple name with the same identifier as INTERFACE,
+ -- FORMAL_TYPE is set to the type of INTERFACE and CONV_TYPE is set
+ -- to NULL_IIR.
+ -- * FORMAL is a selected, indexed or slice name whose extreme prefix is
+ -- a simple name with the same identifier as INTERFACE, FORMAL_TYPE
+ -- is set to the type of the name, and CONV_TYPE is set to NULL_IIR.
+ -- * FORMAL is a function call, whose only argument is an
+ -- association_element_by_expression, whose actual is a name
+ -- whose prefix is the same identifier as INTERFACE (note, since FORMAL
+ -- is not semantized, this is parenthesis name), CONV_TYPE is set to
+ -- the type or list of type of return type of conversion functions and
+ -- FORMAL_TYPE is set to the type of the name.
+ -- * otherwise, FORMAL cannot match INTERFACE and both FORMAL_TYPE and
+ -- CONV_TYPE are set to NULL_IIR.
+ -- If FINISH is true, the simple name is replaced by INTERFACE.
+
+ type Param_Assoc_Type is (None, Open, Individual, Whole);
+
+ function Sem_Formal (Formal : Iir; Inter : Iir) return Param_Assoc_Type
+ is
+ Prefix : Iir;
+ Formal_Type : Iir;
+ begin
+ case Get_Kind (Formal) is
+ when Iir_Kind_Simple_Name =>
+ -- Certainly the most common case: FORMAL_NAME => VAL.
+ -- It is also the easiest. So, handle it completly now.
+ if Get_Identifier (Formal) = Get_Identifier (Inter) then
+ Formal_Type := Get_Type (Inter);
+ Set_Named_Entity (Formal, Inter);
+ Set_Type (Formal, Formal_Type);
+ Set_Base_Name (Formal, Inter);
+ return Whole;
+ end if;
+ return None;
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Parenthesis_Name =>
+ null;
+ when others =>
+ -- Should have been caught by sem_association_list.
+ Error_Kind ("sem_formal", Formal);
+ end case;
+ -- Check for a sub-element.
+ Sem_Formal_Name (Formal, Inter, Prefix, Formal_Type);
+ if Formal_Type /= Null_Iir then
+ Set_Type (Formal, Formal_Type);
+ Set_Named_Entity (Prefix, Inter);
+ return Individual;
+ else
+ return None;
+ end if;
+ end Sem_Formal;
+
+ function Is_Valid_Conversion
+ (Func : Iir; Res_Base_Type : Iir; Param_Base_Type : Iir)
+ return Boolean
+ is
+ R_Type : Iir;
+ P_Type : Iir;
+ begin
+ case Get_Kind (Func) is
+ when Iir_Kinds_Function_Declaration =>
+ R_Type := Get_Type (Func);
+ P_Type := Get_Type (Get_Interface_Declaration_Chain (Func));
+ if Get_Base_Type (R_Type) = Res_Base_Type
+ and then Get_Base_Type (P_Type) = Param_Base_Type
+ then
+ return True;
+ else
+ return False;
+ end if;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ R_Type := Get_Type (Func);
+ if Get_Base_Type (R_Type) = Res_Base_Type
+ and then Are_Types_Closely_Related (R_Type, Param_Base_Type)
+ then
+ return True;
+ else
+ return False;
+ end if;
+ when Iir_Kind_Function_Call =>
+ return Is_Valid_Conversion (Get_Implementation (Func),
+ Res_Base_Type, Param_Base_Type);
+ when Iir_Kind_Type_Conversion =>
+ return Is_Valid_Conversion (Get_Type_Mark (Func),
+ Res_Base_Type, Param_Base_Type);
+ when Iir_Kinds_Denoting_Name =>
+ return Is_Valid_Conversion (Get_Named_Entity (Func),
+ Res_Base_Type, Param_Base_Type);
+ when others =>
+ Error_Kind ("is_valid_conversion(2)", Func);
+ end case;
+ end Is_Valid_Conversion;
+
+ function Extract_Conversion
+ (Conv : Iir; Res_Type : Iir; Param_Type : Iir; Loc : Iir)
+ return Iir
+ is
+ List : Iir_List;
+ Res_Base_Type : Iir;
+ Param_Base_Type : Iir;
+ El : Iir;
+ Res : Iir;
+ begin
+ Res_Base_Type := Get_Base_Type (Res_Type);
+ if Param_Type = Null_Iir then
+ -- In case of error.
+ return Null_Iir;
+ end if;
+ Param_Base_Type := Get_Base_Type (Param_Type);
+ if Is_Overload_List (Conv) then
+ List := Get_Overload_List (Conv);
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Is_Valid_Conversion (El, Res_Base_Type, Param_Base_Type) then
+ if Res /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Free_Iir (Conv);
+ Res := El;
+ end if;
+ end loop;
+ else
+ if Is_Valid_Conversion (Conv, Res_Base_Type, Param_Base_Type) then
+ Res := Conv;
+ else
+ Res := Null_Iir;
+ Error_Msg_Sem ("conversion function or type does not match", Loc);
+ end if;
+ end if;
+ return Res;
+ end Extract_Conversion;
+
+ function Extract_In_Conversion (Conv : Iir;
+ Res_Type : Iir; Param_Type : Iir)
+ return Iir
+ is
+ Func : Iir;
+ begin
+ if Conv = Null_Iir then
+ return Null_Iir;
+ end if;
+ Func := Extract_Conversion (Conv, Res_Type, Param_Type, Conv);
+ if Func = Null_Iir then
+ return Null_Iir;
+ end if;
+ case Get_Kind (Func) is
+ when Iir_Kind_Function_Call
+ | Iir_Kind_Type_Conversion =>
+ return Func;
+ when others =>
+ Error_Kind ("extract_in_conversion", Func);
+ end case;
+ end Extract_In_Conversion;
+
+ function Extract_Out_Conversion (Conv : Iir;
+ Res_Type : Iir; Param_Type : Iir)
+ return Iir
+ is
+ Func : Iir;
+ Res : Iir;
+ begin
+ if Conv = Null_Iir then
+ return Null_Iir;
+ end if;
+ Func := Extract_Conversion (Get_Named_Entity (Conv),
+ Res_Type, Param_Type, Conv);
+ if Func = Null_Iir then
+ return Null_Iir;
+ end if;
+ pragma Assert (Get_Kind (Conv) in Iir_Kinds_Denoting_Name);
+ Set_Named_Entity (Conv, Func);
+
+ case Get_Kind (Func) is
+ when Iir_Kinds_Function_Declaration =>
+ Res := Create_Iir (Iir_Kind_Function_Call);
+ Location_Copy (Res, Conv);
+ Set_Implementation (Res, Func);
+ Set_Prefix (Res, Conv);
+ Set_Base_Name (Res, Res);
+ Set_Parameter_Association_Chain (Res, Null_Iir);
+ Set_Type (Res, Get_Return_Type (Func));
+ Set_Expr_Staticness (Res, None);
+ Mark_Subprogram_Used (Func);
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration =>
+ Res := Create_Iir (Iir_Kind_Type_Conversion);
+ Location_Copy (Res, Conv);
+ Set_Type_Mark (Res, Conv);
+ Set_Type (Res, Get_Type (Func));
+ Set_Expression (Res, Null_Iir);
+ Set_Expr_Staticness (Res, None);
+ when others =>
+ Error_Kind ("extract_out_conversion", Res);
+ end case;
+ Xrefs.Xref_Name (Conv);
+ return Res;
+ end Extract_Out_Conversion;
+
+ procedure Sem_Association_Open
+ (Assoc : Iir;
+ Inter : Iir;
+ Finish : Boolean;
+ Match : out Boolean)
+ is
+ Formal : Iir;
+ Assoc_Kind : Param_Assoc_Type;
+ begin
+ Formal := Get_Formal (Assoc);
+
+ if Formal /= Null_Iir then
+ Assoc_Kind := Sem_Formal (Formal, Inter);
+ if Assoc_Kind = None then
+ Match := False;
+ return;
+ end if;
+ Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole);
+ if Finish then
+ Sem_Name (Formal);
+ Formal := Finish_Sem_Name (Formal);
+ Set_Formal (Assoc, Formal);
+ if Get_Kind (Formal) in Iir_Kinds_Denoting_Name
+ and then Is_Error (Get_Named_Entity (Formal))
+ then
+ Match := False;
+ return;
+ end if;
+
+ -- LRM 4.3.3.2 Associations lists
+ -- It is an error if an actual of open is associated with a
+ -- formal that is associated individually.
+ if Assoc_Kind = Individual then
+ Error_Msg_Sem ("cannot associate individually with open",
+ Assoc);
+ end if;
+ end if;
+ else
+ Set_Whole_Association_Flag (Assoc, True);
+ end if;
+ Match := True;
+ end Sem_Association_Open;
+
+ procedure Sem_Association_Package
+ (Assoc : Iir;
+ Inter : Iir;
+ Finish : Boolean;
+ Match : out Boolean)
+ is
+ Formal : constant Iir := Get_Formal (Assoc);
+ Actual : Iir;
+ Package_Inter : Iir;
+ begin
+ if not Finish then
+ Match := Get_Associated_Interface (Assoc) = Inter;
+ return;
+ end if;
+
+ -- Always match (as this is a generic association, there is no
+ -- need to resolve overload).
+ pragma Assert (Get_Associated_Interface (Assoc) = Inter);
+ Match := True;
+
+ if Formal /= Null_Iir then
+ pragma Assert (Get_Kind (Formal) = Iir_Kind_Simple_Name);
+ pragma Assert (Get_Identifier (Formal) = Get_Identifier (Inter));
+ Set_Named_Entity (Formal, Inter);
+ Set_Base_Name (Formal, Inter);
+ end if;
+
+ -- Analyze actual.
+ Actual := Get_Actual (Assoc);
+ Actual := Sem_Denoting_Name (Actual);
+ Set_Actual (Assoc, Actual);
+
+ Actual := Get_Named_Entity (Actual);
+ if Is_Error (Actual) then
+ return;
+ end if;
+
+ -- LRM08 6.5.7.2 Generic map aspects
+ -- An actual associated with a formal generic package in a
+ -- generic map aspect shall be the name that denotes an instance
+ -- of the uninstantiated package named in the formal generic
+ -- package declaration [...]
+ if Get_Kind (Actual) /= Iir_Kind_Package_Instantiation_Declaration then
+ Error_Msg_Sem
+ ("actual of association is not a package instantiation", Assoc);
+ return;
+ end if;
+
+ Package_Inter :=
+ Get_Named_Entity (Get_Uninstantiated_Package_Name (Inter));
+ if Get_Named_Entity (Get_Uninstantiated_Package_Name (Actual))
+ /= Package_Inter
+ then
+ Error_Msg_Sem
+ ("actual package name is not an instance of interface package",
+ Assoc);
+ return;
+ end if;
+
+ -- LRM08 6.5.7.2 Generic map aspects
+ -- b) If the formal generic package declaration includes an interface
+ -- generic map aspect in the form that includes the box (<>) symbol,
+ -- then the instantiaed package denotes by the actual may be any
+ -- instance of the uninstantiated package named in the formal
+ -- generic package declaration.
+ if Get_Generic_Map_Aspect_Chain (Inter) = Null_Iir then
+ null;
+ else
+ -- Other cases not yet handled.
+ raise Internal_Error;
+ end if;
+
+ return;
+ end Sem_Association_Package;
+
+ -- Associate ASSOC with interface INTERFACE
+ -- This sets MATCH.
+ procedure Sem_Association_By_Expression
+ (Assoc : Iir;
+ Inter : Iir;
+ Finish : Boolean;
+ Match : out Boolean)
+ is
+ Formal : Iir;
+ Formal_Type : Iir;
+ Actual: Iir;
+ Out_Conv, In_Conv : Iir;
+ Expr : Iir;
+ Res_Type : Iir;
+ Assoc_Kind : Param_Assoc_Type;
+ begin
+ Formal := Get_Formal (Assoc);
+
+ -- Pre-semantize formal and extract out conversion.
+ if Formal /= Null_Iir then
+ Assoc_Kind := Sem_Formal (Formal, Inter);
+ if Assoc_Kind = None then
+ Match := False;
+ return;
+ end if;
+ Set_Whole_Association_Flag (Assoc, Assoc_Kind = Whole);
+ Formal := Get_Formal (Assoc);
+
+ Out_Conv := Get_Out_Conversion (Assoc);
+ else
+ Set_Whole_Association_Flag (Assoc, True);
+ Out_Conv := Null_Iir;
+ Formal := Inter;
+ end if;
+ Formal_Type := Get_Type (Formal);
+
+ -- Extract conversion from actual.
+ Actual := Get_Actual (Assoc);
+ In_Conv := Null_Iir;
+ if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then
+ case Get_Kind (Actual) is
+ when Iir_Kind_Function_Call =>
+ Expr := Get_Parameter_Association_Chain (Actual);
+ if Is_Conversion_Function (Expr) then
+ In_Conv := Actual;
+ Actual := Get_Actual (Expr);
+ end if;
+ when Iir_Kind_Type_Conversion =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ In_Conv := Actual;
+ Actual := Get_Expression (Actual);
+ end if;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ -- 4 cases: F:out_conv, G:in_conv.
+ -- A => B type of A = type of B
+ -- F(A) => B type of B = type of F
+ -- A => G(B) type of A = type of G
+ -- F(A) => G(B) type of B = type of F, type of A = type of G
+ if Out_Conv = Null_Iir and then In_Conv = Null_Iir then
+ Match := Is_Expr_Compatible (Formal_Type, Actual);
+ else
+ Match := True;
+ if In_Conv /= Null_Iir then
+ if not Is_Expr_Compatible (Formal_Type, In_Conv) then
+ Match := False;
+ end if;
+ end if;
+ if Out_Conv /= Null_Iir then
+ if not Is_Expr_Compatible (Get_Type (Out_Conv), Actual) then
+ Match := False;
+ end if;
+ end if;
+ end if;
+
+ if not Match then
+ if Finish then
+ Error_Msg_Sem
+ ("can't associate " & Disp_Node (Actual) & " with "
+ & Disp_Node (Inter), Assoc);
+ Error_Msg_Sem
+ ("(type of " & Disp_Node (Actual) & " is "
+ & Disp_Type_Of (Actual) & ")", Assoc);
+ Error_Msg_Sem
+ ("(type of " & Disp_Node (Inter) & " is "
+ & Disp_Type_Of (Inter) & ")", Inter);
+ end if;
+ return;
+ end if;
+
+ if not Finish then
+ return;
+ end if;
+
+ -- At that point, the analysis is being finished.
+
+ if Out_Conv = Null_Iir and then In_Conv = Null_Iir then
+ Res_Type := Formal_Type;
+ else
+ if Out_Conv /= Null_Iir then
+ Res_Type := Search_Compatible_Type (Get_Type (Out_Conv),
+ Get_Type (Actual));
+ else
+ Res_Type := Get_Type (Actual);
+ end if;
+
+ if In_Conv /= Null_Iir then
+ In_Conv := Extract_In_Conversion (In_Conv, Formal_Type, Res_Type);
+ end if;
+ if Out_Conv /= Null_Iir then
+ Out_Conv := Extract_Out_Conversion (Out_Conv,
+ Res_Type, Formal_Type);
+ end if;
+ end if;
+
+ if Res_Type = Null_Iir then
+ -- In case of error, do not go farther.
+ Match := False;
+ return;
+ end if;
+
+ -- Semantize formal.
+ if Get_Formal (Assoc) /= Null_Iir then
+ Set_Type (Formal, Null_Iir);
+ Sem_Name (Formal);
+ Expr := Get_Named_Entity (Formal);
+ if Get_Kind (Expr) = Iir_Kind_Error then
+ return;
+ end if;
+ Formal := Finish_Sem_Name (Formal);
+ Set_Formal (Assoc, Formal);
+ Formal_Type := Get_Type (Expr);
+ if Out_Conv = Null_Iir and In_Conv = Null_Iir then
+ Res_Type := Formal_Type;
+ end if;
+ end if;
+
+ -- LRM08 6.5.7 Association lists
+ -- The formal part of a named association element may be in the form of
+ -- a function call [...] if and only if the formal is an interface
+ -- object, the mode of the formal is OUT, INOUT, BUFFER or LINKAGE [...]
+ Set_Out_Conversion (Assoc, Out_Conv);
+ if Out_Conv /= Null_Iir
+ and then Get_Mode (Inter) = Iir_In_Mode
+ then
+ Error_Msg_Sem
+ ("can't use an out conversion for an in interface", Assoc);
+ end if;
+
+ -- LRM08 6.5.7 Association lists
+ -- The actual part of an association element may be in the form of a
+ -- function call [...] if and only if the mode of the format is IN,
+ -- INOUT or LINKAGE [...]
+ Set_In_Conversion (Assoc, In_Conv);
+ if In_Conv /= Null_Iir
+ and then Get_Mode (Inter) in Iir_Buffer_Mode .. Iir_Out_Mode
+ then
+ Error_Msg_Sem
+ ("can't use an in conversion for an out/buffer interface", Assoc);
+ end if;
+
+ -- FIXME: LRM refs
+ -- This is somewhat wrong. A missing conversion is not an error but
+ -- may result in a type mismatch.
+ if Get_Mode (Inter) = Iir_Inout_Mode then
+ if In_Conv = Null_Iir and then Out_Conv /= Null_Iir then
+ Error_Msg_Sem
+ ("out conversion without corresponding in conversion", Assoc);
+ elsif In_Conv /= Null_Iir and then Out_Conv = Null_Iir then
+ Error_Msg_Sem
+ ("in conversion without corresponding out conversion", Assoc);
+ end if;
+ end if;
+ Set_Actual (Assoc, Actual);
+
+ -- Semantize actual.
+ Expr := Sem_Expression (Actual, Res_Type);
+ if Expr /= Null_Iir then
+ Expr := Eval_Expr_Check_If_Static (Expr, Res_Type);
+ Set_Actual (Assoc, Expr);
+ if In_Conv = Null_Iir and then Out_Conv = Null_Iir then
+ if not Check_Implicit_Conversion (Formal_Type, Expr) then
+ Error_Msg_Sem ("actual length does not match formal length",
+ Assoc);
+ end if;
+ end if;
+ end if;
+ end Sem_Association_By_Expression;
+
+ -- Associate ASSOC with interface INTERFACE
+ -- This sets MATCH.
+ procedure Sem_Association
+ (Assoc : Iir; Inter : Iir; Finish : Boolean; Match : out Boolean) is
+ begin
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ Sem_Association_Open (Assoc, Inter, Finish, Match);
+
+ when Iir_Kind_Association_Element_Package =>
+ Sem_Association_Package (Assoc, Inter, Finish, Match);
+
+ when Iir_Kind_Association_Element_By_Expression =>
+ Sem_Association_By_Expression (Assoc, Inter, Finish, Match);
+
+ when others =>
+ Error_Kind ("sem_assocation", Assoc);
+ end case;
+ end Sem_Association;
+
+ procedure Sem_Association_Chain
+ (Interface_Chain : Iir;
+ Assoc_Chain: in out Iir;
+ Finish: Boolean;
+ Missing : Missing_Type;
+ Loc : Iir;
+ Match : out Boolean)
+ is
+ -- Set POS and INTERFACE to *the* matching interface if any of ASSOC.
+ procedure Search_Interface (Assoc : Iir;
+ Inter : out Iir;
+ Pos : out Integer)
+ is
+ I_Match : Boolean;
+ begin
+ Inter := Interface_Chain;
+ Pos := 0;
+ while Inter /= Null_Iir loop
+ -- Formal assoc is not necessarily a simple name, it may
+ -- be a conversion function, or even an indexed or
+ -- selected name.
+ Sem_Association (Assoc, Inter, False, I_Match);
+ if I_Match then
+ return;
+ end if;
+ Inter := Get_Chain (Inter);
+ Pos := Pos + 1;
+ end loop;
+ end Search_Interface;
+
+ Assoc: Iir;
+ Inter: Iir;
+
+ type Bool_Array is array (Natural range <>) of Param_Assoc_Type;
+ Nbr_Arg: constant Natural := Get_Chain_Length (Interface_Chain);
+ Arg_Matched: Bool_Array (0 .. Nbr_Arg - 1) := (others => None);
+
+ Last_Individual : Iir;
+ Has_Individual : Boolean;
+ Pos : Integer;
+ Formal : Iir;
+
+ Interface_1 : Iir;
+ Pos_1 : Integer;
+ Assoc_1 : Iir;
+ begin
+ Match := True;
+ Has_Individual := False;
+
+ -- Loop on every assoc element, try to match it.
+ Inter := Interface_Chain;
+ Last_Individual := Null_Iir;
+ Pos := 0;
+
+ Assoc := Assoc_Chain;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ if Formal = Null_Iir then
+ -- Positional argument.
+ if Pos < 0 then
+ -- Positional after named argument. Already caught by
+ -- Sem_Actual_Of_Association_Chain (because it is called only
+ -- once, while sem_association_chain may be called several
+ -- times).
+ Match := False;
+ return;
+ end if;
+ -- Try to match actual of ASSOC with the interface.
+ if Inter = Null_Iir then
+ if Finish then
+ Error_Msg_Sem
+ ("too many actuals for " & Disp_Node (Loc), Assoc);
+ end if;
+ Match := False;
+ return;
+ end if;
+ Sem_Association (Assoc, Inter, Finish, Match);
+ if not Match then
+ return;
+ end if;
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
+ Arg_Matched (Pos) := Open;
+ else
+ Arg_Matched (Pos) := Whole;
+ end if;
+ Set_Whole_Association_Flag (Assoc, True);
+ Inter := Get_Chain (Inter);
+ Pos := Pos + 1;
+ else
+ -- FIXME: directly search the formal if finish is true.
+ -- Find the Interface.
+ case Get_Kind (Formal) is
+ when Iir_Kind_Parenthesis_Name =>
+ Assoc_1 := Sem_Formal_Conversion (Assoc);
+ if Assoc_1 /= Null_Iir then
+ Search_Interface (Assoc_1, Interface_1, Pos_1);
+ -- LRM 4.3.2.2 Association Lists
+ -- The formal part of a named element association may be
+ -- in the form of a function call, [...], if and only
+ -- if the mode of the formal is OUT, INOUT, BUFFER, or
+ -- LINKAGE, and the actual is not OPEN.
+ if Interface_1 = Null_Iir
+ or else Get_Mode (Interface_1) = Iir_In_Mode
+ then
+ Sem_Name_Clean (Get_Out_Conversion (Assoc_1));
+ Free_Iir (Assoc_1);
+ Assoc_1 := Null_Iir;
+ end if;
+ end if;
+ Search_Interface (Assoc, Inter, Pos);
+ if Inter = Null_Iir then
+ if Assoc_1 /= Null_Iir then
+ Inter := Interface_1;
+ Pos := Pos_1;
+ Free_Parenthesis_Name
+ (Get_Formal (Assoc), Get_Out_Conversion (Assoc_1));
+ Set_Formal (Assoc, Get_Formal (Assoc_1));
+ Set_Out_Conversion
+ (Assoc, Get_Out_Conversion (Assoc_1));
+ Set_Whole_Association_Flag
+ (Assoc, Get_Whole_Association_Flag (Assoc_1));
+ Free_Iir (Assoc_1);
+ end if;
+ else
+ if Assoc_1 /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ end if;
+ when others =>
+ Search_Interface (Assoc, Inter, Pos);
+ end case;
+
+ if Inter /= Null_Iir then
+ if Get_Whole_Association_Flag (Assoc) then
+ -- Whole association.
+ Last_Individual := Null_Iir;
+ if Arg_Matched (Pos) = None then
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open
+ then
+ Arg_Matched (Pos) := Open;
+ else
+ Arg_Matched (Pos) := Whole;
+ end if;
+ else
+ if Finish then
+ Error_Msg_Sem
+ (Disp_Node (Inter) & " already associated", Assoc);
+ Match := False;
+ return;
+ end if;
+ end if;
+ else
+ -- Individual association.
+ Has_Individual := True;
+ if Arg_Matched (Pos) /= Whole then
+ if Finish
+ and then Arg_Matched (Pos) = Individual
+ and then Last_Individual /= Inter
+ then
+ Error_Msg_Sem
+ ("non consecutive individual association for "
+ & Disp_Node (Inter), Assoc);
+ Match := False;
+ return;
+ end if;
+ Last_Individual := Inter;
+ Arg_Matched (Pos) := Individual;
+ else
+ if Finish then
+ Error_Msg_Sem
+ (Disp_Node (Inter) & " already associated", Assoc);
+ Match := False;
+ return;
+ end if;
+ end if;
+ end if;
+ if Finish then
+ Sem_Association (Assoc, Inter, True, Match);
+ -- MATCH can be false du to errors.
+ end if;
+ else
+ -- Not found.
+ if Finish then
+ -- FIXME: display the name of subprg or component/entity.
+ -- FIXME: fetch the interface (for parenthesis_name).
+ Error_Msg_Sem
+ ("no interface for " & Disp_Node (Get_Formal (Assoc))
+ & " in association", Assoc);
+ end if;
+ Match := False;
+ return;
+ end if;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ if Finish and then Has_Individual then
+ Sem_Individual_Association (Assoc_Chain);
+ end if;
+
+ if Missing = Missing_Allowed then
+ return;
+ end if;
+
+ -- LRM93 8.6 Procedure Call Statement
+ -- For each formal parameter of a procedure, a procedure call must
+ -- specify exactly one corresponding actual parameter.
+ -- This actual parameter is specified either explicitly, by an
+ -- association element (other than the actual OPEN) in the association
+ -- list, or in the absence of such an association element, by a default
+ -- expression (see Section 4.3.3.2).
+
+ -- LRM93 7.3.3 Function Calls
+ -- For each formal parameter of a function, a function call must
+ -- specify exactly one corresponding actual parameter.
+ -- This actual parameter is specified either explicitly, by an
+ -- association element (other than the actual OPEN) in the association
+ -- list, or in the absence of such an association element, by a default
+ -- expression (see Section 4.3.3.2).
+
+ -- LRM93 1.1.1.2 / LRM08 6.5.6.3 Port clauses
+ -- A port of mode IN may be unconnected or unassociated only if its
+ -- declaration includes a default expression.
+ -- It is an error if a port of any mode other than IN is unconnected
+ -- or unassociated and its type is an unconstrained array type.
+
+ -- LRM08 6.5.6.2 Generic clauses
+ -- It is an error if no such actual [instantiated package] is specified
+ -- for a given formal generic package (either because the formal generic
+ -- is unassociated or because the actual is OPEN).
+
+ Inter := Interface_Chain;
+ Pos := 0;
+ while Inter /= Null_Iir loop
+ if Arg_Matched (Pos) <= Open then
+ case Get_Kind (Inter) is
+ when Iir_Kinds_Interface_Object_Declaration =>
+ if Get_Default_Value (Inter) = Null_Iir then
+ case Missing is
+ when Missing_Parameter
+ | Missing_Generic =>
+ if Finish then
+ Error_Msg_Sem
+ ("no actual for " & Disp_Node (Inter), Loc);
+ end if;
+ Match := False;
+ return;
+ when Missing_Port =>
+ case Get_Mode (Inter) is
+ when Iir_In_Mode =>
+ if not Finish then
+ raise Internal_Error;
+ end if;
+ Error_Msg_Sem
+ (Disp_Node (Inter)
+ & " of mode IN must be connected", Loc);
+ Match := False;
+ return;
+ when Iir_Out_Mode
+ | Iir_Linkage_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode =>
+ if not Finish then
+ raise Internal_Error;
+ end if;
+ if not Is_Fully_Constrained_Type
+ (Get_Type (Inter))
+ then
+ Error_Msg_Sem
+ ("unconstrained " & Disp_Node (Inter)
+ & " must be connected", Loc);
+ Match := False;
+ return;
+ end if;
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ end case;
+ when Missing_Allowed =>
+ null;
+ end case;
+ end if;
+ when Iir_Kind_Interface_Package_Declaration =>
+ Error_Msg_Sem
+ (Disp_Node (Inter) & " must be associated", Loc);
+ Match := False;
+ when others =>
+ Error_Kind ("sem_association_chain", Inter);
+ end case;
+ end if;
+ Inter := Get_Chain (Inter);
+ Pos := Pos + 1;
+ end loop;
+ end Sem_Association_Chain;
+end Sem_Assocs;
diff --git a/src/sem_assocs.ads b/src/sem_assocs.ads
new file mode 100644
index 000000000..ec460e0e3
--- /dev/null
+++ b/src/sem_assocs.ads
@@ -0,0 +1,60 @@
+-- Semantic analysis.
+-- 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 Sem_Assocs is
+ -- Change the kind of association corresponding to non-object interfaces.
+ -- Such an association mustn't be handled an like association for object.
+ function Extract_Non_Object_Association
+ (Assoc_Chain : Iir; Inter_Chain : Iir) return Iir;
+
+ -- Semantize actuals of ASSOC_CHAIN.
+ -- Check all named associations are after positionnal one.
+ -- Return TRUE if no error.
+ function Sem_Actual_Of_Association_Chain (Assoc_Chain : Iir) return Boolean;
+
+ -- Semantize association chain ASSOC_CHAIN with interfaces from
+ -- INTERFACE_CHAIN.
+ -- Return the level of compatibility between the two chains in LEVEL.
+ -- If FINISH is true, then ASSOC_CHAIN may be modifies (individual assoc
+ -- added), and error messages (if any) are displayed.
+ -- MISSING control unassociated interfaces.
+ -- LOC is the association.
+ -- Sem_Actual_Of_Association_Chain must have been called before.
+ type Missing_Type is (Missing_Parameter, Missing_Port, Missing_Generic,
+ Missing_Allowed);
+ procedure Sem_Association_Chain
+ (Interface_Chain : Iir;
+ Assoc_Chain: in out Iir;
+ Finish: Boolean;
+ Missing : Missing_Type;
+ Loc : Iir;
+ Match : out Boolean);
+
+ -- Do port Sem_Association_Chain checks for subprograms.
+ procedure Check_Subprogram_Associations
+ (Inter_Chain : Iir; Assoc_Chain : Iir);
+
+ -- Check for restrictions in �1.1.1.2
+ -- Return FALSE in case of error.
+ function Check_Port_Association_Restriction
+ (Formal : Iir_Interface_Signal_Declaration;
+ Actual : Iir_Interface_Signal_Declaration;
+ Assoc : Iir)
+ return Boolean;
+end Sem_Assocs;
diff --git a/src/sem_decls.adb b/src/sem_decls.adb
new file mode 100644
index 000000000..a7c0b4b44
--- /dev/null
+++ b/src/sem_decls.adb
@@ -0,0 +1,3018 @@
+-- Semantic analysis.
+-- 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 Errorout; use Errorout;
+with Types; use Types;
+with Std_Names;
+with Tokens;
+with Flags; use Flags;
+with Std_Package; use Std_Package;
+with Ieee.Std_Logic_1164;
+with Iir_Chains;
+with Evaluation; use Evaluation;
+with Name_Table;
+with Iirs_Utils; use Iirs_Utils;
+with Sem; use Sem;
+with Sem_Expr; use Sem_Expr;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Names; use Sem_Names;
+with Sem_Specs; use Sem_Specs;
+with Sem_Types; use Sem_Types;
+with Sem_Inst;
+with Xrefs; use Xrefs;
+use Iir_Chains;
+
+package body Sem_Decls is
+ -- Emit an error if the type of DECL is a file type, access type,
+ -- protected type or if a subelement of DECL is an access type.
+ procedure Check_Signal_Type (Decl : Iir)
+ is
+ Decl_Type : Iir;
+ begin
+ Decl_Type := Get_Type (Decl);
+ if Get_Signal_Type_Flag (Decl_Type) = False then
+ Error_Msg_Sem ("type of " & Disp_Node (Decl)
+ & " cannot be " & Disp_Node (Decl_Type), Decl);
+ case Get_Kind (Decl_Type) is
+ when Iir_Kind_File_Type_Definition =>
+ null;
+ when Iir_Kind_Protected_Type_Declaration =>
+ null;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when Iir_Kinds_Array_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Error_Msg_Sem ("(" & Disp_Node (Decl_Type)
+ & " has an access subelement)", Decl);
+ when others =>
+ Error_Kind ("check_signal_type", Decl_Type);
+ end case;
+ end if;
+ end Check_Signal_Type;
+
+ procedure Sem_Interface_Object_Declaration
+ (Inter, Last : Iir; Interface_Kind : Interface_Kind_Type)
+ is
+ A_Type: Iir;
+ Default_Value: Iir;
+ begin
+ -- Avoid the reanalysed duplicated types.
+ -- This is not an optimization, since the unanalysed type must have
+ -- been freed.
+ A_Type := Get_Subtype_Indication (Inter);
+ if A_Type = Null_Iir then
+ pragma Assert (Last /= Null_Iir);
+ Set_Subtype_Indication (Inter, Get_Subtype_Indication (Last));
+ A_Type := Get_Type (Last);
+ Default_Value := Get_Default_Value (Last);
+ else
+ A_Type := Sem_Subtype_Indication (A_Type);
+ Set_Subtype_Indication (Inter, A_Type);
+ A_Type := Get_Type_Of_Subtype_Indication (A_Type);
+
+ Default_Value := Get_Default_Value (Inter);
+ if Default_Value /= Null_Iir and then A_Type /= Null_Iir then
+ Deferred_Constant_Allowed := True;
+ Default_Value := Sem_Expression (Default_Value, A_Type);
+ Default_Value :=
+ Eval_Expr_Check_If_Static (Default_Value, A_Type);
+ Deferred_Constant_Allowed := False;
+ Check_Read (Default_Value);
+ end if;
+ end if;
+
+ Set_Name_Staticness (Inter, Locally);
+ Xref_Decl (Inter);
+
+ if A_Type /= Null_Iir then
+ Set_Type (Inter, A_Type);
+
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then
+ case Get_Signal_Kind (Inter) is
+ when Iir_No_Signal_Kind =>
+ null;
+ when Iir_Bus_Kind =>
+ -- FIXME: where this test came from ?
+ -- FIXME: from 4.3.1.2 ?
+ if False
+ and
+ (Get_Kind (A_Type) not in Iir_Kinds_Subtype_Definition
+ or else Get_Resolution_Indication (A_Type) = Null_Iir)
+ then
+ Error_Msg_Sem
+ (Disp_Node (A_Type) & " of guarded " & Disp_Node (Inter)
+ & " is not resolved", Inter);
+ end if;
+
+ -- LRM 2.1.1.2 Signal parameter
+ -- It is an error if the declaration of a formal signal
+ -- parameter includes the reserved word BUS.
+ if Flags.Vhdl_Std >= Vhdl_93
+ and then Interface_Kind in Parameter_Interface_List
+ then
+ Error_Msg_Sem
+ ("signal parameter can't be of kind bus", Inter);
+ end if;
+ when Iir_Register_Kind =>
+ Error_Msg_Sem
+ ("interface signal can't be of kind register", Inter);
+ end case;
+ Set_Type_Has_Signal (A_Type);
+ end if;
+
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ -- LRM 4.3.2 Interface declarations
+ -- For an interface constant declaration or an interface
+ -- signal declaration, the subtype indication must define
+ -- a subtype that is neither a file type, an access type,
+ -- nor a protected type. Moreover, the subtype indication
+ -- must not denote a composite type with a subelement that
+ -- is a file type, an access type, or a protected type.
+ Check_Signal_Type (Inter);
+ when Iir_Kind_Interface_Variable_Declaration =>
+ case Get_Kind (Get_Base_Type (A_Type)) is
+ when Iir_Kind_File_Type_Definition =>
+ if Flags.Vhdl_Std >= Vhdl_93 then
+ Error_Msg_Sem ("variable formal type can't be a "
+ & "file type (vhdl 93)", Inter);
+ end if;
+ when Iir_Kind_Protected_Type_Declaration =>
+ -- LRM 2.1.1.1 Constant and variable parameters
+ -- It is an error if the mode of the parameter is
+ -- other that INOUT.
+ if Get_Mode (Inter) /= Iir_Inout_Mode then
+ Error_Msg_Sem
+ ("parameter of protected type must be inout", Inter);
+ end if;
+ when others =>
+ null;
+ end case;
+ when Iir_Kind_Interface_File_Declaration =>
+ if Get_Kind (Get_Base_Type (A_Type))
+ /= Iir_Kind_File_Type_Definition
+ then
+ Error_Msg_Sem
+ ("file formal type must be a file type", Inter);
+ end if;
+ when others =>
+ -- Inter is not an interface.
+ raise Internal_Error;
+ end case;
+
+ if Default_Value /= Null_Iir then
+ Set_Default_Value (Inter, Default_Value);
+
+ -- LRM 4.3.2 Interface declarations.
+ -- It is an error if a default expression appears in an
+ -- interface declaration and any of the following conditions
+ -- hold:
+ -- - The mode is linkage
+ -- - The interface object is a formal signal parameter
+ -- - The interface object is a formal variable parameter of
+ -- mode other than in
+ -- - The subtype indication of the interface declaration
+ -- denotes a protected type.
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Constant_Declaration =>
+ null;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ if Get_Mode (Inter) = Iir_Linkage_Mode then
+ Error_Msg_Sem
+ ("default expression not allowed for linkage port",
+ Inter);
+ elsif Interface_Kind in Parameter_Interface_List then
+ Error_Msg_Sem ("default expression not allowed"
+ & " for signal parameter", Inter);
+ end if;
+ when Iir_Kind_Interface_Variable_Declaration =>
+ if Get_Mode (Inter) /= Iir_In_Mode then
+ Error_Msg_Sem
+ ("default expression not allowed for"
+ & " out or inout variable parameter", Inter);
+ elsif Get_Kind (A_Type) = Iir_Kind_Protected_Type_Declaration
+ then
+ Error_Msg_Sem
+ ("default expression not allowed for"
+ & " variable parameter of protected type", Inter);
+ end if;
+ when Iir_Kind_Interface_File_Declaration =>
+ raise Internal_Error;
+ when others =>
+ null;
+ end case;
+ end if;
+ else
+ Set_Type (Inter, Error_Type);
+ end if;
+
+ Sem_Scopes.Add_Name (Inter);
+
+ -- By default, interface are not static.
+ -- This may be changed just below.
+ Set_Expr_Staticness (Inter, None);
+
+ case Interface_Kind is
+ when Generic_Interface_List =>
+ -- LRM93 1.1.1
+ -- The generic list in the formal generic clause defines
+ -- generic constants whose values may be determined by the
+ -- environment.
+ if Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration then
+ Error_Msg_Sem
+ ("generic " & Disp_Node (Inter) & " must be a constant",
+ Inter);
+ else
+ -- LRM93 7.4.2 (Globally static primaries)
+ -- 3. a generic constant.
+ Set_Expr_Staticness (Inter, Globally);
+ end if;
+ when Port_Interface_List =>
+ if Get_Kind (Inter) /= Iir_Kind_Interface_Signal_Declaration then
+ Error_Msg_Sem
+ ("port " & Disp_Node (Inter) & " must be a signal", Inter);
+ end if;
+ when Parameter_Interface_List =>
+ if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
+ and then Interface_Kind = Function_Parameter_Interface_List
+ then
+ Error_Msg_Sem ("variable interface parameter are not "
+ & "allowed for a function (use a constant)",
+ Inter);
+ end if;
+
+ -- By default, we suppose a subprogram read the activity of
+ -- a signal.
+ -- This will be adjusted when the body is analyzed.
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
+ and then Get_Mode (Inter) in Iir_In_Modes
+ then
+ Set_Has_Active_Flag (Inter, True);
+ end if;
+
+ case Get_Mode (Inter) is
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ when Iir_In_Mode =>
+ null;
+ when Iir_Inout_Mode
+ | Iir_Out_Mode =>
+ if Interface_Kind = Function_Parameter_Interface_List
+ and then
+ Get_Kind (Inter) /= Iir_Kind_Interface_File_Declaration
+ then
+ Error_Msg_Sem ("mode of a function parameter cannot "
+ & "be inout or out", Inter);
+ end if;
+ when Iir_Buffer_Mode
+ | Iir_Linkage_Mode =>
+ Error_Msg_Sem ("buffer or linkage mode is not allowed "
+ & "for a subprogram parameter", Inter);
+ end case;
+ end case;
+ end Sem_Interface_Object_Declaration;
+
+ procedure Sem_Interface_Package_Declaration (Inter : Iir)
+ is
+ Pkg : Iir;
+ begin
+ -- LRM08 6.5.5 Interface package declarations
+ -- the uninstantiated_package_name shall denote an uninstantiated
+ -- package declared in a package declaration.
+ Pkg := Sem_Uninstantiated_Package_Name (Inter);
+ if Pkg = Null_Iir then
+ return;
+ end if;
+
+ Sem_Inst.Instantiate_Package_Declaration (Inter, Pkg);
+
+ if Get_Generic_Map_Aspect_Chain (Inter) /= Null_Iir then
+ -- TODO
+ raise Internal_Error;
+ end if;
+
+ Sem_Scopes.Add_Name (Inter);
+ end Sem_Interface_Package_Declaration;
+
+ procedure Sem_Interface_Chain (Interface_Chain: Iir;
+ Interface_Kind : Interface_Kind_Type)
+ is
+ Inter : Iir;
+
+ -- LAST is the last interface declaration that has a type. This is
+ -- used to set type and default value for the following declarations
+ -- that appeared in a list of identifiers.
+ Last : Iir;
+ begin
+ Last := Null_Iir;
+
+ Inter := Interface_Chain;
+ while Inter /= Null_Iir loop
+ case Get_Kind (Inter) is
+ when Iir_Kinds_Interface_Object_Declaration =>
+ Sem_Interface_Object_Declaration (Inter, Last, Interface_Kind);
+ Last := Inter;
+ when Iir_Kind_Interface_Package_Declaration =>
+ Sem_Interface_Package_Declaration (Inter);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Inter := Get_Chain (Inter);
+ end loop;
+
+ -- LRM 10.3 Visibility
+ -- A declaration is visible only within a certain part of its scope;
+ -- this starts at the end of the declaration [...]
+
+ -- LRM 4.3.2.1 Interface List
+ -- A name that denotes an interface object must not appear in any
+ -- interface declaration within the interface list containing the
+ -- denotes interface except to declare this object.
+
+ -- GHDL: this is achieved by making the interface object visible after
+ -- having analyzed the interface list.
+ Inter := Interface_Chain;
+ while Inter /= Null_Iir loop
+ Name_Visible (Inter);
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Sem_Interface_Chain;
+
+ -- LRM93 7.2.2
+ -- A discrete array is a one-dimensional array whose elements are of a
+ -- discrete type.
+ function Is_Discrete_Array (Def : Iir) return Boolean
+ is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ null;
+ when others =>
+ raise Internal_Error;
+ -- return False;
+ end case;
+ if not Is_One_Dimensional_Array_Type (Def) then
+ return False;
+ end if;
+ if Get_Kind (Get_Element_Subtype (Def))
+ not in Iir_Kinds_Discrete_Type_Definition
+ then
+ return False;
+ end if;
+ return True;
+ end Is_Discrete_Array;
+
+ procedure Create_Implicit_File_Primitives
+ (Decl : Iir_Type_Declaration; Type_Definition : Iir_File_Type_Definition)
+ is
+ use Iir_Chains.Interface_Declaration_Chain_Handling;
+ Type_Mark : constant Iir := Get_File_Type_Mark (Type_Definition);
+ Type_Mark_Type : constant Iir := Get_Type (Type_Mark);
+ Proc: Iir_Implicit_Procedure_Declaration;
+ Func: Iir_Implicit_Function_Declaration;
+ Inter: Iir;
+ Loc : Location_Type;
+ File_Interface_Kind : Iir_Kind;
+ Last_Interface : Iir;
+ Last : Iir;
+ begin
+ Last := Decl;
+ Loc := Get_Location (Decl);
+
+ if Flags.Vhdl_Std >= Vhdl_93c then
+ for I in 1 .. 2 loop
+ -- Create the implicit file_open (form 1) declaration.
+ -- Create the implicit file_open (form 2) declaration.
+ Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Location (Proc, Loc);
+ Set_Parent (Proc, Get_Parent (Decl));
+ Set_Identifier (Proc, Std_Names.Name_File_Open);
+ Set_Type_Reference (Proc, Decl);
+ Set_Visible_Flag (Proc, True);
+ Build_Init (Last_Interface);
+ case I is
+ when 1 =>
+ Set_Implicit_Definition (Proc, Iir_Predefined_File_Open);
+ when 2 =>
+ Set_Implicit_Definition (Proc,
+ Iir_Predefined_File_Open_Status);
+ -- status : out file_open_status.
+ Inter :=
+ Create_Iir (Iir_Kind_Interface_Variable_Declaration);
+ Set_Location (Inter, Loc);
+ Set_Identifier (Inter, Std_Names.Name_Status);
+ Set_Type (Inter,
+ Std_Package.File_Open_Status_Type_Definition);
+ Set_Mode (Inter, Iir_Out_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ end case;
+ -- File F : FT
+ Inter := Create_Iir (Iir_Kind_Interface_File_Declaration);
+ Set_Location (Inter, Loc);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Type (Inter, Type_Definition);
+ Set_Mode (Inter, Iir_Inout_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ -- External_Name : in STRING
+ Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Set_Location (Inter, Loc);
+ Set_Identifier (Inter, Std_Names.Name_External_Name);
+ Set_Type (Inter, Std_Package.String_Type_Definition);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ -- Open_Kind : in File_Open_Kind := Read_Mode.
+ Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Set_Location (Inter, Loc);
+ Set_Identifier (Inter, Std_Names.Name_Open_Kind);
+ Set_Type (Inter, Std_Package.File_Open_Kind_Type_Definition);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Default_Value (Inter,
+ Std_Package.File_Open_Kind_Read_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Compute_Subprogram_Hash (Proc);
+ -- Add it to the list.
+ Insert_Incr (Last, Proc);
+ end loop;
+
+ -- Create the implicit file_close declaration.
+ Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Identifier (Proc, Std_Names.Name_File_Close);
+ Set_Location (Proc, Loc);
+ Set_Parent (Proc, Get_Parent (Decl));
+ Set_Implicit_Definition (Proc, Iir_Predefined_File_Close);
+ Set_Type_Reference (Proc, Decl);
+ Set_Visible_Flag (Proc, True);
+ Build_Init (Last_Interface);
+ Inter := Create_Iir (Iir_Kind_Interface_File_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Type_Definition);
+ Set_Mode (Inter, Iir_Inout_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Compute_Subprogram_Hash (Proc);
+ -- Add it to the list.
+ Insert_Incr (Last, Proc);
+ end if;
+
+ if Flags.Vhdl_Std = Vhdl_87 then
+ File_Interface_Kind := Iir_Kind_Interface_Variable_Declaration;
+ else
+ File_Interface_Kind := Iir_Kind_Interface_File_Declaration;
+ end if;
+
+ -- Create the implicit procedure read declaration.
+ Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Identifier (Proc, Std_Names.Name_Read);
+ Set_Location (Proc, Loc);
+ Set_Parent (Proc, Get_Parent (Decl));
+ Set_Type_Reference (Proc, Decl);
+ Set_Visible_Flag (Proc, True);
+ Build_Init (Last_Interface);
+ Inter := Create_Iir (File_Interface_Kind);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Type_Definition);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_Value);
+ Set_Location (Inter, Loc);
+ Set_Subtype_Indication (Inter, Type_Mark);
+ Set_Type (Inter, Type_Mark_Type);
+ Set_Mode (Inter, Iir_Out_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ if Get_Kind (Type_Mark_Type) in Iir_Kinds_Array_Type_Definition
+ and then Get_Constraint_State (Type_Mark_Type) /= Fully_Constrained
+ then
+ Inter := Create_Iir (Iir_Kind_Interface_Variable_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_Length);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Std_Package.Natural_Subtype_Definition);
+ Set_Mode (Inter, Iir_Out_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Set_Implicit_Definition (Proc, Iir_Predefined_Read_Length);
+ else
+ Set_Implicit_Definition (Proc, Iir_Predefined_Read);
+ end if;
+ Compute_Subprogram_Hash (Proc);
+ -- Add it to the list.
+ Insert_Incr (Last, Proc);
+
+ -- Create the implicit procedure write declaration.
+ Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Identifier (Proc, Std_Names.Name_Write);
+ Set_Location (Proc, Loc);
+ Set_Parent (Proc, Get_Parent (Decl));
+ Set_Type_Reference (Proc, Decl);
+ Set_Visible_Flag (Proc, True);
+ Build_Init (Last_Interface);
+ Inter := Create_Iir (File_Interface_Kind);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Type_Definition);
+ Set_Mode (Inter, Iir_Out_Mode);
+ Set_Name_Staticness (Inter, Locally);
+ Set_Expr_Staticness (Inter, None);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_Value);
+ Set_Location (Inter, Loc);
+ Set_Subtype_Indication (Inter, Type_Mark);
+ Set_Type (Inter, Type_Mark_Type);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Set_Implicit_Definition (Proc, Iir_Predefined_Write);
+ Compute_Subprogram_Hash (Proc);
+ -- Add it to the list.
+ Insert_Incr (Last, Proc);
+
+ -- Create the implicit procedure flush declaration
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ Proc := Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Identifier (Proc, Std_Names.Name_Flush);
+ Set_Location (Proc, Loc);
+ Set_Parent (Proc, Get_Parent (Decl));
+ Set_Type_Reference (Proc, Decl);
+ Set_Visible_Flag (Proc, True);
+ Build_Init (Last_Interface);
+ Inter := Create_Iir (File_Interface_Kind);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Type_Definition);
+ Set_Name_Staticness (Inter, Locally);
+ Set_Expr_Staticness (Inter, None);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Proc, Inter);
+ Set_Implicit_Definition (Proc, Iir_Predefined_Flush);
+ Compute_Subprogram_Hash (Proc);
+ -- Add it to the list.
+ Insert_Incr (Last, Proc);
+ end if;
+ -- Create the implicit function endfile declaration.
+ Func := Create_Iir (Iir_Kind_Implicit_Function_Declaration);
+ Set_Identifier (Func, Std_Names.Name_Endfile);
+ Set_Location (Func, Loc);
+ Set_Parent (Func, Get_Parent (Decl));
+ Set_Type_Reference (Func, Decl);
+ Set_Visible_Flag (Func, True);
+ Build_Init (Last_Interface);
+ Inter := Create_Iir (File_Interface_Kind);
+ Set_Identifier (Inter, Std_Names.Name_F);
+ Set_Location (Inter, Loc);
+ Set_Type (Inter, Type_Definition);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Append (Last_Interface, Func, Inter);
+ Set_Return_Type (Func, Std_Package.Boolean_Type_Definition);
+ Set_Implicit_Definition (Func, Iir_Predefined_Endfile);
+ Compute_Subprogram_Hash (Func);
+ -- Add it to the list.
+ Insert_Incr (Last, Func);
+ end Create_Implicit_File_Primitives;
+
+ function Create_Anonymous_Interface (Atype : Iir)
+ return Iir_Interface_Constant_Declaration
+ is
+ Inter : Iir_Interface_Constant_Declaration;
+ begin
+ Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Location_Copy (Inter, Atype);
+ Set_Identifier (Inter, Null_Identifier);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Type (Inter, Atype);
+ return Inter;
+ end Create_Anonymous_Interface;
+
+ procedure Create_Implicit_Operations
+ (Decl : Iir; Is_Std_Standard : Boolean := False)
+ is
+ use Std_Names;
+ Binary_Chain : Iir;
+ Unary_Chain : Iir;
+ Type_Definition : Iir;
+ Last : Iir;
+
+ procedure Add_Operation
+ (Name : Name_Id;
+ Def : Iir_Predefined_Functions;
+ Interface_Chain : Iir;
+ Return_Type : Iir)
+ is
+ Operation : Iir_Implicit_Function_Declaration;
+ begin
+ Operation := Create_Iir (Iir_Kind_Implicit_Function_Declaration);
+ Location_Copy (Operation, Decl);
+ Set_Parent (Operation, Get_Parent (Decl));
+ Set_Interface_Declaration_Chain (Operation, Interface_Chain);
+ Set_Type_Reference (Operation, Decl);
+ Set_Return_Type (Operation, Return_Type);
+ Set_Implicit_Definition (Operation, Def);
+ Set_Identifier (Operation, Name);
+ Set_Visible_Flag (Operation, True);
+ Compute_Subprogram_Hash (Operation);
+ Insert_Incr (Last, Operation);
+ end Add_Operation;
+
+ procedure Add_Relational (Name : Name_Id; Def : Iir_Predefined_Functions)
+ is
+ begin
+ Add_Operation
+ (Name, Def, Binary_Chain, Std_Package.Boolean_Type_Definition);
+ end Add_Relational;
+
+ procedure Add_Binary (Name : Name_Id; Def : Iir_Predefined_Functions) is
+ begin
+ Add_Operation (Name, Def, Binary_Chain, Type_Definition);
+ end Add_Binary;
+
+ procedure Add_Unary (Name : Name_Id; Def : Iir_Predefined_Functions) is
+ begin
+ Add_Operation (Name, Def, Unary_Chain, Type_Definition);
+ end Add_Unary;
+
+ procedure Add_To_String (Def : Iir_Predefined_Functions) is
+ begin
+ Add_Operation (Name_To_String, Def,
+ Unary_Chain, String_Type_Definition);
+ end Add_To_String;
+
+ procedure Add_Min_Max (Name : Name_Id; Def : Iir_Predefined_Functions)
+ is
+ Left, Right : Iir;
+ begin
+ Left := Create_Anonymous_Interface (Type_Definition);
+ Set_Identifier (Left, Name_L);
+ Right := Create_Anonymous_Interface (Type_Definition);
+ Set_Identifier (Right, Name_R);
+ Set_Chain (Left, Right);
+ Add_Operation (Name, Def, Left, Type_Definition);
+ end Add_Min_Max;
+
+ procedure Add_Vector_Min_Max
+ (Name : Name_Id; Def : Iir_Predefined_Functions)
+ is
+ Left : Iir;
+ begin
+ Left := Create_Anonymous_Interface (Type_Definition);
+ Set_Identifier (Left, Name_L);
+ Add_Operation
+ (Name, Def, Left, Get_Element_Subtype (Type_Definition));
+ end Add_Vector_Min_Max;
+
+ procedure Add_Shift_Operators
+ is
+ Inter_Chain : Iir_Interface_Constant_Declaration;
+ Inter_Int : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+
+ Inter_Int := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Location_Copy (Inter_Int, Decl);
+ Set_Identifier (Inter_Int, Null_Identifier);
+ Set_Mode (Inter_Int, Iir_In_Mode);
+ Set_Type (Inter_Int, Std_Package.Integer_Subtype_Definition);
+ Set_Lexical_Layout (Inter_Int, Iir_Lexical_Has_Type);
+
+ Set_Chain (Inter_Chain, Inter_Int);
+
+ Add_Operation
+ (Name_Sll, Iir_Predefined_Array_Sll, Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Srl, Iir_Predefined_Array_Srl, Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Sla, Iir_Predefined_Array_Sla, Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Sra, Iir_Predefined_Array_Sra, Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Rol, Iir_Predefined_Array_Rol, Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Ror, Iir_Predefined_Array_Ror, Inter_Chain, Type_Definition);
+ end Add_Shift_Operators;
+ begin
+ Last := Decl;
+
+ Type_Definition := Get_Base_Type (Get_Type_Definition (Decl));
+ if Get_Kind (Type_Definition) /= Iir_Kind_File_Type_Definition then
+ Unary_Chain := Create_Anonymous_Interface (Type_Definition);
+ Binary_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain (Binary_Chain, Unary_Chain);
+ end if;
+
+ case Get_Kind (Type_Definition) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Add_Relational (Name_Op_Equality, Iir_Predefined_Enum_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Enum_Inequality);
+ Add_Relational (Name_Op_Greater, Iir_Predefined_Enum_Greater);
+ Add_Relational
+ (Name_Op_Greater_Equal, Iir_Predefined_Enum_Greater_Equal);
+ Add_Relational (Name_Op_Less, Iir_Predefined_Enum_Less);
+ Add_Relational
+ (Name_Op_Less_Equal, Iir_Predefined_Enum_Less_Equal);
+
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ -- LRM08 5.2.6 Predefined operations on scalar types
+ -- Given a type declaration that declares a scalar type T, the
+ -- following operations are implicitely declared immediately
+ -- following the type declaration (except for the TO_STRING
+ -- operations in package STANDARD [...])
+ Add_Min_Max (Name_Minimum, Iir_Predefined_Enum_Minimum);
+ Add_Min_Max (Name_Maximum, Iir_Predefined_Enum_Maximum);
+ if not Is_Std_Standard then
+ Add_To_String (Iir_Predefined_Enum_To_String);
+ end if;
+
+ -- LRM08 9.2.3 Relational operators
+ -- The matching relational operators are predefined for the
+ -- [predefined type BIT and for the] type STD_ULOGIC defined
+ -- in package STD_LOGIC_1164.
+ if Type_Definition = Ieee.Std_Logic_1164.Std_Ulogic_Type then
+ Add_Binary (Name_Op_Match_Equality,
+ Iir_Predefined_Std_Ulogic_Match_Equality);
+ Add_Binary (Name_Op_Match_Inequality,
+ Iir_Predefined_Std_Ulogic_Match_Inequality);
+ Add_Binary (Name_Op_Match_Less,
+ Iir_Predefined_Std_Ulogic_Match_Less);
+ Add_Binary (Name_Op_Match_Less_Equal,
+ Iir_Predefined_Std_Ulogic_Match_Less_Equal);
+ Add_Binary (Name_Op_Match_Greater,
+ Iir_Predefined_Std_Ulogic_Match_Greater);
+ Add_Binary (Name_Op_Match_Greater_Equal,
+ Iir_Predefined_Std_Ulogic_Match_Greater_Equal);
+ end if;
+ end if;
+
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Element_Type : Iir;
+
+ Element_Array_Inter_Chain : Iir;
+ Array_Element_Inter_Chain : Iir;
+ Element_Element_Inter_Chain : Iir;
+ begin
+ Add_Relational
+ (Name_Op_Equality, Iir_Predefined_Array_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Array_Inequality);
+ if Is_Discrete_Array (Type_Definition) then
+ Add_Relational
+ (Name_Op_Greater, Iir_Predefined_Array_Greater);
+ Add_Relational
+ (Name_Op_Greater_Equal,
+ Iir_Predefined_Array_Greater_Equal);
+ Add_Relational
+ (Name_Op_Less, Iir_Predefined_Array_Less);
+ Add_Relational
+ (Name_Op_Less_Equal, Iir_Predefined_Array_Less_Equal);
+
+ -- LRM08 5.3.2.4 Predefined operations on array types
+ -- Given a type declaration that declares a discrete array
+ -- type T, the following operatons are implicitly declared
+ -- immediately following the type declaration:
+ -- function MINIMUM (L, R : T) return T;
+ -- function MAXIMUM (L, R : T) return T;
+ if Vhdl_Std >= Vhdl_08 then
+ Add_Min_Max (Name_Maximum, Iir_Predefined_Array_Maximum);
+ Add_Min_Max (Name_Minimum, Iir_Predefined_Array_Minimum);
+ end if;
+ end if;
+
+ Element_Type := Get_Element_Subtype (Type_Definition);
+
+ if Is_One_Dimensional_Array_Type (Type_Definition) then
+ -- LRM93 7.2.4 Adding operators
+ -- The concatenation operator & is predefined for any
+ -- one-dimensional array type.
+ Add_Operation (Name_Op_Concatenation,
+ Iir_Predefined_Array_Array_Concat,
+ Binary_Chain,
+ Type_Definition);
+
+ Element_Array_Inter_Chain :=
+ Create_Anonymous_Interface (Element_Type);
+ Set_Chain (Element_Array_Inter_Chain, Unary_Chain);
+ Add_Operation (Name_Op_Concatenation,
+ Iir_Predefined_Element_Array_Concat,
+ Element_Array_Inter_Chain,
+ Type_Definition);
+
+ Array_Element_Inter_Chain :=
+ Create_Anonymous_Interface (Type_Definition);
+ Set_Chain (Array_Element_Inter_Chain,
+ Create_Anonymous_Interface (Element_Type));
+ Add_Operation (Name_Op_Concatenation,
+ Iir_Predefined_Array_Element_Concat,
+ Array_Element_Inter_Chain,
+ Type_Definition);
+
+ Element_Element_Inter_Chain :=
+ Create_Anonymous_Interface (Element_Type);
+ Set_Chain (Element_Element_Inter_Chain,
+ Create_Anonymous_Interface (Element_Type));
+ Add_Operation (Name_Op_Concatenation,
+ Iir_Predefined_Element_Element_Concat,
+ Element_Element_Inter_Chain,
+ Type_Definition);
+
+ -- LRM08 5.3.2.4 Predefined operations on array types
+ -- In addition, given a type declaration that declares a
+ -- one-dimensional array type T whose elements are of a
+ -- sclar type E, the following operations are implicitly
+ -- declared immediately following the type declaration:
+ -- function MINIMUM (L : T) return E;
+ -- function MAXIMUM (L : T) return E;
+ if Vhdl_Std >= Vhdl_08
+ and then (Get_Kind (Element_Type) in
+ Iir_Kinds_Scalar_Type_Definition)
+ then
+ Add_Vector_Min_Max
+ (Name_Maximum, Iir_Predefined_Vector_Maximum);
+ Add_Vector_Min_Max
+ (Name_Minimum, Iir_Predefined_Vector_Minimum);
+ end if;
+
+ if Element_Type = Std_Package.Boolean_Type_Definition
+ or else Element_Type = Std_Package.Bit_Type_Definition
+ then
+ -- LRM93 7.2.1 Logical operators
+ -- LRM08 9.2.2 Logical operators
+ -- The binary logical operators AND, OR, NAND, NOR, XOR,
+ -- and XNOR, and the unary logical operator NOT are
+ -- defined for predefined types BIT and BOOLEAN. They
+ -- are also defined for any one-dimensional array type
+ -- whose element type is BIT or BOOLEAN.
+
+ Add_Unary (Name_Not, Iir_Predefined_TF_Array_Not);
+
+ Add_Binary (Name_And, Iir_Predefined_TF_Array_And);
+ Add_Binary (Name_Or, Iir_Predefined_TF_Array_Or);
+ Add_Binary (Name_Nand, Iir_Predefined_TF_Array_Nand);
+ Add_Binary (Name_Nor, Iir_Predefined_TF_Array_Nor);
+ Add_Binary (Name_Xor, Iir_Predefined_TF_Array_Xor);
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Add_Binary (Name_Xnor, Iir_Predefined_TF_Array_Xnor);
+
+ -- LRM93 7.2.3 Shift operators
+ -- The shift operators SLL, SRL, SLA, SRA, ROL and
+ -- ROR are defined for any one-dimensional array type
+ -- whose element type is either of the predefined
+ -- types BIT or BOOLEAN.
+ Add_Shift_Operators;
+ end if;
+
+ -- LRM08 9.2.2 Logical operators
+ -- For the binary operators AND, OR, NAND, NOR, XOR and
+ -- XNOR, the operands shall both be [of the same base
+ -- type,] or one operand shall be of a scalar type and
+ -- the other operand shall be a one-dimensional array
+ -- whose element type is the scalar type. The result
+ -- type is the same as the base type of the operands if
+ -- [both operands are scalars of the same base type or]
+ -- both operands are arrays, or the same as the base type
+ -- of the array operand if one operand is a scalar and
+ -- the other operand is an array.
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ Add_Operation
+ (Name_And, Iir_Predefined_TF_Element_Array_And,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_And, Iir_Predefined_TF_Array_Element_And,
+ Array_Element_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Or, Iir_Predefined_TF_Element_Array_Or,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Or, Iir_Predefined_TF_Array_Element_Or,
+ Array_Element_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Nand, Iir_Predefined_TF_Element_Array_Nand,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Nand, Iir_Predefined_TF_Array_Element_Nand,
+ Array_Element_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Nor, Iir_Predefined_TF_Element_Array_Nor,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Nor, Iir_Predefined_TF_Array_Element_Nor,
+ Array_Element_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Xor, Iir_Predefined_TF_Element_Array_Xor,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Xor, Iir_Predefined_TF_Array_Element_Xor,
+ Array_Element_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Xnor, Iir_Predefined_TF_Element_Array_Xnor,
+ Element_Array_Inter_Chain, Type_Definition);
+ Add_Operation
+ (Name_Xnor, Iir_Predefined_TF_Array_Element_Xnor,
+ Array_Element_Inter_Chain, Type_Definition);
+ end if;
+
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ -- LRM08 9.2.2 Logical operations
+ -- The unary logical operators AND, OR, NAND, NOR,
+ -- XOR, and XNOR are referred to as logical reduction
+ -- operators. The logical reduction operators are
+ -- predefined for any one-dimensional array type whose
+ -- element type is BIT or BOOLEAN. The result type
+ -- for the logical reduction operators is the same as
+ -- the element type of the operand.
+ Add_Operation
+ (Name_And, Iir_Predefined_TF_Reduction_And,
+ Unary_Chain, Element_Type);
+ Add_Operation
+ (Name_Or, Iir_Predefined_TF_Reduction_Or,
+ Unary_Chain, Element_Type);
+ Add_Operation
+ (Name_Nand, Iir_Predefined_TF_Reduction_Nand,
+ Unary_Chain, Element_Type);
+ Add_Operation
+ (Name_Nor, Iir_Predefined_TF_Reduction_Nor,
+ Unary_Chain, Element_Type);
+ Add_Operation
+ (Name_Xor, Iir_Predefined_TF_Reduction_Xor,
+ Unary_Chain, Element_Type);
+ Add_Operation
+ (Name_Xnor, Iir_Predefined_TF_Reduction_Xnor,
+ Unary_Chain, Element_Type);
+ end if;
+ end if;
+
+ -- LRM08 9.2.3 Relational operators
+ -- The matching equality and matching inequality operatotrs
+ -- are also defined for any one-dimensional array type
+ -- whose element type is BIT or STD_ULOGIC.
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ if Element_Type = Std_Package.Bit_Type_Definition then
+ Add_Operation
+ (Name_Op_Match_Equality,
+ Iir_Predefined_Bit_Array_Match_Equality,
+ Binary_Chain, Element_Type);
+ Add_Operation
+ (Name_Op_Match_Inequality,
+ Iir_Predefined_Bit_Array_Match_Inequality,
+ Binary_Chain, Element_Type);
+ elsif Element_Type = Ieee.Std_Logic_1164.Std_Ulogic_Type
+ then
+ Add_Operation
+ (Name_Op_Match_Equality,
+ Iir_Predefined_Std_Ulogic_Array_Match_Equality,
+ Binary_Chain, Element_Type);
+ Add_Operation
+ (Name_Op_Match_Inequality,
+ Iir_Predefined_Std_Ulogic_Array_Match_Inequality,
+ Binary_Chain, Element_Type);
+ end if;
+ end if;
+
+ -- LRM08 5.3.2.4 Predefined operations on array type
+ --
+ -- Given a type declaration that declares a one-dimensional
+ -- array type T whose element type is a character type that
+ -- contains only character literals, the following operation
+ -- is implicitely declared immediately following the type
+ -- declaration
+ if Vhdl_Std >= Vhdl_08
+ and then String_Type_Definition /= Null_Iir
+ and then (Get_Kind (Element_Type)
+ = Iir_Kind_Enumeration_Type_Definition)
+ and then Get_Only_Characters_Flag (Element_Type)
+ then
+ Add_Operation (Name_To_String,
+ Iir_Predefined_Array_Char_To_String,
+ Unary_Chain,
+ String_Type_Definition);
+ end if;
+ end if;
+ end;
+
+ when Iir_Kind_Access_Type_Definition =>
+ Add_Relational (Name_Op_Equality, Iir_Predefined_Access_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Access_Inequality);
+ declare
+ Deallocate_Proc: Iir_Implicit_Procedure_Declaration;
+ Var_Interface: Iir_Interface_Variable_Declaration;
+ begin
+ Deallocate_Proc :=
+ Create_Iir (Iir_Kind_Implicit_Procedure_Declaration);
+ Set_Identifier (Deallocate_Proc, Std_Names.Name_Deallocate);
+ Set_Implicit_Definition
+ (Deallocate_Proc, Iir_Predefined_Deallocate);
+ Var_Interface :=
+ Create_Iir (Iir_Kind_Interface_Variable_Declaration);
+ Set_Identifier (Var_Interface, Std_Names.Name_P);
+ Set_Type (Var_Interface, Type_Definition);
+ Set_Mode (Var_Interface, Iir_Inout_Mode);
+ Set_Lexical_Layout (Var_Interface, Iir_Lexical_Has_Type);
+ --Set_Purity_State (Deallocate_Proc, Impure);
+ Set_Wait_State (Deallocate_Proc, False);
+ Set_Type_Reference (Deallocate_Proc, Decl);
+ Set_Visible_Flag (Deallocate_Proc, True);
+
+ Set_Interface_Declaration_Chain
+ (Deallocate_Proc, Var_Interface);
+ Compute_Subprogram_Hash (Deallocate_Proc);
+ Insert_Incr (Last, Deallocate_Proc);
+ end;
+
+ when Iir_Kind_Record_Type_Definition =>
+ Add_Relational (Name_Op_Equality, Iir_Predefined_Record_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Record_Inequality);
+
+ when Iir_Kind_Integer_Type_Definition =>
+ Add_Relational (Name_Op_Equality, Iir_Predefined_Integer_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Integer_Inequality);
+ Add_Relational (Name_Op_Greater, Iir_Predefined_Integer_Greater);
+ Add_Relational
+ (Name_Op_Greater_Equal, Iir_Predefined_Integer_Greater_Equal);
+ Add_Relational (Name_Op_Less, Iir_Predefined_Integer_Less);
+ Add_Relational
+ (Name_Op_Less_Equal, Iir_Predefined_Integer_Less_Equal);
+
+ Add_Binary (Name_Op_Plus, Iir_Predefined_Integer_Plus);
+ Add_Binary (Name_Op_Minus, Iir_Predefined_Integer_Minus);
+
+ Add_Unary (Name_Op_Minus, Iir_Predefined_Integer_Negation);
+ Add_Unary (Name_Op_Plus, Iir_Predefined_Integer_Identity);
+
+ Add_Binary (Name_Op_Mul, Iir_Predefined_Integer_Mul);
+ Add_Binary (Name_Op_Div, Iir_Predefined_Integer_Div);
+ Add_Binary (Name_Mod, Iir_Predefined_Integer_Mod);
+ Add_Binary (Name_Rem, Iir_Predefined_Integer_Rem);
+
+ Add_Unary (Name_Abs, Iir_Predefined_Integer_Absolute);
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain
+ (Inter_Chain,
+ Create_Anonymous_Interface (Integer_Type_Definition));
+ Add_Operation (Name_Op_Exp, Iir_Predefined_Integer_Exp,
+ Inter_Chain, Type_Definition);
+ end;
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- LRM08 5.2.6 Predefined operations on scalar types
+ -- Given a type declaration that declares a scalar type T, the
+ -- following operations are implicitely declared immediately
+ -- following the type declaration (except for the TO_STRING
+ -- operations in package STANDARD [...])
+ Add_Min_Max (Name_Minimum, Iir_Predefined_Integer_Minimum);
+ Add_Min_Max (Name_Maximum, Iir_Predefined_Integer_Maximum);
+ if not Is_Std_Standard then
+ Add_To_String (Iir_Predefined_Integer_To_String);
+ end if;
+ end if;
+
+ when Iir_Kind_Floating_Type_Definition =>
+ Add_Relational
+ (Name_Op_Equality, Iir_Predefined_Floating_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Floating_Inequality);
+ Add_Relational
+ (Name_Op_Greater, Iir_Predefined_Floating_Greater);
+ Add_Relational
+ (Name_Op_Greater_Equal, Iir_Predefined_Floating_Greater_Equal);
+ Add_Relational
+ (Name_Op_Less, Iir_Predefined_Floating_Less);
+ Add_Relational
+ (Name_Op_Less_Equal, Iir_Predefined_Floating_Less_Equal);
+
+ Add_Binary (Name_Op_Plus, Iir_Predefined_Floating_Plus);
+ Add_Binary (Name_Op_Minus, Iir_Predefined_Floating_Minus);
+
+ Add_Unary (Name_Op_Minus, Iir_Predefined_Floating_Negation);
+ Add_Unary (Name_Op_Plus, Iir_Predefined_Floating_Identity);
+
+ Add_Binary (Name_Op_Mul, Iir_Predefined_Floating_Mul);
+ Add_Binary (Name_Op_Div, Iir_Predefined_Floating_Div);
+
+ Add_Unary (Name_Abs, Iir_Predefined_Floating_Absolute);
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain
+ (Inter_Chain,
+ Create_Anonymous_Interface (Integer_Type_Definition));
+ Add_Operation (Name_Op_Exp, Iir_Predefined_Floating_Exp,
+ Inter_Chain, Type_Definition);
+ end;
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- LRM08 5.2.6 Predefined operations on scalar types
+ -- Given a type declaration that declares a scalar type T, the
+ -- following operations are implicitely declared immediately
+ -- following the type declaration (except for the TO_STRING
+ -- operations in package STANDARD [...])
+ Add_Min_Max (Name_Minimum, Iir_Predefined_Floating_Minimum);
+ Add_Min_Max (Name_Maximum, Iir_Predefined_Floating_Maximum);
+ if not Is_Std_Standard then
+ Add_To_String (Iir_Predefined_Floating_To_String);
+ end if;
+ end if;
+
+ when Iir_Kind_Physical_Type_Definition =>
+ Add_Relational
+ (Name_Op_Equality, Iir_Predefined_Physical_Equality);
+ Add_Relational
+ (Name_Op_Inequality, Iir_Predefined_Physical_Inequality);
+ Add_Relational
+ (Name_Op_Greater, Iir_Predefined_Physical_Greater);
+ Add_Relational
+ (Name_Op_Greater_Equal, Iir_Predefined_Physical_Greater_Equal);
+ Add_Relational
+ (Name_Op_Less, Iir_Predefined_Physical_Less);
+ Add_Relational
+ (Name_Op_Less_Equal, Iir_Predefined_Physical_Less_Equal);
+
+ Add_Binary (Name_Op_Plus, Iir_Predefined_Physical_Plus);
+ Add_Binary (Name_Op_Minus, Iir_Predefined_Physical_Minus);
+
+ Add_Unary (Name_Op_Minus, Iir_Predefined_Physical_Negation);
+ Add_Unary (Name_Op_Plus, Iir_Predefined_Physical_Identity);
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain
+ (Inter_Chain,
+ Create_Anonymous_Interface (Integer_Type_Definition));
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Integer_Mul,
+ Inter_Chain, Type_Definition);
+ Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Integer_Div,
+ Inter_Chain, Type_Definition);
+ end;
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain :=
+ Create_Anonymous_Interface (Integer_Type_Definition);
+ Set_Chain (Inter_Chain, Unary_Chain);
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Integer_Physical_Mul,
+ Inter_Chain, Type_Definition);
+ end;
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain (Inter_Chain,
+ Create_Anonymous_Interface (Real_Type_Definition));
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Physical_Real_Mul,
+ Inter_Chain, Type_Definition);
+ Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Real_Div,
+ Inter_Chain, Type_Definition);
+ end;
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain :=
+ Create_Anonymous_Interface (Real_Type_Definition);
+ Set_Chain (Inter_Chain, Unary_Chain);
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Real_Physical_Mul,
+ Inter_Chain, Type_Definition);
+ end;
+ Add_Operation (Name_Op_Div, Iir_Predefined_Physical_Physical_Div,
+ Binary_Chain,
+ Std_Package.Convertible_Integer_Type_Definition);
+
+ Add_Unary (Name_Abs, Iir_Predefined_Physical_Absolute);
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- LRM08 5.2.6 Predefined operations on scalar types
+ -- Given a type declaration that declares a scalar type T, the
+ -- following operations are implicitely declared immediately
+ -- following the type declaration (except for the TO_STRING
+ -- operations in package STANDARD [...])
+ Add_Min_Max (Name_Minimum, Iir_Predefined_Physical_Minimum);
+ Add_Min_Max (Name_Maximum, Iir_Predefined_Physical_Maximum);
+ if not Is_Std_Standard then
+ Add_To_String (Iir_Predefined_Physical_To_String);
+ end if;
+ end if;
+
+ when Iir_Kind_File_Type_Definition =>
+ Create_Implicit_File_Primitives (Decl, Type_Definition);
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ null;
+
+ when others =>
+ Error_Kind ("create_predefined_operations", Type_Definition);
+ end case;
+
+ if not Is_Std_Standard then
+ return;
+ end if;
+ if Decl = Std_Package.Boolean_Type_Declaration then
+ Add_Binary (Name_And, Iir_Predefined_Boolean_And);
+ Add_Binary (Name_Or, Iir_Predefined_Boolean_Or);
+ Add_Binary (Name_Nand, Iir_Predefined_Boolean_Nand);
+ Add_Binary (Name_Nor, Iir_Predefined_Boolean_Nor);
+ Add_Binary (Name_Xor, Iir_Predefined_Boolean_Xor);
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Add_Binary (Name_Xnor, Iir_Predefined_Boolean_Xnor);
+ end if;
+ Add_Unary (Name_Not, Iir_Predefined_Boolean_Not);
+ elsif Decl = Std_Package.Bit_Type_Declaration then
+ Add_Binary (Name_And, Iir_Predefined_Bit_And);
+ Add_Binary (Name_Or, Iir_Predefined_Bit_Or);
+ Add_Binary (Name_Nand, Iir_Predefined_Bit_Nand);
+ Add_Binary (Name_Nor, Iir_Predefined_Bit_Nor);
+ Add_Binary (Name_Xor, Iir_Predefined_Bit_Xor);
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Add_Binary (Name_Xnor, Iir_Predefined_Bit_Xnor);
+ end if;
+ Add_Unary (Name_Not, Iir_Predefined_Bit_Not);
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ Add_Binary (Name_Op_Match_Equality,
+ Iir_Predefined_Bit_Match_Equality);
+ Add_Binary (Name_Op_Match_Inequality,
+ Iir_Predefined_Bit_Match_Inequality);
+ Add_Binary (Name_Op_Match_Less,
+ Iir_Predefined_Bit_Match_Less);
+ Add_Binary (Name_Op_Match_Less_Equal,
+ Iir_Predefined_Bit_Match_Less_Equal);
+ Add_Binary (Name_Op_Match_Greater,
+ Iir_Predefined_Bit_Match_Greater);
+ Add_Binary (Name_Op_Match_Greater_Equal,
+ Iir_Predefined_Bit_Match_Greater_Equal);
+
+ -- LRM08 9.2.9 Condition operator
+ -- The unary operator ?? is predefined for type BIT defined in
+ -- package STANDARD.
+ Add_Operation (Name_Op_Condition, Iir_Predefined_Bit_Condition,
+ Unary_Chain, Std_Package.Boolean_Type_Definition);
+
+ end if;
+ elsif Decl = Std_Package.Universal_Real_Type_Declaration then
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain := Create_Anonymous_Interface (Type_Definition);
+ Set_Chain
+ (Inter_Chain,
+ Create_Anonymous_Interface (Universal_Integer_Type_Definition));
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_R_I_Mul,
+ Inter_Chain, Type_Definition);
+ Add_Operation (Name_Op_Div, Iir_Predefined_Universal_R_I_Div,
+ Inter_Chain, Type_Definition);
+ end;
+
+ declare
+ Inter_Chain : Iir;
+ begin
+ Inter_Chain :=
+ Create_Anonymous_Interface (Universal_Integer_Type_Definition);
+ Set_Chain (Inter_Chain, Unary_Chain);
+ Add_Operation (Name_Op_Mul, Iir_Predefined_Universal_I_R_Mul,
+ Inter_Chain, Type_Definition);
+ end;
+ end if;
+ end Create_Implicit_Operations;
+
+ procedure Sem_Type_Declaration (Decl: Iir; Is_Global : Boolean)
+ is
+ Def: Iir;
+ Inter : Name_Interpretation_Type;
+ Old_Decl : Iir;
+ St_Decl : Iir_Subtype_Declaration;
+ Bt_Def : Iir;
+ begin
+ -- Check if DECL complete a previous incomplete type declaration.
+ Inter := Get_Interpretation (Get_Identifier (Decl));
+ if Valid_Interpretation (Inter)
+ and then Is_In_Current_Declarative_Region (Inter)
+ then
+ Old_Decl := Get_Declaration (Inter);
+ if Get_Kind (Old_Decl) /= Iir_Kind_Type_Declaration
+ or else (Get_Kind (Get_Type_Definition (Old_Decl)) /=
+ Iir_Kind_Incomplete_Type_Definition)
+ then
+ Old_Decl := Null_Iir;
+ end if;
+ else
+ Old_Decl := Null_Iir;
+ end if;
+
+ if Old_Decl = Null_Iir then
+ if Get_Kind (Decl) = Iir_Kind_Type_Declaration then
+ -- This is necessary at least for enumeration type definition.
+ Sem_Scopes.Add_Name (Decl);
+ end if;
+ else
+ -- This is a way to prevent:
+ -- type a;
+ -- type a is access a;
+ -- which is non-sense.
+ Set_Visible_Flag (Old_Decl, False);
+ end if;
+
+ -- Check the definition of the type.
+ Def := Get_Type_Definition (Decl);
+ if Def = Null_Iir then
+ -- Incomplete type declaration
+ Def := Create_Iir (Iir_Kind_Incomplete_Type_Definition);
+ Location_Copy (Def, Decl);
+ Set_Type_Definition (Decl, Def);
+ Set_Base_Type (Def, Def);
+ Set_Signal_Type_Flag (Def, True);
+ Set_Type_Declarator (Def, Decl);
+ Set_Visible_Flag (Decl, True);
+ Set_Incomplete_Type_List (Def, Create_Iir_List);
+ Xref_Decl (Decl);
+ else
+ -- A complete type declaration.
+ if Old_Decl = Null_Iir then
+ Xref_Decl (Decl);
+ else
+ Xref_Body (Decl, Old_Decl);
+ end if;
+
+ Def := Sem_Type_Definition (Def, Decl);
+
+ if Def /= Null_Iir then
+ case Get_Kind (Def) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ -- Some type declaration are in fact subtype declarations.
+ St_Decl := Create_Iir (Iir_Kind_Subtype_Declaration);
+ Location_Copy (St_Decl, Decl);
+ Set_Identifier (St_Decl, Get_Identifier (Decl));
+ Set_Type (St_Decl, Def);
+ Set_Type_Declarator (Def, St_Decl);
+ Set_Chain (St_Decl, Get_Chain (Decl));
+ Set_Chain (Decl, St_Decl);
+
+ -- The type declaration declares the base type.
+ Bt_Def := Get_Base_Type (Def);
+ Set_Type_Definition (Decl, Bt_Def);
+ Set_Type_Declarator (Bt_Def, Decl);
+ Set_Subtype_Definition (Decl, Def);
+
+ if Old_Decl = Null_Iir then
+ Sem_Scopes.Add_Name (St_Decl);
+ else
+ Replace_Name (Get_Identifier (Decl), Old_Decl, St_Decl);
+ Set_Type_Declarator
+ (Get_Type_Definition (Old_Decl), St_Decl);
+ end if;
+
+ Sem_Scopes.Name_Visible (St_Decl);
+
+ -- The implicit subprogram will be added in the
+ -- scope just after.
+ Create_Implicit_Operations (Decl, False);
+
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_File_Type_Definition =>
+ St_Decl := Null_Iir;
+ Set_Type_Declarator (Def, Decl);
+
+ Sem_Scopes.Name_Visible (Decl);
+
+ -- The implicit subprogram will be added in the
+ -- scope just after.
+ Create_Implicit_Operations (Decl, False);
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ Set_Type_Declarator (Def, Decl);
+ St_Decl := Null_Iir;
+ -- No implicit subprograms.
+
+ when others =>
+ Error_Kind ("sem_type_declaration", Def);
+ end case;
+
+ if Old_Decl /= Null_Iir then
+ -- Complete the type definition.
+ declare
+ List : Iir_List;
+ El : Iir;
+ Old_Def : Iir;
+ begin
+ Old_Def := Get_Type_Definition (Old_Decl);
+ Set_Signal_Type_Flag (Old_Def, Get_Signal_Type_Flag (Def));
+ List := Get_Incomplete_Type_List (Old_Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Set_Designated_Type (El, Def);
+ end loop;
+ -- Complete the incomplete_type_definition node
+ -- (set type_declarator and base_type).
+
+ Set_Base_Type (Old_Def, Get_Base_Type (Def));
+ if St_Decl = Null_Iir then
+ Set_Type_Declarator (Old_Def, Decl);
+ Replace_Name (Get_Identifier (Decl), Old_Decl, Decl);
+ end if;
+ end;
+ end if;
+
+ if Is_Global then
+ Set_Type_Has_Signal (Def);
+ end if;
+ end if;
+ end if;
+ end Sem_Type_Declaration;
+
+ procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean)
+ is
+ Def: Iir;
+ Ind : Iir;
+ begin
+ -- Real hack to skip subtype declarations of anonymous type decls.
+ if Get_Visible_Flag (Decl) then
+ return;
+ end if;
+
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+
+ -- Analyze the definition of the type.
+ Ind := Get_Subtype_Indication (Decl);
+ Ind := Sem_Subtype_Indication (Ind);
+ Set_Subtype_Indication (Decl, Ind);
+ Def := Get_Type_Of_Subtype_Indication (Ind);
+ if Def = Null_Iir then
+ return;
+ end if;
+
+ if not Is_Anonymous_Type_Definition (Def) then
+ -- There is no added constraints and therefore the subtype
+ -- declaration is in fact an alias of the type. Create a copy so
+ -- that it has its own type declarator.
+ Def := Copy_Subtype_Indication (Def);
+ Location_Copy (Def, Decl);
+ Set_Subtype_Type_Mark (Def, Ind);
+ Set_Subtype_Indication (Decl, Def);
+ end if;
+
+ Set_Type (Decl, Def);
+ Set_Type_Declarator (Def, Decl);
+ Name_Visible (Decl);
+ if Is_Global then
+ Set_Type_Has_Signal (Def);
+ end if;
+ end Sem_Subtype_Declaration;
+
+ -- If DECL is a constant declaration, and there is already a constant
+ -- declaration in the current scope with the same name, then return it.
+ -- Otherwise, return NULL.
+ function Get_Deferred_Constant (Decl : Iir) return Iir
+ is
+ Deferred_Const : Iir;
+ Interp : Name_Interpretation_Type;
+ begin
+ if Get_Kind (Decl) /= Iir_Kind_Constant_Declaration then
+ return Null_Iir;
+ end if;
+ Interp := Get_Interpretation (Get_Identifier (Decl));
+ if not Valid_Interpretation (Interp) then
+ return Null_Iir;
+ end if;
+
+ if not Is_In_Current_Declarative_Region (Interp)
+ or else Is_Potentially_Visible (Interp)
+ then
+ -- Deferred and full declarations must be declared in the same
+ -- declarative region.
+ return Null_Iir;
+ end if;
+
+ Deferred_Const := Get_Declaration (Interp);
+ if Get_Kind (Deferred_Const) /= Iir_Kind_Constant_Declaration then
+ return Null_Iir;
+ end if;
+ -- LRM93 4.3.1.1
+ -- The corresponding full constant declaration, which defines the value
+ -- of the constant, must appear in the body of the package.
+ if Get_Kind (Get_Library_Unit (Get_Current_Design_Unit))
+ /= Iir_Kind_Package_Body
+ then
+ Error_Msg_Sem
+ ("full constant declaration must appear in package body", Decl);
+ end if;
+ return Deferred_Const;
+ end Get_Deferred_Constant;
+
+ procedure Sem_Object_Declaration (Decl: Iir; Parent : Iir; Last_Decl : Iir)
+ is
+ Deferred_Const : constant Iir := Get_Deferred_Constant (Decl);
+ Atype: Iir;
+ Default_Value : Iir;
+ Staticness : Iir_Staticness;
+ begin
+ -- LRM08 12.2 Scope of declarations
+ -- Then scope of a declaration [...] extends from the beginning of the
+ -- declaration [...]
+ if Deferred_Const = Null_Iir then
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+ else
+ Xref_Ref (Decl, Deferred_Const);
+ end if;
+
+ -- Semantize type and default value:
+ Atype := Get_Subtype_Indication (Decl);
+ if Atype /= Null_Iir then
+ Atype := Sem_Subtype_Indication (Atype);
+ Set_Subtype_Indication (Decl, Atype);
+ Atype := Get_Type_Of_Subtype_Indication (Atype);
+ if Atype = Null_Iir then
+ Atype := Create_Error_Type (Get_Type (Decl));
+ end if;
+
+ Default_Value := Get_Default_Value (Decl);
+ if Default_Value /= Null_Iir then
+ Default_Value := Sem_Expression (Default_Value, Atype);
+ if Default_Value = Null_Iir then
+ Default_Value :=
+ Create_Error_Expr (Get_Default_Value (Decl), Atype);
+ end if;
+ Check_Read (Default_Value);
+ Default_Value := Eval_Expr_Check_If_Static (Default_Value, Atype);
+ end if;
+ else
+ Default_Value := Get_Default_Value (Last_Decl);
+ Atype := Get_Type (Last_Decl);
+ end if;
+
+ Set_Type (Decl, Atype);
+ Set_Default_Value (Decl, Default_Value);
+ Set_Name_Staticness (Decl, Locally);
+ Set_Visible_Flag (Decl, True);
+
+ -- LRM93 2.6
+ -- The subtype indication given in the full declaration of the deferred
+ -- constant must conform to that given in the deferred constant
+ -- declaration.
+ if Deferred_Const /= Null_Iir
+ and then not Are_Trees_Equal (Get_Type (Decl),
+ Get_Type (Deferred_Const))
+ then
+ Error_Msg_Sem
+ ("subtype indication doesn't conform with the deferred constant",
+ Decl);
+ end if;
+
+ -- LRM 4.3.1.3
+ -- It is an error if a variable declaration declares a variable that is
+ -- of a file type.
+ --
+ -- LRM 4.3.1.1
+ -- It is an error if a constant declaration declares a constant that is
+ -- of a file type, or an access type, or a composite type which has
+ -- subelement that is a file type of an access type.
+ --
+ -- LRM 4.3.1.2
+ -- It is an error if a signal declaration declares a signal that is of
+ -- a file type [or an access type].
+ case Get_Kind (Atype) is
+ when Iir_Kind_File_Type_Definition =>
+ Error_Msg_Sem (Disp_Node (Decl) & " cannot be of type file", Decl);
+ when others =>
+ if Get_Kind (Decl) /= Iir_Kind_Variable_Declaration then
+ Check_Signal_Type (Decl);
+ end if;
+ end case;
+
+ if not Check_Implicit_Conversion (Atype, Default_Value) then
+ Error_Msg_Sem
+ ("default value length does not match object type length", Decl);
+ end if;
+
+ case Get_Kind (Decl) is
+ when Iir_Kind_Constant_Declaration =>
+ -- LRM93 4.3.1.1
+ -- If the assignment symbol ":=" followed by an expression is not
+ -- present in a constant declaration, then the declaration
+ -- declares a deferred constant.
+ -- Such a constant declaration may only appear in a package
+ -- declaration.
+ if Deferred_Const /= Null_Iir then
+ Set_Deferred_Declaration (Decl, Deferred_Const);
+ Set_Deferred_Declaration (Deferred_Const, Decl);
+ end if;
+ if Default_Value = Null_Iir then
+ if Deferred_Const /= Null_Iir then
+ Error_Msg_Sem
+ ("full constant declaration must have a default value",
+ Decl);
+ else
+ Set_Deferred_Declaration_Flag (Decl, True);
+ end if;
+ if Get_Kind (Parent) /= Iir_Kind_Package_Declaration then
+ Error_Msg_Sem ("a constant must have a default value", Decl);
+ end if;
+ Set_Expr_Staticness (Decl, Globally);
+ else
+ -- LRM93 7.4.1: a locally static primary is defined:
+ -- A constant (other than deferred constant) explicitly
+ -- declared by a constant declaration and initialized
+ -- with a locally static expression.
+ -- Note: the staticness of the full declaration may be locally.
+ if False and Deferred_Const /= Null_Iir then
+ -- This is a deferred constant.
+ Staticness := Globally;
+ else
+ Staticness := Min (Get_Expr_Staticness (Default_Value),
+ Get_Type_Staticness (Atype));
+ -- What about expr staticness of c in:
+ -- constant c : bit_vector (a to b) := "01";
+ -- where a and b are not locally static ?
+ --Staticness := Get_Expr_Staticness (Default_Value);
+
+ -- LRM 7.4.2 (Globally static primaries)
+ -- 5. a constant
+ if Staticness < Globally then
+ Staticness := Globally;
+ end if;
+ end if;
+ Set_Expr_Staticness (Decl, Staticness);
+ end if;
+
+ when Iir_Kind_Signal_Declaration =>
+ -- LRM93 4.3.1.2
+ -- It is also an error if a guarded signal of a
+ -- scalar type is neither a resolved signal nor a
+ -- subelement of a resolved signal.
+ if Get_Signal_Kind (Decl) /= Iir_No_Signal_Kind
+ and then not Get_Resolved_Flag (Atype)
+ then
+ Error_Msg_Sem
+ ("guarded " & Disp_Node (Decl) & " must be resolved", Decl);
+ end if;
+ Set_Expr_Staticness (Decl, None);
+ Set_Has_Disconnect_Flag (Decl, False);
+ Set_Type_Has_Signal (Atype);
+
+ when Iir_Kind_Variable_Declaration =>
+ -- LRM93 4.3.1.3 Variable declarations
+ -- Variable declared immediatly within entity declarations,
+ -- architectures bodies, packages, packages bodies, and blocks
+ -- must be shared variable.
+ -- Variables declared immediatly within subprograms and
+ -- processes must not be shared variables.
+ -- Variables may appear in proteted type bodies; such
+ -- variables, which must not be shared variables, represent
+ -- shared data.
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ if not Get_Shared_Flag (Decl) then
+ Error_Msg_Sem
+ ("non shared variable declaration not allowed here",
+ Decl);
+ end if;
+ when Iir_Kinds_Process_Statement
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ if Get_Shared_Flag (Decl) then
+ Error_Msg_Sem
+ ("shared variable declaration not allowed here", Decl);
+ end if;
+ when Iir_Kind_Protected_Type_Body =>
+ if Get_Shared_Flag (Decl) then
+ Error_Msg_Sem
+ ("variable of protected type body must not be shared",
+ Decl);
+ end if;
+ when Iir_Kind_Protected_Type_Declaration =>
+ -- This is not allowed, but caught
+ -- in sem_protected_type_declaration.
+ null;
+ when others =>
+ Error_Kind ("sem_object_declaration(2)", Parent);
+ end case;
+
+ if Flags.Vhdl_Std >= Vhdl_00 then
+ declare
+ Base_Type : Iir;
+ Is_Protected : Boolean;
+ begin
+ Base_Type := Get_Base_Type (Atype);
+ Is_Protected :=
+ Get_Kind (Base_Type) = Iir_Kind_Protected_Type_Declaration;
+
+ -- LRM00 4.3.1.3
+ -- The base type of the subtype indication of a
+ -- shared variable declaration must be a protected type.
+ if Get_Shared_Flag (Decl) and not Is_Protected then
+ Error_Msg_Sem
+ ("type of a shared variable must be a protected type",
+ Decl);
+ end if;
+
+ -- LRM00 4.3.1.3 Variable declarations
+ -- If a given variable appears (directly or indirectly)
+ -- within a protected type body, then the base type
+ -- denoted by the subtype indication of the variable
+ -- declarations must not be a protected type defined by
+ -- the protected type body.
+ -- FIXME: indirectly ?
+ if Is_Protected
+ and then Get_Kind (Parent) = Iir_Kind_Protected_Type_Body
+ and then Base_Type
+ = Get_Protected_Type_Declaration (Parent)
+ then
+ Error_Msg_Sem
+ ("variable type must not be of the protected type body",
+ Decl);
+ end if;
+ end;
+ end if;
+ Set_Expr_Staticness (Decl, None);
+ when others =>
+ Error_Kind ("sem_object_declaration", Decl);
+ end case;
+
+ case Get_Kind (Decl) is
+ when Iir_Kind_Constant_Declaration =>
+ -- LRM93 �3.2.1.1
+ -- For a constant declared by an object declaration, the index
+ -- ranges are defined by the initial value, if the subtype of the
+ -- constant is unconstrained; otherwise they are defined by this
+ -- subtype.
+ --if Default_Value = Null_Iir
+ -- and then not Sem_Is_Constrained (Atype)
+ --then
+ -- Error_Msg_Sem ("constant declaration of unconstrained "
+ -- & Disp_Node (Atype) & " is not allowed", Decl);
+ --end if;
+ null;
+ --if Deferred_Const = Null_Iir then
+ -- Name_Visible (Decl);
+ --end if;
+
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Signal_Declaration =>
+ -- LRM93 3.2.1.1 / LRM08 5.3.2.2
+ -- For a variable or signal declared by an object declaration, the
+ -- subtype indication of the corressponding object declaration
+ -- must define a constrained array subtype.
+ if not Is_Fully_Constrained_Type (Atype) then
+ Error_Msg_Sem
+ ("declaration of " & Disp_Node (Decl)
+ & " with unconstrained " & Disp_Node (Atype)
+ & " is not allowed", Decl);
+ if Default_Value /= Null_Iir then
+ Error_Msg_Sem ("(even with a default value)", Decl);
+ end if;
+ end if;
+
+ when others =>
+ Error_Kind ("sem_object_declaration(2)", Decl);
+ end case;
+ end Sem_Object_Declaration;
+
+ procedure Sem_File_Declaration (Decl: Iir_File_Declaration; Last_Decl : Iir)
+ is
+ Atype: Iir;
+ Logical_Name: Iir;
+ Open_Kind : Iir;
+ begin
+ Sem_Scopes.Add_Name (Decl);
+ Set_Expr_Staticness (Decl, None);
+ Xref_Decl (Decl);
+
+ -- Try to find a type.
+ Atype := Get_Subtype_Indication (Decl);
+ if Atype /= Null_Iir then
+ Atype := Sem_Subtype_Indication (Atype);
+ Set_Subtype_Indication (Decl, Atype);
+ Atype := Get_Type_Of_Subtype_Indication (Atype);
+ if Atype = Null_Iir then
+ Atype := Create_Error_Type (Get_Type (Decl));
+ end if;
+ else
+ Atype := Get_Type (Last_Decl);
+ end if;
+ Set_Type (Decl, Atype);
+
+ -- LRM93 4.3.1.4
+ -- The subtype indication of a file declaration must define a file
+ -- subtype.
+ if Get_Kind (Atype) /= Iir_Kind_File_Type_Definition then
+ Error_Msg_Sem ("file subtype expected for a file declaration", Decl);
+ return;
+ end if;
+
+ Logical_Name := Get_File_Logical_Name (Decl);
+ -- LRM93 4.3.1.4
+ -- The file logical name must be an expression of predefined type
+ -- STRING.
+ if Logical_Name /= Null_Iir then
+ Logical_Name := Sem_Expression (Logical_Name, String_Type_Definition);
+ if Logical_Name /= Null_Iir then
+ Check_Read (Logical_Name);
+ Set_File_Logical_Name (Decl, Logical_Name);
+ end if;
+ end if;
+
+ Open_Kind := Get_File_Open_Kind (Decl);
+ if Open_Kind /= Null_Iir then
+ Open_Kind :=
+ Sem_Expression (Open_Kind, File_Open_Kind_Type_Definition);
+ if Open_Kind /= Null_Iir then
+ Check_Read (Open_Kind);
+ Set_File_Open_Kind (Decl, Open_Kind);
+ end if;
+ else
+ -- LRM93 4.3.1.4
+ -- If a file open kind expression is not included in the file open
+ -- information of a given file declaration, then the default value
+ -- of READ_MODE is used during elaboration of the file declaration.
+ --
+ -- LRM87 4.3.1.4
+ -- The default mode is IN, if no mode is specified.
+ if Get_Mode (Decl) = Iir_Unknown_Mode then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Set_Mode (Decl, Iir_In_Mode);
+ else
+ null;
+ -- Set_File_Open_Kind (Decl, File_Open_Kind_Read_Mode);
+ end if;
+ end if;
+ end if;
+ Name_Visible (Decl);
+
+ -- LRM 93 2.2
+ -- If a pure function is the parent of a given procedure, then
+ -- that procedure must not contain a reference to an explicitly
+ -- declared file object [...]
+ --
+ -- A pure function must not contain a reference to an explicitly
+ -- declared file.
+
+ -- Note: this check is also performed when a file is referenced.
+ -- But a file can be declared without being explicitly referenced.
+ if Flags.Vhdl_Std > Vhdl_93c then
+ declare
+ Parent : Iir;
+ Spec : Iir;
+ begin
+ Parent := Get_Parent (Decl);
+ case Get_Kind (Parent) is
+ when Iir_Kind_Function_Body =>
+ Spec := Get_Subprogram_Specification (Parent);
+ if Get_Pure_Flag (Spec) then
+ Error_Msg_Sem
+ ("cannot declare a file in a pure function", Decl);
+ end if;
+ when Iir_Kind_Procedure_Body =>
+ Spec := Get_Subprogram_Specification (Parent);
+ Set_Purity_State (Spec, Impure);
+ Set_Impure_Depth (Parent, Iir_Depth_Impure);
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Error_Kind ("sem_file_declaration", Parent);
+ when others =>
+ null;
+ end case;
+ end;
+ end if;
+ end Sem_File_Declaration;
+
+ procedure Sem_Attribute_Declaration (Decl: Iir_Attribute_Declaration)
+ is
+ A_Type : Iir;
+ Ident : Name_Id;
+ begin
+ -- LRM93 4.4
+ -- The identifier is said to be the designator of the attribute.
+ Ident := Get_Identifier (Decl);
+ if Ident in Std_Names.Name_Id_Attributes
+ or else (Flags.Vhdl_Std = Vhdl_87
+ and then Ident in Std_Names.Name_Id_Vhdl87_Attributes)
+ or else (Flags.Vhdl_Std > Vhdl_87
+ and then Ident in Std_Names.Name_Id_Vhdl93_Attributes)
+ then
+ Error_Msg_Sem ("predefined attribute """ & Name_Table.Image (Ident)
+ & """ overriden", Decl);
+ end if;
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+
+ A_Type := Sem_Type_Mark (Get_Type_Mark (Decl));
+ Set_Type_Mark (Decl, A_Type);
+ A_Type := Get_Type (A_Type);
+ Set_Type (Decl, A_Type);
+
+ -- LRM93 4.4 Attribute declarations.
+ -- It is an error if the type mark denotes an access type, a file type,
+ -- a protected type, or a composite type with a subelement that is
+ -- an access type, a file type, or a protected type.
+ -- The subtype need not be constrained.
+ Check_Signal_Type (Decl);
+ Name_Visible (Decl);
+ end Sem_Attribute_Declaration;
+
+ procedure Sem_Component_Declaration (Component: Iir_Component_Declaration)
+ is
+ begin
+ Sem_Scopes.Add_Name (Component);
+ Xref_Decl (Component);
+
+ -- LRM 10.1 Declarative region
+ -- 6. A component declaration.
+ Open_Declarative_Region;
+
+ Sem_Interface_Chain
+ (Get_Generic_Chain (Component), Generic_Interface_List);
+ Sem_Interface_Chain
+ (Get_Port_Chain (Component), Port_Interface_List);
+
+ Close_Declarative_Region;
+
+ Name_Visible (Component);
+ end Sem_Component_Declaration;
+
+ procedure Sem_Object_Alias_Declaration (Alias: Iir_Object_Alias_Declaration)
+ is
+ N_Name: constant Iir := Get_Name (Alias);
+ N_Type: Iir;
+ Name_Type : Iir;
+ begin
+ -- LRM93 4.3.3.1 Object Aliases.
+ -- 1. A signature may not appear in a declaration of an object alias.
+ -- FIXME: todo.
+ --
+ -- 2. The name must be a static name that denotes an object.
+ if Get_Name_Staticness (N_Name) < Globally then
+ Error_Msg_Sem ("aliased name must be a static name", Alias);
+ end if;
+
+ -- LRM93 4.3.3.1
+ -- The base type of the name specified in an alias declaration must be
+ -- the same as the base type of the type mark in the subtype indication
+ -- (if the subtype indication is present);
+ Name_Type := Get_Type (N_Name);
+ N_Type := Get_Subtype_Indication (Alias);
+ if N_Type = Null_Iir then
+ Set_Type (Alias, Name_Type);
+ N_Type := Name_Type;
+ else
+ -- FIXME: must be analyzed before calling Name_Visibility.
+ N_Type := Sem_Subtype_Indication (N_Type);
+ Set_Subtype_Indication (Alias, N_Type);
+ N_Type := Get_Type_Of_Subtype_Indication (N_Type);
+ if N_Type /= Null_Iir then
+ Set_Type (Alias, N_Type);
+ if Get_Base_Type (N_Type) /= Get_Base_Type (Name_Type) then
+ Error_Msg_Sem ("base type of aliased name and name mismatch",
+ Alias);
+ end if;
+ end if;
+ end if;
+
+ -- LRM93 4.3.3.1
+ -- This type must not be a multi-dimensional array type.
+ if Get_Kind (N_Type) in Iir_Kinds_Array_Type_Definition then
+ if not Is_One_Dimensional_Array_Type (N_Type) then
+ Error_Msg_Sem
+ ("aliased name must not be a multi-dimensional array type",
+ Alias);
+ end if;
+ if Get_Type_Staticness (N_Type) = Locally
+ and then Get_Type_Staticness (Name_Type) = Locally
+ and then Eval_Discrete_Type_Length
+ (Get_Nth_Element (Get_Index_Subtype_List (N_Type), 0))
+ /= Eval_Discrete_Type_Length
+ (Get_Nth_Element (Get_Index_Subtype_List (Name_Type), 0))
+ then
+ Error_Msg_Sem
+ ("number of elements not matching in type and name", Alias);
+ end if;
+ end if;
+
+ Set_Name_Staticness (Alias, Get_Name_Staticness (N_Name));
+ Set_Expr_Staticness (Alias, Get_Expr_Staticness (N_Name));
+ if Is_Signal_Object (N_Name) then
+ Set_Type_Has_Signal (N_Type);
+ end if;
+ end Sem_Object_Alias_Declaration;
+
+ function Signature_Match (N_Entity : Iir; Sig : Iir_Signature)
+ return Boolean
+ is
+ List : Iir_List;
+ Inter : Iir;
+ El : Iir;
+ begin
+ List := Get_Type_Marks_List (Sig);
+ case Get_Kind (N_Entity) is
+ when Iir_Kind_Enumeration_Literal =>
+ -- LRM93 2.3.2 Signatures
+ -- * Similarly, a signature is said to match the parameter and
+ -- result type profile of a given enumeration literal if
+ -- the signature matches the parameter and result type profile
+ -- of the subprogram equivalent to the enumeration literal,
+ -- defined in Section 3.1.1
+ return List = Null_Iir_List
+ and then Get_Type (N_Entity)
+ = Get_Type (Get_Return_Type_Mark (Sig));
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ -- LRM93 2.3.2 Signatures
+ -- * if the reserved word RETURN is present, the subprogram is
+ -- a function and the base type of the type mark following
+ -- the reserved word in the signature is the same as the base
+ -- type of the return type of the function, [...]
+ if Get_Type (Get_Return_Type_Mark (Sig)) /=
+ Get_Base_Type (Get_Return_Type (N_Entity))
+ then
+ return False;
+ end if;
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ -- LRM93 2.3.2 Signatures
+ -- * [...] or the reserved word RETURN is absent and the
+ -- subprogram is a procedure.
+ if Get_Return_Type_Mark (Sig) /= Null_Iir then
+ return False;
+ end if;
+ when others =>
+ -- LRM93 2.3.2 Signatures
+ -- A signature distinguishes between overloaded subprograms and
+ -- overloaded enumeration literals based on their parameter
+ -- and result type profiles.
+ return False;
+ end case;
+
+ -- LRM93 2.3.2 Signature
+ -- * the number of type marks prior the reserved word RETURN, if any,
+ -- matches the number of formal parameters of the subprogram;
+ -- * at each parameter position, the base type denoted by the type
+ -- mark of the signature is the same as the base type of the
+ -- corresponding formal parameter of the subprogram; [and finally, ]
+ Inter := Get_Interface_Declaration_Chain (N_Entity);
+ if List = Null_Iir_List then
+ return Inter = Null_Iir;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ if El = Null_Iir and Inter = Null_Iir then
+ return True;
+ end if;
+ if El = Null_Iir or Inter = Null_Iir then
+ return False;
+ end if;
+ if Get_Base_Type (Get_Type (Inter)) /= Get_Type (El) then
+ return False;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ -- Avoid a spurious warning.
+ return False;
+ end Signature_Match;
+
+ -- Extract from NAME the named entity whose profile matches with SIG.
+ function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir
+ is
+ Res : Iir;
+ El : Iir;
+ List : Iir_List;
+ Error : Boolean;
+ begin
+ -- Sem signature.
+ 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;
+ El := Sem_Type_Mark (El);
+ Replace_Nth_Element (List, I, El);
+
+ -- Reuse the Type field of the name for the base type. This is
+ -- a deviation from the use of Type in a name, but restricted to
+ -- analysis of signatures.
+ Set_Type (El, Get_Base_Type (Get_Type (El)));
+ end loop;
+ end if;
+ El := Get_Return_Type_Mark (Sig);
+ if El /= Null_Iir then
+ El := Sem_Type_Mark (El);
+ Set_Return_Type_Mark (Sig, El);
+ -- Likewise.
+ Set_Type (El, Get_Base_Type (Get_Type (El)));
+ end if;
+
+ -- FIXME: what to do in case of error ?
+ Res := Null_Iir;
+ Error := False;
+ if Is_Overload_List (Name) then
+ for I in Natural loop
+ El := Get_Nth_Element (Get_Overload_List (Name), I);
+ exit when El = Null_Iir;
+ if Signature_Match (El, Sig) then
+ if Res = Null_Iir then
+ Res := El;
+ else
+ Error := True;
+ Error_Msg_Sem
+ ("cannot resolve signature, many matching subprograms:",
+ Sig);
+ Error_Msg_Sem ("found: " & Disp_Node (Res), Res);
+ end if;
+ if Error then
+ Error_Msg_Sem ("found: " & Disp_Node (El), El);
+ end if;
+ end if;
+ end loop;
+
+ -- Free the overload list (with a workaround as only variables can
+ -- be free).
+ declare
+ Name_Ov : Iir;
+ begin
+ Name_Ov := Name;
+ Free_Overload_List (Name_Ov);
+ end;
+ else
+ if Signature_Match (Name, Sig) then
+ Res := Name;
+ end if;
+ end if;
+
+ if Error then
+ return Null_Iir;
+ end if;
+ if Res = Null_Iir then
+ Error_Msg_Sem
+ ("cannot resolve signature, no matching subprogram", Sig);
+ end if;
+
+ return Res;
+ end Sem_Signature;
+
+ -- Create implicit aliases for an alias ALIAS of a type or of a subtype.
+ procedure Add_Aliases_For_Type_Alias (Alias : Iir)
+ is
+ N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias));
+ Def : constant Iir := Get_Base_Type (Get_Type (N_Entity));
+ Type_Decl : constant Iir := Get_Type_Declarator (Def);
+ Last : Iir;
+ El : Iir;
+ Enum_List : Iir_Enumeration_Literal_List;
+
+ -- Append an implicit alias
+ procedure Add_Implicit_Alias (Decl : Iir)
+ is
+ N_Alias : constant Iir_Non_Object_Alias_Declaration :=
+ Create_Iir (Iir_Kind_Non_Object_Alias_Declaration);
+ N_Name : constant Iir := Create_Iir (Iir_Kind_Simple_Name);
+ begin
+ -- Create the name (can be in fact a character literal or a symbol
+ -- operator).
+ Location_Copy (N_Name, Alias);
+ Set_Identifier (N_Name, Get_Identifier (Decl));
+ Set_Named_Entity (N_Name, Decl);
+
+ Location_Copy (N_Alias, Alias);
+ Set_Identifier (N_Alias, Get_Identifier (Decl));
+ Set_Name (N_Alias, N_Name);
+ Set_Parent (N_Alias, Get_Parent (Alias));
+ Set_Implicit_Alias_Flag (N_Alias, True);
+
+ Sem_Scopes.Add_Name (N_Alias);
+ Set_Visible_Flag (N_Alias, True);
+
+ -- Append in the declaration chain.
+ Set_Chain (N_Alias, Get_Chain (Last));
+ Set_Chain (Last, N_Alias);
+ Last := N_Alias;
+ end Add_Implicit_Alias;
+ begin
+ Last := Alias;
+
+ if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then
+ -- LRM93 4.3.3.2 Non-Object Aliases
+ -- 3. If the name denotes an enumeration type, then one
+ -- implicit alias declaration for each of the
+ -- literals of the type immediatly follows the alias
+ -- declaration for the enumeration type; [...]
+ --
+ -- LRM08 6.6.3 Nonobject aliases
+ -- c) If the name denotes an enumeration type of a subtype of an
+ -- enumeration type, then one implicit alias declaration for each
+ -- of the litereals of the base type immediately follows the
+ -- alias declaration for the enumeration type; [...]
+ Enum_List := Get_Enumeration_Literal_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (Enum_List, I);
+ exit when El = Null_Iir;
+ -- LRM93 4.3.3.2 Non-Object Aliases
+ -- [...] each such implicit declaration has, as its alias
+ -- designator, the simple name or character literal of the
+ -- literal, and has, as its name, a name constructed by taking
+ -- the name of the alias for the enumeration type and
+ -- substituting the simple name or character literal being
+ -- aliased for the simple name of the type. Each implicit
+ -- alias has a signature that matches the parameter and result
+ -- type profile of the literal being aliased.
+ --
+ -- LRM08 6.6.3 Nonobject aliases
+ -- [...] each such implicit declaration has, as its alias
+ -- designator, the simple name or character literal of the
+ -- literal and has, as its name, a name constructed by taking
+ -- the name of the alias for the enumeration type or subtype
+ -- and substituing the simple name or character literal being
+ -- aliased for the simple name of the type or subtype. Each
+ -- implicit alias has a signature that matches the parameter
+ -- and result type profile of the literal being aliased.
+ Add_Implicit_Alias (El);
+ end loop;
+ end if;
+
+ -- LRM93 4.3.3.2 Non-Object Aliases
+ -- 4. Alternatively, if the name denotes a physical type
+ -- [...]
+ -- GHDL: this is not possible, since a physical type is
+ -- anonymous (LRM93 is buggy on this point).
+ --
+ -- LRM08 6.6.3 Nonobject aliases
+ -- d) Alternatively, if the name denotes a subtype of a physical type,
+ -- [...]
+ if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then
+ -- LRM08 6.3.3 Nonobject aliases
+ -- [...] then one implicit alias declaration for each of the
+ -- units of the base type immediately follows the alias
+ -- declaration for the physical type; each such implicit
+ -- declaration has, as its alias designator, the simple name of
+ -- the unit and has, as its name, a name constructed by taking
+ -- the name of the alias for the subtype of the physical type
+ -- and substituting the simple name of the unit being aliased for
+ -- the simple name of the subtype.
+ El := Get_Unit_Chain (Def);
+ while El /= Null_Iir loop
+ Add_Implicit_Alias (El);
+ El := Get_Chain (El);
+ end loop;
+ end if;
+
+ -- LRM93 4.3.3.2 Non-Object Aliases
+ -- 5. Finally, if the name denotes a type, then implicit
+ -- alias declarations for each predefined operator
+ -- for the type immediatly follow the explicit alias
+ -- declaration for the type, and if present, any
+ -- implicit alias declarations for literals or units
+ -- of the type.
+ -- Each implicit alias has a signature that matches the
+ -- parameter and result type profule of the implicit
+ -- operator being aliased.
+ --
+ -- LRM08 6.6.3 Nonobject aliases
+ -- e) Finally, if the name denotes a type of a subtype, then implicit
+ -- alias declarations for each predefined operation for the type
+ -- immediately follow the explicit alias declaration for the type or
+ -- subtype and, if present, any implicit alias declarations for
+ -- literals or units of the type. Each implicit alias has a
+ -- signature that matches the parameter and result type profile of
+ -- the implicit operation being aliased.
+ El := Get_Chain (Type_Decl);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ exit when Get_Type_Reference (El) /= Type_Decl;
+ when others =>
+ exit;
+ end case;
+ Add_Implicit_Alias (El);
+ El := Get_Chain (El);
+ end loop;
+ end Add_Aliases_For_Type_Alias;
+
+ procedure Sem_Non_Object_Alias_Declaration
+ (Alias : Iir_Non_Object_Alias_Declaration)
+ is
+ use Std_Names;
+ N_Entity : constant Iir := Get_Named_Entity (Get_Name (Alias));
+ Id : Name_Id;
+ begin
+ case Get_Kind (N_Entity) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ -- LRM93 4.3.3.2 Non-Object Aliases
+ -- 2. A signature is required if the name denotes a subprogram
+ -- (including an operator) or enumeration literal.
+ if Get_Alias_Signature (Alias) = Null_Iir then
+ Error_Msg_Sem ("signature required for subprogram", Alias);
+ end if;
+ when Iir_Kind_Enumeration_Literal =>
+ if Get_Alias_Signature (Alias) = Null_Iir then
+ Error_Msg_Sem ("signature required for enumeration literal",
+ Alias);
+ end if;
+ when Iir_Kind_Type_Declaration =>
+ Add_Aliases_For_Type_Alias (Alias);
+ when Iir_Kind_Subtype_Declaration =>
+ -- LRM08 6.6.3 Nonobject aliases
+ -- ... or a subtype ...
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ Add_Aliases_For_Type_Alias (Alias);
+ end if;
+ when Iir_Kinds_Object_Declaration =>
+ raise Internal_Error;
+ when Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Component_Declaration =>
+ null;
+ when Iir_Kind_Terminal_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("sem_non_object_alias_declaration", N_Entity);
+ end case;
+
+ Id := Get_Identifier (Alias);
+
+ case Id is
+ when Name_Characters =>
+ -- LRM 4.3.3 Alias declarations
+ -- If the alias designator is a character literal, the
+ -- name must denote an enumeration literal.
+ if Get_Kind (N_Entity) /= Iir_Kind_Enumeration_Literal then
+ Error_Msg_Sem
+ ("alias of a character must denote an enumeration literal",
+ Alias);
+ return;
+ end if;
+ when Name_Id_Operators
+ | Name_Shift_Operators
+ | Name_Word_Operators =>
+ -- LRM 4.3.3 Alias declarations
+ -- If the alias designator is an operator symbol, the
+ -- name must denote a function, and that function then
+ -- overloads the operator symbol. In this latter case,
+ -- the operator symbol and the function both must meet the
+ -- requirements of 2.3.1.
+ if Get_Kind (N_Entity) not in Iir_Kinds_Function_Declaration then
+ Error_Msg_Sem
+ ("alias of an operator must denote a function", Alias);
+ return;
+ end if;
+ Check_Operator_Requirements (Id, N_Entity);
+ when others =>
+ null;
+ end case;
+ end Sem_Non_Object_Alias_Declaration;
+
+ function Sem_Alias_Declaration (Alias : Iir) return Iir
+ is
+ use Std_Names;
+ Name : Iir;
+ Sig : Iir_Signature;
+ N_Entity : Iir;
+ Res : Iir;
+ begin
+ Xref_Decl (Alias);
+
+ Name := Get_Name (Alias);
+ if Get_Kind (Name) = Iir_Kind_Signature then
+ Sig := Name;
+ Name := Get_Signature_Prefix (Sig);
+ Sem_Name (Name);
+ Set_Signature_Prefix (Sig, Name);
+ else
+ Sem_Name (Name);
+ Sig := Null_Iir;
+ end if;
+
+ N_Entity := Get_Named_Entity (Name);
+ if N_Entity = Error_Mark then
+ return Alias;
+ end if;
+
+ if Is_Overload_List (N_Entity) then
+ if Sig = Null_Iir then
+ Error_Msg_Sem
+ ("signature required for alias of a subprogram", Alias);
+ return Alias;
+ end if;
+ end if;
+
+ if Sig /= Null_Iir then
+ N_Entity := Sem_Signature (N_Entity, Sig);
+ end if;
+ if N_Entity = Null_Iir then
+ return Alias;
+ end if;
+
+ Set_Named_Entity (Name, N_Entity);
+ Set_Name (Alias, Finish_Sem_Name (Name));
+
+ if Is_Object_Name (N_Entity) then
+ -- Object alias declaration.
+
+ Sem_Scopes.Add_Name (Alias);
+ Name_Visible (Alias);
+
+ if Sig /= Null_Iir then
+ Error_Msg_Sem ("signature not allowed for object alias", Sig);
+ end if;
+ Sem_Object_Alias_Declaration (Alias);
+ return Alias;
+ else
+ -- Non object alias declaration.
+
+ if Get_Type (Alias) /= Null_Iir then
+ Error_Msg_Sem
+ ("subtype indication not allowed for non-object alias", Alias);
+ end if;
+ if Get_Subtype_Indication (Alias) /= Null_Iir then
+ Error_Msg_Sem
+ ("subtype indication shall not appear in a nonobject alias",
+ Alias);
+ end if;
+
+ Res := Create_Iir (Iir_Kind_Non_Object_Alias_Declaration);
+ Location_Copy (Res, Alias);
+ Set_Parent (Res, Get_Parent (Alias));
+ Set_Chain (Res, Get_Chain (Alias));
+ Set_Identifier (Res, Get_Identifier (Alias));
+ Set_Name (Res, Name);
+ Set_Alias_Signature (Res, Sig);
+
+ Sem_Scopes.Add_Name (Res);
+ Name_Visible (Res);
+
+ Free_Iir (Alias);
+
+ Sem_Non_Object_Alias_Declaration (Res);
+ return Res;
+ end if;
+ end Sem_Alias_Declaration;
+
+ procedure Sem_Group_Template_Declaration
+ (Decl : Iir_Group_Template_Declaration)
+ is
+ begin
+ Sem_Scopes.Add_Name (Decl);
+ Sem_Scopes.Name_Visible (Decl);
+ Xref_Decl (Decl);
+ end Sem_Group_Template_Declaration;
+
+ procedure Sem_Group_Declaration (Group : Iir_Group_Declaration)
+ is
+ use Tokens;
+
+ Constituent_List : Iir_Group_Constituent_List;
+ Template : Iir_Group_Template_Declaration;
+ Template_Name : Iir;
+ Class, Prev_Class : Token_Type;
+ El : Iir;
+ El_Name : Iir;
+ El_Entity : Iir_Entity_Class;
+ begin
+ Sem_Scopes.Add_Name (Group);
+ Xref_Decl (Group);
+
+ Template_Name := Sem_Denoting_Name (Get_Group_Template_Name (Group));
+ Set_Group_Template_Name (Group, Template_Name);
+ Template := Get_Named_Entity (Template_Name);
+ if Get_Kind (Template) /= Iir_Kind_Group_Template_Declaration then
+ Error_Class_Match (Template_Name, "group template");
+ return;
+ end if;
+ Constituent_List := Get_Group_Constituent_List (Group);
+ El_Entity := Get_Entity_Class_Entry_Chain (Template);
+ Prev_Class := Tok_Eof;
+ for I in Natural loop
+ El := Get_Nth_Element (Constituent_List, I);
+ exit when El = Null_Iir;
+
+ Sem_Name (El);
+
+ if El_Entity = Null_Iir then
+ Error_Msg_Sem
+ ("too many elements in group constituent list", Group);
+ exit;
+ end if;
+
+ Class := Get_Entity_Class (El_Entity);
+ if Class = Tok_Box then
+ -- LRM93 4.6
+ -- An entity class entry that includes a box (<>) allows zero
+ -- or more group constituents to appear in this position in the
+ -- corresponding group declaration.
+ Class := Prev_Class;
+ else
+ Prev_Class := Class;
+ El_Entity := Get_Chain (El_Entity);
+ end if;
+
+ El_Name := Get_Named_Entity (El);
+ if Is_Error (El_Name) then
+ null;
+ elsif Is_Overload_List (El_Name) then
+ Error_Overload (El_Name);
+ else
+ El := Finish_Sem_Name (El);
+ Replace_Nth_Element (Constituent_List, I, El);
+ El_Name := Get_Named_Entity (El);
+
+ -- LRM93 4.7
+ -- It is an error if the class of any group constituent in the
+ -- group constituent list is not the same as the class specified
+ -- by the corresponding entity class entry in the entity class
+ -- entry list of the group template.
+ if Get_Entity_Class_Kind (El_Name) /= Class then
+ Error_Msg_Sem
+ ("constituent not of class '" & Tokens.Image (Class) & ''',
+ El);
+ end if;
+ end if;
+ end loop;
+
+ -- End of entity_class list reached or zero or more constituent allowed.
+ if not (El_Entity = Null_Iir
+ or else Get_Entity_Class (El_Entity) = Tok_Box)
+ then
+ Error_Msg_Sem
+ ("not enough elements in group constituent list", Group);
+ end if;
+ Set_Visible_Flag (Group, True);
+ end Sem_Group_Declaration;
+
+ function Sem_Scalar_Nature_Definition (Def : Iir; Decl : Iir) return Iir
+ is
+ function Sem_Scalar_Nature_Typemark (T : Iir; Name : String) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Sem_Type_Mark (T);
+ Res := Get_Type (Res);
+ if Is_Error (Res) then
+ return Real_Type_Definition;
+ end if;
+ -- LRM93 3.5.1
+ -- The type marks must denote floating point types
+ case Get_Kind (Res) is
+ when Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ return Res;
+ when others =>
+ Error_Msg_Sem (Name & "type must be a floating point type", T);
+ return Real_Type_Definition;
+ end case;
+ end Sem_Scalar_Nature_Typemark;
+
+ Tm : Iir;
+ Ref : Iir;
+ begin
+ Tm := Get_Across_Type (Def);
+ Tm := Sem_Scalar_Nature_Typemark (Tm, "across");
+ Set_Across_Type (Def, Tm);
+
+ Tm := Get_Through_Type (Def);
+ Tm := Sem_Scalar_Nature_Typemark (Tm, "through");
+ Set_Through_Type (Def, Tm);
+
+ -- Declare the reference
+ Ref := Get_Reference (Def);
+ Set_Nature (Ref, Def);
+ Set_Chain (Ref, Get_Chain (Decl));
+ Set_Chain (Decl, Ref);
+
+ return Def;
+ end Sem_Scalar_Nature_Definition;
+
+ function Sem_Nature_Definition (Def : Iir; Decl : Iir) return Iir
+ is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ return Sem_Scalar_Nature_Definition (Def, Decl);
+ when others =>
+ Error_Kind ("sem_nature_definition", Def);
+ return Null_Iir;
+ end case;
+ end Sem_Nature_Definition;
+
+ procedure Sem_Nature_Declaration (Decl : Iir)
+ is
+ Def : Iir;
+ begin
+ Def := Get_Nature (Decl);
+ if Def /= Null_Iir then
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+
+ Def := Sem_Nature_Definition (Def, Decl);
+ if Def /= Null_Iir then
+ Set_Nature_Declarator (Def, Decl);
+ Sem_Scopes.Name_Visible (Decl);
+ end if;
+ end if;
+ end Sem_Nature_Declaration;
+
+ procedure Sem_Terminal_Declaration (Decl : Iir; Last_Decl : Iir)
+ is
+ Def, Nature : Iir;
+ begin
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+
+ Def := Get_Nature (Decl);
+
+ if Def = Null_Iir then
+ Nature := Get_Nature (Last_Decl);
+ else
+ Nature := Sem_Subnature_Indication (Def);
+ end if;
+
+ if Nature /= Null_Iir then
+ Set_Nature (Decl, Nature);
+ Sem_Scopes.Name_Visible (Decl);
+ end if;
+ end Sem_Terminal_Declaration;
+
+ procedure Sem_Branch_Quantity_Declaration (Decl : Iir; Last_Decl : Iir)
+ is
+ Plus_Name : Iir;
+ Minus_Name : Iir;
+ Branch_Type : Iir;
+ Value : Iir;
+ Is_Second : Boolean;
+ begin
+ Sem_Scopes.Add_Name (Decl);
+ Xref_Decl (Decl);
+
+ Plus_Name := Get_Plus_Terminal (Decl);
+ if Plus_Name = Null_Iir then
+ -- List of identifier.
+ Is_Second := True;
+ Plus_Name := Get_Plus_Terminal (Last_Decl);
+ Minus_Name := Get_Minus_Terminal (Last_Decl);
+ Value := Get_Default_Value (Last_Decl);
+ else
+ Is_Second := False;
+ Plus_Name := Sem_Terminal_Name (Plus_Name);
+ Minus_Name := Get_Minus_Terminal (Decl);
+ if Minus_Name /= Null_Iir then
+ Minus_Name := Sem_Terminal_Name (Minus_Name);
+ end if;
+ Value := Get_Default_Value (Decl);
+ end if;
+ Set_Plus_Terminal (Decl, Plus_Name);
+ Set_Minus_Terminal (Decl, Minus_Name);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Across_Quantity_Declaration =>
+ Branch_Type := Get_Across_Type (Get_Nature (Plus_Name));
+ when Iir_Kind_Through_Quantity_Declaration =>
+ Branch_Type := Get_Through_Type (Get_Nature (Plus_Name));
+ when others =>
+ raise Program_Error;
+ end case;
+ Set_Type (Decl, Branch_Type);
+
+ if not Is_Second and then Value /= Null_Iir then
+ Value := Sem_Expression (Value, Branch_Type);
+ end if;
+ Set_Default_Value (Decl, Value);
+
+ -- TODO: tolerance
+
+ Sem_Scopes.Name_Visible (Decl);
+ end Sem_Branch_Quantity_Declaration;
+
+ procedure Sem_Declaration_Chain (Parent : Iir)
+ is
+ Decl: Iir;
+ Last_Decl : Iir;
+ Attr_Spec_Chain : Iir;
+
+ -- Used for list of identifiers in object declarations to get the type
+ -- and default value for the following declarations.
+ Last_Obj_Decl : Iir;
+
+ -- If IS_GLOBAL is set, then declarations may be seen outside of unit.
+ -- This must be set for entities and packages (except when
+ -- Flags.Flag_Whole_Analyze is set).
+ Is_Global : Boolean;
+ begin
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration =>
+ Is_Global := not Flags.Flag_Whole_Analyze;
+ when others =>
+ Is_Global := False;
+ end case;
+
+ -- Due to implicit declarations, the list can grow during sem.
+ Decl := Get_Declaration_Chain (Parent);
+ Last_Decl := Null_Iir;
+ Attr_Spec_Chain := Null_Iir;
+ Last_Obj_Decl := Null_Iir;
+
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ Sem_Type_Declaration (Decl, Is_Global);
+ when Iir_Kind_Subtype_Declaration =>
+ Sem_Subtype_Declaration (Decl, Is_Global);
+ when Iir_Kind_Signal_Declaration =>
+ Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when Iir_Kind_Constant_Declaration =>
+ Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when Iir_Kind_Variable_Declaration =>
+ Sem_Object_Declaration (Decl, Parent, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when Iir_Kind_File_Declaration =>
+ Sem_File_Declaration (Decl, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when Iir_Kind_Attribute_Declaration =>
+ Sem_Attribute_Declaration (Decl);
+ when Iir_Kind_Attribute_Specification =>
+ Sem_Attribute_Specification (Decl, Parent);
+ if Get_Entity_Name_List (Decl) in Iir_Lists_All_Others then
+ Set_Attribute_Specification_Chain (Decl, Attr_Spec_Chain);
+ Attr_Spec_Chain := Decl;
+ end if;
+ when Iir_Kind_Component_Declaration =>
+ Sem_Component_Declaration (Decl);
+ when Iir_Kind_Function_Declaration =>
+ Sem_Subprogram_Declaration (Decl);
+ if Is_Global
+ and then Is_A_Resolution_Function (Decl, Null_Iir)
+ then
+ Set_Resolution_Function_Flag (Decl, True);
+ end if;
+ when Iir_Kind_Procedure_Declaration =>
+ Sem_Subprogram_Declaration (Decl);
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Sem_Subprogram_Body (Decl);
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Sem_Scopes.Add_Name (Decl);
+ -- Implicit subprogram are already visible.
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ -- Added by Sem_Alias_Declaration. Need to check that no
+ -- existing attribute specification apply to them.
+ null;
+ when Iir_Kind_Object_Alias_Declaration =>
+ declare
+ Res : Iir;
+ begin
+ Res := Sem_Alias_Declaration (Decl);
+ if Res /= Decl then
+ -- Replace DECL with RES.
+ if Last_Decl = Null_Iir then
+ Set_Declaration_Chain (Parent, Res);
+ else
+ Set_Chain (Last_Decl, Res);
+ end if;
+ Decl := Res;
+
+ -- An alias may add new alias declarations. Do not skip
+ -- them: check that no existing attribute specifications
+ -- apply to them.
+ end if;
+ end;
+ when Iir_Kind_Use_Clause =>
+ Sem_Use_Clause (Decl);
+ when Iir_Kind_Configuration_Specification =>
+ null;
+ when Iir_Kind_Disconnection_Specification =>
+ Sem_Disconnection_Specification (Decl);
+ when Iir_Kind_Group_Template_Declaration =>
+ Sem_Group_Template_Declaration (Decl);
+ when Iir_Kind_Group_Declaration =>
+ Sem_Group_Declaration (Decl);
+ when Iir_Kinds_Signal_Attribute =>
+ -- Added by sem, so nothing to do.
+ null;
+ when Iir_Kind_Protected_Type_Body =>
+ Sem_Protected_Type_Body (Decl);
+ when Iir_Kind_Nature_Declaration =>
+ Sem_Nature_Declaration (Decl);
+ when Iir_Kind_Terminal_Declaration =>
+ Sem_Terminal_Declaration (Decl, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration =>
+ Sem_Branch_Quantity_Declaration (Decl, Last_Obj_Decl);
+ Last_Obj_Decl := Decl;
+ when others =>
+ Error_Kind ("sem_declaration_chain", Decl);
+ end case;
+ if Attr_Spec_Chain /= Null_Iir then
+ Check_Post_Attribute_Specification (Attr_Spec_Chain, Decl);
+ end if;
+ Last_Decl := Decl;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Sem_Declaration_Chain;
+
+ procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir)
+ is
+ El: Iir;
+
+ -- If set, emit a warning if a declaration is not used.
+ Check_Unused : Boolean;
+ begin
+ -- LRM 3.5 Protected types.
+ -- Each protected type declaration appearing immediatly within a given
+ -- declaration region must have exactly one corresponding protected type
+ -- body appearing immediatly within the same declarative region and
+ -- textually subsequent to the protected type declaration.
+
+ -- LRM 3.3.1 Incomplete type declarations
+ -- For each incomplete type declaration, there must be a corresponding
+ -- full type declaration with the same identifier. This full type
+ -- declaration must occur later and immediatly within the same
+ -- declarative part as the incomplete type declaration to which it
+ -- correspinds.
+
+ -- LRM 4.3.1.1 Constant declarations
+ -- If the assignment symbol ":=" followed by an expression is not
+ -- present in a constant declaration, then the declaration declares a
+ -- deferred constant. Such a constant declaration must appear in a
+ -- package declaration. The corresponding full constant declaration,
+ -- which defines the value of the constant, must appear in the body of
+ -- the package (see 2.6).
+
+ -- LRM 2.2 Subprogram bodies
+ -- If both a declaration and a body are given, [...]. Furthermore,
+ -- both the declaration and the body must occur immediatly within the
+ -- same declaration region.
+
+ -- Set Check_Unused.
+ Check_Unused := False;
+ if Flags.Warn_Unused then
+ case Get_Kind (Decl) is
+ when Iir_Kind_Entity_Declaration =>
+ -- May be used in architecture.
+ null;
+ when Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ -- Might be used in a configuration.
+ -- FIXME: create a second level of warning.
+ null;
+ when Iir_Kind_Package_Body
+ | Iir_Kind_Protected_Type_Body =>
+ -- Check only for declarations of the body.
+ if Decls_Parent = Decl then
+ Check_Unused := True;
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Check_Unused := True;
+ when others =>
+ -- Note: Check_Full_Declaration is not called
+ -- for package declarations or protected type declarations.
+ Error_Kind ("check_full_declaration", Decl);
+ end case;
+ end if;
+
+ El := Get_Declaration_Chain (Decls_Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Constant_Declaration =>
+ if Get_Deferred_Declaration_Flag (El) then
+ if Get_Deferred_Declaration (El) = Null_Iir then
+ Error_Msg_Sem ("missing value for constant declared at "
+ & Disp_Location (El), Decl);
+ else
+ -- Remove from visibility the full declaration of the
+ -- constant.
+ -- FIXME: this is not a check!
+ Set_Deferred_Declaration (El, Null_Iir);
+ end if;
+ end if;
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if Get_Subprogram_Body (El) = Null_Iir then
+ Error_Msg_Sem ("missing body for " & Disp_Node (El)
+ & " declared at "
+ & Disp_Location (El), Decl);
+ end if;
+ when Iir_Kind_Type_Declaration =>
+ declare
+ Def : Iir;
+ begin
+ Def := Get_Type_Definition (El);
+ if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition
+ and then Get_Type_Declarator (Def) = El
+ then
+ Error_Msg_Sem ("missing full type declaration for "
+ & Disp_Node (El), El);
+ elsif Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration
+ and then Get_Protected_Type_Body (Def) = Null_Iir
+ then
+ Error_Msg_Sem ("missing protected type body for "
+ & Disp_Node (El), El);
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+
+ if Check_Unused then
+ -- All subprograms declared in the specification (package or
+ -- protected type) have only their *body* in the body.
+ -- Therefore, they don't appear as declaration in body.
+ -- Only private subprograms appears as declarations.
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if not Get_Use_Flag (El)
+ and then not Is_Second_Subprogram_Specification (El)
+ then
+ Warning_Msg_Sem
+ (Disp_Node (El) & " is never referenced", El);
+ end if;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ El := Get_Chain (El);
+ end loop;
+ end Check_Full_Declaration;
+
+ procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration;
+ Staticness : Iir_Staticness)
+ is
+ It_Range: constant Iir := Get_Discrete_Range (Iterator);
+ It_Type : Iir;
+ A_Range: Iir;
+ begin
+ Xref_Decl (Iterator);
+
+ A_Range := Sem_Discrete_Range_Integer (It_Range);
+ if A_Range = Null_Iir then
+ Set_Type (Iterator, Create_Error_Type (It_Range));
+ return;
+ end if;
+
+ Set_Discrete_Range (Iterator, A_Range);
+
+ It_Type := Range_To_Subtype_Indication (A_Range);
+ Set_Subtype_Indication (Iterator, It_Type);
+ Set_Type (Iterator, Get_Type_Of_Subtype_Indication (It_Type));
+
+ Set_Expr_Staticness (Iterator, Staticness);
+ end Sem_Iterator;
+end Sem_Decls;
diff --git a/src/sem_decls.ads b/src/sem_decls.ads
new file mode 100644
index 000000000..7a8e24042
--- /dev/null
+++ b/src/sem_decls.ads
@@ -0,0 +1,52 @@
+-- Semantic analysis.
+-- 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 Sem_Decls is
+ procedure Sem_Interface_Chain (Interface_Chain: Iir;
+ Interface_Kind : Interface_Kind_Type);
+
+ -- Create predefined operations for DECL.
+ procedure Create_Implicit_Operations
+ (Decl : Iir; Is_Std_Standard : Boolean := False);
+
+ -- Semantize declarations of PARENT.
+ procedure Sem_Declaration_Chain (Parent : Iir);
+
+ -- Check all declarations of DECLS_PARENT are complete
+ -- This checks subprograms, deferred constants, incomplete types and
+ -- protected types.
+ --
+ -- DECL is the declaration that contains the declaration_list DECLS_PARENT.
+ -- (location of errors).
+ -- DECL is different from DECLS_PARENT for package bodies and protected
+ -- type bodies.
+ --
+ -- Also, report unused declarations if DECL = DECLS_PARENT.
+ -- As a consequence, Check_Full_Declaration must be called after sem
+ -- of statements, if any.
+ procedure Check_Full_Declaration (Decls_Parent : Iir; Decl: Iir);
+
+ procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration;
+ Staticness : Iir_Staticness);
+
+ -- Extract from NAME the named entity whose profile matches SIG. If NAME
+ -- is an overload list, it is destroyed.
+ function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir;
+
+end Sem_Decls;
diff --git a/src/sem_expr.adb b/src/sem_expr.adb
new file mode 100644
index 000000000..f7af76c09
--- /dev/null
+++ b/src/sem_expr.adb
@@ -0,0 +1,4262 @@
+-- Semantic analysis.
+-- 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 Std_Package; use Std_Package;
+with Errorout; use Errorout;
+with Flags; use Flags;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Names; use Sem_Names;
+with Sem;
+with Name_Table;
+with Iirs_Utils; use Iirs_Utils;
+with Evaluation; use Evaluation;
+with Iir_Chains; use Iir_Chains;
+with Sem_Types;
+with Sem_Stmts; use Sem_Stmts;
+with Sem_Assocs; use Sem_Assocs;
+with Xrefs; use Xrefs;
+
+package body Sem_Expr is
+ procedure Not_Match (Expr: Iir; A_Type: Iir)
+ is
+ pragma Inline (Not_Match);
+ begin
+ Error_Not_Match (Expr, A_Type, Expr);
+ end Not_Match;
+
+-- procedure Not_Match (Expr: Iir; Type1: Iir; Type2: Iir) is
+-- begin
+-- Error_Msg_Sem
+-- ("can't match '" & Disp_Node (Expr) & "' with type '"
+-- & Disp_Node (Type1) & "' or type '" & Disp_Node (Type2) & "'",
+-- Expr);
+-- end Not_Match;
+
+-- procedure Overloaded (Expr: Iir) is
+-- begin
+-- Error_Msg_Sem
+-- ("cant resolve overloaded identifier '" & Get_String (Expr) & "'",
+-- Expr);
+-- end Overloaded;
+
+ -- Replace type of TARGET by A_TYPE.
+ -- If TARGET has already a type, it must be an overload list, and in this
+ -- case, this list is freed, or it must be A_TYPE.
+ -- A_TYPE can't be an overload list.
+ --
+ -- This procedure can be called in the second pass, when the type is known.
+ procedure Replace_Type (Target: Iir; A_Type: Iir) is
+ Old_Type: Iir;
+ begin
+ Old_Type := Get_Type (Target);
+ if Old_Type /= Null_Iir then
+ if Is_Overload_List (Old_Type) then
+ Free_Iir (Old_Type);
+ elsif Old_Type = A_Type then
+ return;
+ else
+ -- Cannot replace a type.
+ raise Internal_Error;
+ end if;
+ end if;
+ if A_Type = Null_Iir then
+ return;
+ end if;
+ if Is_Overload_List (A_Type) then
+ raise Internal_Error;
+ end if;
+ Set_Type (Target, A_Type);
+ end Replace_Type;
+
+ -- Return true if EXPR is overloaded, ie has several meanings.
+ function Is_Overloaded (Expr : Iir) return Boolean
+ is
+ Expr_Type : constant Iir := Get_Type (Expr);
+ begin
+ return Expr_Type = Null_Iir or else Is_Overload_List (Expr_Type);
+ end Is_Overloaded;
+
+ -- Return the common type of base types LEFT and RIGHT.
+ -- LEFT are RIGHT must be really base types (not subtypes).
+ -- Roughly speaking, it returns LEFT (= RIGHT) if LEFT = RIGHT (ie, same
+ -- type), null otherwise.
+ -- However, it handles implicite conversions of universal types.
+ function Get_Common_Basetype (Left: Iir; Right: Iir)
+ return Iir is
+ begin
+ if Left = Right then
+ return Left;
+ end if;
+ case Get_Kind (Left) is
+ when Iir_Kind_Integer_Type_Definition =>
+ if Right = Convertible_Integer_Type_Definition then
+ return Left;
+ elsif Left = Convertible_Integer_Type_Definition
+ and then Get_Kind (Right) = Iir_Kind_Integer_Type_Definition
+ then
+ return Right;
+ end if;
+ when Iir_Kind_Floating_Type_Definition =>
+ if Right = Convertible_Real_Type_Definition then
+ return Left;
+ elsif Left = Convertible_Real_Type_Definition
+ and then Get_Kind (Right) = Iir_Kind_Floating_Type_Definition
+ then
+ return Right;
+ end if;
+ when others =>
+ null;
+ end case;
+ return Null_Iir;
+ end Get_Common_Basetype;
+
+ -- LEFT are RIGHT must be really a type (not a subtype).
+ function Are_Basetypes_Compatible (Left: Iir; Right: Iir)
+ return Boolean is
+ begin
+ return Get_Common_Basetype (Left, Right) /= Null_Iir;
+ end Are_Basetypes_Compatible;
+
+ function Are_Types_Compatible (Left: Iir; Right: Iir)
+ return Boolean is
+ begin
+ return Get_Common_Basetype (Get_Base_Type (Left),
+ Get_Base_Type (Right)) /= Null_Iir;
+ end Are_Types_Compatible;
+
+ function Are_Nodes_Compatible (Left: Iir; Right: Iir)
+ return Boolean is
+ begin
+ return Are_Types_Compatible (Get_Type (Left), Get_Type (Right));
+ end Are_Nodes_Compatible;
+
+ -- Return TRUE iif LEFT_TYPE and RIGHT_TYPES are compatible. RIGHT_TYPES
+ -- may be an overload list.
+ function Compatibility_Types1 (Left_Type : Iir; Right_Types : Iir)
+ return Boolean
+ is
+ El : Iir;
+ Right_List : Iir_List;
+ begin
+ pragma Assert (not Is_Overload_List (Left_Type));
+
+ if Is_Overload_List (Right_Types) then
+ Right_List := Get_Overload_List (Right_Types);
+ for I in Natural loop
+ El := Get_Nth_Element (Right_List, I);
+ exit when El = Null_Iir;
+ if Are_Types_Compatible (Left_Type, El) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ else
+ return Are_Types_Compatible (Left_Type, Right_Types);
+ end if;
+ end Compatibility_Types1;
+
+ -- Return compatibility for nodes LEFT and RIGHT.
+ -- LEFT is expected to be an interface of a function definition.
+ -- Type of RIGHT can be an overload_list
+ -- RIGHT might be implicitly converted to LEFT.
+ function Compatibility_Nodes (Left : Iir; Right : Iir)
+ return Boolean
+ is
+ Left_Type, Right_Type : Iir;
+ begin
+ Left_Type := Get_Base_Type (Get_Type (Left));
+ Right_Type := Get_Type (Right);
+
+ -- Check.
+ case Get_Kind (Left_Type) is
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ null;
+ when others =>
+ Error_Kind ("are_node_compatible_ov", Left_Type);
+ end case;
+
+ return Compatibility_Types1 (Left_Type, Right_Type);
+ end Compatibility_Nodes;
+
+ -- Return TRUE iff A_TYPE can be the type of string or bit string literal
+ -- EXPR. EXPR is needed to distinguish between string and bit string
+ -- for VHDL87 rule about the type of a bit string.
+ function Is_String_Literal_Type (A_Type : Iir; Expr : Iir) return Boolean
+ is
+ Base_Type : constant Iir := Get_Base_Type (A_Type);
+ El_Bt : Iir;
+ begin
+ -- LRM 7.3.1
+ -- [...] the type of the literal must be a one-dimensional array ...
+ if not Is_One_Dimensional_Array_Type (Base_Type) then
+ return False;
+ end if;
+ -- LRM 7.3.1
+ -- ... of a character type ...
+ El_Bt := Get_Base_Type (Get_Element_Subtype (Base_Type));
+ if Get_Kind (El_Bt) /= Iir_Kind_Enumeration_Type_Definition then
+ return False;
+ end if;
+ -- LRM87 7.3.1
+ -- ... (for string literals) or of type BIT (for bit string literals).
+ if Flags.Vhdl_Std = Vhdl_87
+ and then Get_Kind (Expr) = Iir_Kind_Bit_String_Literal
+ and then El_Bt /= Bit_Type_Definition
+ then
+ return False;
+ end if;
+ return True;
+ end Is_String_Literal_Type;
+
+ -- Return TRUE iff A_TYPE can be the type of an aggregate.
+ function Is_Aggregate_Type (A_Type : Iir) return Boolean is
+ begin
+ -- LRM 7.3.2 Aggregates
+ -- [...] the type of the aggregate must be a composite type.
+ case Get_Kind (Get_Base_Type (A_Type)) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Record_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Aggregate_Type;
+
+ -- Return TRUE iff A_TYPE can be the type of a null literal.
+ function Is_Null_Literal_Type (A_Type : Iir) return Boolean is
+ begin
+ -- LRM 7.3.1 Literals
+ -- The literal NULL represents the null access value for any access
+ -- type.
+ return
+ Get_Kind (Get_Base_Type (A_Type)) = Iir_Kind_Access_Type_Definition;
+ end Is_Null_Literal_Type;
+
+ -- Return TRUE iff A_TYPE can be the type of allocator EXPR. Note that
+ -- the allocator must have been analyzed.
+ function Is_Allocator_Type (A_Type : Iir; Expr : Iir) return Boolean
+ is
+ Base_Type : constant Iir := Get_Base_Type (A_Type);
+ Designated_Type : Iir;
+ begin
+ -- LRM 7.3.6 Allocators
+ -- [...] the value returned is of an access type having the named
+ -- designated type.
+
+ if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then
+ return False;
+ end if;
+ Designated_Type := Get_Allocator_Designated_Type (Expr);
+ pragma Assert (Designated_Type /= Null_Iir);
+ -- Cheat: there is no allocators on universal types.
+ return Get_Base_Type (Get_Designated_Type (Base_Type))
+ = Get_Base_Type (Designated_Type);
+ end Is_Allocator_Type;
+
+ -- Return TRUE iff the type of EXPR is compatible with A_TYPE
+ function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean
+ is
+ Expr_Type : constant Iir := Get_Type (Expr);
+ begin
+ if Expr_Type /= Null_Iir then
+ return Compatibility_Types1 (A_Type, Expr_Type);
+ end if;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Aggregate =>
+ return Is_Aggregate_Type (A_Type);
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return Is_String_Literal_Type (A_Type, Expr);
+ when Iir_Kind_Null_Literal =>
+ return Is_Null_Literal_Type (A_Type);
+ when Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype =>
+ return Is_Allocator_Type (A_Type, Expr);
+ when Iir_Kind_Parenthesis_Expression =>
+ return Is_Expr_Compatible (A_Type, Get_Expression (Expr));
+ when others =>
+ -- Error while EXPR was typed. FIXME: should create an ERROR
+ -- node?
+ return False;
+ end case;
+ end Is_Expr_Compatible;
+
+ function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir
+ is
+ begin
+ if Expr = Null_Iir then
+ return Null_Iir;
+ end if;
+ case Get_Kind (Expr) is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kinds_Subtype_Definition
+ | Iir_Kind_Design_Unit
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Library_Clause
+ | Iir_Kind_Component_Declaration
+ | Iir_Kinds_Procedure_Declaration
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Psl_Declaration =>
+ Error_Msg_Sem (Disp_Node (Expr)
+ & " not allowed in an expression", Loc);
+ return Null_Iir;
+ when Iir_Kinds_Function_Declaration =>
+ return Expr;
+ when Iir_Kind_Overload_List =>
+ return Expr;
+ when Iir_Kinds_Literal
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Enumeration_Literal =>
+ return Expr;
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Aggregate
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Qualified_Expression =>
+ return Expr;
+ when Iir_Kinds_Quantity_Declaration =>
+ return Expr;
+ when Iir_Kinds_Dyadic_Operator
+ | Iir_Kinds_Monadic_Operator =>
+ return Expr;
+ when Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kinds_Expression_Attribute
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Parenthesis_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Function_Call =>
+ return Expr;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Selected_By_All_Name =>
+ return Expr;
+ when Iir_Kind_Error =>
+ return Expr;
+ when others =>
+ Error_Kind ("check_is_expression", Expr);
+ --N := Get_Type (Expr);
+ --return Expr;
+ end case;
+ end Check_Is_Expression;
+
+ function Check_Implicit_Conversion (Targ_Type : Iir; Expr : Iir)
+ return Boolean
+ is
+ Expr_Type : Iir;
+ Targ_Indexes : Iir_List;
+ Expr_Indexes : Iir_List;
+ Targ_Index : Iir;
+ Expr_Index : Iir;
+ begin
+ -- Handle errors.
+ if Targ_Type = Null_Iir or else Expr = Null_Iir then
+ return True;
+ end if;
+ if Get_Kind (Targ_Type) /= Iir_Kind_Array_Subtype_Definition
+ or else Get_Constraint_State (Targ_Type) /= Fully_Constrained
+ then
+ return True;
+ end if;
+ Expr_Type := Get_Type (Expr);
+ if Expr_Type = Null_Iir
+ or else Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition
+ or else Get_Constraint_State (Expr_Type) /= Fully_Constrained
+ then
+ return True;
+ end if;
+ Targ_Indexes := Get_Index_Subtype_List (Targ_Type);
+ Expr_Indexes := Get_Index_Subtype_List (Expr_Type);
+ for I in Natural loop
+ Targ_Index := Get_Index_Type (Targ_Indexes, I);
+ Expr_Index := Get_Index_Type (Expr_Indexes, I);
+ exit when Targ_Index = Null_Iir and Expr_Index = Null_Iir;
+ if Targ_Index = Null_Iir or Expr_Index = Null_Iir then
+ -- Types does not match.
+ raise Internal_Error;
+ end if;
+ if Get_Type_Staticness (Targ_Index) = Locally
+ and then Get_Type_Staticness (Expr_Index) = Locally
+ then
+ if Eval_Discrete_Type_Length (Targ_Index)
+ /= Eval_Discrete_Type_Length (Expr_Index)
+ then
+ return False;
+ end if;
+ end if;
+ end loop;
+ return True;
+ end Check_Implicit_Conversion;
+
+ -- Find a type compatible with A_TYPE in TYPE_LIST (which can be an
+ -- overload list or a simple type) and return it.
+ -- In case of failure, return null.
+ function Search_Overloaded_Type (Type_List: Iir; A_Type: Iir)
+ return Iir
+ is
+ Type_List_List : Iir_List;
+ El: Iir;
+ Com : Iir;
+ Res : Iir;
+ begin
+ if not Is_Overload_List (Type_List) then
+ return Get_Common_Basetype (Get_Base_Type (Type_List),
+ Get_Base_Type (A_Type));
+ else
+ Type_List_List := Get_Overload_List (Type_List);
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (Type_List_List, I);
+ exit when El = Null_Iir;
+ Com := Get_Common_Basetype (Get_Base_Type (El),
+ Get_Base_Type (A_Type));
+ if Com /= Null_Iir then
+ if Res = Null_Iir then
+ Res := Com;
+ else
+ -- Several compatible types.
+ return Null_Iir;
+ end if;
+ end if;
+ end loop;
+ return Res;
+ end if;
+ end Search_Overloaded_Type;
+
+ -- LIST1, LIST2 are either a type node or an overload list of types.
+ -- Return THE type which is compatible with LIST1 are LIST2.
+ -- Return null_iir if there is no such type or if there are several types.
+ function Search_Compatible_Type (List1, List2 : Iir) return Iir
+ is
+ List1_List : Iir_List;
+ Res : Iir;
+ El : Iir;
+ Tmp : Iir;
+ begin
+ if Is_Overload_List (List1) then
+ List1_List := Get_Overload_List (List1);
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (List1_List, I);
+ exit when El = Null_Iir;
+ Tmp := Search_Overloaded_Type (List2, El);
+ if Tmp /= Null_Iir then
+ if Res = Null_Iir then
+ Res := Tmp;
+ else
+ -- Several types match.
+ return Null_Iir;
+ end if;
+ end if;
+ end loop;
+ return Res;
+ else
+ return Search_Overloaded_Type (List2, List1);
+ end if;
+ end Search_Compatible_Type;
+
+ -- Semantize the range expression EXPR.
+ -- If A_TYPE is not null_iir, EXPR is expected to be of type A_TYPE.
+ -- LRM93 3.2.1.1
+ -- FIXME: avoid to run it on an already semantized node, be careful
+ -- with range_type_expr.
+ function Sem_Simple_Range_Expression
+ (Expr: Iir_Range_Expression; A_Type: Iir; Any_Dir : Boolean)
+ return Iir_Range_Expression
+ is
+ Base_Type: Iir;
+ Left, Right: Iir;
+ Left_Type, Right_Type : Iir;
+ Expr_Type : Iir;
+ begin
+ Expr_Type := Get_Type (Expr);
+ Left := Get_Left_Limit (Expr);
+ Right := Get_Right_Limit (Expr);
+
+ if Expr_Type = Null_Iir then
+ -- Pass 1.
+
+ if A_Type = Null_Iir then
+ Base_Type := Null_Iir;
+ else
+ Base_Type := Get_Base_Type (A_Type);
+ end if;
+
+ -- Analyze left and right bounds.
+ Right := Sem_Expression_Ov (Right, Base_Type);
+ Left := Sem_Expression_Ov (Left, Base_Type);
+
+ if Left = Null_Iir or else Right = Null_Iir then
+ -- Error.
+ return Null_Iir;
+ end if;
+
+ Left_Type := Get_Type (Left);
+ Right_Type := Get_Type (Right);
+ -- Check for string or aggregate literals
+ -- FIXME: improve error message
+ if Left_Type = Null_Iir then
+ Error_Msg_Sem ("bad expression for a scalar", Left);
+ return Null_Iir;
+ end if;
+ if Right_Type = Null_Iir then
+ Error_Msg_Sem ("bad expression for a scalar", Right);
+ return Null_Iir;
+ end if;
+
+ if Is_Overload_List (Left_Type)
+ or else Is_Overload_List (Right_Type)
+ then
+ if Base_Type /= Null_Iir then
+ -- Cannot happen, since sem_expression_ov should resolve
+ -- ambiguties if a type is given.
+ raise Internal_Error;
+ end if;
+
+ -- Try to find a common type.
+ Expr_Type := Search_Compatible_Type (Left_Type, Right_Type);
+ if Expr_Type = Null_Iir then
+ if Compatibility_Types1 (Universal_Integer_Type_Definition,
+ Left_Type)
+ and then
+ Compatibility_Types1 (Universal_Integer_Type_Definition,
+ Right_Type)
+ then
+ Expr_Type := Universal_Integer_Type_Definition;
+ elsif Compatibility_Types1 (Universal_Real_Type_Definition,
+ Left_Type)
+ and then
+ Compatibility_Types1 (Universal_Real_Type_Definition,
+ Right_Type)
+ then
+ Expr_Type := Universal_Real_Type_Definition;
+ else
+ -- FIXME: handle overload
+ Error_Msg_Sem
+ ("left and right expressions of range are not compatible",
+ Expr);
+ return Null_Iir;
+ end if;
+ end if;
+ Left := Sem_Expression (Left, Expr_Type);
+ Right := Sem_Expression (Right, Expr_Type);
+ if Left = Null_Iir or else Right = Null_Iir then
+ return Null_Iir;
+ end if;
+ else
+ Expr_Type := Get_Common_Basetype (Get_Base_Type (Left_Type),
+ Get_Base_Type (Right_Type));
+ if Expr_Type = Null_Iir then
+ Error_Msg_Sem
+ ("left and right expressions of range are not compatible",
+ Expr);
+ return Null_Iir;
+ end if;
+ end if;
+
+ -- The type of the range is known, finish analysis.
+ else
+ -- Second call.
+
+ pragma Assert (A_Type /= Null_Iir);
+
+ if Is_Overload_List (Expr_Type) then
+ -- FIXME: resolve overload
+ raise Internal_Error;
+ else
+ if not Are_Types_Compatible (Expr_Type, A_Type) then
+ Error_Msg_Sem
+ ("type of range doesn't match expected type", Expr);
+ return Null_Iir;
+ end if;
+
+ return Expr;
+ end if;
+ end if;
+
+ Left := Eval_Expr_If_Static (Left);
+ Right := Eval_Expr_If_Static (Right);
+ Set_Left_Limit (Expr, Left);
+ Set_Right_Limit (Expr, Right);
+ Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left),
+ Get_Expr_Staticness (Right)));
+
+ if A_Type /= Null_Iir
+ and then not Are_Types_Compatible (Expr_Type, A_Type)
+ then
+ Error_Msg_Sem ("type of range doesn't match expected type", Expr);
+ return Null_Iir;
+ end if;
+
+ Set_Type (Expr, Expr_Type);
+ if Get_Kind (Get_Base_Type (Expr_Type))
+ not in Iir_Kinds_Scalar_Type_Definition
+ then
+ Error_Msg_Sem ("type of range is not a scalar type", Expr);
+ return Null_Iir;
+ end if;
+
+ if Get_Expr_Staticness (Expr) = Locally
+ and then Get_Type_Staticness (Expr_Type) = Locally
+ and then Get_Kind (Expr_Type) in Iir_Kinds_Subtype_Definition
+ then
+ Eval_Check_Range (Expr, Expr_Type, Any_Dir);
+ end if;
+
+ return Expr;
+ end Sem_Simple_Range_Expression;
+
+ -- The result can be:
+ -- a subtype definition
+ -- a range attribute
+ -- a range type definition
+ -- LRM93 3.2.1.1
+ -- FIXME: avoid to run it on an already semantized node, be careful
+ -- with range_type_expr.
+ function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean)
+ return Iir
+ is
+ Res : Iir;
+ Res_Type : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Range_Expression =>
+ Res := Sem_Simple_Range_Expression (Expr, A_Type, Any_Dir);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ Res_Type := Get_Type (Res);
+
+ when Iir_Kinds_Denoting_Name
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Parenthesis_Name =>
+ if Get_Named_Entity (Expr) = Null_Iir then
+ Sem_Name (Expr);
+ end if;
+ Res := Name_To_Range (Expr);
+ if Res = Error_Mark then
+ return Null_Iir;
+ end if;
+
+ case Get_Kind (Res) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ pragma Assert (Get_Kind (Get_Named_Entity (Res))
+ in Iir_Kinds_Type_Declaration);
+ Res_Type := Get_Type (Get_Named_Entity (Res));
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ Res_Type := Get_Type (Res);
+ when others =>
+ Error_Msg_Sem ("name must denote a range", Expr);
+ return Null_Iir;
+ end case;
+ if A_Type /= Null_Iir
+ and then Get_Base_Type (Res_Type) /= Get_Base_Type (A_Type)
+ then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+
+ when others =>
+ Error_Msg_Sem ("range expression required", Expr);
+ return Null_Iir;
+ end case;
+
+ if Get_Kind (Res_Type) not in Iir_Kinds_Scalar_Type_Definition then
+ Error_Msg_Sem (Disp_Node (Res) & " is not a range type", Expr);
+ return Null_Iir;
+ end if;
+
+ Res := Eval_Range_If_Static (Res);
+
+ if A_Type /= Null_Iir
+ and then Get_Type_Staticness (A_Type) = Locally
+ and then Get_Kind (A_Type) in Iir_Kinds_Subtype_Definition
+ then
+ if Get_Expr_Staticness (Res) = Locally then
+ Eval_Check_Range (Res, A_Type, Any_Dir);
+ end if;
+ end if;
+ return Res;
+ end Sem_Range_Expression;
+
+ function Sem_Discrete_Range_Expression
+ (Expr: Iir; A_Type: Iir; Any_Dir : Boolean)
+ return Iir
+ is
+ Res : Iir;
+ Res_Type : Iir;
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Subtype_Definition then
+ Res := Sem_Types.Sem_Subtype_Indication (Expr);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ Res_Type := Res;
+ if A_Type /= Null_Iir
+ and then (not Are_Types_Compatible
+ (A_Type, Get_Type_Of_Subtype_Indication (Res)))
+ then
+ -- A_TYPE is known when analyzing an index_constraint within
+ -- a subtype indication.
+ Error_Msg_Sem ("subtype " & Disp_Node (Res)
+ & " doesn't match expected type "
+ & Disp_Node (A_Type), Expr);
+ -- FIXME: override type of RES ?
+ end if;
+ else
+ Res := Sem_Range_Expression (Expr, A_Type, Any_Dir);
+
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ Res_Type := Get_Type (Res);
+ end if;
+
+ -- Check the type is discrete.
+ if Get_Kind (Res_Type) not in Iir_Kinds_Discrete_Type_Definition then
+ if Get_Kind (Res_Type) /= Iir_Kind_Error then
+ -- FIXME: avoid that test with error.
+ if Get_Kind (Res) not in Iir_Kinds_Denoting_Name then
+ Error_Msg_Sem ("range is not discrete", Res);
+ else
+ Error_Msg_Sem
+ (Disp_Node (Res) & " is not a discrete range type", Expr);
+ end if;
+ end if;
+ return Null_Iir;
+ end if;
+
+ return Res;
+ end Sem_Discrete_Range_Expression;
+
+ function Sem_Discrete_Range_Integer (Expr: Iir) return Iir
+ is
+ Res : Iir;
+ Range_Type : Iir;
+ begin
+ Res := Sem_Discrete_Range_Expression (Expr, Null_Iir, True);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ if Get_Kind (Expr) /= Iir_Kind_Range_Expression then
+ return Res;
+ end if;
+
+ Range_Type := Get_Type (Res);
+ if Range_Type = Convertible_Integer_Type_Definition then
+ -- LRM 3.2.1.1 Index constraints and discrete ranges
+ -- For a discrete range used in a constrained array
+ -- definition and defined by a range, an implicit
+ -- conversion to the predefined type INTEGER is assumed
+ -- if each bound is either a numeric literal or an
+ -- attribute, and the type of both bounds (prior to the
+ -- implicit conversion) is the type universal_integer.
+
+ -- FIXME: catch phys/phys.
+ Set_Type (Res, Integer_Type_Definition);
+ if Get_Expr_Staticness (Res) = Locally then
+ Eval_Check_Range (Res, Integer_Subtype_Definition, True);
+ end if;
+ elsif Range_Type = Universal_Integer_Type_Definition then
+ if Vhdl_Std >= Vhdl_08 then
+ -- LRM08 5.3.2.2
+ -- For a discrete range used in a constrained array definition
+ -- and defined by a range, an implicit conversion to the
+ -- predefined type INTEGER is assumed if the type of both bounds
+ -- (prior the implicit conversion) is the type universal_integer.
+ null;
+ elsif Vhdl_Std = Vhdl_93c then
+ -- GHDL: this is not allowed, however often used:
+ -- eg: for i in 0 to v'length + 1 loop
+ -- eg: for i in -1 to 1 loop
+
+ -- Be tolerant.
+ Warning_Msg_Sem ("universal integer bound must be numeric literal "
+ & "or attribute", Res);
+ else
+ Error_Msg_Sem ("universal integer bound must be numeric literal "
+ & "or attribute", Res);
+ end if;
+ Set_Type (Res, Integer_Type_Definition);
+ end if;
+ return Res;
+ end Sem_Discrete_Range_Integer;
+
+ procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir)
+ is
+ Staticness : Iir_Staticness;
+ begin
+ -- LRM93 7.4.1 (Locally Static Primaries)
+ -- 4. a function call whose function name denotes an implicitly
+ -- defined operator, and whose actual parameters are each
+ -- locally static expressions;
+ --
+ -- LRM93 7.4.2 (Globally Static Primaries)
+ -- 9. a function call whose function name denotes a pure function,
+ -- and whose actual parameters are each globally static
+ -- expressions.
+ case Get_Kind (Expr) is
+ when Iir_Kinds_Monadic_Operator =>
+ Staticness := Get_Expr_Staticness (Get_Operand (Expr));
+ when Iir_Kinds_Dyadic_Operator =>
+ Staticness := Min (Get_Expr_Staticness (Get_Left (Expr)),
+ Get_Expr_Staticness (Get_Right (Expr)));
+ when Iir_Kind_Function_Call =>
+ Staticness := Locally;
+ declare
+ Assoc : Iir;
+ begin
+ Assoc := Get_Parameter_Association_Chain (Expr);
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_Open then
+ Staticness := Min
+ (Get_Expr_Staticness (Get_Actual (Assoc)),
+ Staticness);
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end;
+ when Iir_Kind_Procedure_Call =>
+ return;
+ when others =>
+ Error_Kind ("set_function_call_staticness (1)", Expr);
+ end case;
+ case Get_Kind (Imp) is
+ when Iir_Kind_Implicit_Function_Declaration =>
+ if Get_Implicit_Definition (Imp)
+ not in Iir_Predefined_Pure_Functions
+ then
+ -- Predefined functions such as Now, Endfile are not static.
+ Staticness := None;
+ end if;
+ when Iir_Kind_Function_Declaration =>
+ if Get_Pure_Flag (Imp) then
+ Staticness := Min (Staticness, Globally);
+ else
+ Staticness := None;
+ end if;
+ when others =>
+ Error_Kind ("set_function_call_staticness (2)", Imp);
+ end case;
+ Set_Expr_Staticness (Expr, Staticness);
+ end Set_Function_Call_Staticness;
+
+ -- Add CALLEE in the callees list of SUBPRG (which must be a subprg decl).
+ procedure Add_In_Callees_List (Subprg : Iir; Callee : Iir)
+ is
+ Holder : constant Iir := Get_Callees_List_Holder (Subprg);
+ List : Iir_List;
+ begin
+ List := Get_Callees_List (Holder);
+ if List = Null_Iir_List then
+ List := Create_Iir_List;
+ Set_Callees_List (Holder, List);
+ end if;
+ -- FIXME: May use a flag in IMP to speed up the
+ -- add operation.
+ Add_Element (List, Callee);
+ end Add_In_Callees_List;
+
+ -- Check purity rules when SUBPRG calls CALLEE.
+ -- Both SUBPRG and CALLEE are subprogram declarations.
+ -- Update purity_state/impure_depth of SUBPRG if it is a procedure.
+ procedure Sem_Call_Purity_Check (Subprg : Iir; Callee : Iir; Loc : Iir)
+ is
+ begin
+ if Callee = Subprg then
+ return;
+ end if;
+
+ -- Handle easy cases.
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ if not Get_Pure_Flag (Subprg) then
+ return;
+ end if;
+ when Iir_Kind_Procedure_Declaration =>
+ if Get_Purity_State (Subprg) = Impure then
+ return;
+ end if;
+ when Iir_Kinds_Process_Statement =>
+ return;
+ when others =>
+ Error_Kind ("sem_call_purity_check(0)", Subprg);
+ end case;
+
+ case Get_Kind (Callee) is
+ when Iir_Kind_Function_Declaration =>
+ if Get_Pure_Flag (Callee) then
+ -- Pure functions may be called anywhere.
+ return;
+ end if;
+ -- CALLEE is impure.
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ Error_Pure (Subprg, Callee, Loc);
+ when Iir_Kind_Procedure_Declaration =>
+ Set_Purity_State (Subprg, Impure);
+ when others =>
+ Error_Kind ("sem_call_purity_check(1)", Subprg);
+ end case;
+ when Iir_Kind_Procedure_Declaration =>
+ declare
+ Depth : Iir_Int32;
+ Callee_Body : Iir;
+ Subprg_Body : Iir;
+ begin
+ Callee_Body := Get_Subprogram_Body (Callee);
+ Subprg_Body := Get_Subprogram_Body (Subprg);
+ -- Get purity depth of callee, if possible.
+ case Get_Purity_State (Callee) is
+ when Pure =>
+ return;
+ when Impure =>
+ Depth := Iir_Depth_Impure;
+ when Maybe_Impure =>
+ if Callee_Body = Null_Iir then
+ -- Cannot be 'maybe_impure' if no body!
+ raise Internal_Error;
+ end if;
+ Depth := Get_Impure_Depth (Callee_Body);
+ when Unknown =>
+ -- Add in list.
+ Add_In_Callees_List (Subprg, Callee);
+
+ if Callee_Body /= Null_Iir then
+ Depth := Get_Impure_Depth (Callee_Body);
+ else
+ return;
+ end if;
+ end case;
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ if Depth = Iir_Depth_Impure then
+ Error_Pure (Subprg, Callee, Loc);
+ else
+ if Depth < Get_Subprogram_Depth (Subprg) then
+ Error_Pure (Subprg, Callee, Loc);
+ end if;
+ end if;
+ when Iir_Kind_Procedure_Declaration =>
+ if Depth = Iir_Depth_Impure then
+ Set_Purity_State (Subprg, Impure);
+ -- FIXME: free callee list ? (wait state).
+ else
+ -- Set depth to the worst.
+ if Depth < Get_Impure_Depth (Subprg_Body) then
+ Set_Impure_Depth (Subprg_Body, Depth);
+ end if;
+ end if;
+ when others =>
+ Error_Kind ("sem_call_purity_check(2)", Subprg);
+ end case;
+ end;
+ when others =>
+ Error_Kind ("sem_call_purity_check", Callee);
+ end case;
+ end Sem_Call_Purity_Check;
+
+ procedure Sem_Call_Wait_Check (Subprg : Iir; Callee : Iir; Loc : Iir)
+ is
+ procedure Error_Wait is
+ begin
+ Error_Msg_Sem
+ (Disp_Node (Subprg) & " must not contain wait statement, but calls",
+ Loc);
+ Error_Msg_Sem
+ (Disp_Node (Callee) & " which has (indirectly) a wait statement",
+ Callee);
+ --Error_Msg_Sem
+ -- ("(indirect) wait statement not allowed in " & Where, Loc);
+ end Error_Wait;
+ begin
+ pragma Assert (Get_Kind (Callee) = Iir_Kind_Procedure_Declaration);
+
+ case Get_Wait_State (Callee) is
+ when False =>
+ return;
+ when True =>
+ null;
+ when Unknown =>
+ Add_In_Callees_List (Subprg, Callee);
+ return;
+ end case;
+
+ -- LRM 8.1
+ -- It is an error if a wait statement appears [...] in a procedure that
+ -- has a parent that is a function subprogram.
+ --
+ -- Furthermore, it is an error if a wait statement appears [...] in a
+ -- procedure that has a parent that is such a process statement.
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Sensitized_Process_Statement =>
+ Error_Wait;
+ return;
+ when Iir_Kind_Process_Statement =>
+ return;
+ when Iir_Kind_Function_Declaration =>
+ Error_Wait;
+ return;
+ when Iir_Kind_Procedure_Declaration =>
+ if Is_Subprogram_Method (Subprg) then
+ Error_Wait;
+ else
+ Set_Wait_State (Subprg, True);
+ end if;
+ when others =>
+ Error_Kind ("sem_call_wait_check", Subprg);
+ end case;
+ end Sem_Call_Wait_Check;
+
+ procedure Sem_Call_All_Sensitized_Check
+ (Subprg : Iir; Callee : Iir; Loc : Iir)
+ is
+ begin
+ -- No need to deal with 'process (all)' if standard predates it.
+ if Vhdl_Std < Vhdl_08 then
+ return;
+ end if;
+
+ -- If subprogram called is pure, then there is no signals reference.
+ case Get_Kind (Callee) is
+ when Iir_Kind_Function_Declaration =>
+ if Get_Pure_Flag (Callee) then
+ return;
+ end if;
+ when Iir_Kind_Procedure_Declaration =>
+ if Get_Purity_State (Callee) = Pure then
+ return;
+ end if;
+ when others =>
+ Error_Kind ("sem_call_all_sensitized_check", Callee);
+ end case;
+
+ case Get_All_Sensitized_State (Callee) is
+ when Invalid_Signal =>
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Sensitized_Process_Statement =>
+ if Get_Sensitivity_List (Subprg) = Iir_List_All then
+ -- LRM08 11.3
+ --
+ -- It is an error if a process statement with the
+ -- reserved word ALL as its process sensitivity list
+ -- is the parent of a subprogram declared in a design
+ -- unit other than that containing the process statement
+ -- and the subprogram reads an explicitly declared
+ -- signal that is not a formal signal parameter or
+ -- member of a formal signal parameter of the
+ -- subprogram or of any of its parents. Similarly,
+ -- it is an error if such subprogram reads an implicit
+ -- signal whose explicit ancestor is not a formal signal
+ -- parameter or member of a formal parameter of
+ -- the subprogram or of any of its parents.
+ Error_Msg_Sem
+ ("all-sensitized " & Disp_Node (Subprg)
+ & " can't call " & Disp_Node (Callee), Loc);
+ Error_Msg_Sem
+ (" (as this subprogram reads (indirectly) a signal)",
+ Loc);
+ end if;
+ when Iir_Kind_Process_Statement =>
+ return;
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Set_All_Sensitized_State (Subprg, Invalid_Signal);
+ when others =>
+ Error_Kind ("sem_call_all_sensitized_check", Subprg);
+ end case;
+ when Read_Signal =>
+ -- Put this subprogram in callees list as it may read a signal.
+ -- Used by canon to build the sensitivity list.
+ Add_In_Callees_List (Subprg, Callee);
+ if Get_Kind (Subprg) in Iir_Kinds_Subprogram_Declaration then
+ if Get_All_Sensitized_State (Subprg) < Read_Signal then
+ Set_All_Sensitized_State (Subprg, Read_Signal);
+ end if;
+ end if;
+ when Unknown =>
+ -- Put this subprogram in callees list as it may read a signal.
+ -- Used by canon to build the sensitivity list.
+ Add_In_Callees_List (Subprg, Callee);
+ when No_Signal =>
+ null;
+ end case;
+ end Sem_Call_All_Sensitized_Check;
+
+ -- Set IMP as the implementation to being called by EXPR.
+ -- If the context is a subprogram or a process (ie, if current_subprogram
+ -- is not NULL), then mark IMP as callee of current_subprogram, and
+ -- update states.
+ procedure Sem_Subprogram_Call_Finish (Expr : Iir; Imp : Iir)
+ is
+ Subprg : constant Iir := Get_Current_Subprogram;
+ begin
+ Set_Function_Call_Staticness (Expr, Imp);
+ Mark_Subprogram_Used (Imp);
+
+ -- Check purity/wait/passive.
+
+ if Subprg = Null_Iir then
+ -- Not inside a suprogram or a process.
+ return;
+ end if;
+ if Subprg = Imp then
+ -- Recursive call.
+ return;
+ end if;
+
+ case Get_Kind (Imp) is
+ when Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ if Get_Implicit_Definition (Imp) in Iir_Predefined_Pure_Functions
+ then
+ return;
+ end if;
+ when Iir_Kind_Function_Declaration =>
+ Sem_Call_Purity_Check (Subprg, Imp, Expr);
+ Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr);
+ when Iir_Kind_Procedure_Declaration =>
+ Sem_Call_Purity_Check (Subprg, Imp, Expr);
+ Sem_Call_Wait_Check (Subprg, Imp, Expr);
+ Sem_Call_All_Sensitized_Check (Subprg, Imp, Expr);
+ -- Check passive.
+ if Get_Passive_Flag (Imp) = False then
+ case Get_Kind (Subprg) is
+ when Iir_Kinds_Process_Statement =>
+ if Get_Passive_Flag (Subprg) then
+ Error_Msg_Sem
+ (Disp_Node (Subprg)
+ & " is passive, but calls non-passive "
+ & Disp_Node (Imp), Expr);
+ end if;
+ when others =>
+ null;
+ end case;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Sem_Subprogram_Call_Finish;
+
+ -- EXPR is a function or procedure call.
+ function Sem_Subprogram_Call_Stage1
+ (Expr : Iir; A_Type : Iir; Is_Func_Call : Boolean)
+ return Iir
+ is
+ Imp : Iir;
+ Nbr_Inter: Natural;
+ A_Func: Iir;
+ Imp_List: Iir_List;
+ Assoc_Chain: Iir;
+ Inter_Chain : Iir;
+ Res_Type: Iir_List;
+ Inter: Iir;
+ Match : Boolean;
+ begin
+ -- Sem_Name has gathered all the possible names for the prefix of this
+ -- call. Reduce this list to only names that match the types.
+ Nbr_Inter := 0;
+ Imp := Get_Implementation (Expr);
+ Imp_List := Get_Overload_List (Imp);
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+
+ for I in Natural loop
+ A_Func := Get_Nth_Element (Imp_List, I);
+ exit when A_Func = Null_Iir;
+
+ case Get_Kind (A_Func) is
+ when Iir_Kinds_Functions_And_Literals =>
+ if not Is_Func_Call then
+ -- The identifier of a function call must be a function or
+ -- an enumeration literal.
+ goto Continue;
+ end if;
+ when Iir_Kinds_Procedure_Declaration =>
+ if Is_Func_Call then
+ -- The identifier of a procedure call must be a procedure.
+ goto Continue;
+ end if;
+ when others =>
+ Error_Kind ("sem_subprogram_call_stage1", A_Func);
+ end case;
+
+ -- Keep this interpretation only if compatible.
+ if A_Type = Null_Iir
+ or else Compatibility_Nodes (A_Type, Get_Return_Type (A_Func))
+ then
+ Sem_Association_Chain
+ (Get_Interface_Declaration_Chain (A_Func),
+ Assoc_Chain, False, Missing_Parameter, Expr, Match);
+ if Match then
+ Replace_Nth_Element (Imp_List, Nbr_Inter, A_Func);
+ Nbr_Inter := Nbr_Inter + 1;
+ end if;
+ end if;
+
+ << Continue >> null;
+ end loop;
+ Set_Nbr_Elements (Imp_List, Nbr_Inter);
+
+ -- Set_Implementation (Expr, Inter_List);
+ -- A set of possible functions to call is in INTER_LIST.
+ -- Create a set of possible return type in RES_TYPE.
+ case Nbr_Inter is
+ when 0 =>
+ -- FIXME: display subprogram name.
+ Error_Msg_Sem
+ ("cannot resolve overloading for subprogram call", Expr);
+ return Null_Iir;
+
+ when 1 =>
+ -- Simple case: no overloading.
+ Inter := Get_First_Element (Imp_List);
+ Free_Overload_List (Imp);
+ Set_Implementation (Expr, Inter);
+ if Is_Func_Call then
+ Set_Type (Expr, Get_Return_Type (Inter));
+ end if;
+ Inter_Chain := Get_Interface_Declaration_Chain (Inter);
+ Sem_Association_Chain
+ (Inter_Chain, Assoc_Chain,
+ True, Missing_Parameter, Expr, Match);
+ Set_Parameter_Association_Chain (Expr, Assoc_Chain);
+ if not Match then
+ raise Internal_Error;
+ end if;
+ Check_Subprogram_Associations (Inter_Chain, Assoc_Chain);
+ Sem_Subprogram_Call_Finish (Expr, Inter);
+ return Expr;
+
+ when others =>
+ if Is_Func_Call then
+ if A_Type /= Null_Iir then
+ -- Cannot find a single interpretation for a given
+ -- type.
+ Error_Overload (Expr);
+ Disp_Overload_List (Imp_List, Expr);
+ return Null_Iir;
+ end if;
+
+ -- Create the list of types for the result.
+ Res_Type := Create_Iir_List;
+ for I in 0 .. Nbr_Inter - 1 loop
+ Add_Element
+ (Res_Type,
+ Get_Return_Type (Get_Nth_Element (Imp_List, I)));
+ end loop;
+
+ if Get_Nbr_Elements (Res_Type) = 1 then
+ -- several implementations but one profile.
+ Error_Overload (Expr);
+ Disp_Overload_List (Imp_List, Expr);
+ return Null_Iir;
+ end if;
+ Set_Type (Expr, Create_Overload_List (Res_Type));
+ else
+ -- For a procedure call, the context does't help to resolve
+ -- overload.
+ Error_Overload (Expr);
+ Disp_Overload_List (Imp_List, Expr);
+ end if;
+ return Expr;
+ end case;
+ end Sem_Subprogram_Call_Stage1;
+
+ -- For a procedure call, A_TYPE must be null.
+ -- Associations must have already been semantized by sem_association_list.
+ function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir
+ is
+ Is_Func: constant Boolean := Get_Kind (Expr) = Iir_Kind_Function_Call;
+ Res_Type: Iir;
+ Res: Iir;
+ Inter_List: Iir;
+ Param_Chain : Iir;
+ Inter: Iir;
+ Assoc_Chain : Iir;
+ Match : Boolean;
+ begin
+ if Is_Func then
+ Res_Type := Get_Type (Expr);
+ end if;
+
+ if not Is_Func or else Res_Type = Null_Iir then
+ -- First call to sem_subprogram_call.
+ -- Create the list of possible implementations and possible
+ -- return types, according to arguments and A_TYPE.
+
+ -- Select possible interpretations among all interpretations.
+ -- NOTE: the list of possible implementations was already created
+ -- during the transformation of iir_kind_parenthesis_name to
+ -- iir_kind_function_call.
+ Inter_List := Get_Implementation (Expr);
+ if Get_Kind (Inter_List) = Iir_Kind_Error then
+ return Null_Iir;
+ elsif Is_Overload_List (Inter_List) then
+ -- Subprogram name is overloaded.
+ return Sem_Subprogram_Call_Stage1 (Expr, A_Type, Is_Func);
+ else
+ -- Only one interpretation for the subprogram name.
+ if Is_Func then
+ if Get_Kind (Inter_List) not in Iir_Kinds_Function_Declaration
+ then
+ Error_Msg_Sem ("name does not designate a function", Expr);
+ return Null_Iir;
+ end if;
+ else
+ if Get_Kind (Inter_List) not in Iir_Kinds_Procedure_Declaration
+ then
+ Error_Msg_Sem ("name does not designate a procedure", Expr);
+ return Null_Iir;
+ end if;
+ end if;
+
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ Param_Chain := Get_Interface_Declaration_Chain (Inter_List);
+ Sem_Association_Chain
+ (Param_Chain, Assoc_Chain,
+ True, Missing_Parameter, Expr, Match);
+ Set_Parameter_Association_Chain (Expr, Assoc_Chain);
+ if not Match then
+ -- No need to disp an error message, this is done by
+ -- sem_subprogram_arguments.
+ return Null_Iir;
+ end if;
+ if Is_Func then
+ Set_Type (Expr, Get_Return_Type (Inter_List));
+ end if;
+ Check_Subprogram_Associations (Param_Chain, Assoc_Chain);
+ Set_Implementation (Expr, Inter_List);
+ Sem_Subprogram_Call_Finish (Expr, Inter_List);
+ return Expr;
+ end if;
+ end if;
+
+ -- Second call to Sem_Function_Call (only for functions).
+ pragma Assert (Is_Func);
+ pragma Assert (A_Type /= Null_Iir);
+
+ -- The implementation list was set.
+ -- The return type was set.
+ -- A_TYPE is not null, A_TYPE is *the* return type.
+
+ Inter_List := Get_Implementation (Expr);
+
+ -- Find a single implementation.
+ Res := Null_Iir;
+ if Is_Overload_List (Inter_List) then
+ -- INTER_LIST is a list of possible declaration to call.
+ -- Find one, based on the return type A_TYPE.
+ for I in Natural loop
+ Inter := Get_Nth_Element (Get_Overload_List (Inter_List), I);
+ exit when Inter = Null_Iir;
+ if Are_Basetypes_Compatible
+ (A_Type, Get_Base_Type (Get_Return_Type (Inter)))
+ then
+ if Res /= Null_Iir then
+ Error_Overload (Expr);
+ Disp_Overload_List (Get_Overload_List (Inter_List), Expr);
+ return Null_Iir;
+ else
+ Res := Inter;
+ end if;
+ end if;
+ end loop;
+ else
+ if Are_Basetypes_Compatible
+ (A_Type, Get_Base_Type (Get_Return_Type (Inter_List)))
+ then
+ Res := Inter_List;
+ end if;
+ end if;
+ if Res = Null_Iir then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+
+ -- Clean up.
+ if Res_Type /= Null_Iir and then Is_Overload_List (Res_Type) then
+ Free_Iir (Res_Type);
+ end if;
+
+ if Is_Overload_List (Inter_List) then
+ Free_Iir (Inter_List);
+ end if;
+
+ -- Simple case: this is not a call to a function, but an enumeration
+ -- literal.
+ if Get_Kind (Res) = Iir_Kind_Enumeration_Literal then
+ -- Free_Iir (Expr);
+ return Res;
+ end if;
+
+ -- Set types.
+ Set_Type (Expr, Get_Return_Type (Res));
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ Param_Chain := Get_Interface_Declaration_Chain (Res);
+ Sem_Association_Chain
+ (Param_Chain, Assoc_Chain, True, Missing_Parameter, Expr, Match);
+ Set_Parameter_Association_Chain (Expr, Assoc_Chain);
+ if not Match then
+ return Null_Iir;
+ end if;
+ Check_Subprogram_Associations (Param_Chain, Assoc_Chain);
+ Set_Implementation (Expr, Res);
+ Sem_Subprogram_Call_Finish (Expr, Res);
+ return Expr;
+ end Sem_Subprogram_Call;
+
+ procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir)
+ is
+ Imp: Iir;
+ Name : Iir;
+ Parameters_Chain : Iir;
+ Param : Iir;
+ Formal : Iir;
+ Prefix : Iir;
+ Inter : Iir;
+ begin
+ Name := Get_Prefix (Call);
+ -- FIXME: check for denoting name.
+ Sem_Name (Name);
+
+ -- Return now if the procedure declaration wasn't found.
+ Imp := Get_Named_Entity (Name);
+ if Is_Error (Imp) then
+ return;
+ end if;
+ Set_Implementation (Call, Imp);
+
+ Name_To_Method_Object (Call, Name);
+ Parameters_Chain := Get_Parameter_Association_Chain (Call);
+ if Sem_Actual_Of_Association_Chain (Parameters_Chain) = False then
+ return;
+ end if;
+ if Sem_Subprogram_Call (Call, Null_Iir) /= Call then
+ return;
+ end if;
+ Imp := Get_Implementation (Call);
+ if Is_Overload_List (Imp) then
+ -- Failed to resolve overload.
+ return;
+ end if;
+ Set_Named_Entity (Name, Imp);
+ Set_Prefix (Call, Finish_Sem_Name (Name));
+
+ -- LRM 2.1.1.2 Signal Parameters
+ -- A process statement contains a driver for each actual signal
+ -- associated with a formal signal parameter of mode OUT or INOUT in
+ -- a subprogram call.
+ -- Similarly, a subprogram contains a driver for each formal signal
+ -- parameter of mode OUT or INOUT declared in its subrogram
+ -- specification.
+ Param := Parameters_Chain;
+ Inter := Get_Interface_Declaration_Chain (Imp);
+ while Param /= Null_Iir loop
+ Formal := Get_Formal (Param);
+ if Formal = Null_Iir then
+ Formal := Inter;
+ Inter := Get_Chain (Inter);
+ else
+ Formal := Get_Base_Name (Formal);
+ Inter := Null_Iir;
+ end if;
+ if Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration
+ and then Get_Mode (Formal) in Iir_Out_Modes
+ then
+ Prefix := Name_To_Object (Get_Actual (Param));
+ if Prefix /= Null_Iir then
+ case Get_Kind (Get_Object_Prefix (Prefix)) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Prefix := Get_Longuest_Static_Prefix (Prefix);
+ Sem_Stmts.Sem_Add_Driver (Prefix, Stmt);
+ when others =>
+ null;
+ end case;
+ end if;
+ end if;
+ Param := Get_Chain (Param);
+ end loop;
+ end Sem_Procedure_Call;
+
+ -- List must be an overload list containing subprograms declarations.
+ -- Try to resolve overload and return the uniq interpretation if one,
+ -- NULL_IIR otherwise.
+ --
+ -- If there are two functions, one primitive of a universal
+ -- type and the other not, return the primitive of the universal type.
+ -- This rule is *not* from LRM (but from Ada) and allows to resolve
+ -- common cases such as:
+ -- constant c1 : integer := - 4; -- or '+', 'abs'
+ -- constant c2 : integer := 2 ** 3;
+ -- constant c3 : integer := 3 - 2; -- or '+', '*', '/'...
+ function Get_Non_Implicit_Subprogram (List : Iir_List) return Iir
+ is
+ El : Iir;
+ Res : Iir;
+ Ref_Type : Iir;
+ begin
+ -- Conditions:
+ -- 1. All the possible functions must return boolean.
+ -- 2. There is only one implicit function for universal or real.
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Get_Base_Type (Get_Return_Type (El)) /= Boolean_Type_Definition
+ then
+ return Null_Iir;
+ end if;
+
+ if Get_Kind (El) = Iir_Kind_Implicit_Function_Declaration then
+ Ref_Type := Get_Type_Reference (El);
+ if Ref_Type = Universal_Integer_Type_Declaration
+ or Ref_Type = Universal_Real_Type_Declaration
+ then
+ if Res = Null_Iir then
+ Res := El;
+ else
+ return Null_Iir;
+ end if;
+ end if;
+ end if;
+ end loop;
+ return Res;
+ end Get_Non_Implicit_Subprogram;
+
+ -- Honor the -fexplicit flag.
+ -- If LIST is composed of 2 declarations that matches the 'explicit' rule,
+ -- return the explicit declaration.
+ -- Otherwise, return NULL_IIR.
+ function Get_Explicit_Subprogram (List : Iir_List) return Iir
+ is
+ Sub1 : Iir;
+ Sub2 : Iir;
+ Res : Iir;
+ begin
+ if Get_Nbr_Elements (List) /= 2 then
+ return Null_Iir;
+ end if;
+
+ Sub1 := Get_Nth_Element (List, 0);
+ Sub2 := Get_Nth_Element (List, 1);
+
+ -- One must be an implicit declaration, the other must be an explicit
+ -- declaration.
+ if Get_Kind (Sub1) = Iir_Kind_Implicit_Function_Declaration then
+ if Get_Kind (Sub2) /= Iir_Kind_Function_Declaration then
+ return Null_Iir;
+ end if;
+ Res := Sub2;
+ elsif Get_Kind (Sub1) = Iir_Kind_Function_Declaration then
+ if Get_Kind (Sub2) /= Iir_Kind_Implicit_Function_Declaration then
+ return Null_Iir;
+ end if;
+ Res := Sub1;
+ else
+ Error_Kind ("get_explicit_subprogram", Sub1);
+ end if;
+
+ -- They must have the same profile.
+ if Get_Subprogram_Hash (Sub1) /= Get_Subprogram_Hash (Sub2)
+ or else not Is_Same_Profile (Sub1, Sub2)
+ then
+ return Null_Iir;
+ end if;
+
+ -- They must be declared in a package.
+ if Get_Kind (Get_Parent (Sub1)) /= Iir_Kind_Package_Declaration
+ or else Get_Kind (Get_Parent (Sub2)) /= Iir_Kind_Package_Declaration
+ then
+ return Null_Iir;
+ end if;
+
+ return Res;
+ end Get_Explicit_Subprogram;
+
+ -- Set when the -fexplicit option was adviced.
+ Explicit_Advice_Given : Boolean := False;
+
+ function Sem_Operator (Expr : Iir; Res_Type : Iir; Arity : Positive)
+ return Iir
+ is
+ Operator : Name_Id;
+ Left, Right: Iir;
+ Interpretation : Name_Interpretation_Type;
+ Decl : Iir;
+ Overload_List : Iir_List;
+ Overload : Iir;
+ Res_Type_List : Iir;
+ Full_Compat : Iir;
+
+ -- LEFT and RIGHT must be set.
+ function Set_Uniq_Interpretation (Decl : Iir) return Iir
+ is
+ Interface_Chain : Iir;
+ Err : Boolean;
+ begin
+ Set_Type (Expr, Get_Return_Type (Decl));
+ Interface_Chain := Get_Interface_Declaration_Chain (Decl);
+ Err := False;
+ if Is_Overloaded (Left) then
+ Left := Sem_Expression_Ov
+ (Left, Get_Base_Type (Get_Type (Interface_Chain)));
+ if Left = Null_Iir then
+ Err := True;
+ else
+ if Arity = 1 then
+ Set_Operand (Expr, Left);
+ else
+ Set_Left (Expr, Left);
+ end if;
+ end if;
+ end if;
+ Check_Read (Left);
+ if Arity = 2 then
+ if Is_Overloaded (Right) then
+ Right := Sem_Expression_Ov
+ (Right,
+ Get_Base_Type (Get_Type (Get_Chain (Interface_Chain))));
+ if Right = Null_Iir then
+ Err := True;
+ else
+ Set_Right (Expr, Right);
+ end if;
+ end if;
+ Check_Read (Right);
+ end if;
+ Destroy_Iir_List (Overload_List);
+ if not Err then
+ Set_Implementation (Expr, Decl);
+ Sem_Subprogram_Call_Finish (Expr, Decl);
+ return Eval_Expr_If_Static (Expr);
+ else
+ return Expr;
+ end if;
+ end Set_Uniq_Interpretation;
+
+ -- Note: operator and implementation node of expr must be set.
+ procedure Error_Operator_Overload (List : Iir_List) is
+ begin
+ Error_Msg_Sem ("operator """ & Name_Table.Image (Operator)
+ & """ is overloaded", Expr);
+ Disp_Overload_List (List, Expr);
+ end Error_Operator_Overload;
+
+ Interface_Chain : Iir;
+ begin
+ if Arity = 1 then
+ Left := Get_Operand (Expr);
+ Right := Null_Iir;
+ else
+ Left := Get_Left (Expr);
+ Right := Get_Right (Expr);
+ end if;
+ Operator := Iirs_Utils.Get_Operator_Name (Expr);
+
+ if Get_Type (Expr) = Null_Iir then
+ -- First pass.
+ -- Semantize operands.
+ -- FIXME: should try to semantize right operand even if semantization
+ -- of left operand has failed ??
+ if Get_Type (Left) = Null_Iir then
+ Left := Sem_Expression_Ov (Left, Null_Iir);
+ if Left = Null_Iir then
+ return Null_Iir;
+ end if;
+ if Arity = 1 then
+ Set_Operand (Expr, Left);
+ else
+ Set_Left (Expr, Left);
+ end if;
+ end if;
+ if Arity = 2 and then Get_Type (Right) = Null_Iir then
+ Right := Sem_Expression_Ov (Right, Null_Iir);
+ if Right = Null_Iir then
+ return Null_Iir;
+ end if;
+ Set_Right (Expr, Right);
+ end if;
+
+ Overload_List := Create_Iir_List;
+
+ -- Try to find an implementation among user defined function
+ Interpretation := Get_Interpretation (Operator);
+ while Valid_Interpretation (Interpretation) loop
+ Decl := Get_Non_Alias_Declaration (Interpretation);
+
+ -- It is compatible with operand types ?
+ if Get_Kind (Decl) not in Iir_Kinds_Function_Declaration then
+ raise Internal_Error;
+ end if;
+
+ -- LRM08 12.3 Visibility
+ -- [...] or all visible declarations denote the same named entity.
+ --
+ -- GHDL: If DECL has already been seen, then skip it.
+ if Get_Seen_Flag (Decl) then
+ goto Next;
+ end if;
+
+ -- Check return type.
+ if Res_Type /= Null_Iir
+ and then
+ not Are_Types_Compatible (Res_Type, Get_Return_Type (Decl))
+ then
+ goto Next;
+ end if;
+
+ Interface_Chain := Get_Interface_Declaration_Chain (Decl);
+
+ -- Check arity.
+
+ -- LRM93 2.5.2 Operator overloading
+ -- The subprogram specification of a unary operator must have
+ -- a single parameter [...]
+ -- The subprogram specification of a binary operator must have
+ -- two parameters [...]
+ --
+ -- GHDL: So even in presence of default expression in a parameter,
+ -- a unary operation has to match with a binary operator.
+ if Iir_Chains.Get_Chain_Length (Interface_Chain) /= Arity then
+ goto Next;
+ end if;
+
+ -- Check operands.
+ if not Is_Expr_Compatible (Get_Type (Interface_Chain), Left) then
+ goto Next;
+ end if;
+ if Arity = 2 then
+ if not Is_Expr_Compatible
+ (Get_Type (Get_Chain (Interface_Chain)), Right)
+ then
+ goto Next;
+ end if;
+ end if;
+
+ -- Match.
+ Set_Seen_Flag (Decl, True);
+ Append_Element (Overload_List, Decl);
+
+ << Next >> null;
+ Interpretation := Get_Next_Interpretation (Interpretation);
+ end loop;
+
+ -- Clear seen_flags.
+ for I in Natural loop
+ Decl := Get_Nth_Element (Overload_List, I);
+ exit when Decl = Null_Iir;
+ Set_Seen_Flag (Decl, False);
+ end loop;
+
+ -- The list of possible implementations was computed.
+ case Get_Nbr_Elements (Overload_List) is
+ when 0 =>
+ Error_Msg_Sem
+ ("no function declarations for " & Disp_Node (Expr), Expr);
+ Destroy_Iir_List (Overload_List);
+ return Null_Iir;
+
+ when 1 =>
+ Decl := Get_First_Element (Overload_List);
+ return Set_Uniq_Interpretation (Decl);
+
+ when others =>
+ -- Preference for universal operator.
+ -- This roughly corresponds to:
+ --
+ -- LRM 7.3.5
+ -- An implicit conversion of a convertible universal operand
+ -- is applied if and only if the innermost complete context
+ -- determines a unique (numeric) target type for the implicit
+ -- conversion, and there is no legal interpretation of this
+ -- context without this conversion.
+ if Arity = 2 then
+ Decl := Get_Non_Implicit_Subprogram (Overload_List);
+ if Decl /= Null_Iir then
+ return Set_Uniq_Interpretation (Decl);
+ end if;
+ end if;
+
+ Set_Implementation (Expr, Create_Overload_List (Overload_List));
+
+ -- Create the list of possible return types, if it is not yet
+ -- determined.
+ if Res_Type = Null_Iir then
+ Res_Type_List := Create_List_Of_Types (Overload_List);
+ if Is_Overload_List (Res_Type_List) then
+ -- There are many possible return types.
+ -- Try again.
+ Set_Type (Expr, Res_Type_List);
+ return Expr;
+ end if;
+ end if;
+
+ -- The return type is known.
+ -- Search for explicit subprogram.
+
+ -- It was impossible to find one solution.
+ Error_Operator_Overload (Overload_List);
+
+ -- Give an advice.
+ if not Flags.Flag_Explicit
+ and then not Explicit_Advice_Given
+ and then Flags.Vhdl_Std < Vhdl_08
+ then
+ Decl := Get_Explicit_Subprogram (Overload_List);
+ if Decl /= Null_Iir then
+ Error_Msg_Sem
+ ("(you may want to use the -fexplicit option)", Expr);
+ Explicit_Advice_Given := True;
+ end if;
+ end if;
+
+ return Null_Iir;
+ end case;
+ else
+ -- Second pass
+ -- Find the uniq implementation for this call.
+ Overload := Get_Implementation (Expr);
+ Overload_List := Get_Overload_List (Overload);
+ Full_Compat := Null_Iir;
+ for I in Natural loop
+ Decl := Get_Nth_Element (Overload_List, I);
+ exit when Decl = Null_Iir;
+ -- FIXME: wrong: compatibilty with return type and args.
+ if Are_Types_Compatible (Get_Return_Type (Decl), Res_Type) then
+ if Full_Compat /= Null_Iir then
+ Error_Operator_Overload (Overload_List);
+ return Null_Iir;
+ else
+ Full_Compat := Decl;
+ end if;
+ end if;
+ end loop;
+ Free_Iir (Overload);
+ Overload := Get_Type (Expr);
+ Free_Overload_List (Overload);
+ return Set_Uniq_Interpretation (Full_Compat);
+ end if;
+ end Sem_Operator;
+
+ -- Semantize LIT whose elements must be of type EL_TYPE, and return
+ -- the length.
+ -- FIXME: the errors are reported, but there is no mark of that.
+ function Sem_String_Literal (Lit: Iir; El_Type : Iir) return Natural
+ is
+ function Find_Literal (Etype : Iir_Enumeration_Type_Definition;
+ C : Character)
+ return Iir_Enumeration_Literal
+ is
+ Inter : Name_Interpretation_Type;
+ Id : Name_Id;
+ Decl : Iir;
+ begin
+ Id := Name_Table.Get_Identifier (C);
+ Inter := Get_Interpretation (Id);
+ while Valid_Interpretation (Inter) loop
+ Decl := Get_Declaration (Inter);
+ if Get_Kind (Decl) = Iir_Kind_Enumeration_Literal
+ and then Get_Type (Decl) = Etype
+ then
+ return Decl;
+ end if;
+ Inter := Get_Next_Interpretation (Inter);
+ end loop;
+ -- Character C is not visible...
+ if Find_Name_In_List (Get_Enumeration_Literal_List (Etype), Id)
+ = Null_Iir
+ then
+ -- ... because it is not defined.
+ Error_Msg_Sem
+ ("type " & Disp_Node (Etype) & " does not define character '"
+ & C & "'", Lit);
+ else
+ -- ... because it is not visible.
+ Error_Msg_Sem ("character '" & C & "' of type "
+ & Disp_Node (Etype) & " is not visible", Lit);
+ end if;
+ return Null_Iir;
+ end Find_Literal;
+
+ Ptr : String_Fat_Acc;
+ El : Iir;
+ pragma Unreferenced (El);
+ Len : Nat32;
+ begin
+ Len := Get_String_Length (Lit);
+
+ if Get_Kind (Lit) = Iir_Kind_Bit_String_Literal then
+ Set_Bit_String_0 (Lit, Find_Literal (El_Type, '0'));
+ Set_Bit_String_1 (Lit, Find_Literal (El_Type, '1'));
+ else
+ Ptr := Get_String_Fat_Acc (Lit);
+
+ -- For a string_literal, check all characters of the string is a
+ -- literal of the type.
+ -- Always check, for visibility.
+ for I in 1 .. Len loop
+ El := Find_Literal (El_Type, Ptr (I));
+ end loop;
+ end if;
+
+ Set_Expr_Staticness (Lit, Locally);
+
+ return Natural (Len);
+ end Sem_String_Literal;
+
+ procedure Sem_String_Literal (Lit: Iir)
+ is
+ Lit_Type : constant Iir := Get_Type (Lit);
+ Lit_Base_Type : constant Iir := Get_Base_Type (Lit_Type);
+
+ -- The subtype created for the literal.
+ N_Type: Iir;
+ -- type of the index of the array type.
+ Index_Type: Iir;
+ Len : Natural;
+ El_Type : Iir;
+ begin
+ El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type));
+ Len := Sem_String_Literal (Lit, El_Type);
+
+ if Get_Constraint_State (Lit_Type) = Fully_Constrained then
+ -- The type of the context is constrained.
+ Index_Type := Get_Index_Type (Lit_Type, 0);
+ if Get_Type_Staticness (Index_Type) = Locally then
+ if Eval_Discrete_Type_Length (Index_Type) /= Iir_Int64 (Len) then
+ Error_Msg_Sem ("string length does not match that of "
+ & Disp_Node (Index_Type), Lit);
+ end if;
+ else
+ -- FIXME: emit a warning because of dubious construct (the type
+ -- of the string is not locally constrained) ?
+ null;
+ end if;
+ else
+ -- Context type is not constained. Set type of the string literal,
+ -- according to LRM93 7.3.2.2.
+ N_Type := Create_Unidim_Array_By_Length
+ (Lit_Base_Type, Iir_Int64 (Len), Lit);
+ Set_Type (Lit, N_Type);
+ Set_Literal_Subtype (Lit, N_Type);
+ end if;
+ end Sem_String_Literal;
+
+ generic
+ -- Compare two elements, return true iff OP1 < OP2.
+ with function Lt (Op1, Op2 : Natural) return Boolean;
+
+ -- Swap two elements.
+ with procedure Swap (From : Natural; To : Natural);
+ package Heap_Sort is
+ -- Heap sort the N elements.
+ procedure Sort (N : Natural);
+ end Heap_Sort;
+
+ package body Heap_Sort is
+ -- An heap is an almost complete binary tree whose each edge is less
+ -- than or equal as its decendent.
+
+ -- Bubble down element I of a partially ordered heap of length N in
+ -- array ARR.
+ procedure Bubble_Down (I, N : Natural)
+ is
+ Child : Natural;
+ Parent : Natural := I;
+ begin
+ loop
+ Child := 2 * Parent;
+ if Child < N and then Lt (Child, Child + 1) then
+ Child := Child + 1;
+ end if;
+ exit when Child > N;
+ exit when not Lt (Parent, Child);
+ Swap (Parent, Child);
+ Parent := Child;
+ end loop;
+ end Bubble_Down;
+
+ -- Heap sort of ARR.
+ procedure Sort (N : Natural)
+ is
+ begin
+ -- Heapify
+ for I in reverse 1 .. N / 2 loop
+ Bubble_Down (I, N);
+ end loop;
+
+ -- Sort
+ for I in reverse 2 .. N loop
+ Swap (1, I);
+ Bubble_Down (1, I - 1);
+ end loop;
+ end Sort;
+ end Heap_Sort;
+
+ procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir)
+ is
+ -- True if others choice is present.
+ Has_Others : Boolean;
+
+ -- Number of simple choices.
+ Nbr_Choices : Natural;
+
+ -- Type of SEL.
+ Sel_Type : Iir;
+
+ -- Type of the element of SEL.
+ Sel_El_Type : Iir;
+ -- Number of literals in the element type.
+ Sel_El_Length : Iir_Int64;
+
+ -- Length of SEL (number of characters in SEL).
+ Sel_Length : Iir_Int64;
+
+ -- Array of choices.
+ Arr : Iir_Array_Acc;
+ Index : Natural;
+
+ -- True if length of a choice mismatches
+ Has_Length_Error : Boolean := False;
+
+ El : Iir;
+
+ -- Compare two elements of ARR.
+ -- Return true iff OP1 < OP2.
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)),
+ Get_Choice_Expression (Arr (Op2)))
+ = Compare_Lt;
+ end Lt;
+
+ function Eq (Op1, Op2 : Natural) return Boolean is
+ begin
+ return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)),
+ Get_Choice_Expression (Arr (Op2)))
+ = Compare_Eq;
+ end Eq;
+
+ procedure Swap (From : Natural; To : Natural)
+ is
+ Tmp : Iir;
+ begin
+ Tmp := Arr (To);
+ Arr (To) := Arr (From);
+ Arr (From) := Tmp;
+ end Swap;
+
+ package Str_Heap_Sort is new Heap_Sort (Lt => Lt, Swap => Swap);
+
+ procedure Sem_Simple_Choice (Choice : Iir)
+ is
+ Expr : Iir;
+ begin
+ -- LRM93 8.8
+ -- In such case, each choice appearing in any of the case statement
+ -- alternative must be a locally static expression whose value is of
+ -- the same length as that of the case expression.
+ Expr := Sem_Expression (Get_Choice_Expression (Choice), Sel_Type);
+ if Expr = Null_Iir then
+ Has_Length_Error := True;
+ return;
+ end if;
+ Set_Choice_Expression (Choice, Expr);
+ if Get_Expr_Staticness (Expr) < Locally then
+ Error_Msg_Sem ("choice must be locally static expression", Expr);
+ Has_Length_Error := True;
+ return;
+ end if;
+ Expr := Eval_Expr (Expr);
+ Set_Choice_Expression (Choice, Expr);
+ if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then
+ Error_Msg_Sem
+ ("bound error during evaluation of choice expression", Expr);
+ Has_Length_Error := True;
+ elsif Eval_Discrete_Type_Length
+ (Get_String_Type_Bound_Type (Get_Type (Expr))) /= Sel_Length
+ then
+ Has_Length_Error := True;
+ Error_Msg_Sem
+ ("value not of the same length of the case expression", Expr);
+ return;
+ end if;
+ end Sem_Simple_Choice;
+ begin
+ -- LRM93 8.8
+ -- If the expression is of one-dimensional character array type, then
+ -- the expression must be one of the following:
+ -- FIXME: to complete.
+ Sel_Type := Get_Type (Sel);
+ if not Is_One_Dimensional_Array_Type (Sel_Type) then
+ Error_Msg_Sem
+ ("expression must be discrete or one-dimension array subtype", Sel);
+ return;
+ end if;
+ if Get_Type_Staticness (Sel_Type) /= Locally then
+ Error_Msg_Sem ("array type must be locally static", Sel);
+ return;
+ end if;
+ Sel_Length := Eval_Discrete_Type_Length
+ (Get_String_Type_Bound_Type (Sel_Type));
+ Sel_El_Type := Get_Element_Subtype (Sel_Type);
+ Sel_El_Length := Eval_Discrete_Type_Length (Sel_El_Type);
+
+ Has_Others := False;
+ Nbr_Choices := 0;
+ El := Choice_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ raise Internal_Error;
+ when Iir_Kind_Choice_By_Range =>
+ Error_Msg_Sem
+ ("range choice are not allowed for non-discrete type", El);
+ when Iir_Kind_Choice_By_Expression =>
+ Nbr_Choices := Nbr_Choices + 1;
+ Sem_Simple_Choice (El);
+ when Iir_Kind_Choice_By_Others =>
+ if Has_Others then
+ Error_Msg_Sem ("duplicate others choice", El);
+ elsif Get_Chain (El) /= Null_Iir then
+ Error_Msg_Sem
+ ("choice others must be the last alternative", El);
+ end if;
+ Has_Others := True;
+ when others =>
+ Error_Kind ("sem_string_choices_range", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ -- Null choices.
+ if Sel_Length = 0 then
+ return;
+ end if;
+ if Has_Length_Error then
+ return;
+ end if;
+
+ -- LRM 8.8
+ --
+ -- If the expression is the name of an object whose subtype is locally
+ -- static, wether a scalar type or an array type, then each value of the
+ -- subtype must be represented once and only once in the set of choices
+ -- of the case statement and no other value is allowed; [...]
+
+ -- 1. Allocate Arr and fill it
+ Arr := new Iir_Array (1 .. Nbr_Choices);
+ Index := 0;
+ El := Choice_Chain;
+ while El /= Null_Iir loop
+ if Get_Kind (El) = Iir_Kind_Choice_By_Expression then
+ Index := Index + 1;
+ Arr (Index) := El;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ -- 2. Sort Arr
+ Str_Heap_Sort.Sort (Nbr_Choices);
+
+ -- 3. Check for duplicate choices
+ for I in 1 .. Nbr_Choices - 1 loop
+ if Eq (I, I + 1) then
+ Error_Msg_Sem ("duplicate choice with choice at " &
+ Disp_Location (Arr (I + 1)),
+ Arr (I));
+ exit;
+ end if;
+ end loop;
+
+ -- 4. Free Arr
+ Free (Arr);
+
+ -- Check for missing choice.
+ -- Do not try to compute the expected number of choices as this can
+ -- easily overflow.
+ if not Has_Others then
+ declare
+ Nbr : Iir_Int64 := Iir_Int64 (Nbr_Choices);
+ begin
+ for I in 1 .. Sel_Length loop
+ Nbr := Nbr / Sel_El_Length;
+ if Nbr = 0 then
+ Error_Msg_Sem ("missing choice(s)", Choice_Chain);
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+ end Sem_String_Choices_Range;
+
+ procedure Sem_Choices_Range
+ (Choice_Chain : in out Iir;
+ Sub_Type : Iir;
+ Is_Sub_Range : Boolean;
+ Is_Case_Stmt : Boolean;
+ Loc : Location_Type;
+ Low : out Iir;
+ High : out Iir)
+ is
+ -- Number of positionnal choice.
+ Nbr_Pos : Iir_Int64;
+
+ -- Number of named choices.
+ Nbr_Named : Natural;
+
+ -- True if others choice is present.
+ Has_Others : Boolean;
+
+ Has_Error : Boolean;
+
+ -- True if SUB_TYPE has bounds.
+ Type_Has_Bounds : Boolean;
+
+ Arr : Iir_Array_Acc;
+ Index : Natural;
+ Pos_Max : Iir_Int64;
+ El : Iir;
+ Prev_El : Iir;
+
+ -- Staticness of the current choice.
+ Choice_Staticness : Iir_Staticness;
+
+ -- Staticness of all the choices.
+ Staticness : Iir_Staticness;
+
+ function Replace_By_Range_Choice (Name : Iir; Range_Type : Iir)
+ return Boolean
+ is
+ N_Choice : Iir;
+ Name1 : Iir;
+ begin
+ if not Are_Types_Compatible (Range_Type, Sub_Type) then
+ Not_Match (Name, Sub_Type);
+ return False;
+ end if;
+
+ Name1 := Finish_Sem_Name (Name);
+ N_Choice := Create_Iir (Iir_Kind_Choice_By_Range);
+ Location_Copy (N_Choice, El);
+ Set_Chain (N_Choice, Get_Chain (El));
+ Set_Associated_Expr (N_Choice, Get_Associated_Expr (El));
+ Set_Associated_Chain (N_Choice, Get_Associated_Chain (El));
+ Set_Same_Alternative_Flag (N_Choice, Get_Same_Alternative_Flag (El));
+ Set_Choice_Range (N_Choice, Eval_Range_If_Static (Name1));
+ Set_Choice_Staticness (N_Choice, Get_Type_Staticness (Range_Type));
+ Free_Iir (El);
+
+ if Prev_El = Null_Iir then
+ Choice_Chain := N_Choice;
+ else
+ Set_Chain (Prev_El, N_Choice);
+ end if;
+ El := N_Choice;
+
+ return True;
+ end Replace_By_Range_Choice;
+
+ -- Semantize a simple (by expression or by range) choice.
+ -- Return FALSE in case of error.
+ function Sem_Simple_Choice return Boolean
+ is
+ Expr : Iir;
+ Ent : Iir;
+ begin
+ if Get_Kind (El) = Iir_Kind_Choice_By_Range then
+ Expr := Get_Choice_Range (El);
+ Expr := Sem_Discrete_Range_Expression (Expr, Sub_Type, True);
+ if Expr = Null_Iir then
+ return False;
+ end if;
+ Expr := Eval_Range_If_Static (Expr);
+ Set_Choice_Range (El, Expr);
+ else
+ Expr := Get_Choice_Expression (El);
+ case Get_Kind (Expr) is
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Attribute_Name =>
+ Sem_Name (Expr);
+ Ent := Get_Named_Entity (Expr);
+ if Ent = Error_Mark then
+ return False;
+ end if;
+
+ -- So range or expression ?
+ -- FIXME: share code with sem_name for slice/index.
+ case Get_Kind (Ent) is
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Range_Expression =>
+ return Replace_By_Range_Choice (Expr, Ent);
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration =>
+ Ent := Is_Type_Name (Expr);
+ Set_Expr_Staticness (Expr, Get_Type_Staticness (Ent));
+ return Replace_By_Range_Choice (Expr, Ent);
+ when others =>
+ Expr := Name_To_Expression
+ (Expr, Get_Base_Type (Sub_Type));
+ end case;
+ when others =>
+ Expr := Sem_Expression_Ov (Expr, Get_Base_Type (Sub_Type));
+ end case;
+ if Expr = Null_Iir then
+ return False;
+ end if;
+ Expr := Eval_Expr_If_Static (Expr);
+ Set_Choice_Expression (El, Expr);
+ end if;
+ Set_Choice_Staticness (El, Get_Expr_Staticness (Expr));
+ return True;
+ end Sem_Simple_Choice;
+
+ -- Get low limit of ASSOC.
+ -- First, get the expression of the association, then the low limit.
+ -- ASSOC may be either association_by_range (in this case the low limit
+ -- is to be fetched), or association_by_expression (and the low limit
+ -- is the expression).
+ function Get_Low (Assoc : Iir) return Iir
+ is
+ Expr : Iir;
+ begin
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_Expression =>
+ return Get_Choice_Expression (Assoc);
+ when Iir_Kind_Choice_By_Range =>
+ Expr := Get_Choice_Range (Assoc);
+ case Get_Kind (Expr) is
+ when Iir_Kind_Range_Expression =>
+ case Get_Direction (Expr) is
+ when Iir_To =>
+ return Get_Left_Limit (Expr);
+ when Iir_Downto =>
+ return Get_Right_Limit (Expr);
+ end case;
+ when others =>
+ return Expr;
+ end case;
+ when others =>
+ Error_Kind ("get_low", Assoc);
+ end case;
+ end Get_Low;
+
+ function Get_High (Assoc : Iir) return Iir
+ is
+ Expr : Iir;
+ begin
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_Expression =>
+ return Get_Choice_Expression (Assoc);
+ when Iir_Kind_Choice_By_Range =>
+ Expr := Get_Choice_Range (Assoc);
+ case Get_Kind (Expr) is
+ when Iir_Kind_Range_Expression =>
+ case Get_Direction (Expr) is
+ when Iir_To =>
+ return Get_Right_Limit (Expr);
+ when Iir_Downto =>
+ return Get_Left_Limit (Expr);
+ end case;
+ when others =>
+ return Expr;
+ end case;
+ when others =>
+ Error_Kind ("get_high", Assoc);
+ end case;
+ end Get_High;
+
+ -- Compare two elements of ARR.
+ -- Return true iff OP1 < OP2.
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return
+ Eval_Pos (Get_Low (Arr (Op1))) < Eval_Pos (Get_Low (Arr (Op2)));
+ end Lt;
+
+ -- Swap two elements of ARR.
+ procedure Swap (From : Natural; To : Natural)
+ is
+ Tmp : Iir;
+ begin
+ Tmp := Arr (To);
+ Arr (To) := Arr (From);
+ Arr (From) := Tmp;
+ end Swap;
+
+ package Disc_Heap_Sort is new Heap_Sort (Lt => Lt, Swap => Swap);
+ begin
+ Low := Null_Iir;
+ High := Null_Iir;
+
+ -- First:
+ -- semantize the choices
+ -- compute the range of positionnal choices
+ -- compute the number of choice elements (extracted from lists).
+ -- check for others presence.
+ Nbr_Pos := 0;
+ Nbr_Named := 0;
+ Has_Others := False;
+ Has_Error := False;
+ Staticness := Locally;
+ El := Choice_Chain;
+ Prev_El := Null_Iir;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ Nbr_Pos := Nbr_Pos + 1;
+ when Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range =>
+ if Sem_Simple_Choice then
+ Choice_Staticness := Get_Choice_Staticness (El);
+ Staticness := Min (Staticness, Choice_Staticness);
+ if Choice_Staticness /= Locally
+ and then Is_Case_Stmt
+ then
+ -- FIXME: explain why
+ Error_Msg_Sem ("choice is not locally static", El);
+ end if;
+ else
+ Has_Error := True;
+ end if;
+ Nbr_Named := Nbr_Named + 1;
+ when Iir_Kind_Choice_By_Name =>
+ -- It is not possible to have such a choice in an array
+ -- aggregate.
+ -- Should have been caught previously.
+ raise Internal_Error;
+ when Iir_Kind_Choice_By_Others =>
+ if Has_Others then
+ Error_Msg_Sem ("duplicate others choice", El);
+ elsif Get_Chain (El) /= Null_Iir then
+ Error_Msg_Sem
+ ("choice others should be the last alternative", El);
+ end if;
+ Has_Others := True;
+ when others =>
+ Error_Kind ("sem_choices_range", El);
+ end case;
+ Prev_El := El;
+ El := Get_Chain (El);
+ end loop;
+
+ if Has_Error then
+ -- Nothing can be done here...
+ return;
+ end if;
+ if Nbr_Pos > 0 and then Nbr_Named > 0 then
+ -- LRM93 7.3.2.2
+ -- Apart from the final element with the single choice OTHERS, the
+ -- rest (if any) of the element associations of an array aggregate
+ -- must be either all positionnal or all named.
+ Error_Msg_Sem
+ ("element associations must be all positional or all named", Loc);
+ return;
+ end if;
+
+ -- For a positional aggregate.
+ if Nbr_Pos > 0 then
+ -- Check number of elements match, but only if it is possible.
+ if Get_Type_Staticness (Sub_Type) /= Locally then
+ return;
+ end if;
+ Pos_Max := Eval_Discrete_Type_Length (Sub_Type);
+ if (not Has_Others and not Is_Sub_Range)
+ and then Nbr_Pos < Pos_Max
+ then
+ Error_Msg_Sem ("not enough elements associated", Loc);
+ elsif Nbr_Pos > Pos_Max then
+ Error_Msg_Sem ("too many elements associated", Loc);
+ end if;
+ return;
+ end if;
+
+ -- Second:
+ -- Create the list of choices
+ if Nbr_Named = 0 and then Has_Others then
+ -- This is only a others association.
+ return;
+ end if;
+ if Staticness /= Locally then
+ -- Emit a message for aggregrate. The message has already been
+ -- emitted for a case stmt.
+ -- FIXME: what about individual associations?
+ if not Is_Case_Stmt then
+ -- LRM93 �7.3.2.2
+ -- A named association of an array aggregate is allowed to have
+ -- a choice that is not locally static, or likewise a choice that
+ -- is a null range, only if the aggregate includes a single
+ -- element association and the element association has a single
+ -- choice.
+ if Nbr_Named > 1 or Has_Others then
+ Error_Msg_Sem ("not static choice exclude others choice", Loc);
+ end if;
+ end if;
+ return;
+ end if;
+
+ -- Set TYPE_HAS_BOUNDS
+ case Get_Kind (Sub_Type) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Type_Has_Bounds := True;
+ when Iir_Kind_Integer_Type_Definition =>
+ Type_Has_Bounds := False;
+ when others =>
+ Error_Kind ("sem_choice_range(3)", Sub_Type);
+ end case;
+
+ Arr := new Iir_Array (1 .. Nbr_Named);
+ Index := 0;
+
+ declare
+ procedure Add_Choice (Choice : Iir; A_Type : Iir)
+ is
+ Ok : Boolean;
+ Expr : Iir;
+ begin
+ Ok := True;
+ if Type_Has_Bounds
+ and then Get_Type_Staticness (A_Type) = Locally
+ then
+ if Get_Kind (Choice) = Iir_Kind_Choice_By_Range then
+ Expr := Get_Choice_Range (Choice);
+ if Get_Expr_Staticness (Expr) = Locally then
+ Ok := Eval_Is_Range_In_Bound (Expr, A_Type, True);
+ end if;
+ else
+ Expr := Get_Choice_Expression (Choice);
+ if Get_Expr_Staticness (Expr) = Locally then
+ Ok := Eval_Is_In_Bound (Expr, A_Type);
+ end if;
+ end if;
+ if not Ok then
+ Error_Msg_Sem
+ (Disp_Node (Expr) & " out of index range", Choice);
+ end if;
+ end if;
+ if Ok then
+ Index := Index + 1;
+ Arr (Index) := Choice;
+ end if;
+ end Add_Choice;
+ begin
+ -- Fill the array.
+ El := Choice_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ -- Only named associations are considered.
+ raise Internal_Error;
+ when Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range =>
+ Add_Choice (El, Sub_Type);
+ when Iir_Kind_Choice_By_Others =>
+ null;
+ when others =>
+ Error_Kind ("sem_choices_range(2)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end;
+
+ -- Third:
+ -- Sort the list
+ Disc_Heap_Sort.Sort (Index);
+
+ -- Set low and high bounds.
+ if Index > 0 then
+ Low := Get_Low (Arr (1));
+ High := Get_High (Arr (Index));
+ else
+ Low := Null_Iir;
+ High := Null_Iir;
+ end if;
+
+ -- Fourth:
+ -- check for lacking choice (if no others)
+ -- check for overlapping choices
+ declare
+ -- Emit an error message for absence of choices in position L to H
+ -- of index type BT at location LOC.
+ procedure Error_No_Choice (Bt : Iir;
+ L, H : Iir_Int64;
+ Loc : Location_Type)
+ is
+ begin
+ if L = H then
+ Error_Msg_Sem ("no choice for " & Disp_Discrete (Bt, L), Loc);
+ else
+ Error_Msg_Sem
+ ("no choices for " & Disp_Discrete (Bt, L)
+ & " to " & Disp_Discrete (Bt, H), Loc);
+ end if;
+ end Error_No_Choice;
+
+ -- Lowest and highest bounds.
+ Lb, Hb : Iir;
+ Pos : Iir_Int64;
+ Pos_Max : Iir_Int64;
+ E_Pos : Iir_Int64;
+
+ Bt : Iir;
+ begin
+ Bt := Get_Base_Type (Sub_Type);
+ if not Is_Sub_Range
+ and then Get_Type_Staticness (Sub_Type) = Locally
+ and then Type_Has_Bounds
+ then
+ Get_Low_High_Limit (Get_Range_Constraint (Sub_Type), Lb, Hb);
+ else
+ Lb := Low;
+ Hb := High;
+ end if;
+ -- Checks all values between POS and POS_MAX are handled.
+ Pos := Eval_Pos (Lb);
+ Pos_Max := Eval_Pos (Hb);
+ if Pos > Pos_Max then
+ -- Null range.
+ Free (Arr);
+ return;
+ end if;
+ for I in 1 .. Index loop
+ E_Pos := Eval_Pos (Get_Low (Arr (I)));
+ if E_Pos > Pos_Max then
+ -- Choice out of bound, already handled.
+ Error_No_Choice (Bt, Pos, Pos_Max, Get_Location (Arr (I)));
+ -- Avoid other errors.
+ Pos := Pos_Max + 1;
+ exit;
+ end if;
+ if Pos < E_Pos and then not Has_Others then
+ Error_No_Choice (Bt, Pos, E_Pos - 1, Get_Location (Arr (I)));
+ elsif Pos > E_Pos then
+ if Pos + 1 = E_Pos then
+ Error_Msg_Sem
+ ("duplicate choice for " & Disp_Discrete (Bt, Pos),
+ Arr (I));
+ else
+ Error_Msg_Sem
+ ("duplicate choices for " & Disp_Discrete (Bt, E_Pos)
+ & " to " & Disp_Discrete (Bt, Pos), Arr (I));
+ end if;
+ end if;
+ Pos := Eval_Pos (Get_High (Arr (I))) + 1;
+ end loop;
+ if Pos /= Pos_Max + 1 and then not Has_Others then
+ Error_No_Choice (Bt, Pos, Pos_Max, Loc);
+ end if;
+ end;
+
+ Free (Arr);
+ end Sem_Choices_Range;
+
+-- -- Find out the MIN and the MAX of an all named association choice list.
+-- -- It also returns the number of elements associed (counting range).
+-- procedure Sem_Find_Min_Max_Association_Choice_List
+-- (List: Iir_Association_Choices_List;
+-- Min: out Iir;
+-- Max: out Iir;
+-- Length: out natural)
+-- is
+-- Min_Res: Iir := null;
+-- Max_Res: Iir := null;
+-- procedure Update_With_Value (Val: Iir) is
+-- begin
+-- if Min_Res = null then
+-- Min_Res := Val;
+-- Max_Res := Val;
+-- elsif Get_Value (Val) < Get_Value (Min_Res) then
+-- Min_Res := Val;
+-- elsif Get_Value (Val) > Get_Value (Max_Res) then
+-- Max_Res := Val;
+-- end if;
+-- end Update_With_Value;
+
+-- Number_Elements: Natural;
+
+-- procedure Update (Choice: Iir) is
+-- Left, Right: Iir;
+-- Expr: Iir;
+-- begin
+-- case Get_Kind (Choice) is
+-- when Iir_Kind_Choice_By_Expression =>
+-- Update_With_Value (Get_Expression (Choice));
+-- Number_Elements := Number_Elements + 1;
+-- when Iir_Kind_Choice_By_Range =>
+-- Expr := Get_Expression (Choice);
+-- Left := Get_Left_Limit (Expr);
+-- Right := Get_Right_Limit (Expr);
+-- Update_With_Value (Left);
+-- Update_With_Value (Right);
+-- -- There can't be null range.
+-- case Get_Direction (Expr) is
+-- when Iir_To =>
+-- Number_Elements := Number_Elements +
+-- Natural (Get_Value (Right) - Get_Value (Left) + 1);
+-- when Iir_Downto =>
+-- Number_Elements := Number_Elements +
+-- Natural (Get_Value (Left) - Get_Value (Right) + 1);
+-- end case;
+-- when others =>
+-- Error_Kind ("sem_find_min_max_association_choice_list", Choice);
+-- end case;
+-- end Update;
+
+-- El: Iir;
+-- Sub_List: Iir_Association_Choices_List;
+-- Sub_El: Iir;
+-- begin
+-- Number_Elements := 0;
+-- for I in Natural loop
+-- El := Get_Nth_Element (List, I);
+-- exit when El = null;
+-- case Get_Kind (El) is
+-- when Iir_Kind_Choice_By_List =>
+-- Sub_List := Get_Choice_List (El);
+-- for J in Natural loop
+-- Sub_El := Get_Nth_Element (Sub_List, J);
+-- exit when Sub_El = null;
+-- Update (Sub_El);
+-- end loop;
+-- when others =>
+-- Update (El);
+-- end case;
+-- end loop;
+-- Min := Min_Res;
+-- Max := Max_Res;
+-- Length := Number_Elements;
+-- end Sem_Find_Min_Max_Association_Choice_List;
+
+ -- Perform semantisation on a (sub)aggregate AGGR, which is of type
+ -- A_TYPE.
+ -- return FALSE is case of failure
+ function Sem_Record_Aggregate (Aggr: Iir_Aggregate; A_Type: Iir)
+ return boolean
+ is
+ Base_Type : constant Iir := Get_Base_Type (A_Type);
+ El_List : constant Iir_List := Get_Elements_Declaration_List (Base_Type);
+
+ -- Type of the element.
+ El_Type : Iir;
+
+ Matches: Iir_Array (0 .. Get_Nbr_Elements (El_List) - 1);
+ Ok : Boolean;
+
+ -- Add a choice for element REC_EL.
+ -- Checks the element is not already associated.
+ -- Checks type of expression is compatible with type of element.
+ procedure Add_Match (El : Iir; Rec_El : Iir_Element_Declaration)
+ is
+ Ass_Type : Iir;
+ Pos : constant Natural := Natural (Get_Element_Position (Rec_El));
+ begin
+ if Matches (Pos) /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (Matches (Pos)) & " was already associated", El);
+ Ok := False;
+ return;
+ end if;
+ Matches (Pos) := El;
+
+ -- LRM 7.3.2.1 Record aggregates
+ -- An element association with more than once choice, [...], is
+ -- only allowed if the elements specified are all of the same type.
+ Ass_Type := Get_Type (Rec_El);
+ if El_Type = Null_Iir then
+ El_Type := Ass_Type;
+ elsif not Are_Types_Compatible (El_Type, Ass_Type) then
+ Error_Msg_Sem ("elements are not of the same type", El);
+ Ok := False;
+ end if;
+ end Add_Match;
+
+ -- Semantize a simple choice: extract the record element corresponding
+ -- to the expression, and create a choice_by_name.
+ -- FIXME: should mutate the node.
+ function Sem_Simple_Choice (Ass : Iir) return Iir
+ is
+ N_El : Iir;
+ Expr : Iir;
+ Aggr_El : Iir_Element_Declaration;
+ begin
+ Expr := Get_Choice_Expression (Ass);
+ if Get_Kind (Expr) /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem ("element association must be a simple name", Ass);
+ Ok := False;
+ return Ass;
+ end if;
+ Aggr_El := Find_Name_In_List
+ (Get_Elements_Declaration_List (Base_Type), Get_Identifier (Expr));
+ if Aggr_El = Null_Iir then
+ Error_Msg_Sem
+ ("record has no such element " & Disp_Node (Ass), Ass);
+ Ok := False;
+ return Ass;
+ end if;
+
+ N_El := Create_Iir (Iir_Kind_Choice_By_Name);
+ Location_Copy (N_El, Ass);
+ Set_Choice_Name (N_El, Aggr_El);
+ Set_Associated_Expr (N_El, Get_Associated_Expr (Ass));
+ Set_Associated_Chain (N_El, Get_Associated_Chain (Ass));
+ Set_Chain (N_El, Get_Chain (Ass));
+ Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass));
+
+ Xref_Ref (Expr, Aggr_El);
+ Free_Iir (Ass);
+ Free_Iir (Expr);
+ Add_Match (N_El, Aggr_El);
+ return N_El;
+ end Sem_Simple_Choice;
+
+ Assoc_Chain : Iir;
+ El, Prev_El : Iir;
+ Expr: Iir;
+ Has_Named : Boolean;
+ Rec_El_Index : Natural;
+ Value_Staticness : Iir_Staticness;
+ begin
+ Ok := True;
+ Assoc_Chain := Get_Association_Choices_Chain (Aggr);
+ Matches := (others => Null_Iir);
+ Value_Staticness := Locally;
+
+ El_Type := Null_Iir;
+ Has_Named := False;
+ Rec_El_Index := 0;
+ Prev_El := Null_Iir;
+ El := Assoc_Chain;
+ while El /= Null_Iir loop
+ Expr := Get_Associated_Expr (El);
+
+ -- If there is an associated expression with the choice, then the
+ -- choice is a new alternative, and has no expected type.
+ if Expr /= Null_Iir then
+ El_Type := Null_Iir;
+ end if;
+
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ if Has_Named then
+ Error_Msg_Sem ("positional association after named one", El);
+ Ok := False;
+ elsif Rec_El_Index > Matches'Last then
+ Error_Msg_Sem ("too many elements", El);
+ exit;
+ else
+ Add_Match (El, Get_Nth_Element (El_List, Rec_El_Index));
+ Rec_El_Index := Rec_El_Index + 1;
+ end if;
+ when Iir_Kind_Choice_By_Expression =>
+ Has_Named := True;
+ El := Sem_Simple_Choice (El);
+ -- This creates a choice_by_name, which replaces the
+ -- choice_by_expression.
+ if Prev_El = Null_Iir then
+ Set_Association_Choices_Chain (Aggr, El);
+ else
+ Set_Chain (Prev_El, El);
+ end if;
+ when Iir_Kind_Choice_By_Others =>
+ Has_Named := True;
+ if Get_Chain (El) /= Null_Iir then
+ Error_Msg_Sem
+ ("choice others must be the last alternative", El);
+ end if;
+ declare
+ Found : Boolean := False;
+ begin
+ for I in Matches'Range loop
+ if Matches (I) = Null_Iir then
+ Add_Match (El, Get_Nth_Element (El_List, I));
+ Found := True;
+ end if;
+ end loop;
+ if not Found then
+ Error_Msg_Sem ("no element for choice others", El);
+ Ok := False;
+ end if;
+ end;
+ when others =>
+ Error_Kind ("sem_record_aggregate", El);
+ end case;
+
+ -- Semantize the expression associated.
+ if Expr /= Null_Iir then
+ if El_Type /= Null_Iir then
+ Expr := Sem_Expression (Expr, El_Type);
+ if Expr /= Null_Iir then
+ Set_Associated_Expr (El, Eval_Expr_If_Static (Expr));
+ Value_Staticness := Min (Value_Staticness,
+ Get_Expr_Staticness (Expr));
+ else
+ Ok := False;
+ end if;
+ else
+ -- This case is not possible unless there is an error.
+ if Ok then
+ raise Internal_Error;
+ end if;
+ end if;
+ end if;
+
+ Prev_El := El;
+ El := Get_Chain (El);
+ end loop;
+
+ -- Check for missing associations.
+ for I in Matches'Range loop
+ if Matches (I) = Null_Iir then
+ Error_Msg_Sem
+ ("no value for " & Disp_Node (Get_Nth_Element (El_List, I)),
+ Aggr);
+ Ok := False;
+ end if;
+ end loop;
+ Set_Value_Staticness (Aggr, Value_Staticness);
+ Set_Expr_Staticness (Aggr, Min (Globally, Value_Staticness));
+ return Ok;
+ end Sem_Record_Aggregate;
+
+ -- Information for each dimension of an aggregate.
+ type Array_Aggr_Info is record
+ -- False if one sub-aggregate has no others choices.
+ -- If FALSE, the dimension is constrained.
+ Has_Others : Boolean := True;
+
+ -- True if one sub-aggregate is by named/by position.
+ Has_Named : Boolean := False;
+ Has_Positional : Boolean := False;
+
+ -- True if one sub-aggregate is dynamic.
+ Has_Dynamic : Boolean := False;
+
+ -- LOW and HIGH limits for the dimension.
+ Low : Iir := Null_Iir;
+ High : Iir := Null_Iir;
+
+ -- Minimum length of the dimension. This is a minimax.
+ Min_Length : Natural := 0;
+
+ -- If not NULL_IIR, this is the bounds of the dimension.
+ -- If every dimension has bounds, then the aggregate is constrained.
+ Index_Subtype : Iir := Null_Iir;
+
+ -- True if there is an error.
+ Error : Boolean := False;
+ end record;
+
+ type Array_Aggr_Info_Arr is array (Natural range <>) of Array_Aggr_Info;
+
+ -- Semantize an array aggregate AGGR of *base type* A_TYPE.
+ -- The type of the array is computed into A_SUBTYPE.
+ -- DIM is the dimension index in A_TYPE.
+ -- Return FALSE in case of error.
+ procedure Sem_Array_Aggregate_Type_1 (Aggr: Iir;
+ A_Type: Iir;
+ Infos : in out Array_Aggr_Info_Arr;
+ Constrained : Boolean;
+ Dim: Natural)
+ is
+ Assoc_Chain : Iir;
+ Choice: Iir;
+ Is_Positional: Tri_State_Type;
+ Has_Positional_Choice: Boolean;
+ Low, High : Iir;
+ Index_List : Iir_List;
+ Has_Others : Boolean;
+
+ Len : Natural;
+
+ -- Type of the index (this is also the type of the choices).
+ Index_Type : Iir;
+
+ --Index_Subtype : Iir;
+ Index_Subtype_Constraint : Iir_Range_Expression;
+ Index_Constraint : Iir_Range_Expression; -- FIXME: 'range.
+ Choice_Staticness : Iir_Staticness;
+
+ Info : Array_Aggr_Info renames Infos (Dim);
+ begin
+ Index_List := Get_Index_Subtype_List (A_Type);
+ Index_Type := Get_Index_Type (Index_List, Dim - 1);
+
+ -- Sem choices.
+ case Get_Kind (Aggr) is
+ when Iir_Kind_Aggregate =>
+ Assoc_Chain := Get_Association_Choices_Chain (Aggr);
+ Sem_Choices_Range (Assoc_Chain, Index_Type, not Constrained, False,
+ Get_Location (Aggr), Low, High);
+ Set_Association_Choices_Chain (Aggr, Assoc_Chain);
+
+ -- Update infos.
+ if Low /= Null_Iir
+ and then (Info.Low = Null_Iir
+ or else Eval_Pos (Low) < Eval_Pos (Info.Low))
+ then
+ Info.Low := Low;
+ end if;
+ if High /= Null_Iir
+ and then (Info.High = Null_Iir
+ or else Eval_Pos (High) > Eval_Pos (Info.High))
+ then
+ Info.High := High;
+ end if;
+
+ -- Determine if the aggregate is positionnal or named;
+ -- and compute choice staticness.
+ Is_Positional := Unknown;
+ Choice_Staticness := Locally;
+ Has_Positional_Choice := False;
+ Has_Others := False;
+ Len := 0;
+ Choice := Assoc_Chain;
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_Expression =>
+ Is_Positional := False;
+ Choice_Staticness :=
+ Iirs.Min (Choice_Staticness,
+ Get_Choice_Staticness (Choice));
+ -- FIXME: not true for range.
+ Len := Len + 1;
+ when Iir_Kind_Choice_By_None =>
+ Has_Positional_Choice := True;
+ Len := Len + 1;
+ when Iir_Kind_Choice_By_Others =>
+ if not Constrained then
+ Error_Msg_Sem ("'others' choice not allowed for an "
+ & "aggregate in this context", Aggr);
+ Infos (Dim).Error := True;
+ return;
+ end if;
+ Has_Others := True;
+ when others =>
+ Error_Kind ("sem_array_aggregate_type", Choice);
+ end case;
+ -- LRM93 7.3.2.2
+ -- Apart from the final element with the single choice
+ -- OTHERS, the rest (if any) of the element
+ -- associations of an array aggregate must be either
+ -- all positionnal or all named.
+ if Has_Positional_Choice then
+ if Is_Positional = False then
+ -- The error has already been emited
+ -- by sem_choices_range.
+ Infos (Dim).Error := True;
+ return;
+ end if;
+ Is_Positional := True;
+ end if;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ Info.Min_Length := Integer'Max (Info.Min_Length, Len);
+
+ if Choice_Staticness = Unknown then
+ -- This is possible when a choice is erroneous.
+ Infos (Dim).Error := True;
+ return;
+ end if;
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ Len := Sem_String_Literal
+ (Aggr, Get_Base_Type (Get_Element_Subtype (A_Type)));
+ Assoc_Chain := Null_Iir;
+ Info.Min_Length := Integer'Max (Info.Min_Length, Len);
+ Is_Positional := True;
+ Has_Others := False;
+ Choice_Staticness := Locally;
+
+ when others =>
+ Error_Kind ("sem_array_aggregate_type_1", Aggr);
+ end case;
+
+ if Is_Positional = True then
+ Info.Has_Positional := True;
+ end if;
+ if Is_Positional = False then
+ Info.Has_Named := True;
+ end if;
+ if not Has_Others then
+ Info.Has_Others := False;
+ end if;
+
+ -- LRM93 7.3.2.2
+ -- A named association of an array aggregate is allowed to have a choice
+ -- that is not locally static, [or likewise a choice that is a null
+ -- range], only if the aggregate includes a single element association
+ -- and this element association has a single choice.
+ if Is_Positional = False and then Choice_Staticness /= Locally then
+ Choice := Assoc_Chain;
+ if not Is_Chain_Length_One (Assoc_Chain) or else
+ (Get_Kind (Choice) /= Iir_Kind_Choice_By_Expression
+ and then Get_Kind (Choice) /= Iir_Kind_Choice_By_Range)
+ then
+ Error_Msg_Sem ("non-locally static choice for an aggregate is "
+ & "allowed only if only choice", Aggr);
+ Infos (Dim).Error := True;
+ return;
+ end if;
+ Info.Has_Dynamic := True;
+ end if;
+
+ -- Compute bounds of the index if there is no index subtype.
+ if Info.Index_Subtype = Null_Iir and then Has_Others = False then
+ -- LRM93 7.3.2.2
+ -- the direction of the index subtype of the aggregate is that of the
+ -- index subtype of the base type of the aggregate.
+
+ if Is_Positional = True then
+ -- LRM93 7.3.2.2
+ -- For a positionnal aggregate, [...] the leftmost bound is given
+ -- by S'LEFT where S is the index subtype of the base type of the
+ -- array; [...] the rightmost bound is determined by the direction
+ -- of the index subtype and the number of element.
+ if Get_Type_Staticness (Index_Type) = Locally then
+ Info.Index_Subtype := Create_Range_Subtype_By_Length
+ (Index_Type, Iir_Int64 (Len), Get_Location (Aggr));
+ end if;
+ else
+ -- Create an index subtype.
+ case Get_Kind (Index_Type) is
+ when Iir_Kind_Integer_Subtype_Definition =>
+ Info.Index_Subtype := Create_Iir (Get_Kind (Index_Type));
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Info.Index_Subtype :=
+ Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when others =>
+ Error_Kind ("sem_array_aggregate_type2", Index_Type);
+ end case;
+ Location_Copy (Info.Index_Subtype, Aggr);
+ Set_Base_Type (Info.Index_Subtype, Get_Base_Type (Index_Type));
+ Index_Constraint := Get_Range_Constraint (Index_Type);
+
+ -- LRM93 7.3.2.2
+ -- If the aggregate appears in one of the above contexts, then the
+ -- direction of the index subtype of the aggregate is that of the
+ -- corresponding constrained array subtype; [...]
+ Index_Subtype_Constraint := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Index_Subtype_Constraint, Aggr);
+ Set_Range_Constraint
+ (Info.Index_Subtype, Index_Subtype_Constraint);
+ Set_Type_Staticness (Info.Index_Subtype, Choice_Staticness);
+ Set_Expr_Staticness (Index_Subtype_Constraint, Choice_Staticness);
+
+ -- LRM93 7.3.2.2
+ -- For an aggregate that has named associations, the leftmost and
+ -- the rightmost bounds are determined by the direction of the
+ -- index subtype of the aggregate and the smallest and largest
+ -- choice given.
+ if Choice_Staticness = Locally then
+ if Low = Null_Iir or High = Null_Iir then
+ -- Avoid error propagation.
+ Set_Range_Constraint (Info.Index_Subtype,
+ Get_Range_Constraint (Index_Type));
+ Free_Iir (Index_Subtype_Constraint);
+ else
+ Set_Direction (Index_Subtype_Constraint,
+ Get_Direction (Index_Constraint));
+ case Get_Direction (Index_Constraint) is
+ when Iir_To =>
+ Set_Left_Limit (Index_Subtype_Constraint, Low);
+ Set_Right_Limit (Index_Subtype_Constraint, High);
+ when Iir_Downto =>
+ Set_Left_Limit (Index_Subtype_Constraint, High);
+ Set_Right_Limit (Index_Subtype_Constraint, Low);
+ end case;
+ end if;
+ else
+ -- Dynamic aggregate.
+ declare
+ Expr : Iir;
+ Choice : Iir;
+ begin
+ Choice := Assoc_Chain;
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Expression =>
+ Expr := Get_Choice_Expression (Choice);
+ Set_Direction (Index_Subtype_Constraint,
+ Get_Direction (Index_Constraint));
+ Set_Left_Limit (Index_Subtype_Constraint, Expr);
+ Set_Right_Limit (Index_Subtype_Constraint, Expr);
+ when Iir_Kind_Choice_By_Range =>
+ Expr := Get_Choice_Range (Choice);
+ Set_Range_Constraint (Info.Index_Subtype, Expr);
+ -- FIXME: avoid allocation-free.
+ Free_Iir (Index_Subtype_Constraint);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+ end if;
+ end if;
+ --Set_Type_Staticness
+ -- (A_Subtype, Iirs.Min (Get_Type_Staticness (A_Subtype),
+ -- Get_Type_Staticness (Index_Subtype)));
+ --Append_Element (Get_Index_List (A_Subtype), Index_Subtype);
+ elsif Has_Others = False then
+ -- Check the subaggregate bounds are the same.
+ if Is_Positional = True then
+ if Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint
+ (Info.Index_Subtype)))
+ /= Eval_Pos (Eval_Discrete_Range_Left (Get_Range_Constraint
+ (Index_Type)))
+ then
+ Error_Msg_Sem ("subaggregate bounds mismatch", Aggr);
+ else
+ if Eval_Discrete_Type_Length (Info.Index_Subtype)
+ /= Iir_Int64 (Len)
+ then
+ Error_Msg_Sem ("subaggregate length mismatch", Aggr);
+ end if;
+ end if;
+ else
+ declare
+ L, H : Iir;
+ begin
+ Get_Low_High_Limit
+ (Get_Range_Constraint (Info.Index_Subtype), L, H);
+ if Eval_Pos (L) /= Eval_Pos (Low)
+ or else Eval_Pos (H) /= Eval_Pos (H)
+ then
+ Error_Msg_Sem ("subagregate bounds mismatch", Aggr);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Semantize aggregate elements.
+ if Dim = Get_Nbr_Elements (Index_List) then
+ -- A type has been found for AGGR, semantize AGGR as if it was
+ -- an aggregate with a subtype.
+
+ if Get_Kind (Aggr) = Iir_Kind_Aggregate then
+ -- LRM93 7.3.2.2:
+ -- the expression of each element association must be of the
+ -- element type.
+ declare
+ El : Iir;
+ Element_Type : Iir;
+ Expr : Iir;
+ Value_Staticness : Iir_Staticness;
+ Expr_Staticness : Iir_Staticness;
+ begin
+ Element_Type := Get_Element_Subtype (A_Type);
+ El := Assoc_Chain;
+ Value_Staticness := Locally;
+ while El /= Null_Iir loop
+ Expr := Get_Associated_Expr (El);
+ if Expr /= Null_Iir then
+ Expr := Sem_Expression (Expr, Element_Type);
+ if Expr /= Null_Iir then
+ Expr_Staticness := Get_Expr_Staticness (Expr);
+ Set_Expr_Staticness
+ (Aggr, Min (Get_Expr_Staticness (Aggr),
+ Expr_Staticness));
+ Set_Associated_Expr (El, Eval_Expr_If_Static (Expr));
+
+ -- FIXME: handle name/others in translate.
+ -- if Get_Kind (Expr) = Iir_Kind_Aggregate then
+ -- Expr_Staticness := Get_Value_Staticness (Expr);
+ -- end if;
+ Value_Staticness := Min (Value_Staticness,
+ Expr_Staticness);
+ else
+ Info.Error := True;
+ end if;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ Set_Value_Staticness (Aggr, Value_Staticness);
+ end;
+ end if;
+ else
+ declare
+ Assoc : Iir;
+ Value_Staticness : Iir_Staticness;
+ begin
+ Assoc := Null_Iir;
+ Choice := Assoc_Chain;
+ Value_Staticness := Locally;
+ while Choice /= Null_Iir loop
+ if Get_Associated_Expr (Choice) /= Null_Iir then
+ Assoc := Get_Associated_Expr (Choice);
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Aggregate =>
+ Sem_Array_Aggregate_Type_1
+ (Assoc, A_Type, Infos, Constrained, Dim + 1);
+ Value_Staticness := Min (Value_Staticness,
+ Get_Value_Staticness (Assoc));
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ if Dim + 1 = Get_Nbr_Elements (Index_List) then
+ Sem_Array_Aggregate_Type_1
+ (Assoc, A_Type, Infos, Constrained, Dim + 1);
+ else
+ Error_Msg_Sem
+ ("string literal not allowed here", Assoc);
+ Infos (Dim + 1).Error := True;
+ end if;
+ when others =>
+ Error_Msg_Sem ("sub-aggregate expected", Assoc);
+ Infos (Dim + 1).Error := True;
+ end case;
+ Choice := Get_Chain (Choice);
+ end loop;
+ Set_Value_Staticness (Aggr, Value_Staticness);
+ end;
+ end if;
+ end Sem_Array_Aggregate_Type_1;
+
+ -- Semantize an array aggregate whose type is AGGR_TYPE.
+ -- If CONSTRAINED is true, then the aggregate appears in one of the
+ -- context and can have an 'others' choice.
+ -- If CONSTRAINED is false, the aggregate can not have an 'others' choice.
+ -- Create a subtype for this aggregate.
+ -- Return NULL_IIR in case of error, or AGGR if not.
+ function Sem_Array_Aggregate_Type
+ (Aggr : Iir; Aggr_Type : Iir; Constrained : Boolean)
+ return Iir
+ is
+ A_Subtype: Iir;
+ Base_Type : Iir;
+ Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type);
+ Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List);
+ Infos : Array_Aggr_Info_Arr (1 .. Nbr_Dim);
+ Aggr_Constrained : Boolean;
+ Info, Prev_Info : Iir_Aggregate_Info;
+ begin
+ -- Semantize the aggregate.
+ Sem_Array_Aggregate_Type_1 (Aggr, Aggr_Type, Infos, Constrained, 1);
+
+ Aggr_Constrained := True;
+ for I in Infos'Range loop
+ -- Return now in case of error.
+ if Infos (I).Error then
+ return Null_Iir;
+ end if;
+ if Infos (I).Index_Subtype = Null_Iir then
+ Aggr_Constrained := False;
+ end if;
+ end loop;
+ Base_Type := Get_Base_Type (Aggr_Type);
+
+ -- FIXME: should reuse AGGR_TYPE iff AGGR_TYPE is fully constrained
+ -- and statically match the subtype of the aggregate.
+ if Aggr_Constrained then
+ A_Subtype := Create_Array_Subtype (Base_Type, Get_Location (Aggr));
+ for I in Infos'Range loop
+ Append_Element (Get_Index_Subtype_List (A_Subtype),
+ Infos (I).Index_Subtype);
+ Set_Type_Staticness
+ (A_Subtype,
+ Iirs.Min (Get_Type_Staticness (A_Subtype),
+ Get_Type_Staticness (Infos (I).Index_Subtype)));
+ end loop;
+ Set_Index_Constraint_Flag (A_Subtype, True);
+ Set_Constraint_State (A_Subtype, Fully_Constrained);
+ Set_Type (Aggr, A_Subtype);
+ Set_Literal_Subtype (Aggr, A_Subtype);
+ else
+ -- Free unused indexes subtype.
+ for I in Infos'Range loop
+ declare
+ St : constant Iir := Infos (I).Index_Subtype;
+ begin
+ if St /= Null_Iir then
+ Free_Iir (Get_Range_Constraint (St));
+ Free_Iir (St);
+ end if;
+ end;
+ end loop;
+ end if;
+
+ Prev_Info := Null_Iir;
+ for I in Infos'Range loop
+ -- Create info and link.
+ Info := Create_Iir (Iir_Kind_Aggregate_Info);
+ if I = 1 then
+ Set_Aggregate_Info (Aggr, Info);
+ else
+ Set_Sub_Aggregate_Info (Prev_Info, Info);
+ end if;
+ Prev_Info := Info;
+
+ -- Fill info.
+ Set_Aggr_Dynamic_Flag (Info, Infos (I).Has_Dynamic);
+ Set_Aggr_Named_Flag (Info, Infos (I).Has_Named);
+ Set_Aggr_Low_Limit (Info, Infos (I).Low);
+ Set_Aggr_High_Limit (Info, Infos (I).High);
+ Set_Aggr_Min_Length (Info, Iir_Int32 (Infos (I).Min_Length));
+ Set_Aggr_Others_Flag (Info, Infos (I).Has_Others);
+ end loop;
+ return Aggr;
+ end Sem_Array_Aggregate_Type;
+
+ -- Semantize aggregate EXPR whose type is expected to be A_TYPE.
+ -- A_TYPE cannot be null_iir (this case is handled in sem_expression_ov)
+ function Sem_Aggregate (Expr: Iir_Aggregate; A_Type: Iir)
+ return Iir_Aggregate is
+ begin
+ pragma Assert (A_Type /= Null_Iir);
+
+ -- An aggregate is at most globally static.
+ Set_Expr_Staticness (Expr, Globally);
+
+ Set_Type (Expr, A_Type); -- FIXME: should free old type
+ case Get_Kind (A_Type) is
+ when Iir_Kind_Array_Subtype_Definition =>
+ return Sem_Array_Aggregate_Type
+ (Expr, A_Type, Get_Index_Constraint_Flag (A_Type));
+ when Iir_Kind_Array_Type_Definition =>
+ return Sem_Array_Aggregate_Type (Expr, A_Type, False);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ if not Sem_Record_Aggregate (Expr, A_Type) then
+ return Null_Iir;
+ end if;
+ return Expr;
+ when others =>
+ Error_Msg_Sem ("type " & Disp_Node (A_Type) & " is not composite",
+ Expr);
+ return Null_Iir;
+ end case;
+ end Sem_Aggregate;
+
+ -- Transform LIT into a physical_literal.
+ -- LIT can be either a not semantized physical literal or
+ -- a simple name that is a physical unit. In the later case, a physical
+ -- literal is created.
+ function Sem_Physical_Literal (Lit: Iir) return Iir
+ is
+ Unit_Name : Iir;
+ Unit_Type : Iir;
+ Res: Iir;
+ begin
+ case Get_Kind (Lit) is
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ Unit_Name := Get_Unit_Name (Lit);
+ Res := Lit;
+ when Iir_Kind_Unit_Declaration =>
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Location_Copy (Res, Lit);
+ Set_Value (Res, 1);
+ Unit_Name := Null_Iir;
+ raise Program_Error;
+ when Iir_Kinds_Denoting_Name =>
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Location_Copy (Res, Lit);
+ Set_Value (Res, 1);
+ Unit_Name := Lit;
+ when others =>
+ Error_Kind ("sem_physical_literal", Lit);
+ end case;
+ Unit_Name := Sem_Denoting_Name (Unit_Name);
+ if Get_Kind (Get_Named_Entity (Unit_Name)) /= Iir_Kind_Unit_Declaration
+ then
+ Error_Class_Match (Unit_Name, "unit");
+ Set_Named_Entity (Unit_Name, Create_Error_Name (Unit_Name));
+ end if;
+ Set_Unit_Name (Res, Unit_Name);
+ Unit_Type := Get_Type (Unit_Name);
+ Set_Type (Res, Unit_Type);
+
+ -- LRM93 7.4.2
+ -- 1. a literal of type TIME.
+ --
+ -- LRM93 7.4.1
+ -- 1. a literal of any type other than type TIME;
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Unit_Name));
+ --Eval_Check_Constraints (Res);
+ return Res;
+ end Sem_Physical_Literal;
+
+ -- Semantize an allocator by expression or an allocator by subtype.
+ function Sem_Allocator (Expr : Iir; A_Type : Iir) return Iir
+ is
+ Arg: Iir;
+ Arg_Type : Iir;
+ begin
+ Set_Expr_Staticness (Expr, None);
+
+ Arg_Type := Get_Allocator_Designated_Type (Expr);
+
+ if Arg_Type = Null_Iir then
+ -- Expression was not analyzed.
+ case Iir_Kinds_Allocator (Get_Kind (Expr)) is
+ when Iir_Kind_Allocator_By_Expression =>
+ Arg := Get_Expression (Expr);
+ pragma Assert (Get_Kind (Arg) = Iir_Kind_Qualified_Expression);
+ Arg := Sem_Expression (Arg, Null_Iir);
+ if Arg = Null_Iir then
+ return Null_Iir;
+ end if;
+ Check_Read (Arg);
+ Set_Expression (Expr, Arg);
+ Arg_Type := Get_Type (Arg);
+ when Iir_Kind_Allocator_By_Subtype =>
+ Arg := Get_Subtype_Indication (Expr);
+ Arg := Sem_Types.Sem_Subtype_Indication (Arg);
+ Set_Subtype_Indication (Expr, Arg);
+ Arg := Get_Type_Of_Subtype_Indication (Arg);
+ if Arg = Null_Iir then
+ return Null_Iir;
+ end if;
+ -- LRM93 7.3.6
+ -- If an allocator includes a subtype indication and if the
+ -- type of the object created is an array type, then the
+ -- subtype indication must either denote a constrained
+ -- subtype or include an explicit index constraint.
+ if not Is_Fully_Constrained_Type (Arg) then
+ Error_Msg_Sem
+ ("allocator of unconstrained " &
+ Disp_Node (Arg) & " is not allowed", Expr);
+ end if;
+ -- LRM93 7.3.6
+ -- A subtype indication that is part of an allocator must
+ -- not include a resolution function.
+ if Is_Anonymous_Type_Definition (Arg)
+ and then Get_Resolution_Indication (Arg) /= Null_Iir
+ then
+ Error_Msg_Sem ("subtype indication must not include"
+ & " a resolution function", Expr);
+ end if;
+ Arg_Type := Arg;
+ end case;
+ Set_Allocator_Designated_Type (Expr, Arg_Type);
+ end if;
+
+ -- LRM 7.3.6 Allocators
+ -- The type of the access value returned by an allocator must be
+ -- determinable solely from the context, but using the fact that the
+ -- value returned is of an access type having the named designated
+ -- type.
+ if A_Type = Null_Iir then
+ -- Type of the context is not yet known.
+ return Expr;
+ else
+ if not Is_Allocator_Type (A_Type, Expr) then
+ if Get_Kind (A_Type) /= Iir_Kind_Access_Type_Definition then
+ if Get_Kind (A_Type) /= Iir_Kind_Error then
+ Error_Msg_Sem ("expected type is not an access type", Expr);
+ end if;
+ else
+ Not_Match (Expr, A_Type);
+ end if;
+ return Null_Iir;
+ end if;
+ Set_Type (Expr, A_Type);
+ return Expr;
+ end if;
+ end Sem_Allocator;
+
+ procedure Check_Read_Aggregate (Aggr : Iir)
+ is
+ pragma Unreferenced (Aggr);
+ begin
+ -- FIXME: todo.
+ null;
+ end Check_Read_Aggregate;
+
+ -- Check EXPR can be read.
+ procedure Check_Read (Expr : Iir)
+ is
+ Obj : Iir;
+ begin
+ if Expr = Null_Iir then
+ return;
+ end if;
+
+ Obj := Expr;
+ loop
+ case Get_Kind (Obj) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ return;
+ when Iir_Kinds_Quantity_Declaration =>
+ return;
+ when Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ -- LRM 4.3.2 Interface declarations
+ -- The value of an object is said to be read [...]
+ -- - When the object is a file and a READ operation is
+ -- performed on the file.
+ return;
+ when Iir_Kind_Object_Alias_Declaration =>
+ Obj := Get_Name (Obj);
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Variable_Declaration =>
+ case Get_Mode (Obj) is
+ when Iir_In_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode =>
+ null;
+ when Iir_Out_Mode
+ | Iir_Linkage_Mode =>
+ Error_Msg_Sem (Disp_Node (Obj) & " cannot be read", Expr);
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ end case;
+ return;
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Integer_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Null_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Overflow_Literal =>
+ return;
+ when Iir_Kinds_Monadic_Operator
+ | Iir_Kinds_Dyadic_Operator
+ | Iir_Kind_Function_Call =>
+ return;
+ when Iir_Kind_Parenthesis_Expression =>
+ Obj := Get_Expression (Obj);
+ when Iir_Kind_Qualified_Expression =>
+ return;
+ when Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Dereference
+ | Iir_Kind_Attribute_Name =>
+ return;
+ when Iir_Kinds_Scalar_Type_Attribute
+ | Iir_Kinds_Type_Attribute
+ | Iir_Kinds_Array_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kinds_Name_Attribute
+ | Iir_Kinds_Signal_Attribute
+ | Iir_Kinds_Signal_Value_Attribute =>
+ return;
+ when Iir_Kind_Aggregate =>
+ Check_Read_Aggregate (Obj);
+ return;
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element =>
+ -- FIXME: speed up using Base_Name
+ -- Obj := Get_Base_Name (Obj);
+ Obj := Get_Prefix (Obj);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Obj := Get_Named_Entity (Obj);
+ when Iir_Kind_Error =>
+ return;
+ when others =>
+ Error_Kind ("check_read", Obj);
+ end case;
+ end loop;
+ end Check_Read;
+
+ procedure Check_Update (Expr : Iir)
+ is
+ pragma Unreferenced (Expr);
+ begin
+ null;
+ end Check_Update;
+
+ -- Emit an error if the constant EXPR is deferred and cannot be used in
+ -- the current context.
+ procedure Check_Constant_Restriction (Expr : Iir; Loc : Iir)
+ is
+ Lib : Iir;
+ Cur_Lib : Iir;
+ begin
+ -- LRM93 �2.6
+ -- Within a package declaration that contains the declaration
+ -- of a deferred constant, and within the body of that package,
+ -- before the end of the corresponding full declaration, the
+ -- use of a name that denotes the deferred constant is only
+ -- allowed in the default expression for a local generic,
+ -- local port or formal parameter.
+ if Get_Deferred_Declaration_Flag (Expr) = False
+ or else Get_Deferred_Declaration (Expr) /= Null_Iir
+ then
+ -- The constant declaration is not deferred
+ -- or the it has been fully declared.
+ return;
+ end if;
+
+ Lib := Get_Parent (Expr);
+ if Get_Kind (Lib) = Iir_Kind_Design_Unit then
+ Lib := Get_Library_Unit (Lib);
+ -- FIXME: the parent of the constant is the library unit or
+ -- the design unit ?
+ raise Internal_Error;
+ end if;
+ Cur_Lib := Get_Library_Unit (Sem.Get_Current_Design_Unit);
+ if (Get_Kind (Cur_Lib) = Iir_Kind_Package_Declaration
+ and then Lib = Cur_Lib)
+ or else (Get_Kind (Cur_Lib) = Iir_Kind_Package_Body
+ and then Get_Package (Cur_Lib) = Lib)
+ then
+ Error_Msg_Sem ("invalid use of a deferred constant", Loc);
+ end if;
+ end Check_Constant_Restriction;
+
+ -- Set semantic to EXPR.
+ -- Replace simple_name with the referenced node,
+ -- Set type to nodes,
+ -- Resolve overloading
+
+ -- If A_TYPE is not null, then EXPR must be of type A_TYPE.
+ -- Return null in case of error.
+ function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir
+ is
+ A_Type: Iir;
+ begin
+-- -- Avoid to run sem_expression_ov when a node was already semantized
+-- -- except to resolve overload.
+-- if Get_Type (Expr) /= Null_Iir then
+-- -- EXPR was already semantized.
+-- if A_Type1 = null or else not Is_Overload_List (Get_Type (Expr)) then
+-- -- This call to sem_expression_ov do not add any informations.
+-- Check_Restrictions (Expr, Restriction);
+-- return Expr;
+-- end if;
+-- -- This is an overload list that will be reduced.
+-- end if;
+
+ -- A_TYPE must be a type definition and not a subtype.
+ if A_Type1 /= Null_Iir then
+ A_Type := Get_Base_Type (A_Type1);
+ if A_Type /= A_Type1 then
+ raise Internal_Error;
+ end if;
+ else
+ A_Type := Null_Iir;
+ end if;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Attribute_Name =>
+ declare
+ E : Iir;
+ begin
+ E := Get_Named_Entity (Expr);
+ if E = Null_Iir then
+ Sem_Name (Expr);
+ E := Get_Named_Entity (Expr);
+ if E = Null_Iir then
+ raise Internal_Error;
+ end if;
+ end if;
+ if E = Error_Mark then
+ return Null_Iir;
+ end if;
+ if Get_Kind (E) = Iir_Kind_Constant_Declaration
+ and then not Deferred_Constant_Allowed
+ then
+ Check_Constant_Restriction (E, Expr);
+ end if;
+ E := Name_To_Expression (Expr, A_Type);
+ return E;
+ end;
+
+ when Iir_Kinds_Monadic_Operator =>
+ return Sem_Operator (Expr, A_Type, 1);
+
+ when Iir_Kinds_Dyadic_Operator =>
+ return Sem_Operator (Expr, A_Type, 2);
+
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kinds_Object_Declaration =>
+ -- All these case have already a type.
+ if Get_Type (Expr) = Null_Iir then
+ return Null_Iir;
+ end if;
+ if A_Type /= Null_Iir
+ and then not Are_Basetypes_Compatible
+ (A_Type, Get_Base_Type (Get_Type (Expr)))
+ then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+ return Expr;
+
+ when Iir_Kind_Integer_Literal =>
+ Set_Expr_Staticness (Expr, Locally);
+ if A_Type = Null_Iir then
+ Set_Type (Expr, Convertible_Integer_Type_Definition);
+ return Expr;
+ elsif Get_Kind (A_Type) = Iir_Kind_Integer_Type_Definition then
+ Set_Type (Expr, A_Type);
+ return Expr;
+ else
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+
+ when Iir_Kind_Floating_Point_Literal =>
+ Set_Expr_Staticness (Expr, Locally);
+ if A_Type = Null_Iir then
+ Set_Type (Expr, Convertible_Real_Type_Definition);
+ return Expr;
+ elsif Get_Kind (A_Type) = Iir_Kind_Floating_Type_Definition then
+ Set_Type (Expr, A_Type);
+ return Expr;
+ else
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Unit_Declaration =>
+ declare
+ Res: Iir;
+ begin
+ Res := Sem_Physical_Literal (Expr);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ if A_Type /= Null_Iir and then Get_Type (Res) /= A_Type then
+ Not_Match (Res, A_Type);
+ return Null_Iir;
+ end if;
+ return Res;
+ end;
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ -- LRM93 7.3.1 Literals
+ -- The type of a string or bit string literal must be
+ -- determinable solely from the context in whcih the literal
+ -- appears, excluding the literal itself [...]
+ if A_Type = Null_Iir then
+ return Expr;
+ end if;
+
+ if not Is_String_Literal_Type (A_Type, Expr) then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ else
+ Replace_Type (Expr, A_Type);
+ Sem_String_Literal (Expr);
+ return Expr;
+ end if;
+
+ when Iir_Kind_Null_Literal =>
+ Set_Expr_Staticness (Expr, Locally);
+ -- GHDL: the LRM doesn't explain how the type of NULL is
+ -- determined. Use the same rule as string or aggregates.
+ if A_Type = Null_Iir then
+ return Expr;
+ end if;
+ if not Is_Null_Literal_Type (A_Type) then
+ Error_Msg_Sem ("null literal can only be access type", Expr);
+ return Null_Iir;
+ else
+ Set_Type (Expr, A_Type);
+ return Expr;
+ end if;
+
+ when Iir_Kind_Aggregate =>
+ -- LRM93 7.3.2 Aggregates
+ -- The type of an aggregate must be determinable solely from the
+ -- context in which the aggregate appears, excluding the aggregate
+ -- itself but [...]
+ if A_Type = Null_Iir then
+ return Expr;
+ else
+ return Sem_Aggregate (Expr, A_Type);
+ end if;
+
+ when Iir_Kind_Parenthesis_Expression =>
+ declare
+ Sub_Expr : Iir;
+ begin
+ Sub_Expr := Get_Expression (Expr);
+ Sub_Expr := Sem_Expression_Ov (Sub_Expr, A_Type1);
+ if Sub_Expr = Null_Iir then
+ return Null_Iir;
+ end if;
+ Set_Expression (Expr, Sub_Expr);
+ Set_Type (Expr, Get_Type (Sub_Expr));
+ Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr));
+ return Expr;
+ end;
+
+ when Iir_Kind_Qualified_Expression =>
+ declare
+ N_Type: Iir;
+ Res: Iir;
+ begin
+ N_Type := Sem_Type_Mark (Get_Type_Mark (Expr));
+ Set_Type_Mark (Expr, N_Type);
+ N_Type := Get_Type (N_Type);
+ Set_Type (Expr, N_Type);
+ if A_Type /= Null_Iir
+ and then not Are_Types_Compatible (A_Type, N_Type)
+ then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+ Res := Sem_Expression (Get_Expression (Expr), N_Type);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ Check_Read (Res);
+ Set_Expression (Expr, Res);
+ Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Res),
+ Get_Type_Staticness (N_Type)));
+ return Expr;
+ end;
+
+ when Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype =>
+ return Sem_Allocator (Expr, A_Type);
+
+ when Iir_Kinds_Procedure_Declaration =>
+ Error_Msg_Sem
+ (Disp_Node (Expr) & " cannot be used as an expression", Expr);
+ return Null_Iir;
+
+ when others =>
+ Error_Kind ("sem_expression_ov", Expr);
+ return Null_Iir;
+ end case;
+ end Sem_Expression_Ov;
+
+ -- If A_TYPE is not null, then EXPR must be of type A_TYPE.
+ -- Return null in case of error.
+ function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir
+ is
+ A_Type1: Iir;
+ Res: Iir;
+ Expr_Type : Iir;
+ begin
+ if Check_Is_Expression (Expr, Expr) = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- Can't try to run sem_expression_ov when a node was already semantized
+ Expr_Type := Get_Type (Expr);
+ if Expr_Type /= Null_Iir and then not Is_Overload_List (Expr_Type) then
+ -- Checks types.
+ -- This is necessary when the first call to sem_expression was done
+ -- with A_TYPE set to NULL_IIR and results in setting the type of
+ -- EXPR.
+ if A_Type /= Null_Iir
+ and then not Are_Types_Compatible (Expr_Type, A_Type)
+ then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+ return Expr;
+ end if;
+
+ -- A_TYPE must be a type definition and not a subtype.
+ if A_Type /= Null_Iir then
+ A_Type1 := Get_Base_Type (A_Type);
+ else
+ A_Type1 := Null_Iir;
+ end if;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Aggregate =>
+ Res := Sem_Aggregate (Expr, A_Type);
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ if A_Type = Null_Iir then
+ Res := Sem_Expression_Ov (Expr, Null_Iir);
+ else
+ if not Is_String_Literal_Type (A_Type, Expr) then
+ Not_Match (Expr, A_Type);
+ return Null_Iir;
+ end if;
+ Set_Type (Expr, A_Type);
+ Sem_String_Literal (Expr);
+ return Expr;
+ end if;
+ when others =>
+ Res := Sem_Expression_Ov (Expr, A_Type1);
+ end case;
+
+ if Res /= Null_Iir and then Is_Overloaded (Res) then
+ -- FIXME: clarify between overload and not determinable from the
+ -- context.
+ Error_Overload (Expr);
+ if Get_Type (Res) /= Null_Iir then
+ Disp_Overload_List (Get_Overload_List (Get_Type (Res)), Expr);
+ end if;
+ return Null_Iir;
+ end if;
+ return Res;
+ end Sem_Expression;
+
+ function Sem_Composite_Expression (Expr : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Sem_Expression_Ov (Expr, Null_Iir);
+ if Res = Null_Iir or else Get_Type (Res) = Null_Iir then
+ return Res;
+ elsif Is_Overload_List (Get_Type (Res)) then
+ declare
+ List : constant Iir_List := Get_Overload_List (Get_Type (Res));
+ Res_Type : Iir;
+ Atype : Iir;
+ begin
+ Res_Type := Null_Iir;
+ for I in Natural loop
+ Atype := Get_Nth_Element (List, I);
+ exit when Atype = Null_Iir;
+ if Is_Aggregate_Type (Atype) then
+ Add_Result (Res_Type, Atype);
+ end if;
+ end loop;
+
+ if Res_Type = Null_Iir then
+ Error_Overload (Expr);
+ return Null_Iir;
+ elsif Is_Overload_List (Res_Type) then
+ Error_Overload (Expr);
+ Disp_Overload_List (Get_Overload_List (Res_Type), Expr);
+ Free_Overload_List (Res_Type);
+ return Null_Iir;
+ else
+ return Sem_Expression_Ov (Expr, Res_Type);
+ end if;
+ end;
+ else
+ -- Either an error (already handled) or not overloaded. Type
+ -- matching will be done later (when the target is analyzed).
+ return Res;
+ end if;
+ end Sem_Composite_Expression;
+
+ function Sem_Expression_Universal (Expr : Iir) return Iir
+ is
+ Expr1 : Iir;
+ Expr_Type : Iir;
+ El : Iir;
+ Res : Iir;
+ List : Iir_List;
+ begin
+ Expr1 := Sem_Expression_Ov (Expr, Null_Iir);
+ if Expr1 = Null_Iir then
+ return Null_Iir;
+ end if;
+ Expr_Type := Get_Type (Expr1);
+ if Expr_Type = Null_Iir then
+ -- FIXME: improve message
+ Error_Msg_Sem ("bad expression for a scalar", Expr);
+ return Null_Iir;
+ end if;
+ if not Is_Overload_List (Expr_Type) then
+ return Expr1;
+ end if;
+
+ List := Get_Overload_List (Expr_Type);
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if El = Universal_Integer_Type_Definition
+ or El = Convertible_Integer_Type_Definition
+ or El = Universal_Real_Type_Definition
+ or El = Convertible_Real_Type_Definition
+ then
+ if Res = Null_Iir then
+ Res := El;
+ else
+ Error_Overload (Expr1);
+ Disp_Overload_List (List, Expr1);
+ return Null_Iir;
+ end if;
+ end if;
+ end loop;
+ if Res = Null_Iir then
+ Error_Overload (Expr1);
+ Disp_Overload_List (List, Expr1);
+ return Null_Iir;
+ end if;
+ return Sem_Expression_Ov (Expr1, Res);
+ end Sem_Expression_Universal;
+
+ function Sem_Case_Expression (Expr : Iir) return Iir
+ is
+ Expr1 : Iir;
+ Expr_Type : Iir;
+ El : Iir;
+ Res : Iir;
+ List : Iir_List;
+ begin
+ Expr1 := Sem_Expression_Ov (Expr, Null_Iir);
+ if Expr1 = Null_Iir then
+ return Null_Iir;
+ end if;
+ Expr_Type := Get_Type (Expr1);
+ if Expr_Type = Null_Iir then
+ -- Possible only if the type cannot be determined without the
+ -- context (aggregate or string literal).
+ Error_Msg_Sem
+ ("cannot determine the type of choice expression", Expr);
+ if Get_Kind (Expr1) = Iir_Kind_Aggregate then
+ Error_Msg_Sem
+ ("(use a qualified expression of the form T'(xxx).)", Expr);
+ end if;
+ return Null_Iir;
+ end if;
+ if not Is_Overload_List (Expr_Type) then
+ return Expr1;
+ end if;
+
+ -- In case of overload, try to find one match.
+ -- FIXME: match only character types.
+
+ -- LRM93 8.8 Case statement
+ -- This type must be determinable independently of the context in which
+ -- the expression occurs, but using the fact that the expression must be
+ -- of a discrete type or a one-dimensional character array type.
+ List := Get_Overload_List (Expr_Type);
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Get_Kind (El) in Iir_Kinds_Discrete_Type_Definition
+ or else Is_One_Dimensional_Array_Type (El)
+ then
+ if Res = Null_Iir then
+ Res := El;
+ else
+ Error_Overload (Expr1);
+ Disp_Overload_List (List, Expr1);
+ return Null_Iir;
+ end if;
+ end if;
+ end loop;
+ if Res = Null_Iir then
+ Error_Overload (Expr1);
+ Disp_Overload_List (List, Expr1);
+ return Null_Iir;
+ end if;
+ return Sem_Expression_Ov (Expr1, Get_Base_Type (Res));
+ end Sem_Case_Expression;
+
+ function Sem_Condition (Cond : Iir) return Iir
+ is
+ Res : Iir;
+ Op : Iir;
+ begin
+ if Vhdl_Std < Vhdl_08 then
+ Res := Sem_Expression (Cond, Boolean_Type_Definition);
+
+ Check_Read (Res);
+ return Res;
+ else
+ -- LRM08 9.2.9
+ -- If, without overload resolution (see 12.5), the expression is
+ -- of type BOOLEAN defined in package STANDARD, or if, assuming a
+ -- rule requiring the expression to be of type BOOLEAN defined in
+ -- package STANDARD, overload resolution can determine at least one
+ -- interpretation of each constituent of the innermost complete
+ -- context including the expression, then the condition operator is
+ -- not applied.
+
+ -- GHDL: what does the second alternative mean ? Any example ?
+
+ Res := Sem_Expression_Ov (Cond, Null_Iir);
+
+ if Res = Null_Iir then
+ return Res;
+ end if;
+
+ if not Is_Overloaded (Res)
+ and then Get_Type (Res) = Boolean_Type_Definition
+ then
+ Check_Read (Res);
+ return Res;
+ end if;
+
+ -- LRM08 9.2.9
+ -- Otherwise, the condition operator is implicitely applied, and the
+ -- type of the expresion with the implicit application shall be
+ -- BOOLEAN defined in package STANDARD.
+
+ Op := Create_Iir (Iir_Kind_Condition_Operator);
+ Location_Copy (Op, Res);
+ Set_Operand (Op, Res);
+
+ Res := Sem_Operator (Op, Boolean_Type_Definition, 1);
+ Check_Read (Res);
+ return Res;
+ end if;
+ end Sem_Condition;
+
+end Sem_Expr;
diff --git a/src/sem_expr.ads b/src/sem_expr.ads
new file mode 100644
index 000000000..a0422e727
--- /dev/null
+++ b/src/sem_expr.ads
@@ -0,0 +1,178 @@
+-- Semantic analysis.
+-- 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 Sem_Expr is
+ -- Set semantic to EXPR.
+ -- Replace simple_name with the referenced node,
+ -- Set type to nodes,
+ -- Resolve overloading
+
+ Deferred_Constant_Allowed : Boolean := False;
+
+ -- Semantize an expression (other than a range) with a possible overloading.
+ -- Sem_expression_ov (and therefore sem_expression) must be called *once*
+ -- for each expression node with A_TYPE1 not null and at most *once* with
+ -- A_TYPE1 null.
+ --
+ -- When A_TYPE1 is null, sem_expression_ov find all possible types
+ -- of the expression. If there is only one possible type (ie, overloading
+ -- is non-existant or solved), then the type of the expression is set,
+ -- and the node is completly semantized. Sem_expression_ov must not
+ -- be called for such a node.
+ -- If there is several possible types (ie overloaded), then the type is
+ -- set with a list of overload. To finishes the semantisation,
+ -- sem_expression_ov must be called again with A_TYPE1 set to the
+ -- expected type.
+ --
+ -- If A_TYPE1 is set, sem_expression_ov must finishes the semantisation
+ -- of the expression, and set its type, which is not necessary a base type.
+ -- A_TYPE1 must be a base type.
+ --
+ -- In case of error, it displays a message and return null.
+ -- In case of success, it returns the semantized expression, which can
+ -- be different from EXPR (eg, a character literal is transformed into an
+ -- enumeration literal).
+ function Sem_Expression_Ov (Expr: Iir; A_Type1: Iir) return Iir;
+
+ -- If A_TYPE is not null, then EXPR must be of type A_TYPE.
+ -- Return null in case of error.
+ function Sem_Expression (Expr: Iir; A_Type: Iir) return Iir;
+
+ -- Same as Sem_Expression, but also implicitly choose an universal type
+ -- if overloaded.
+ function Sem_Expression_Universal (Expr : Iir) return Iir;
+
+ -- Same as Sem_Expression but specialized for a case expression.
+ -- (Handle specific overloading rules).
+ function Sem_Case_Expression (Expr : Iir) return Iir;
+
+ -- Sem COND as a condition.
+ -- In VHDL08, this follows 9.2.9 Condition operator.
+ -- In VHDL87 and 93, type of COND must be a boolean.
+ -- A check is made that COND can be read.
+ function Sem_Condition (Cond : Iir) return Iir;
+
+ -- Same as Sem_Expression but knowing that the type of EXPR must be a
+ -- composite type. Used for expressions in assignment statement when the
+ -- target is an aggregate.
+ function Sem_Composite_Expression (Expr : Iir) return Iir;
+
+ -- Check EXPR can be read.
+ procedure Check_Read (Expr : Iir);
+
+ -- Check EXPR can be updated.
+ procedure Check_Update (Expr : Iir);
+
+ -- Check the type of EXPR can be implicitly converted to TARG_TYPE, ie
+ -- if TARG_TYPE is a constrained array subtype, number of elements matches.
+ -- Return FALSE in case of error.
+ -- If TARG_TYPE or EXPR is NULL_IIR, silently returns TRUE.
+ function Check_Implicit_Conversion (Targ_Type : Iir; Expr : Iir)
+ return Boolean;
+
+ -- For a procedure call, A_TYPE must be null.
+ function Sem_Subprogram_Call (Expr: Iir; A_Type: Iir) return Iir;
+
+ -- If EXPR is a node for an expression, then return EXPR.
+ -- Otherwise, emit an error message using LOC as location
+ -- and return NULL_IIR.
+ -- If EXPR is NULL_IIR, NULL_IIR is silently returned.
+ function Check_Is_Expression (Expr : Iir; Loc : Iir) return Iir;
+
+ -- Semantize a procedure_call or a concurrent_procedure_call_statement.
+ -- A procedure call is not an expression but because most of the code
+ -- for procedure call is common with function call, procedure calls are
+ -- handled in this package.
+ procedure Sem_Procedure_Call (Call : Iir_Procedure_Call; Stmt : Iir);
+
+ -- Analyze a range (ie a range attribute or a range expression). If
+ -- ANY_DIR is true, the range can't be a null range (slice vs subtype,
+ -- used in static evaluation). A_TYPE may be Null_Iir.
+ -- Return Null_Iir in case of error, or EXPR analyzed (and evaluated if
+ -- possible).
+ function Sem_Range_Expression (Expr: Iir; A_Type: Iir; Any_Dir : Boolean)
+ return Iir;
+
+ -- Analyze a discrete range. If ANY_DIR is true, the range can't be a
+ -- null range (slice vs subtype -- used in static evaluation). A_TYPE may
+ -- be Null_Iir. Return Null_Iir in case of error.
+ function Sem_Discrete_Range_Expression
+ (Expr: Iir; A_Type: Iir; Any_Dir: Boolean) return Iir;
+
+ -- Semantize a discrete range and convert to integer if both bounds are
+ -- universal integer types, according to rules of LRM 3.2.1.1
+ function Sem_Discrete_Range_Integer (Expr: Iir) return Iir;
+
+ -- Transform LIT into a physical_literal.
+ -- LIT can be either a not semantized physical literal or
+ -- a simple name that is a physical unit. In the later case, a physical
+ -- literal is created.
+ function Sem_Physical_Literal (Lit: Iir) return Iir;
+
+ -- CHOICES_LIST is a list of choices (none, expression, range, list or
+ -- others).
+ -- If IS_SUB_RANGE is true, then SUB_TYPE may not be fully convered,
+ -- otherwise, SUB_TYPE must be fully covered.
+ -- This is used when the subtype of an aggregate must be determined.
+ -- SUB_TYPE is the discrete subtype.
+ -- Emit a message if:
+ -- * the SUB_TYPE is not fully covered by the choices
+ -- * the choices are not mutually exclusif (an element is present twice)
+ -- * OTHERS is not the last choice, or is present several times.
+ --
+ -- If there is at least one named choice, LOW and HIGH are set with the
+ -- lowest and highest index.
+ -- If LOW and HIGH are set, they are locally static.
+ --
+ -- Unidimensional strings are not handled here but by
+ -- sem_string_choices_range.
+ --
+ -- TODO:
+ -- * be smarter if only positional choices (do not create the list).
+ -- * smarter messages.
+ procedure Sem_Choices_Range
+ (Choice_Chain : in out Iir;
+ Sub_Type : Iir;
+ Is_Sub_Range : Boolean;
+ Is_Case_Stmt : Boolean;
+ Loc : Location_Type;
+ Low : out Iir;
+ High : out Iir);
+
+ -- Semantize CHOICE_LIST when the choice expression SEL is of a
+ -- one-dimensional character array type.
+ procedure Sem_String_Choices_Range (Choice_Chain : Iir; Sel : Iir);
+
+ -- LEFT are RIGHT must be really a type (not a subtype).
+ function Are_Basetypes_Compatible (Left: Iir; Right: Iir)
+ return Boolean;
+
+ -- Return TRUE iif types of LEFT and RIGHT are compatible.
+ function Are_Nodes_Compatible (Left: Iir; Right: Iir)
+ return Boolean;
+
+ -- Return TRUE iff the type of EXPR is compatible with A_TYPE
+ function Is_Expr_Compatible (A_Type : Iir; Expr : Iir) return Boolean;
+
+ -- LIST1, LIST2 are either a type node or an overload list of types.
+ -- Return THE type which is compatible with LIST1 are LIST2.
+ -- Return null_iir if there is no such type or if there are several types.
+ function Search_Compatible_Type (List1, List2 : Iir) return Iir;
+end Sem_Expr;
diff --git a/src/sem_inst.adb b/src/sem_inst.adb
new file mode 100644
index 000000000..a9ba7560e
--- /dev/null
+++ b/src/sem_inst.adb
@@ -0,0 +1,639 @@
+-- Package (and subprograms) instantiations
+
+-- When a package is instantiated, we need to 'duplicate' its declaration.
+-- This looks useless for analysis but it isn't: a type from a package
+-- instantiated twice declares two different types. Without duplication, we
+-- need to attach to each declaration its instance, which looks more expansive
+-- that duplicating the declaration.
+--
+-- Furthermore, for generic type interface, it looks a good idea to duplicate
+-- the body (macro expansion).
+--
+-- Duplicating is not trivial: internal links must be kept and external
+-- links preserved. A table is used to map nodes from the uninstantiated
+-- package to its duplicated node. Links from instantiated declaration to
+-- the original declaration are also stored in that table.
+
+with GNAT.Table;
+with Nodes;
+with Nodes_Meta;
+with Types; use Types;
+with Iirs_Utils; use Iirs_Utils;
+with Errorout; use Errorout;
+
+package body Sem_Inst is
+ -- Table of origin. This is an extension of vhdl nodes to track the
+ -- origin of a node. If a node has a non-null origin, then the node was
+ -- instantiated for the origin node.
+ --
+ -- Furthermore, during instantiation, we need to keep track of instantiated
+ -- nodes (ie nodes created by instantiation) used by references. As an
+ -- instance cannot be uninstantiated, there is no collisions, as soon as
+ -- such entries are cleaned after instantiation.
+ --
+ -- As an example, here are declarations of an uninstantiated package:
+ -- type Nat is range 0 to 1023;
+ -- constant N : Nat := 5;
+ -- A node Nat1 will be created from node Nat (an integer type definition).
+ -- The origin of Nat1 is Nat and this is true forever. During
+ -- instantiation, the instance of Nat is Nat1, so that the type of N will
+ -- be set to Nat1.
+ package Origin_Table is new GNAT.Table
+ (Table_Component_Type => Iir,
+ Table_Index_Type => Iir,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ procedure Expand_Origin_Table
+ is
+ use Nodes;
+ Last : constant Iir := Iirs.Get_Last_Node;
+ El: Iir;
+ begin
+ El := Origin_Table.Last;
+ if El < Last then
+ Origin_Table.Set_Last (Last);
+ Origin_Table.Table (El + 1 .. Last) := (others => Null_Iir);
+ end if;
+ end Expand_Origin_Table;
+
+ -- This is the public function; the table may not have been extended.
+ function Get_Origin (N : Iir) return Iir
+ is
+ -- Make the '<=' operator visible.
+ use Nodes;
+ begin
+ if N <= Origin_Table.Last then
+ return Origin_Table.Table (N);
+ else
+ return Null_Iir;
+ end if;
+ end Get_Origin;
+
+ -- This is the private function: the table *must* have been extended.
+ function Get_Instance (N : Iir) return Iir
+ is
+ -- Make '<=' operator visible for the assert.
+ use Nodes;
+ begin
+ pragma Assert (N <= Origin_Table.Last);
+ return Origin_Table.Table (N);
+ end Get_Instance;
+
+ procedure Set_Origin (N : Iir; Orig : Iir) is
+ begin
+ -- As nodes are created, we need to expand origin table.
+ Expand_Origin_Table;
+
+ pragma Assert (Orig = Null_Iir
+ or else Origin_Table.Table (N) = Null_Iir);
+ Origin_Table.Table (N) := Orig;
+ end Set_Origin;
+
+ type Instance_Entry_Type is record
+ -- Node
+ N : Iir;
+
+ -- Old value in Origin_Table.
+ Old_Origin : Iir;
+ end record;
+
+ type Instance_Index_Type is new Natural;
+
+ -- Table of previous values in Origin_Table. The first purpose of this
+ -- table is to be able to revert the calls to Set_Instance, so that a unit
+ -- can be instantiated several times. Keep the nodes that have been
+ -- instantiated is cheaper than walking the tree a second time.
+ -- The second purpose of this table is not yet implemented: being able to
+ -- have uninstantiated packages in instantiated packages. In that case,
+ -- the slot in Origin_Table cannot be the origin and the instance at the
+ -- same time.
+ package Prev_Instance_Table is new GNAT.Table
+ (Table_Component_Type => Instance_Entry_Type,
+ Table_Index_Type => Instance_Index_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 256,
+ Table_Increment => 100);
+
+ procedure Set_Instance (Orig : Iir; N : Iir)
+ is
+ use Nodes;
+ begin
+ pragma Assert (Orig <= Origin_Table.Last);
+
+ -- Save the old entry
+ Prev_Instance_Table.Append
+ (Instance_Entry_Type'(N => Orig,
+ Old_Origin => Origin_Table.Table (Orig)));
+
+ -- Set the entry.
+ Origin_Table.Table (Orig) := N;
+ end Set_Instance;
+
+ procedure Restore_Origin (Mark : Instance_Index_Type) is
+ begin
+ for I in reverse Mark + 1 .. Prev_Instance_Table.Last loop
+ declare
+ El : Instance_Entry_Type renames Prev_Instance_Table.Table (I);
+ begin
+ Origin_Table.Table (El.N) := El.Old_Origin;
+ end;
+ end loop;
+ Prev_Instance_Table.Set_Last (Mark);
+ end Restore_Origin;
+
+ -- The location to be used while instantiated nodes.
+ Instantiate_Loc : Location_Type;
+
+ function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir;
+
+ -- Instantiate a list. Simply create a new list and instantiate nodes of
+ -- that list.
+ function Instantiate_Iir_List (L : Iir_List; Is_Ref : Boolean)
+ return Iir_List
+ is
+ Res : Iir_List;
+ El : Iir;
+ begin
+ case L is
+ when Null_Iir_List
+ | Iir_List_All
+ | Iir_List_Others =>
+ return L;
+ when others =>
+ Res := Create_Iir_List;
+ for I in Natural loop
+ El := Get_Nth_Element (L, I);
+ exit when El = Null_Iir;
+ Append_Element (Res, Instantiate_Iir (El, Is_Ref));
+ end loop;
+ return Res;
+ end case;
+ end Instantiate_Iir_List;
+
+ -- Instantiate a chain. This is a special case to reduce stack depth.
+ function Instantiate_Iir_Chain (N : Iir) return Iir
+ is
+ First : Iir;
+ Last : Iir;
+ Next_N : Iir;
+ Next_R : Iir;
+ begin
+ if N = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ First := Instantiate_Iir (N, False);
+ Last := First;
+ Next_N := Get_Chain (N);
+ while Next_N /= Null_Iir loop
+ Next_R := Instantiate_Iir (Next_N, False);
+ Set_Chain (Last, Next_R);
+ Last := Next_R;
+ Next_N := Get_Chain (Next_N);
+ end loop;
+
+ return First;
+ end Instantiate_Iir_Chain;
+
+ procedure Instantiate_Iir_Field
+ (Res : Iir; N : Iir; F : Nodes_Meta.Fields_Enum)
+ is
+ use Nodes_Meta;
+ begin
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ declare
+ S : constant Iir := Get_Iir (N, F);
+ R : Iir;
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ R := Instantiate_Iir (S, False);
+ when Attr_Ref =>
+ R := Instantiate_Iir (S, True);
+ when Attr_Maybe_Ref =>
+ R := Instantiate_Iir (S, Get_Is_Ref (N));
+ when Attr_Chain =>
+ R := Instantiate_Iir_Chain (S);
+ when Attr_Chain_Next =>
+ R := Null_Iir;
+ when Attr_Of_Ref =>
+ -- Can only appear in list.
+ raise Internal_Error;
+ end case;
+ Set_Iir (Res, F, R);
+ end;
+ when Type_Iir_List =>
+ declare
+ S : constant Iir_List := Get_Iir_List (N, F);
+ R : Iir_List;
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ R := Instantiate_Iir_List (S, False);
+ when Attr_Of_Ref =>
+ R := Instantiate_Iir_List (S, True);
+ when others =>
+ -- Ref is specially handled in Instantiate_Iir.
+ -- Others cannot appear for lists.
+ raise Internal_Error;
+ end case;
+ Set_Iir_List (Res, F, R);
+ end;
+ when Type_PSL_NFA
+ | Type_PSL_Node =>
+ -- TODO
+ raise Internal_Error;
+ when Type_String_Id =>
+ Set_String_Id (Res, F, Get_String_Id (N, F));
+ when Type_Source_Ptr =>
+ Set_Source_Ptr (Res, F, Get_Source_Ptr (N, F));
+ when Type_Date_Type
+ | Type_Date_State_Type
+ | Type_Time_Stamp_Id =>
+ -- Can this happen ?
+ raise Internal_Error;
+ when Type_Base_Type =>
+ Set_Base_Type (Res, F, Get_Base_Type (N, F));
+ when Type_Iir_Constraint =>
+ Set_Iir_Constraint (Res, F, Get_Iir_Constraint (N, F));
+ when Type_Iir_Mode =>
+ Set_Iir_Mode (Res, F, Get_Iir_Mode (N, F));
+ when Type_Iir_Index32 =>
+ Set_Iir_Index32 (Res, F, Get_Iir_Index32 (N, F));
+ when Type_Iir_Int64 =>
+ Set_Iir_Int64 (Res, F, Get_Iir_Int64 (N, F));
+ when Type_Boolean =>
+ Set_Boolean (Res, F, Get_Boolean (N, F));
+ when Type_Iir_Staticness =>
+ Set_Iir_Staticness (Res, F, Get_Iir_Staticness (N, F));
+ when Type_Iir_All_Sensitized =>
+ Set_Iir_All_Sensitized (Res, F, Get_Iir_All_Sensitized (N, F));
+ when Type_Iir_Signal_Kind =>
+ Set_Iir_Signal_Kind (Res, F, Get_Iir_Signal_Kind (N, F));
+ when Type_Tri_State_Type =>
+ Set_Tri_State_Type (Res, F, Get_Tri_State_Type (N, F));
+ when Type_Iir_Pure_State =>
+ Set_Iir_Pure_State (Res, F, Get_Iir_Pure_State (N, F));
+ when Type_Iir_Delay_Mechanism =>
+ Set_Iir_Delay_Mechanism (Res, F, Get_Iir_Delay_Mechanism (N, F));
+ when Type_Iir_Lexical_Layout_Type =>
+ Set_Iir_Lexical_Layout_Type
+ (Res, F, Get_Iir_Lexical_Layout_Type (N, F));
+ when Type_Iir_Predefined_Functions =>
+ Set_Iir_Predefined_Functions
+ (Res, F, Get_Iir_Predefined_Functions (N, F));
+ when Type_Iir_Direction =>
+ Set_Iir_Direction (Res, F, Get_Iir_Direction (N, F));
+ when Type_Location_Type =>
+ Set_Location_Type (Res, F, Instantiate_Loc);
+ when Type_Iir_Int32 =>
+ Set_Iir_Int32 (Res, F, Get_Iir_Int32 (N, F));
+ when Type_Int32 =>
+ Set_Int32 (Res, F, Get_Int32 (N, F));
+ when Type_Iir_Fp64 =>
+ Set_Iir_Fp64 (Res, F, Get_Iir_Fp64 (N, F));
+ when Type_Token_Type =>
+ Set_Token_Type (Res, F, Get_Token_Type (N, F));
+ when Type_Name_Id =>
+ Set_Name_Id (Res, F, Get_Name_Id (N, F));
+ end case;
+ end Instantiate_Iir_Field;
+
+ function Instantiate_Iir (N : Iir; Is_Ref : Boolean) return Iir
+ is
+ Res : Iir;
+ begin
+ -- Nothing to do for null node.
+ if N = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- For a reference, do not create a new node.
+ if Is_Ref then
+ Res := Get_Instance (N);
+ if Res /= Null_Iir then
+ -- There is an instance for N.
+ return Res;
+ else
+ -- Reference outside the instance.
+ return N;
+ end if;
+ end if;
+
+ declare
+ use Nodes_Meta;
+ Kind : constant Iir_Kind := Get_Kind (N);
+ Fields : constant Fields_Array := Get_Fields (Kind);
+ F : Fields_Enum;
+ begin
+ Res := Get_Instance (N);
+
+ if Kind = Iir_Kind_Interface_Constant_Declaration
+ and then Get_Identifier (N) = Null_Identifier
+ and then Res /= Null_Iir
+ then
+ -- Anonymous constant interface declarations are the only nodes
+ -- that can be shared. Handle that very special case.
+ return Res;
+ end if;
+
+ pragma Assert (Res = Null_Iir);
+
+ -- Create a new node.
+ Res := Create_Iir (Kind);
+
+ -- The origin of this new node is N.
+ Set_Origin (Res, N);
+
+ -- And the instance of N is RES.
+ Set_Instance (N, Res);
+
+ Set_Location (Res, Instantiate_Loc);
+
+ for I in Fields'Range loop
+ F := Fields (I);
+
+ -- Fields that are handled specially.
+ case F is
+ when Field_Index_Subtype_List =>
+ -- Index_Subtype_List is always a reference, so retrieve
+ -- the instance of the referenced list. This is a special
+ -- case because there is no origins for list.
+ declare
+ List : Iir_List;
+ begin
+ case Kind is
+ when Iir_Kind_Array_Type_Definition =>
+ List := Get_Index_Subtype_Definition_List (Res);
+ when Iir_Kind_Array_Subtype_Definition =>
+ List := Get_Index_Constraint_List (Res);
+ if List = Null_Iir_List then
+ List := Get_Index_Subtype_List
+ (Get_Denoted_Type_Mark (Res));
+ end if;
+ when others =>
+ -- All the nodes where Index_Subtype_List appears
+ -- are handled above.
+ raise Internal_Error;
+ end case;
+ Set_Index_Subtype_List (Res, List);
+ end;
+
+ when others =>
+ -- Common case.
+ Instantiate_Iir_Field (Res, N, F);
+ end case;
+ end loop;
+
+ case Kind is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- Subprogram body is a forward declaration.
+ Set_Subprogram_Body (Res, Null_Iir);
+ when others =>
+ -- TODO: other forward references:
+ -- incomplete constant
+ -- attribute_value
+ null;
+ end case;
+
+ return Res;
+ end;
+ end Instantiate_Iir;
+
+ -- As the scope generic interfaces extends beyond the immediate scope (see
+ -- LRM08 12.2 Scope of declarations), they must be instantiated.
+ function Instantiate_Generic_Chain (Inst : Iir; Inters : Iir) return Iir
+ is
+ Inter : Iir;
+ First : Iir;
+ Last : Iir;
+ Res : Iir;
+ begin
+ First := Null_Iir;
+ Last := Null_Iir;
+
+ Inter := Inters;
+ while Inter /= Null_Iir loop
+ -- Create a copy of the interface. FIXME: is it really needed ?
+ Res := Create_Iir (Get_Kind (Inter));
+ Set_Location (Res, Instantiate_Loc);
+ Set_Parent (Res, Inst);
+ Set_Identifier (Res, Get_Identifier (Inter));
+ Set_Visible_Flag (Res, Get_Visible_Flag (Inter));
+
+ Set_Origin (Res, Inter);
+ Set_Instance (Inter, Res);
+
+ case Get_Kind (Res) is
+ when Iir_Kind_Interface_Constant_Declaration =>
+ Set_Type (Res, Get_Type (Inter));
+ Set_Subtype_Indication (Res, Get_Subtype_Indication (Inter));
+ Set_Mode (Res, Get_Mode (Inter));
+ Set_Lexical_Layout (Res, Get_Lexical_Layout (Inter));
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Inter));
+ Set_Name_Staticness (Res, Get_Name_Staticness (Inter));
+ when Iir_Kind_Interface_Package_Declaration =>
+ Set_Uninstantiated_Package_Name
+ (Res, Get_Uninstantiated_Package_Name (Inter));
+ when others =>
+ Error_Kind ("instantiate_generic_chain", Res);
+ end case;
+
+ -- Append
+ if First = Null_Iir then
+ First := Res;
+ else
+ Set_Chain (Last, Res);
+ end if;
+ Last := Res;
+
+ Inter := Get_Chain (Inter);
+ end loop;
+
+ return First;
+ end Instantiate_Generic_Chain;
+
+ procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir);
+ procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List);
+
+ procedure Set_Instance_On_Iir (N : Iir; Inst : Iir) is
+ begin
+ if N = Null_Iir then
+ pragma Assert (Inst = Null_Iir);
+ return;
+ end if;
+ pragma Assert (Inst /= Null_Iir);
+
+ declare
+ use Nodes_Meta;
+ Kind : constant Iir_Kind := Get_Kind (N);
+ Fields : constant Fields_Array := Get_Fields (Kind);
+ F : Fields_Enum;
+ begin
+ pragma Assert (Get_Kind (Inst) = Kind);
+
+ if Kind = Iir_Kind_Interface_Constant_Declaration
+ and then Get_Identifier (N) = Null_Identifier
+ then
+ -- Anonymous constant interface declarations are the only nodes
+ -- that can be shared. Handle that very special case.
+ return;
+ end if;
+
+ -- pragma Assert (Get_Instance (N) = Null_Iir);
+ Set_Instance (N, Inst);
+
+ for I in Fields'Range loop
+ F := Fields (I);
+
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ declare
+ S : constant Iir := Get_Iir (N, F);
+ S_Inst : constant Iir := Get_Iir (Inst, F);
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Set_Instance_On_Iir (S, S_Inst);
+ when Attr_Ref =>
+ null;
+ when Attr_Maybe_Ref =>
+ if not Get_Is_Ref (N) then
+ Set_Instance_On_Iir (S, S_Inst);
+ end if;
+ when Attr_Chain =>
+ Set_Instance_On_Chain (S, S_Inst);
+ when Attr_Chain_Next =>
+ null;
+ when Attr_Of_Ref =>
+ -- Can only appear in list.
+ raise Internal_Error;
+ end case;
+ end;
+ when Type_Iir_List =>
+ declare
+ S : constant Iir_List := Get_Iir_List (N, F);
+ S_Inst : constant Iir_List := Get_Iir_List (Inst, F);
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Set_Instance_On_Iir_List (S, S_Inst);
+ when Attr_Of_Ref
+ | Attr_Ref =>
+ null;
+ when others =>
+ -- Ref is specially handled in Instantiate_Iir.
+ -- Others cannot appear for lists.
+ raise Internal_Error;
+ end case;
+ end;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end;
+ end Set_Instance_On_Iir;
+
+ procedure Set_Instance_On_Iir_List (N : Iir_List; Inst : Iir_List)
+ is
+ El : Iir;
+ El_Inst : Iir;
+ begin
+ case N is
+ when Null_Iir_List
+ | Iir_List_All
+ | Iir_List_Others =>
+ pragma Assert (Inst = N);
+ return;
+ when others =>
+ for I in Natural loop
+ El := Get_Nth_Element (N, I);
+ El_Inst := Get_Nth_Element (Inst, I);
+ exit when El = Null_Iir;
+ pragma Assert (El_Inst /= Null_Iir);
+
+ Set_Instance_On_Iir (El, El_Inst);
+ end loop;
+ pragma Assert (El_Inst = Null_Iir);
+ end case;
+ end Set_Instance_On_Iir_List;
+
+ procedure Set_Instance_On_Chain (Chain : Iir; Inst_Chain : Iir)
+ is
+ El : Iir;
+ Inst_El : Iir;
+ begin
+ El := Chain;
+ Inst_El := Inst_Chain;
+ while El /= Null_Iir loop
+ pragma Assert (Inst_El /= Null_Iir);
+ Set_Instance_On_Iir (El, Inst_El);
+ El := Get_Chain (El);
+ Inst_El := Get_Chain (Inst_El);
+ end loop;
+ pragma Assert (Inst_El = Null_Iir);
+ end Set_Instance_On_Chain;
+
+ -- In the instance, replace references (and inner references) to interface
+ -- package declaration to the associated package.
+ procedure Instantiate_Generic_Map_Chain (Inst : Iir; Pkg : Iir)
+ is
+ pragma Unreferenced (Pkg);
+ Assoc : Iir;
+ begin
+ Assoc := Get_Generic_Map_Aspect_Chain (Inst);
+ while Assoc /= Null_Iir loop
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open =>
+ null;
+ when Iir_Kind_Association_Element_Package =>
+ declare
+ Sub_Inst : constant Iir :=
+ Get_Named_Entity (Get_Actual (Assoc));
+ Sub_Pkg : constant Iir := Get_Associated_Interface (Assoc);
+ begin
+ Set_Instance (Sub_Pkg, Sub_Inst);
+ Set_Instance_On_Chain (Get_Generic_Chain (Sub_Pkg),
+ Get_Generic_Chain (Sub_Inst));
+ Set_Instance_On_Chain (Get_Declaration_Chain (Sub_Pkg),
+ Get_Declaration_Chain (Sub_Inst));
+ end;
+ when others =>
+ Error_Kind ("instantiate_generic_map_chain", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Instantiate_Generic_Map_Chain;
+
+ procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir)
+ is
+ Header : constant Iir := Get_Package_Header (Pkg);
+ Prev_Loc : constant Location_Type := Instantiate_Loc;
+ Mark : constant Instance_Index_Type := Prev_Instance_Table.Last;
+ begin
+ Instantiate_Loc := Get_Location (Inst);
+
+ -- Be sure Get_Origin_Priv can be called on existing nodes.
+ Expand_Origin_Table;
+
+ -- For Parent: the instance of PKG is INST.
+ Set_Origin (Pkg, Inst);
+
+ Set_Generic_Chain
+ (Inst, Instantiate_Generic_Chain (Inst, Get_Generic_Chain (Header)));
+ Instantiate_Generic_Map_Chain (Inst, Pkg);
+ Set_Declaration_Chain
+ (Inst, Instantiate_Iir_Chain (Get_Declaration_Chain (Pkg)));
+
+ Set_Origin (Pkg, Null_Iir);
+
+ Instantiate_Loc := Prev_Loc;
+ Restore_Origin (Mark);
+ end Instantiate_Package_Declaration;
+end Sem_Inst;
diff --git a/src/sem_inst.ads b/src/sem_inst.ads
new file mode 100644
index 000000000..da8cd5d27
--- /dev/null
+++ b/src/sem_inst.ads
@@ -0,0 +1,26 @@
+-- Package (and subprograms) instantiations
+
+-- When a package is instantiated, we need to 'duplicate' its declaration.
+-- This looks useless for analysis but it isn't: a type from a package
+-- instantiated twice declares two different types. Without duplication, we
+-- need to attach to each declaration its instance, which looks more expansive
+-- that duplicating the declaration.
+--
+-- Furthermore, for generic type interface, it looks a good idea to duplicate
+-- the body (macro expansion).
+--
+-- Duplicating is not trivial: internal links must be kept and external
+-- links preserved. A table is used to map nodes from the uninstantiated
+-- package to its duplicated node. Links from instantiated declaration to
+-- the original declaration are also stored in that table.
+
+with Iirs; use Iirs;
+
+package Sem_Inst is
+ -- Return the origin of node N, the node from which N was instantiated.
+ -- If N is not an instance, this function returns Null_Iir.
+ function Get_Origin (N : Iir) return Iir;
+
+ -- Create declaration chain and generic declarations for INST from PKG.
+ procedure Instantiate_Package_Declaration (Inst : Iir; Pkg : Iir);
+end Sem_Inst;
diff --git a/src/sem_names.adb b/src/sem_names.adb
new file mode 100644
index 000000000..151e81708
--- /dev/null
+++ b/src/sem_names.adb
@@ -0,0 +1,3788 @@
+-- Semantic analysis.
+-- 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 Evaluation; use Evaluation;
+with Iirs_Utils; use Iirs_Utils;
+with Libraries;
+with Errorout; use Errorout;
+with Flags; use Flags;
+with Name_Table;
+with Std_Package; use Std_Package;
+with Types; use Types;
+with Iir_Chains; use Iir_Chains;
+with Std_Names;
+with Sem;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Expr; use Sem_Expr;
+with Sem_Stmts; use Sem_Stmts;
+with Sem_Decls; use Sem_Decls;
+with Sem_Assocs; use Sem_Assocs;
+with Sem_Types;
+with Sem_Psl;
+with Xrefs; use Xrefs;
+
+package body Sem_Names is
+ -- Finish the semantization of NAME using RES as named entity.
+ -- This is called when the semantization is finished and an uniq
+ -- interpretation has been determined (RES).
+ --
+ -- Error messages are emitted here.
+ function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir;
+
+ procedure Error_Overload (Expr: Iir) is
+ begin
+ Error_Msg_Sem ("can't resolve overload for " & Disp_Node (Expr), Expr);
+ end Error_Overload;
+
+ procedure Disp_Overload_List (List : Iir_List; Loc : Iir)
+ is
+ El : Iir;
+ begin
+ Error_Msg_Sem ("possible interpretations are:", Loc);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Error_Msg_Sem (Disp_Subprg (El), El);
+ when Iir_Kind_Function_Call =>
+ El := Get_Implementation (El);
+ Error_Msg_Sem (Disp_Subprg (El), El);
+ when others =>
+ Error_Msg_Sem (Disp_Node (El), El);
+ end case;
+ end loop;
+ end Disp_Overload_List;
+
+ -- Create an overload list.
+ -- must be destroyed with free_iir.
+ function Get_Overload_List return Iir_Overload_List
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Overload_List);
+ return Res;
+ end Get_Overload_List;
+
+ function Create_Overload_List (List : Iir_List) return Iir_Overload_List
+ is
+ Res : Iir_Overload_List;
+ begin
+ Res := Get_Overload_List;
+ Set_Overload_List (Res, List);
+ return Res;
+ end Create_Overload_List;
+
+ procedure Free_Overload_List (N : in out Iir_Overload_List)
+ is
+ List : Iir_List;
+ begin
+ List := Get_Overload_List (N);
+ Destroy_Iir_List (List);
+ Free_Iir (N);
+ N := Null_Iir;
+ end Free_Overload_List;
+
+ function Simplify_Overload_List (List : Iir_List) return Iir
+ is
+ Res : Iir;
+ L1 : Iir_List;
+ begin
+ case Get_Nbr_Elements (List) is
+ when 0 =>
+ L1 := List;
+ Destroy_Iir_List (L1);
+ return Null_Iir;
+ when 1 =>
+ L1 := List;
+ Res := Get_First_Element (List);
+ Destroy_Iir_List (L1);
+ return Res;
+ when others =>
+ return Create_Overload_List (List);
+ end case;
+ end Simplify_Overload_List;
+
+ -- Return true if AN_IIR is an overload list.
+ function Is_Overload_List (An_Iir: Iir) return Boolean is
+ begin
+ return Get_Kind (An_Iir) = Iir_Kind_Overload_List;
+ end Is_Overload_List;
+
+ -- From the list LIST of function or enumeration literal, extract the
+ -- list of (return) types.
+ -- If there is only one type, return it.
+ -- If there is no types, return NULL.
+ -- Otherwise, return the list as an overload list.
+ function Create_List_Of_Types (List : Iir_List)
+ return Iir
+ is
+ Res_List : Iir_List;
+ Decl : Iir;
+ begin
+ -- Create the list of possible return types.
+ Res_List := Create_Iir_List;
+ for I in Natural loop
+ Decl := Get_Nth_Element (List, I);
+ exit when Decl = Null_Iir;
+ case Get_Kind (Decl) is
+ when Iir_Kinds_Function_Declaration =>
+ Add_Element (Res_List, Get_Return_Type (Decl));
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element =>
+ Add_Element (Res_List, Get_Type (Decl));
+ when others =>
+ Error_Kind ("create_list_of_types", Decl);
+ end case;
+ end loop;
+ return Simplify_Overload_List (Res_List);
+ end Create_List_Of_Types;
+
+ procedure Add_Result (Res : in out Iir; Decl : Iir)
+ is
+ Nres : Iir;
+ Nres_List : Iir_List;
+ begin
+ if Decl = Null_Iir then
+ return;
+ end if;
+ if Res = Null_Iir then
+ Res := Decl;
+ elsif Is_Overload_List (Res) then
+ Append_Element (Get_Overload_List (Res), Decl);
+ else
+ Nres_List := Create_Iir_List;
+ Nres := Create_Overload_List (Nres_List);
+ Append_Element (Nres_List, Res);
+ Append_Element (Nres_List, Decl);
+ Res := Nres;
+ end if;
+ end Add_Result;
+
+ -- Move elements of result list LIST to result list RES.
+ -- Destroy LIST if necessary.
+ procedure Add_Result_List (Res : in out Iir; List : Iir);
+ pragma Unreferenced (Add_Result_List);
+
+ procedure Add_Result_List (Res : in out Iir; List : Iir)
+ is
+ El : Iir;
+ List_List : Iir_List;
+ Res_List : Iir_List;
+ begin
+ if Res = Null_Iir then
+ Res := List;
+ elsif List = Null_Iir then
+ null;
+ elsif not Is_Overload_List (List) then
+ Add_Result (Res, List);
+ else
+ if not Is_Overload_List (Res) then
+ El := Res;
+ Res := Get_Overload_List;
+ Append_Element (Get_Overload_List (Res), El);
+ end if;
+ List_List := Get_Overload_List (List);
+ Res_List := Get_Overload_List (Res);
+ for I in Natural loop
+ El := Get_Nth_Element (List_List, I);
+ exit when El = Null_Iir;
+ Append_Element (Res_List, El);
+ end loop;
+ Free_Iir (List);
+ end if;
+ end Add_Result_List;
+
+ -- Free interpretations of LIST except KEEP.
+ procedure Sem_Name_Free_Result (List : Iir; Keep : Iir)
+ is
+ procedure Sem_Name_Free (El : Iir) is
+ begin
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Call
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element =>
+ Sem_Name_Free (Get_Prefix (El));
+ Free_Iir (El);
+ when Iir_Kind_Attribute_Name =>
+ Free_Iir (El);
+ when Iir_Kinds_Function_Declaration
+ | Iir_Kinds_Procedure_Declaration
+ | Iir_Kind_Enumeration_Literal =>
+ null;
+ when Iir_Kinds_Denoting_Name =>
+ null;
+ when others =>
+ Error_Kind ("sem_name_free", El);
+ end case;
+ end Sem_Name_Free;
+
+ El : Iir;
+ List_List : Iir_List;
+ begin
+ if List = Null_Iir then
+ return;
+ elsif not Is_Overload_List (List) then
+ if List /= Keep then
+ Sem_Name_Free (List);
+ end if;
+ else
+ List_List := Get_Overload_List (List);
+ for I in Natural loop
+ El := Get_Nth_Element (List_List, I);
+ exit when El = Null_Iir;
+ if El /= Keep then
+ Sem_Name_Free (El);
+ end if;
+ end loop;
+ Free_Iir (List);
+ end if;
+ end Sem_Name_Free_Result;
+
+ procedure Free_Parenthesis_Name (Name : Iir; Res : Iir)
+ is
+ Chain, Next_Chain : Iir;
+ begin
+ pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call);
+ Chain := Get_Association_Chain (Name);
+ while Chain /= Null_Iir loop
+ Next_Chain := Get_Chain (Chain);
+ Free_Iir (Chain);
+ Chain := Next_Chain;
+ end loop;
+ Free_Iir (Name);
+ end Free_Parenthesis_Name;
+
+ -- Find all named declaration whose identifier is ID in DECL_LIST and
+ -- return it.
+ -- The result can be NULL (if no such declaration exist),
+ -- a declaration, or an overload_list containing all declarations.
+ function Find_Declarations_In_List
+ (Decl: Iir; Name : Iir_Selected_Name; Keep_Alias : Boolean)
+ return Iir
+ is
+ Res: Iir := Null_Iir;
+
+ -- If indentifier of DECL is ID, then add DECL in the result.
+ procedure Handle_Decl (Decl : Iir; Id : Name_Id) is
+ begin
+ -- Use_clauses may appear in a declaration list.
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ return;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ if Get_Identifier (Decl) = Id then
+ if Keep_Alias then
+ Add_Result (Res, Decl);
+ else
+ Add_Result (Res, Get_Named_Entity (Get_Name (Decl)));
+ end if;
+ end if;
+ when others =>
+ if Get_Identifier (Decl) = Id then
+ Add_Result (Res, Decl);
+ end if;
+ end case;
+ end Handle_Decl;
+
+ procedure Iterator_Decl is new Sem_Scopes.Iterator_Decl
+ (Arg_Type => Name_Id, Handle_Decl => Handle_Decl);
+ --procedure Iterator_Decl_List is new Sem_Scopes.Iterator_Decl_List
+ -- (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl);
+ procedure Iterator_Decl_Chain is new Sem_Scopes.Iterator_Decl_Chain
+ (Arg_Type => Name_Id, Handle_Decl => Iterator_Decl);
+
+ Id : Name_Id;
+ Decl_Body : Iir;
+ begin
+ Id := Get_Identifier (Name);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Iterator_Decl_Chain (Get_Interface_Declaration_Chain (Decl), Id);
+ when Iir_Kind_Entity_Declaration =>
+ Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id);
+ Iterator_Decl_Chain (Get_Port_Chain (Decl), Id);
+ when Iir_Kind_Architecture_Body =>
+ null;
+ when Iir_Kind_Generate_Statement =>
+ null;
+ when Iir_Kind_Package_Declaration =>
+ null;
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Iterator_Decl_Chain (Get_Generic_Chain (Decl), Id);
+ when Iir_Kind_Block_Statement =>
+ declare
+ Header : constant Iir := Get_Block_Header (Decl);
+ begin
+ if Header /= Null_Iir then
+ Iterator_Decl_Chain (Get_Generic_Chain (Header), Id);
+ Iterator_Decl_Chain (Get_Port_Chain (Header), Id);
+ end if;
+ end;
+ when Iir_Kind_For_Loop_Statement =>
+ Handle_Decl (Get_Parameter_Specification (Decl), Id);
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ null;
+ when others =>
+ Error_Kind ("find_declarations_in_list", Decl);
+ end case;
+
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Decl_Body := Get_Subprogram_Body (Decl);
+ Iterator_Decl_Chain
+ (Get_Declaration_Chain (Decl_Body), Id);
+ Iterator_Decl_Chain
+ (Get_Sequential_Statement_Chain (Decl_Body), Id);
+ when Iir_Kind_Architecture_Body
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Block_Statement =>
+ Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id);
+ Iterator_Decl_Chain (Get_Concurrent_Statement_Chain (Decl), Id);
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id);
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Iterator_Decl_Chain (Get_Declaration_Chain (Decl), Id);
+ Iterator_Decl_Chain (Get_Sequential_Statement_Chain (Decl), Id);
+ when Iir_Kind_For_Loop_Statement =>
+ null;
+ when others =>
+ Error_Kind ("find_declarations_in_list", Decl);
+ end case;
+ --if Res = Null_Iir then
+ -- Error_Msg_Sem ("""" & Name_Table.Image (Id) & """ not defined in "
+ -- & Disp_Node (Decl), Name);
+ --end if;
+ return Res;
+ end Find_Declarations_In_List;
+
+ -- Create an implicit_dereference node if PREFIX is of type access.
+ -- Return PREFIX otherwise.
+ -- PARENT is used if an implicit dereference node is created, to copy
+ -- location from.
+ function Insert_Implicit_Dereference (Prefix : Iir; Parent : Iir)
+ return Iir
+ is
+ Prefix_Type : Iir;
+ Res : Iir_Implicit_Dereference;
+ begin
+ Prefix_Type := Get_Type (Prefix);
+
+ case Get_Kind (Prefix_Type) is
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when others =>
+ return Prefix;
+ end case;
+ Check_Read (Prefix);
+ Res := Create_Iir (Iir_Kind_Implicit_Dereference);
+ Location_Copy (Res, Parent);
+ Set_Type (Res, Get_Designated_Type (Prefix_Type));
+ Set_Prefix (Res, Prefix);
+ Set_Base_Name (Res, Res);
+ Set_Expr_Staticness (Res, None);
+ return Res;
+ end Insert_Implicit_Dereference;
+
+ -- If PREFIX is a function specification that cannot be converted to a
+ -- function call (because of lack of association), return FALSE.
+ function Maybe_Function_Call (Prefix : Iir) return Boolean
+ is
+ Inter : Iir;
+ begin
+ if Get_Kind (Prefix) not in Iir_Kinds_Function_Declaration then
+ return True;
+ end if;
+ Inter := Get_Interface_Declaration_Chain (Prefix);
+ while Inter /= Null_Iir loop
+ if Get_Default_Value (Inter) = Null_Iir then
+ return False;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ return True;
+ end Maybe_Function_Call;
+
+ procedure Name_To_Method_Object (Call : Iir; Name : Iir)
+ is
+ Prefix : Iir;
+ Obj : Iir;
+ begin
+ if Get_Kind (Name) /= Iir_Kind_Selected_Name then
+ return;
+ end if;
+
+ Prefix := Get_Prefix (Name);
+ Obj := Get_Named_Entity (Prefix);
+ if Obj /= Null_Iir
+ and then Kind_In (Obj, Iir_Kind_Variable_Declaration,
+ Iir_Kind_Interface_Variable_Declaration)
+ and then Get_Type (Obj) /= Null_Iir
+ then
+ if Get_Kind (Get_Type (Obj)) /= Iir_Kind_Protected_Type_Declaration
+ then
+ Error_Msg_Sem ("type of the prefix should be a protected type",
+ Prefix);
+ return;
+ end if;
+ Set_Method_Object (Call, Obj);
+ end if;
+ end Name_To_Method_Object;
+
+ -- NAME is the name of the function (and not the parenthesis name)
+ function Sem_As_Function_Call (Name : Iir; Spec : Iir; Assoc_Chain : Iir)
+ return Iir_Function_Call
+ is
+ Call : Iir_Function_Call;
+ begin
+ -- Check.
+ pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name);
+
+ Call := Create_Iir (Iir_Kind_Function_Call);
+ Location_Copy (Call, Name);
+ if Get_Kind (Name) = Iir_Kind_Parenthesis_Name then
+ Set_Prefix (Call, Get_Prefix (Name));
+ else
+ Set_Prefix (Call, Name);
+ end if;
+ Name_To_Method_Object (Call, Name);
+ Set_Implementation (Call, Spec);
+ Set_Parameter_Association_Chain (Call, Assoc_Chain);
+ Set_Type (Call, Get_Return_Type (Spec));
+ Set_Base_Name (Call, Call);
+ return Call;
+ end Sem_As_Function_Call;
+
+ -- If SPEC is a function specification, then return a function call,
+ -- else return SPEC.
+ function Maybe_Insert_Function_Call (Name : Iir; Spec : Iir) return Iir
+ is
+ begin
+ if Get_Kind (Spec) in Iir_Kinds_Function_Declaration then
+ return Sem_As_Function_Call (Name, Spec, Null_Iir);
+ else
+ return Spec;
+ end if;
+ end Maybe_Insert_Function_Call;
+
+ -- If PTR_TYPE is not NULL_IIR, then return an implciti dereference to
+ -- PREFIX, else return PREFIX.
+ function Maybe_Insert_Dereference (Prefix : Iir; Ptr_Type : Iir) return Iir
+ is
+ Id : Iir;
+ begin
+ if Ptr_Type /= Null_Iir then
+ Id := Create_Iir (Iir_Kind_Implicit_Dereference);
+ Location_Copy (Id, Prefix);
+ Set_Type (Id, Get_Designated_Type (Ptr_Type));
+ Set_Prefix (Id, Prefix);
+ Set_Base_Name (Id, Id);
+ return Id;
+ else
+ return Prefix;
+ end if;
+ end Maybe_Insert_Dereference;
+
+ procedure Finish_Sem_Indexed_Name (Expr : Iir)
+ is
+ Prefix : constant Iir := Get_Prefix (Expr);
+ Prefix_Type : constant Iir := Get_Type (Prefix);
+ Index_List : constant Iir_List := Get_Index_List (Expr);
+ Index_Subtype : Iir;
+ Index : Iir;
+ Expr_Staticness : Iir_Staticness;
+ begin
+ Expr_Staticness := Locally;
+
+ -- LRM93 �6.4: there must be one such expression for each index
+ -- position of the array and each expression must be of the
+ -- type of the corresponding index.
+ -- Loop on the indexes.
+ for I in Natural loop
+ Index_Subtype := Get_Index_Type (Prefix_Type, I);
+ exit when Index_Subtype = Null_Iir;
+ Index := Get_Nth_Element (Index_List, I);
+ -- The index_subtype can be an unconstrained index type.
+ Index := Check_Is_Expression (Index, Index);
+ if Index /= Null_Iir then
+ Index := Sem_Expression (Index, Get_Base_Type (Index_Subtype));
+ end if;
+ if Index /= Null_Iir then
+ if Get_Expr_Staticness (Index) = Locally
+ and then Get_Type_Staticness (Index_Subtype) = Locally
+ then
+ Index := Eval_Expr_Check (Index, Index_Subtype);
+ end if;
+ Replace_Nth_Element (Get_Index_List (Expr), I, Index);
+ Expr_Staticness := Min (Expr_Staticness,
+ Get_Expr_Staticness (Index));
+ else
+ Expr_Staticness := None;
+ end if;
+ end loop;
+
+ Set_Type (Expr, Get_Element_Subtype (Prefix_Type));
+
+ -- An indexed name cannot be locally static.
+ Set_Expr_Staticness
+ (Expr, Min (Globally, Min (Expr_Staticness,
+ Get_Expr_Staticness (Prefix))));
+
+ -- LRM93 �6.1:
+ -- a name is said to be a static name iff:
+ -- The name is an indexed name whose prefix is a static name
+ -- and every expression that appears as part of the name is a
+ -- static expression.
+ --
+ -- a name is said to be a locally static name iif:
+ -- The name is an indexed name whose prefix is a locally
+ -- static name and every expression that appears as part
+ -- of the name is a locally static expression.
+ Set_Name_Staticness (Expr, Min (Expr_Staticness,
+ Get_Name_Staticness (Prefix)));
+
+ Set_Base_Name (Expr, Get_Base_Name (Prefix));
+ end Finish_Sem_Indexed_Name;
+
+ procedure Finish_Sem_Dereference (Res : Iir)
+ is
+ begin
+ Set_Base_Name (Res, Res);
+ Check_Read (Get_Prefix (Res));
+ Set_Expr_Staticness (Res, None);
+ Set_Name_Staticness (Res, None);
+ end Finish_Sem_Dereference;
+
+ procedure Finish_Sem_Slice_Name (Name : Iir_Slice_Name)
+ is
+ -- The prefix of the slice
+ Prefix : constant Iir := Get_Prefix (Name);
+ Prefix_Type : constant Iir := Get_Type (Prefix);
+ Prefix_Base_Type : Iir;
+ Prefix_Bt : constant Iir := Get_Base_Type (Prefix_Type);
+ Index_List: Iir_List;
+ Index_Type: Iir;
+ Suffix: Iir;
+ Slice_Type : Iir;
+ Expr_Type : Iir;
+ Staticness : Iir_Staticness;
+ Prefix_Rng : Iir;
+ begin
+ Set_Base_Name (Name, Get_Base_Name (Prefix));
+
+ -- LRM93 �6.5: the prefix of an indexed name must be appropriate
+ -- for an array type.
+ if Get_Kind (Prefix_Bt) /= Iir_Kind_Array_Type_Definition then
+ Error_Msg_Sem ("slice can only be applied to an array", Name);
+ return;
+ end if;
+
+ -- LRM93 �6.5:
+ -- The prefix of a slice must be appropriate for a
+ -- one-dimensionnal array object.
+ Index_List := Get_Index_Subtype_List (Prefix_Type);
+ if Get_Nbr_Elements (Index_List) /= 1 then
+ Error_Msg_Sem ("slice prefix must be an unidimensional array", Name);
+ return;
+ end if;
+
+ Index_Type := Get_Index_Type (Index_List, 0);
+ Prefix_Rng := Eval_Static_Range (Index_Type);
+
+ -- LRM93 6.5
+ -- It is an error if either the bounds of the discrete range does not
+ -- belong to the index range of the prefixing array, *unless* the slice
+ -- is a null slice.
+ --
+ -- LRM93 6.5
+ -- The slice is a null slice if the discrete range is a null range.
+
+ -- LRM93 �6.5:
+ -- The bounds of the discrete range [...] must be of the
+ -- type of the index of the array.
+ Suffix := Sem_Discrete_Range_Expression
+ (Get_Suffix (Name), Index_Type, False);
+ if Suffix = Null_Iir then
+ return;
+ end if;
+ Suffix := Eval_Range_If_Static (Suffix);
+ Set_Suffix (Name, Suffix);
+
+ -- LRM93 �6.5:
+ -- It is an error if the direction of the discrete range is not
+ -- the same as that of the index range of the array denoted
+ -- by the prefix of the slice name.
+
+ -- Check this only if the type is a constrained type.
+ if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Index_Constraint_Flag (Prefix_Type)
+ and then Get_Expr_Staticness (Suffix) = Locally
+ and then Prefix_Rng /= Null_Iir
+ and then Get_Direction (Suffix) /= Get_Direction (Prefix_Rng)
+ then
+ if False and then Flags.Vhdl_Std = Vhdl_87 then
+ -- emit a warning for a null slice.
+ Warning_Msg_Sem
+ ("direction mismatch results in a null slice", Name);
+ end if;
+ Error_Msg_Sem ("direction of the range mismatch", Name);
+ end if;
+
+ -- LRM93 �7.4.1
+ -- A slice is never a locally static expression.
+ case Get_Kind (Suffix) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Suffix := Get_Type (Suffix);
+ Staticness := Get_Type_Staticness (Suffix);
+ when Iir_Kind_Range_Expression
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ Staticness := Get_Expr_Staticness (Suffix);
+ when others =>
+ Error_Kind ("finish_sem_slice_name", Suffix);
+ end case;
+ Set_Expr_Staticness
+ (Name, Min (Min (Staticness, Get_Expr_Staticness (Prefix)), Globally));
+ Set_Name_Staticness
+ (Name, Min (Staticness, Get_Name_Staticness (Prefix)));
+
+ -- The type of the slice is a subtype of the base type whose
+ -- range contraint is the slice itself.
+ if Get_Kind (Suffix) in Iir_Kinds_Discrete_Type_Definition then
+ Slice_Type := Suffix;
+ else
+ case Get_Kind (Get_Base_Type (Index_Type)) is
+ when Iir_Kind_Integer_Type_Definition =>
+ Slice_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Slice_Type :=
+ Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when others =>
+ Error_Kind ("sem_expr: slice_name", Get_Base_Type (Index_Type));
+ end case;
+ Set_Range_Constraint (Slice_Type, Suffix);
+ Set_Type_Staticness (Slice_Type, Staticness);
+ Set_Base_Type (Slice_Type, Get_Base_Type (Index_Type));
+ Set_Location (Slice_Type, Get_Location (Suffix));
+ end if;
+
+ Expr_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Location (Expr_Type, Get_Location (Suffix));
+ Set_Index_Subtype_List (Expr_Type, Create_Iir_List);
+ Prefix_Base_Type := Get_Base_Type (Prefix_Type);
+ Set_Base_Type (Expr_Type, Prefix_Base_Type);
+ Set_Signal_Type_Flag (Expr_Type,
+ Get_Signal_Type_Flag (Prefix_Base_Type));
+ Append_Element (Get_Index_Subtype_List (Expr_Type), Slice_Type);
+ Set_Element_Subtype (Expr_Type, Get_Element_Subtype (Prefix_Type));
+ if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition then
+ Set_Resolution_Indication
+ (Expr_Type, Get_Resolution_Indication (Prefix_Type));
+ else
+ Set_Resolution_Indication (Expr_Type, Null_Iir);
+ end if;
+ Set_Type_Staticness
+ (Expr_Type, Min (Get_Type_Staticness (Prefix_Type),
+ Get_Type_Staticness (Slice_Type)));
+ Set_Type (Name, Expr_Type);
+ Set_Slice_Subtype (Name, Expr_Type);
+ Set_Index_Constraint_Flag (Expr_Type, True);
+ Set_Constraint_State (Expr_Type, Fully_Constrained);
+ if Is_Signal_Object (Prefix) then
+ Sem_Types.Set_Type_Has_Signal (Expr_Type);
+ end if;
+ end Finish_Sem_Slice_Name;
+
+ -- PREFIX is the name denoting the function declaration, and its analysis
+ -- is already finished.
+ procedure Finish_Sem_Function_Call (Call : Iir; Prefix : Iir)
+ is
+ Rtype : Iir;
+ begin
+ Set_Prefix (Call, Prefix);
+ Set_Implementation (Call, Get_Named_Entity (Prefix));
+
+ -- LRM08 8.1 Names
+ -- The name is a simple name or seleted name that does NOT denote a
+ -- function call [...]
+ --
+ -- GHDL: so function calls are never static names.
+ Set_Name_Staticness (Call, None);
+
+ -- FIXME: modify sem_subprogram_call to avoid such a type swap.
+ Rtype := Get_Type (Call);
+ Set_Type (Call, Null_Iir);
+ if Sem_Subprogram_Call (Call, Null_Iir) = Null_Iir then
+ Set_Type (Call, Rtype);
+ end if;
+ end Finish_Sem_Function_Call;
+
+ function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False)
+ return Iir
+ is
+ Atype : Iir;
+ Res : Iir;
+ begin
+ -- The name must not have been analyzed.
+ pragma Assert (Get_Type (Name) = Null_Iir);
+
+ -- Analyze the name (if not already done).
+ if Get_Named_Entity (Name) = Null_Iir then
+ Sem_Name (Name);
+ end if;
+ Res := Finish_Sem_Name (Name);
+
+ if Get_Kind (Res) in Iir_Kinds_Denoting_Name then
+ -- Common correct case.
+ Atype := Get_Named_Entity (Res);
+ if Get_Kind (Atype) = Iir_Kind_Type_Declaration then
+ Atype := Get_Type_Definition (Atype);
+ elsif Get_Kind (Atype) = Iir_Kind_Subtype_Declaration then
+ Atype := Get_Type (Atype);
+ else
+ Error_Msg_Sem
+ ("a type mark must denote a type or a subtype", Name);
+ Atype := Create_Error_Type (Atype);
+ Set_Named_Entity (Res, Atype);
+ end if;
+ else
+ if Get_Kind (Res) /= Iir_Kind_Error then
+ Error_Msg_Sem
+ ("a type mark must be a simple or expanded name", Name);
+ end if;
+ Res := Name;
+ Atype := Create_Error_Type (Name);
+ Set_Named_Entity (Res, Atype);
+ end if;
+
+ if not Incomplete then
+ if Get_Kind (Atype) = Iir_Kind_Incomplete_Type_Definition then
+ Error_Msg_Sem
+ ("invalid use of an incomplete type definition", Name);
+ Atype := Create_Error_Type (Name);
+ Set_Named_Entity (Res, Atype);
+ end if;
+ end if;
+
+ Set_Type (Res, Atype);
+
+ return Res;
+ end Sem_Type_Mark;
+
+ procedure Finish_Sem_Array_Attribute
+ (Attr_Name : Iir; Attr : Iir; Param : Iir)
+ is
+ Parameter : Iir;
+ Prefix_Type : Iir;
+ Index_Type : Iir;
+ Prefix : Iir;
+ Prefix_Name : Iir;
+ Staticness : Iir_Staticness;
+ begin
+ -- LRM93 14.1
+ -- Parameter: A locally static expression of type universal_integer, the
+ -- value of which must not exceed the dimensionality of A. If omitted,
+ -- it defaults to 1.
+ if Param = Null_Iir then
+ Parameter := Universal_Integer_One;
+ else
+ Parameter := Sem_Expression
+ (Param, Universal_Integer_Type_Definition);
+ if Parameter = Null_Iir then
+ Parameter := Universal_Integer_One;
+ else
+ if Get_Expr_Staticness (Parameter) /= Locally then
+ Error_Msg_Sem ("parameter must be locally static", Parameter);
+ Parameter := Universal_Integer_One;
+ end if;
+ end if;
+ end if;
+
+ Prefix_Name := Get_Prefix (Attr_Name);
+ if Is_Type_Name (Prefix_Name) /= Null_Iir then
+ Prefix := Sem_Type_Mark (Prefix_Name);
+ else
+ Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr));
+ end if;
+ Set_Prefix (Attr, Prefix);
+
+ Prefix_Type := Get_Type (Prefix);
+ if Is_Error (Prefix_Type) then
+ return;
+ end if;
+
+ declare
+ Dim : Iir_Int64;
+ Indexes_List : constant Iir_List :=
+ Get_Index_Subtype_List (Prefix_Type);
+ begin
+ Dim := Get_Value (Parameter);
+ if Dim < 1 or else Dim > Iir_Int64 (Get_Nbr_Elements (Indexes_List))
+ then
+ Error_Msg_Sem ("parameter value out of bound", Attr);
+ Parameter := Universal_Integer_One;
+ Dim := 1;
+ end if;
+ Index_Type := Get_Index_Type (Indexes_List, Natural (Dim - 1));
+ end;
+
+ case Get_Kind (Attr) is
+ when Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute =>
+ Set_Type (Attr, Index_Type);
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ Set_Type (Attr, Index_Type);
+ when Iir_Kind_Length_Array_Attribute =>
+ Set_Type (Attr, Convertible_Integer_Type_Definition);
+ when Iir_Kind_Ascending_Array_Attribute =>
+ Set_Type (Attr, Boolean_Type_Definition);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ pragma Assert (Get_Parameter (Attr) = Null_Iir);
+
+ Set_Parameter (Attr, Parameter);
+
+ -- If the corresponding type is known, save it so that it is not
+ -- necessary to extract it from the object.
+ if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Constraint_State (Prefix_Type) = Fully_Constrained
+ then
+ Set_Index_Subtype (Attr, Index_Type);
+ end if;
+
+ -- LRM 7.4.1
+ -- A locally static range is either [...], or a range of the first form
+ -- whose prefix denotes either a locally static subtype or an object
+ -- that is of a locally static subtype.
+
+ -- LRM 7.4.2
+ -- A globally static range is either [...], or a range of the first form
+ -- whose prefix denotes either a globally static subtype or an object
+ -- that is of a globally static subtype.
+ --
+ -- A globally static subtype is either a globally static scalar subtype,
+ -- a globally static array subtype, [...]
+ --
+ -- A globally static array subtype is a constrained array subtype
+ -- formed by imposing on an unconstrained array type a globally static
+ -- index constraint.
+ Staticness := Get_Type_Staticness (Prefix_Type);
+ if Flags.Vhdl_Std = Vhdl_93c
+ and then Get_Kind (Prefix) not in Iir_Kinds_Type_Declaration
+ then
+ -- For 93c:
+ -- if the prefix is a static expression, the staticness of the
+ -- expression may be higher than the staticness of the type
+ -- (eg: generic whose type is an unconstrained array).
+ -- Also consider expression staticness.
+ Staticness := Iir_Staticness'Max (Staticness,
+ Get_Expr_Staticness (Prefix));
+ end if;
+ Set_Expr_Staticness (Attr, Staticness);
+ end Finish_Sem_Array_Attribute;
+
+ procedure Finish_Sem_Scalar_Type_Attribute
+ (Attr_Name : Iir; Attr : Iir; Param : Iir)
+ is
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ Prefix_Bt : Iir;
+ Parameter : Iir;
+ Param_Type : Iir;
+ begin
+ if Param = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Attr) & " requires a parameter", Attr);
+ return;
+ end if;
+
+ Prefix := Get_Prefix (Attr);
+ if Get_Kind (Prefix) = Iir_Kind_Attribute_Name then
+ Prefix := Finish_Sem_Name (Prefix);
+ Set_Prefix (Attr, Prefix);
+ pragma Assert (Get_Kind (Prefix) = Iir_Kind_Base_Attribute);
+ else
+ Prefix := Sem_Type_Mark (Prefix);
+ end if;
+ Set_Prefix (Attr, Prefix);
+ Free_Iir (Attr_Name);
+ Prefix_Type := Get_Type (Prefix);
+ Prefix_Bt := Get_Base_Type (Prefix_Type);
+
+ case Get_Kind (Attr) is
+ when Iir_Kind_Pos_Attribute =>
+ -- LRM93 14.1
+ -- Parameter: An expression whose type is the base type of T.
+ Parameter := Sem_Expression (Param, Prefix_Bt);
+ when Iir_Kind_Val_Attribute =>
+ -- LRM93 14.1
+ -- Parameter: An expression of any integer type.
+ Param_Type := Get_Type (Param);
+ if Is_Overload_List (Param_Type) then
+ Parameter := Sem_Expression
+ (Param, Universal_Integer_Type_Definition);
+ else
+ if Get_Kind (Get_Base_Type (Param_Type))
+ /= Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("parameter must be an integer", Attr);
+ return;
+ end if;
+ Parameter := Param;
+ end if;
+ when Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute =>
+ -- LRM93 14.1
+ -- Parameter: An expression whose type is the base type of T.
+ Parameter := Sem_Expression (Param, Prefix_Bt);
+ when Iir_Kind_Image_Attribute =>
+ -- LRM93 14.1
+ -- Parameter: An expression whose type is the base type of T.
+ Parameter := Sem_Expression (Param, Prefix_Bt);
+ when Iir_Kind_Value_Attribute =>
+ -- Parameter: An expression of type string.
+ Parameter := Sem_Expression (Param, String_Type_Definition);
+ when others =>
+ raise Internal_Error;
+ end case;
+ if Get_Parameter (Attr) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ if Parameter = Null_Iir then
+ Set_Parameter (Attr, Param);
+ Set_Expr_Staticness (Attr, None);
+ return;
+ end if;
+ Set_Parameter (Attr, Parameter);
+ Set_Expr_Staticness (Attr, Min (Get_Type_Staticness (Prefix_Type),
+ Get_Expr_Staticness (Parameter)));
+ Set_Name_Staticness (Attr, Get_Expr_Staticness (Attr));
+ end Finish_Sem_Scalar_Type_Attribute;
+
+ procedure Finish_Sem_Signal_Attribute
+ (Attr_Name : Iir; Attr : Iir; Parameter : Iir)
+ is
+ Param : Iir;
+ Prefix : Iir;
+ Prefix_Name : Iir;
+ begin
+ Prefix_Name := Get_Prefix (Attr_Name);
+ Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr));
+ Set_Prefix (Attr, Prefix);
+ Free_Iir (Attr_Name);
+
+ if Parameter = Null_Iir then
+ return;
+ end if;
+ if Get_Kind (Attr) = Iir_Kind_Transaction_Attribute then
+ Error_Msg_Sem ("'transaction does not allow a parameter", Attr);
+ else
+ Param := Sem_Expression (Parameter, Time_Subtype_Definition);
+ if Param /= Null_Iir then
+ -- LRM93 14.1
+ -- Parameter: A static expression of type TIME [that evaluate
+ -- to a nonnegative value.]
+ if Get_Expr_Staticness (Param) = None then
+ Error_Msg_Sem
+ ("parameter of signal attribute must be static", Param);
+ end if;
+ Set_Parameter (Attr, Param);
+ end if;
+ end if;
+ end Finish_Sem_Signal_Attribute;
+
+ function Is_Type_Abstract_Numeric (Atype : Iir) return Boolean is
+ begin
+ case Get_Kind (Atype) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Type_Abstract_Numeric;
+
+ function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean
+ is
+ Base_Type1 : constant Iir := Get_Base_Type (Type1);
+ Base_Type2 : constant Iir := Get_Base_Type (Type2);
+ Ant1, Ant2 : Boolean;
+ Index_List1, Index_List2 : Iir_List;
+ El1, El2 : Iir;
+ begin
+ -- LRM 7.3.5
+ -- In particular, a type is closely related to itself.
+ if Base_Type1 = Base_Type2 then
+ return True;
+ end if;
+
+ -- LRM 7.3.5
+ -- a) Abstract Numeric Types: Any abstract numeric type is closely
+ -- related to any other abstract numeric type.
+ Ant1 := Is_Type_Abstract_Numeric (Type1);
+ Ant2 := Is_Type_Abstract_Numeric (Type2);
+ if Ant1 and Ant2 then
+ return True;
+ end if;
+ if Ant1 or Ant2 then
+ return False;
+ end if;
+
+ -- LRM 7.3.5
+ -- b) Array Types: Two array types are closely related if and only if
+ -- The types have the same dimensionality; For each index position,
+ -- the index types are either the same or are closely related; and
+ -- The element types are the same.
+ --
+ -- No other types are closely related.
+ if not (Get_Kind (Base_Type1) = Iir_Kind_Array_Type_Definition
+ and then Get_Kind (Base_Type2) = Iir_Kind_Array_Type_Definition)
+ then
+ return False;
+ end if;
+ Index_List1 := Get_Index_Subtype_List (Base_Type1);
+ Index_List2 := Get_Index_Subtype_List (Base_Type2);
+ if Get_Nbr_Elements (Index_List1) /= Get_Nbr_Elements (Index_List2) then
+ return False;
+ end if;
+ if Get_Base_Type (Get_Element_Subtype (Base_Type1))
+ /= Get_Base_Type (Get_Element_Subtype (Base_Type2))
+ then
+ return False;
+ end if;
+ for I in Natural loop
+ El1 := Get_Index_Type (Index_List1, I);
+ exit when El1 = Null_Iir;
+ El2 := Get_Index_Type (Index_List2, I);
+ if not Are_Types_Closely_Related (El1, El2) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Are_Types_Closely_Related;
+
+ function Sem_Type_Conversion (Loc : Iir; Type_Mark : Iir; Actual : Iir)
+ return Iir
+ is
+ Conv_Type : constant Iir := Get_Type (Type_Mark);
+ Conv: Iir_Type_Conversion;
+ Expr: Iir;
+ Staticness : Iir_Staticness;
+ begin
+ Conv := Create_Iir (Iir_Kind_Type_Conversion);
+ Location_Copy (Conv, Loc);
+ Set_Type_Mark (Conv, Type_Mark);
+ Set_Type (Conv, Conv_Type);
+ Set_Expression (Conv, Actual);
+
+ -- Default staticness in case of error.
+ Set_Expr_Staticness (Conv, None);
+
+ -- Bail out if no actual (or invalid one).
+ if Actual = Null_Iir then
+ return Conv;
+ end if;
+
+ -- LRM93 7.3.5
+ -- Furthermore, the operand of a type conversion is not allowed to be
+ -- the literal null, an allocator, an aggregate, or a string literal.
+ case Get_Kind (Actual) is
+ when Iir_Kind_Null_Literal
+ | Iir_Kind_Aggregate
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ Error_Msg_Sem
+ (Disp_Node (Actual) & " cannot be a type conversion operand",
+ Actual);
+ return Conv;
+ when others =>
+ -- LRM93 7.3.5
+ -- The type of the operand of a type conversion must be
+ -- determinable independent of the context (in particular,
+ -- independent of the target type).
+ Expr := Sem_Expression_Universal (Actual);
+ if Expr = Null_Iir then
+ return Conv;
+ end if;
+ if Get_Kind (Expr) in Iir_Kinds_Allocator then
+ Error_Msg_Sem
+ (Disp_Node (Expr) & " cannot be a type conversion operand",
+ Expr);
+ end if;
+ Set_Expression (Conv, Expr);
+ end case;
+
+ -- LRM93 7.4.1 Locally Static Primaries.
+ -- 9. a type conversion whose expression is a locally static expression.
+ -- LRM93 7.4.2 Globally Static Primaries.
+ -- 14. a type conversion whose expression is a globally static
+ -- expression.
+ if Expr /= Null_Iir then
+ Staticness := Get_Expr_Staticness (Expr);
+
+ -- If the type mark is not locally static, the expression cannot
+ -- be locally static. This was clarified in VHDL 08, but a type
+ -- mark that denotes an unconstrained array type, does not prevent
+ -- the expression from being static.
+ if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition
+ or else Get_Constraint_State (Conv_Type) = Fully_Constrained
+ then
+ Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type));
+ end if;
+
+ -- LRM87 7.4 Static Expressions
+ -- A type conversion is not a locally static expression.
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Staticness := Min (Globally, Staticness);
+ end if;
+ Set_Expr_Staticness (Conv, Staticness);
+
+ if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr))
+ then
+ -- FIXME: should explain why the types are not closely related.
+ Error_Msg_Sem
+ ("conversion not allowed between not closely related types",
+ Conv);
+ -- Avoid error storm in evaluation.
+ Set_Expr_Staticness (Conv, None);
+ else
+ Check_Read (Expr);
+ end if;
+ end if;
+ return Conv;
+ end Sem_Type_Conversion;
+
+ -- OBJ is an 'impure' object (variable, signal or file) referenced at
+ -- location LOC.
+ -- Check the pure rules (LRM08 4 Subprograms and packages,
+ -- LRM08 4.3 Subprograms bodies).
+ procedure Sem_Check_Pure (Loc : Iir; Obj : Iir)
+ is
+ procedure Update_Impure_Depth (Subprg_Spec : Iir; Depth : Iir_Int32)
+ is
+ Bod : Iir;
+ begin
+ Bod := Get_Subprogram_Body (Subprg_Spec);
+ if Bod = Null_Iir then
+ return;
+ end if;
+ if Depth < Get_Impure_Depth (Bod) then
+ Set_Impure_Depth (Bod, Depth);
+ end if;
+ end Update_Impure_Depth;
+
+ procedure Error_Pure (Subprg : Iir; Obj : Iir)
+ is
+ begin
+ Error_Msg_Sem
+ ("reference to " & Disp_Node (Obj) & " violate pure rule for "
+ & Disp_Node (Subprg), Loc);
+ end Error_Pure;
+
+ Subprg : constant Iir := Sem_Stmts.Get_Current_Subprogram;
+ Subprg_Body : Iir;
+ Parent : Iir;
+ begin
+ -- Apply only in subprograms.
+ if Subprg = Null_Iir then
+ return;
+ end if;
+ case Get_Kind (Subprg) is
+ when Iir_Kinds_Process_Statement =>
+ return;
+ when Iir_Kind_Procedure_Declaration =>
+ -- Exit now if already known as impure.
+ if Get_Purity_State (Subprg) = Impure then
+ return;
+ end if;
+ when Iir_Kind_Function_Declaration =>
+ -- Exit now if impure.
+ if Get_Pure_Flag (Subprg) = False then
+ return;
+ end if;
+ when others =>
+ Error_Kind ("sem_check_pure", Subprg);
+ end case;
+
+ -- Not all objects are impure.
+ case Get_Kind (Obj) is
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ null;
+ when Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ -- When referenced as a formal name (FIXME: this is an
+ -- approximation), the rules don't apply.
+ if not Get_Is_Within_Flag (Get_Parent (Obj)) then
+ return;
+ end if;
+ when Iir_Kind_File_Declaration =>
+ -- LRM 93 2.2
+ -- If a pure function is the parent of a given procedure, then
+ -- that procedure must not contain a reference to an explicitly
+ -- declared file object [...]
+ --
+ -- A pure function must not contain a reference to an explicitly
+ -- declared file.
+ if Flags.Vhdl_Std > Vhdl_93c then
+ if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then
+ Error_Pure (Subprg, Obj);
+ else
+ Set_Purity_State (Subprg, Impure);
+ Set_Impure_Depth (Get_Subprogram_Body (Subprg),
+ Iir_Depth_Impure);
+ end if;
+ end if;
+ return;
+ when others =>
+ return;
+ end case;
+
+ -- OBJ is declared in the immediate declarative part of the subprogram.
+ Parent := Get_Parent (Obj);
+ Subprg_Body := Get_Subprogram_Body (Subprg);
+ if Parent = Subprg or else Parent = Subprg_Body then
+ return;
+ end if;
+
+ -- Function.
+ if Get_Kind (Subprg) = Iir_Kind_Function_Declaration then
+ Error_Pure (Subprg, Obj);
+ return;
+ end if;
+
+ case Get_Kind (Parent) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kinds_Process_Statement
+ | Iir_Kind_Protected_Type_Body =>
+ -- The procedure is impure.
+ Set_Purity_State (Subprg, Impure);
+ Set_Impure_Depth (Subprg_Body, Iir_Depth_Impure);
+ return;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Update_Impure_Depth
+ (Subprg,
+ Get_Subprogram_Depth (Get_Subprogram_Specification (Parent)));
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Update_Impure_Depth (Subprg, Get_Subprogram_Depth (Parent));
+ when others =>
+ Error_Kind ("sem_check_pure(2)", Parent);
+ end case;
+ end Sem_Check_Pure;
+
+ -- Set All_Sensitized_State to False iff OBJ is a signal declaration
+ -- and the current subprogram is in a package body.
+ procedure Sem_Check_All_Sensitized (Obj : Iir)
+ is
+ Subprg : Iir;
+ begin
+ -- We cares only of signals.
+ if Get_Kind (Obj) /= Iir_Kind_Signal_Declaration then
+ return;
+ end if;
+ -- We cares only of subprograms. Give up if we are in a process.
+ Subprg := Sem_Stmts.Get_Current_Subprogram;
+ if Subprg = Null_Iir
+ or else Get_Kind (Subprg) not in Iir_Kinds_Subprogram_Declaration
+ then
+ return;
+ end if;
+ if Get_Kind (Get_Library_Unit (Sem.Get_Current_Design_Unit))
+ = Iir_Kind_Package_Body
+ then
+ Set_All_Sensitized_State (Subprg, Invalid_Signal);
+ else
+ Set_All_Sensitized_State (Subprg, Read_Signal);
+ end if;
+ end Sem_Check_All_Sensitized;
+
+ function Finish_Sem_Denoting_Name (Name : Iir; Res : Iir) return Iir
+ is
+ Prefix : Iir;
+ begin
+ case Iir_Kinds_Denoting_Name (Get_Kind (Name)) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Operator_Symbol =>
+ Xref_Ref (Name, Res);
+ return Name;
+ when Iir_Kind_Selected_Name =>
+ Xref_Ref (Name, Res);
+ Prefix := Get_Prefix (Name);
+ loop
+ pragma Assert (Get_Kind (Prefix) in Iir_Kinds_Denoting_Name);
+ Xref_Ref (Prefix, Get_Named_Entity (Prefix));
+ exit when Get_Kind (Prefix) /= Iir_Kind_Selected_Name;
+ Prefix := Get_Prefix (Prefix);
+ end loop;
+ return Name;
+ end case;
+ end Finish_Sem_Denoting_Name;
+
+ function Finish_Sem_Name_1 (Name : Iir; Res : Iir) return Iir
+ is
+ Prefix : Iir;
+ Name_Prefix : Iir;
+ Name_Res : Iir;
+ begin
+ case Get_Kind (Res) is
+ when Iir_Kinds_Library_Unit_Declaration =>
+ return Finish_Sem_Denoting_Name (Name, Res);
+ when Iir_Kinds_Sequential_Statement
+ | Iir_Kinds_Concurrent_Statement =>
+ -- Label or part of an expanded name (for process, block
+ -- and generate).
+ return Finish_Sem_Denoting_Name (Name, Res);
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kinds_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Unit_Declaration =>
+ Name_Res := Finish_Sem_Denoting_Name (Name, Res);
+ Set_Base_Name (Name_Res, Res);
+ Set_Name_Staticness (Name_Res, Get_Name_Staticness (Res));
+ Set_Expr_Staticness (Name_Res, Get_Expr_Staticness (Res));
+ Sem_Check_Pure (Name_Res, Res);
+ Sem_Check_All_Sensitized (Res);
+ Set_Type (Name_Res, Get_Type (Res));
+ return Name_Res;
+ when Iir_Kind_Attribute_Value =>
+ pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name);
+ Prefix := Finish_Sem_Name (Get_Prefix (Name));
+ Set_Prefix (Name, Prefix);
+ Set_Base_Name (Name, Res);
+ Set_Type (Name, Get_Type (Res));
+ Set_Name_Staticness (Name, Get_Name_Staticness (Res));
+ Set_Expr_Staticness (Name, Get_Expr_Staticness (Res));
+ return Name;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Interface_Package_Declaration =>
+ Name_Res := Finish_Sem_Denoting_Name (Name, Res);
+ Set_Base_Name (Name_Res, Res);
+ return Name_Res;
+ when Iir_Kinds_Function_Declaration =>
+ Name_Res := Finish_Sem_Denoting_Name (Name, Res);
+ Set_Type (Name_Res, Get_Return_Type (Res));
+ return Name_Res;
+ when Iir_Kinds_Procedure_Declaration =>
+ return Finish_Sem_Denoting_Name (Name, Res);
+ when Iir_Kind_Type_Conversion =>
+ pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name);
+ Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name)));
+ Free_Parenthesis_Name (Name, Res);
+ return Res;
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Dereference =>
+ -- Fall through.
+ null;
+ when Iir_Kind_Implicit_Dereference =>
+ -- The name may not have a prefix.
+ Prefix := Finish_Sem_Name (Name, Get_Prefix (Res));
+ Set_Prefix (Res, Prefix);
+ Finish_Sem_Dereference (Res);
+ return Res;
+ when Iir_Kind_Function_Call =>
+ case Get_Kind (Name) is
+ when Iir_Kind_Parenthesis_Name =>
+ Prefix := Finish_Sem_Name
+ (Get_Prefix (Name), Get_Implementation (Res));
+ Finish_Sem_Function_Call (Res, Prefix);
+ Free_Iir (Name);
+ when Iir_Kinds_Denoting_Name =>
+ Prefix := Finish_Sem_Name (Name, Get_Implementation (Res));
+ Finish_Sem_Function_Call (Res, Prefix);
+ when others =>
+ Error_Kind ("Finish_Sem_Name(function call)", Name);
+ end case;
+ return Res;
+ when Iir_Kinds_Array_Attribute =>
+ if Get_Parameter (Res) = Null_Iir then
+ Finish_Sem_Array_Attribute (Name, Res, Null_Iir);
+ end if;
+ if Get_Kind (Name) = Iir_Kind_Attribute_Name then
+ Free_Iir (Name);
+ else
+ Free_Iir (Get_Prefix (Name));
+ Free_Parenthesis_Name (Name, Res);
+ end if;
+ return Res;
+ when Iir_Kinds_Scalar_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute =>
+ if Get_Parameter (Res) = Null_Iir then
+ Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir);
+ else
+ Free_Parenthesis_Name (Name, Res);
+ end if;
+ return Res;
+ when Iir_Kinds_Signal_Value_Attribute =>
+ null;
+ when Iir_Kinds_Signal_Attribute =>
+ if Get_Parameter (Res) = Null_Iir then
+ Finish_Sem_Signal_Attribute (Name, Res, Null_Iir);
+ else
+ Free_Parenthesis_Name (Name, Res);
+ end if;
+ return Res;
+ when Iir_Kinds_Type_Attribute =>
+ Free_Iir (Name);
+ return Res;
+ when Iir_Kind_Base_Attribute =>
+ return Res;
+ when Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ Free_Iir (Name);
+ return Res;
+ when Iir_Kind_Psl_Expression =>
+ return Res;
+ when Iir_Kind_Psl_Declaration =>
+ return Name;
+ when Iir_Kind_Element_Declaration
+ | Iir_Kind_Error =>
+ -- Certainly an error!
+ return Res;
+ when others =>
+ Error_Kind ("finish_sem_name", Res);
+ end case;
+
+ -- Finish prefix.
+ Prefix := Get_Prefix (Res);
+ Name_Prefix := Get_Prefix (Name);
+ Prefix := Finish_Sem_Name_1 (Name_Prefix, Prefix);
+ Set_Prefix (Res, Prefix);
+
+ case Get_Kind (Res) is
+ when Iir_Kind_Indexed_Name =>
+ Finish_Sem_Indexed_Name (Res);
+ Free_Parenthesis_Name (Name, Res);
+ when Iir_Kind_Slice_Name =>
+ Finish_Sem_Slice_Name (Res);
+ Free_Parenthesis_Name (Name, Res);
+ when Iir_Kind_Selected_Element =>
+ pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_Name);
+ Xref_Ref (Res, Get_Selected_Element (Res));
+ Set_Name_Staticness (Res, Get_Name_Staticness (Prefix));
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix));
+ Set_Base_Name (Res, Get_Base_Name (Prefix));
+ Free_Iir (Name);
+ when Iir_Kind_Dereference =>
+ pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name);
+ Finish_Sem_Dereference (Res);
+ Free_Iir (Name);
+ when Iir_Kinds_Signal_Value_Attribute =>
+ Sem_Name_Free_Result (Name, Res);
+ when others =>
+ Error_Kind ("finish_sem_name(2)", Res);
+ end case;
+ return Res;
+ end Finish_Sem_Name_1;
+
+ function Finish_Sem_Name (Name : Iir; Res : Iir) return Iir
+ is
+ Old_Res : Iir;
+ begin
+ if Get_Kind (Res) /= Iir_Kind_Implicit_Dereference then
+ Old_Res := Get_Named_Entity (Name);
+ if Old_Res /= Null_Iir and then Old_Res /= Res then
+ pragma Assert (Is_Overload_List (Old_Res));
+ Sem_Name_Free_Result (Old_Res, Res);
+ end if;
+ Set_Named_Entity (Name, Res);
+ end if;
+ return Finish_Sem_Name_1 (Name, Res);
+ end Finish_Sem_Name;
+
+ function Finish_Sem_Name (Name : Iir) return Iir is
+ begin
+ return Finish_Sem_Name_1 (Name, Get_Named_Entity (Name));
+ end Finish_Sem_Name;
+
+ -- LRM93 6.2
+ -- The evaluation of a simple name has no other effect than to determine
+ -- the named entity denoted by the name.
+ --
+ -- NAME may be a simple name, a strig literal or a character literal.
+ -- GHDL: set interpretation of NAME (possibly an overload list) or
+ -- error_mark for unknown names.
+ -- If SOFT is TRUE, then no error message is reported in case of failure.
+ procedure Sem_Simple_Name (Name : Iir; Keep_Alias : Boolean; Soft : Boolean)
+ is
+ Id : constant Name_Id := Get_Identifier (Name);
+ Interpretation: Name_Interpretation_Type;
+ Res: Iir;
+ Res_List : Iir_List;
+ N : Natural;
+ begin
+ Interpretation := Get_Interpretation (Id);
+
+ if not Valid_Interpretation (Interpretation) then
+ -- Unknown name.
+ if not Soft then
+ Error_Msg_Sem
+ ("no declaration for """ & Image_Identifier (Name) & """", Name);
+ end if;
+ Res := Error_Mark;
+ elsif not Valid_Interpretation (Get_Next_Interpretation (Interpretation))
+ then
+ -- One simple interpretation.
+ Res := Get_Declaration (Interpretation);
+
+ -- For a design unit, return the library unit
+ if Get_Kind (Res) = Iir_Kind_Design_Unit then
+ -- FIXME: should replace interpretation ?
+ Libraries.Load_Design_Unit (Res, Name);
+ Sem.Add_Dependence (Res);
+ Res := Get_Library_Unit (Res);
+ end if;
+
+ -- Check visibility.
+ if not Get_Visible_Flag (Res) then
+ if Flag_Relaxed_Rules
+ and then Get_Kind (Res) in Iir_Kinds_Object_Declaration
+ and then Valid_Interpretation (Get_Under_Interpretation (Id))
+ then
+ Res := Get_Declaration (Get_Under_Interpretation (Id));
+ else
+ if not Soft then
+ Error_Msg_Sem
+ (Disp_Node (Res) & " is not visible here", Name);
+ end if;
+ -- Even if a named entity was found, return an error_mark.
+ -- Indeed, the named entity found is certainly the one being
+ -- semantized, and the semantization may be uncomplete.
+ Res := Error_Mark;
+ end if;
+ end if;
+
+ if not Keep_Alias
+ and then Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration
+ then
+ Set_Alias_Declaration (Name, Res);
+ Res := Get_Named_Entity (Get_Name (Res));
+ end if;
+ else
+ -- Name is overloaded.
+ Res_List := Create_Iir_List;
+ N := 0;
+ -- The SEEN_FLAG is used to get only one meaning which can be reached
+ -- through several pathes (such as aliases).
+ while Valid_Interpretation (Interpretation) loop
+ if Keep_Alias then
+ Res := Get_Declaration (Interpretation);
+ else
+ Res := Get_Non_Alias_Declaration (Interpretation);
+ end if;
+ if not Get_Seen_Flag (Res) then
+ Set_Seen_Flag (Res, True);
+ N := N + 1;
+ Append_Element (Res_List, Res);
+ end if;
+ Interpretation := Get_Next_Interpretation (Interpretation);
+ end loop;
+
+ -- FIXME: there can be only one element (a function and its alias!).
+
+ -- Clear SEEN_FLAG.
+ for I in 0 .. N - 1 loop
+ Res := Get_Nth_Element (Res_List, I);
+ Set_Seen_Flag (Res, False);
+ end loop;
+
+ Res := Create_Overload_List (Res_List);
+ end if;
+
+ Set_Base_Name (Name, Res);
+ Set_Named_Entity (Name, Res);
+ end Sem_Simple_Name;
+
+ -- LRM93 �6.3
+ -- Selected Names.
+ procedure Sem_Selected_Name (Name: Iir; Keep_Alias : Boolean := False)
+ is
+ Suffix : constant Name_Id := Get_Identifier (Name);
+ Prefix_Name : constant Iir := Get_Prefix (Name);
+ Prefix_Loc : constant Location_Type := Get_Location (Prefix_Name);
+
+ Prefix: Iir;
+ Res : Iir;
+
+ -- Semantize SUB_NAME.NAME as an expanded name (ie, NAME is declared
+ -- within SUB_NAME). This is possible only if the expanded name is
+ -- analyzed within the context of SUB_NAME.
+ procedure Sem_As_Expanded_Name (Sub_Name : Iir)
+ is
+ Sub_Res : Iir;
+ begin
+ if Get_Is_Within_Flag (Sub_Name) then
+ Sub_Res := Find_Declarations_In_List (Sub_Name, Name, Keep_Alias);
+ if Sub_Res /= Null_Iir then
+ Add_Result (Res, Sub_Res);
+ end if;
+ end if;
+ end Sem_As_Expanded_Name;
+
+ -- LRM93 �6.3
+ -- For a selected name that is used to denote a record element,
+ -- the suffix must be a simple name denoting an element of a
+ -- record object or value. The prefix must be appropriate for the
+ -- type of this object or value.
+ --
+ -- Semantize SUB_NAME.NAME as a selected element.
+ procedure Sem_As_Selected_Element (Sub_Name : Iir)
+ is
+ Base_Type : Iir;
+ Ptr_Type : Iir;
+ Rec_El : Iir;
+ R : Iir;
+ Se : Iir;
+ begin
+ -- FIXME: if not is_expr (sub_name) return.
+ Base_Type := Get_Base_Type (Get_Type (Sub_Name));
+ if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then
+ Ptr_Type := Base_Type;
+ Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type));
+ else
+ Ptr_Type := Null_Iir;
+ end if;
+
+ if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then
+ return;
+ end if;
+
+ Rec_El := Find_Name_In_List
+ (Get_Elements_Declaration_List (Base_Type), Suffix);
+ if Rec_El = Null_Iir then
+ return;
+ end if;
+
+ if not Maybe_Function_Call (Sub_Name) then
+ return;
+ end if;
+
+ R := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name);
+ R := Maybe_Insert_Dereference (R, Ptr_Type);
+
+ Se := Create_Iir (Iir_Kind_Selected_Element);
+ Location_Copy (Se, Name);
+ Set_Prefix (Se, R);
+ Set_Type (Se, Get_Type (Rec_El));
+ Set_Selected_Element (Se, Rec_El);
+ Set_Base_Name (Se, Get_Object_Prefix (R, False));
+ Add_Result (Res, Se);
+ end Sem_As_Selected_Element;
+
+ procedure Error_Selected_Element (Prefix_Type : Iir)
+ is
+ Base_Type : Iir;
+ begin
+ Base_Type := Get_Base_Type (Prefix_Type);
+ if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then
+ Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type));
+ end if;
+ if Get_Kind (Base_Type) /= Iir_Kind_Record_Type_Definition then
+ Error_Msg_Sem
+ (Disp_Node (Prefix) & " does not designate a record", Name);
+ else
+ Error_Msg_Sem
+ ("no element """ & Name_Table.Image (Suffix)
+ & """ in " & Disp_Node (Base_Type), Name);
+ end if;
+ end Error_Selected_Element;
+
+ procedure Sem_As_Protected_Item (Sub_Name : Iir)
+ is
+ Prot_Type : constant Iir := Get_Type (Sub_Name);
+ Method : Iir;
+ begin
+ -- LRM98 12.3 Visibility
+ -- s) For a subprogram declared immediately within a given protected
+ -- type declaration: at the place of the suffix in a selected
+ -- name whose prefix denotes an object of the protected type.
+ Method := Get_Declaration_Chain (Prot_Type);
+ while Method /= Null_Iir loop
+ case Get_Kind (Method) is
+ when Iir_Kind_Function_Declaration |
+ Iir_Kind_Procedure_Declaration =>
+ if Get_Identifier (Method) = Suffix then
+ Add_Result (Res, Method);
+ end if;
+ when Iir_Kind_Attribute_Specification
+ | Iir_Kind_Use_Clause =>
+ null;
+ when others =>
+ Error_Kind ("sem_as_protected_item", Method);
+ end case;
+ Method := Get_Chain (Method);
+ end loop;
+ end Sem_As_Protected_Item;
+
+ procedure Error_Protected_Item (Prot_Type : Iir) is
+ begin
+ Error_Msg_Sem
+ ("no method " & Name_Table.Image (Suffix) & " in "
+ & Disp_Node (Prot_Type), Name);
+ end Error_Protected_Item;
+ begin
+ -- Analyze prefix.
+ Sem_Name (Prefix_Name);
+ Prefix := Get_Named_Entity (Prefix_Name);
+ if Prefix = Error_Mark then
+ Set_Named_Entity (Name, Prefix);
+ return;
+ end if;
+
+ Res := Null_Iir;
+
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Overload_List =>
+ -- LRM93 6.3
+ -- If, according to the visibility rules, there is at
+ -- least one possible interpretation of the prefix of a
+ -- selected name as the name of an enclosing entity
+ -- interface, architecture, subprogram, block statement,
+ -- process statement, generate statement, or loop
+ -- statement, then the only interpretations considered are
+ -- those of the immediately preceding paragraph.
+ --
+ -- In this case, the selected name is always interpreted
+ -- as an expanded name. In particular, no interpretations
+ -- of the prefix as a function call are considered.
+ declare
+ Prefix_List : Iir_List;
+ El : Iir;
+ begin
+ -- So, first try as expanded name.
+ Prefix_List := Get_Overload_List (Prefix);
+ for I in Natural loop
+ El := Get_Nth_Element (Prefix_List, I);
+ exit when El = Null_Iir;
+ Sem_As_Expanded_Name (El);
+ end loop;
+
+ -- If no expanded name are found, try as selected element.
+ if Res = Null_Iir then
+ for I in Natural loop
+ El := Get_Nth_Element (Prefix_List, I);
+ exit when El = Null_Iir;
+ Sem_As_Selected_Element (El);
+ end loop;
+ end if;
+ end;
+ if Res = Null_Iir then
+ Error_Msg_Sem ("no suffix """ & Name_Table.Image (Suffix)
+ & """ for overloaded selected name", Name);
+ end if;
+ when Iir_Kind_Library_Declaration =>
+ -- LRM93 6.3
+ -- An expanded name denotes a primary unit constained in a design
+ -- library if the prefix denotes the library and the suffix is the
+ -- simple name if a primary unit whose declaration is contained
+ -- in that library.
+ -- An expanded name is not allowed for a secondary unit,
+ -- particularly for an architecture body.
+ -- GHDL: FIXME: error message more explicit
+ Res := Libraries.Load_Primary_Unit (Prefix, Suffix, Name);
+ if Res = Null_Iir then
+ Error_Msg_Sem
+ ("primary unit """ & Name_Table.Image (Suffix)
+ & """ not found in " & Disp_Node (Prefix), Name);
+ else
+ Sem.Add_Dependence (Res);
+ Res := Get_Library_Unit (Res);
+ end if;
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_For_Loop_Statement =>
+ -- LRM93 �6.3
+ -- An expanded name denotes a named entity declared immediatly
+ -- within a named construct if the prefix that is an entity
+ -- interface, an architecture, a subprogram, a block statement,
+ -- a process statement, a generate statement, or a loop
+ -- statement, and the suffix is the simple name, character
+ -- literal, or operator symbol of an named entity whose
+ -- declaration occurs immediatly within that construct.
+ if Get_Kind (Prefix) = Iir_Kind_Design_Unit then
+ Libraries.Load_Design_Unit (Prefix, Name);
+ Sem.Add_Dependence (Prefix);
+ Prefix := Get_Library_Unit (Prefix);
+ -- Modified only for xrefs, since a design_unit points to
+ -- the first context clause, while a library unit points to
+ -- the identifier.
+ Set_Named_Entity (Get_Prefix (Name), Prefix);
+ end if;
+
+ Res := Find_Declarations_In_List (Prefix, Name, Keep_Alias);
+
+ if Res = Null_Iir then
+ Error_Msg_Sem
+ ("no declaration for """ & Name_Table.Image (Suffix)
+ & """ in " & Disp_Node (Prefix), Name);
+ else
+ -- LRM93 �6.3
+ -- This form of expanded name is only allowed within the
+ -- construct itself.
+ if not Kind_In (Prefix,
+ Iir_Kind_Package_Declaration,
+ Iir_Kind_Package_Instantiation_Declaration)
+ and then not Get_Is_Within_Flag (Prefix)
+ then
+ Error_Msg_Sem
+ ("this expanded name is only allowed within the construct",
+ Prefix_Loc);
+ -- Hum, keep res.
+ end if;
+ end if;
+ when Iir_Kind_Function_Declaration =>
+ Sem_As_Expanded_Name (Prefix);
+ if Res = Null_Iir then
+ Sem_As_Selected_Element (Prefix);
+ end if;
+ if Res = Null_Iir then
+ Error_Selected_Element (Get_Return_Type (Prefix));
+ end if;
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Function_Call =>
+ if Get_Kind (Get_Type (Prefix))
+ = Iir_Kind_Protected_Type_Declaration
+ then
+ Sem_As_Protected_Item (Prefix);
+ if Res = Null_Iir then
+ Error_Protected_Item (Prefix);
+ end if;
+ else
+ Sem_As_Selected_Element (Prefix);
+ if Res = Null_Iir then
+ Error_Selected_Element (Get_Type (Prefix));
+ end if;
+ end if;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Slice_Name =>
+ Error_Msg_Sem
+ (Disp_Node (Prefix) & " cannot be selected by name", Prefix_Loc);
+
+ when others =>
+ Error_Kind ("sem_selected_name(2)", Prefix);
+ end case;
+ if Res = Null_Iir then
+ Res := Error_Mark;
+ end if;
+ Set_Named_Entity (Name, Res);
+ end Sem_Selected_Name;
+
+ -- If ASSOC_LIST has one element, which is an expression without formal,
+ -- return the actual, else return NULL_IIR.
+ function Get_One_Actual (Assoc_Chain : Iir) return Iir
+ is
+ Assoc : Iir;
+ begin
+ -- Only one actual ?
+ if Assoc_Chain = Null_Iir or else Get_Chain (Assoc_Chain) /= Null_Iir
+ then
+ return Null_Iir;
+ end if;
+
+ -- Not 'open' association element ?
+ Assoc := Assoc_Chain;
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then
+ return Null_Iir;
+ end if;
+
+ -- Not an association (ie no formal) ?
+ if Get_Formal (Assoc) /= Null_Iir then
+ return Null_Iir;
+ end if;
+
+ return Get_Actual (Assoc);
+ end Get_One_Actual;
+
+ function Slice_Or_Index (Actual : Iir) return Iir_Kind is
+ begin
+ -- But it may be a slice name.
+ case Get_Kind (Actual) is
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Range_Expression =>
+ return Iir_Kind_Slice_Name;
+ when others =>
+ if Is_Range_Attribute_Name (Actual) then
+ return Iir_Kind_Slice_Name;
+ end if;
+ end case;
+ -- By default, this is an indexed name.
+ return Iir_Kind_Indexed_Name;
+ end Slice_Or_Index;
+
+ -- Check whether association chain ASSOCS may be interpreted as indexes.
+ function Index_Or_Not (Assocs : Iir) return Iir_Kind
+ is
+ El : Iir;
+ begin
+ El := Assocs;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_Formal (El) /= Null_Iir then
+ return Iir_Kind_Error;
+ end if;
+ when others =>
+ -- Only expression are allowed.
+ return Iir_Kind_Error;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ return Iir_Kind_Indexed_Name;
+ end Index_Or_Not;
+
+ function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir)
+ return Iir
+ is
+ Actual : Iir;
+ Kind : Iir_Kind;
+ Res : Iir;
+ begin
+ -- FIXME: reuse Sem_Name for the whole analysis ?
+
+ Actual := Get_One_Actual (Get_Association_Chain (Name));
+ if Actual = Null_Iir then
+ Error_Msg_Sem ("only one index specification is allowed", Name);
+ return Null_Iir;
+ end if;
+ case Get_Kind (Actual) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Sem_Name (Actual);
+ Kind := Slice_Or_Index (Get_Named_Entity (Actual));
+ -- FIXME: semantization to be finished.
+ --Maybe_Finish_Sem_Name (Actual);
+ when others =>
+ Kind := Slice_Or_Index (Actual);
+ end case;
+
+ Res := Create_Iir (Kind);
+ Location_Copy (Res, Name);
+ case Kind is
+ when Iir_Kind_Indexed_Name =>
+ Actual := Sem_Expression (Actual, Itype);
+ if Actual = Null_Iir then
+ return Null_Iir;
+ end if;
+ Check_Read (Actual);
+ if Get_Expr_Staticness (Actual) < Globally then
+ Error_Msg_Sem ("index must be a static expression", Name);
+ end if;
+ Set_Index_List (Res, Create_Iir_List);
+ Append_Element (Get_Index_List (Res), Actual);
+ when Iir_Kind_Slice_Name =>
+ Actual := Sem_Discrete_Range_Expression (Actual, Itype, False);
+ if Actual = Null_Iir then
+ return Null_Iir;
+ end if;
+ if Get_Expr_Staticness (Actual) < Globally then
+ Error_Msg_Sem ("index must be a static expression", Name);
+ end if;
+ Set_Suffix (Res, Actual);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Free_Parenthesis_Name (Name, Res);
+ return Res;
+ end Sem_Index_Specification;
+
+ procedure Sem_Parenthesis_Name (Name : Iir_Parenthesis_Name)
+ is
+ Prefix: Iir;
+ Prefix_Name : Iir;
+ Res : Iir;
+ Assoc_Chain : Iir;
+
+ Slice_Index_Kind : Iir_Kind;
+
+ -- If FINISH is TRUE, then display error message in case of error.
+ function Sem_As_Indexed_Or_Slice_Name (Sub_Name : Iir; Finish : Boolean)
+ return Iir
+ is
+ Base_Type : Iir;
+ Ptr_Type : Iir;
+ P : Iir;
+ R : Iir;
+ begin
+ if Slice_Index_Kind = Iir_Kind_Error then
+ if Finish then
+ Error_Msg_Sem ("prefix is not a function name", Name);
+ end if;
+ -- No way.
+ return Null_Iir;
+ end if;
+
+ -- Only values can be indexed or sliced.
+ -- Catch errors such as slice of a type conversion.
+ if not Is_Object_Name (Sub_Name)
+ and then Get_Kind (Sub_Name) not in Iir_Kinds_Function_Declaration
+ then
+ if Finish then
+ Error_Msg_Sem ("prefix is not an array value (found "
+ & Disp_Node (Sub_Name) & ")", Name);
+ end if;
+ return Null_Iir;
+ end if;
+
+ -- Extract type of prefix, handle possible implicit deference.
+ Base_Type := Get_Base_Type (Get_Type (Sub_Name));
+ if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then
+ Ptr_Type := Base_Type;
+ Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type));
+ else
+ Ptr_Type := Null_Iir;
+ end if;
+
+ if Get_Kind (Base_Type) /= Iir_Kind_Array_Type_Definition then
+ if Finish then
+ Error_Msg_Sem ("type of prefix is not an array", Name);
+ end if;
+ return Null_Iir;
+ end if;
+ if Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) /=
+ Get_Chain_Length (Assoc_Chain)
+ then
+ if Finish then
+ Error_Msg_Sem
+ ("number of indexes mismatches array dimension", Name);
+ end if;
+ return Null_Iir;
+ end if;
+
+ if not Maybe_Function_Call (Sub_Name) then
+ if Finish then
+ Error_Msg_Sem ("missing parameters for function call", Name);
+ end if;
+ return Null_Iir;
+ end if;
+
+ P := Maybe_Insert_Function_Call (Prefix_Name, Sub_Name);
+ P := Maybe_Insert_Dereference (P, Ptr_Type);
+
+ R := Create_Iir (Slice_Index_Kind);
+ Location_Copy (R, Name);
+ Set_Prefix (R, P);
+ Set_Base_Name (R, Get_Object_Prefix (P));
+
+ case Slice_Index_Kind is
+ when Iir_Kind_Slice_Name =>
+ Set_Suffix (R, Get_Actual (Assoc_Chain));
+ Set_Type (R, Get_Base_Type (Get_Type (P)));
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Idx_El : Iir;
+ Idx_List : Iir_List;
+ begin
+ Idx_List := Create_Iir_List;
+ Set_Index_List (R, Idx_List);
+ Idx_El := Assoc_Chain;
+ while Idx_El /= Null_Iir loop
+ Append_Element (Idx_List, Get_Actual (Idx_El));
+ Idx_El := Get_Chain (Idx_El);
+ end loop;
+ end;
+ Set_Type (R, Get_Element_Subtype (Base_Type));
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ return R;
+ end Sem_As_Indexed_Or_Slice_Name;
+
+ -- Sem parenthesis name when the prefix is a function declaration.
+ -- Can be either a function call (and the expression is the actual) or
+ -- a slice/index of the result of a call without actual.
+ procedure Sem_Parenthesis_Function (Sub_Name : Iir) is
+ Used : Boolean;
+ R : Iir;
+ Match : Boolean;
+ begin
+ Used := False;
+ if Get_Kind (Sub_Name) in Iir_Kinds_Function_Declaration then
+ Sem_Association_Chain
+ (Get_Interface_Declaration_Chain (Sub_Name),
+ Assoc_Chain, False, Missing_Parameter, Name, Match);
+ if Match then
+ Add_Result
+ (Res,
+ Sem_As_Function_Call (Prefix_Name, Sub_Name, Assoc_Chain));
+ Used := True;
+ end if;
+ end if;
+ if Get_Kind (Sub_Name) not in Iir_Kinds_Procedure_Declaration then
+ R := Sem_As_Indexed_Or_Slice_Name (Sub_Name, False);
+ if R /= Null_Iir then
+ Add_Result (Res, R);
+ Used := True;
+ end if;
+ end if;
+ if not Used then
+ Sem_Name_Free_Result (Sub_Name, Null_Iir);
+ end if;
+ end Sem_Parenthesis_Function;
+
+ procedure Error_Parenthesis_Function (Spec : Iir)
+ is
+ Match : Boolean;
+ begin
+ Error_Msg_Sem
+ ("cannot match " & Disp_Node (Prefix) & " with actuals", Name);
+ -- Display error message.
+ Sem_Association_Chain
+ (Get_Interface_Declaration_Chain (Spec),
+ Assoc_Chain, True, Missing_Parameter, Name, Match);
+ end Error_Parenthesis_Function;
+
+ Actual : Iir;
+ Actual_Expr : Iir;
+ begin
+ -- The prefix is a function name, a type mark or an array.
+ Prefix_Name := Get_Prefix (Name);
+ Sem_Name (Prefix_Name);
+ Prefix := Get_Named_Entity (Prefix_Name);
+ if Prefix = Error_Mark then
+ Set_Named_Entity (Name, Error_Mark);
+ return;
+ end if;
+ Res := Null_Iir;
+
+ Assoc_Chain := Get_Association_Chain (Name);
+ Actual := Get_One_Actual (Assoc_Chain);
+
+ if Get_Kind (Prefix) = Iir_Kind_Type_Declaration
+ or else Get_Kind (Prefix) = Iir_Kind_Subtype_Declaration
+ then
+ -- A type conversion. The prefix is a type mark.
+
+ if Actual = Null_Iir then
+ -- More than one actual. Keep only the first.
+ Error_Msg_Sem
+ ("type conversion allows only one expression", Name);
+ end if;
+
+ -- This is certainly the easiest case: the prefix is not overloaded,
+ -- so the result can be computed.
+ Set_Named_Entity (Name, Sem_Type_Conversion (Name, Prefix, Actual));
+ return;
+ end if;
+
+ -- Select between slice or indexed name.
+ Actual_Expr := Null_Iir;
+ if Actual /= Null_Iir then
+ if Get_Kind (Actual) in Iir_Kinds_Name
+ or else Get_Kind (Actual) = Iir_Kind_Attribute_Name
+ then
+ -- Maybe a discrete range name.
+ Sem_Name (Actual);
+ Actual_Expr := Get_Named_Entity (Actual);
+ if Actual_Expr = Error_Mark then
+ Set_Named_Entity (Name, Actual_Expr);
+ return;
+ end if;
+ -- Decides between sliced or indexed name to actual.
+ Slice_Index_Kind := Slice_Or_Index (Actual_Expr);
+ elsif Get_Kind (Actual) = Iir_Kind_Range_Expression then
+ -- This can only be a slice.
+ Slice_Index_Kind := Iir_Kind_Slice_Name;
+ -- Actual_Expr :=
+ -- Sem_Discrete_Range_Expression (Actual, Null_Iir, False);
+ -- Set_Actual (Assoc_Chain, Actual_Expr);
+ else
+ Slice_Index_Kind := Iir_Kind_Indexed_Name;
+ end if;
+ else
+ -- FIXME: improve error message for multi-dim slice ?
+ Slice_Index_Kind := Index_Or_Not (Assoc_Chain);
+ end if;
+
+ if Slice_Index_Kind /= Iir_Kind_Slice_Name then
+ if Sem_Actual_Of_Association_Chain (Assoc_Chain) = False then
+ Actual := Null_Iir;
+ else
+ Actual := Get_One_Actual (Assoc_Chain);
+ end if;
+ end if;
+
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Overload_List =>
+ declare
+ El : Iir;
+ Prefix_List : Iir_List;
+ begin
+ Prefix_List := Get_Overload_List (Prefix);
+ for I in Natural loop
+ El := Get_Nth_Element (Prefix_List, I);
+ exit when El = Null_Iir;
+ Sem_Parenthesis_Function (El);
+ end loop;
+ end;
+ if Res = Null_Iir then
+ Error_Msg_Sem
+ ("no overloaded function found matching "
+ & Disp_Node (Prefix_Name), Name);
+ end if;
+ when Iir_Kinds_Function_Declaration =>
+ Sem_Parenthesis_Function (Prefix);
+ if Res = Null_Iir then
+ Error_Parenthesis_Function (Prefix);
+ end if;
+
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Function_Call =>
+ Add_Result (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True));
+
+ when Iir_Kinds_Array_Attribute =>
+ if Actual /= Null_Iir then
+ Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Actual);
+ Set_Named_Entity (Name, Prefix);
+ else
+ Error_Msg_Sem ("bad attribute parameter", Name);
+ Set_Named_Entity (Name, Error_Mark);
+ end if;
+ return;
+
+ when Iir_Kinds_Scalar_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute =>
+ if Get_Parameter (Prefix) /= Null_Iir then
+ -- Attribute already has a parameter, the expression
+ -- is either a slice or an index.
+ Add_Result
+ (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True));
+ elsif Actual /= Null_Iir then
+ Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual);
+ Set_Named_Entity (Name, Prefix);
+ return;
+ else
+ Error_Msg_Sem ("bad attribute parameter", Name);
+ Set_Named_Entity (Name, Error_Mark);
+ return;
+ end if;
+
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ Error_Msg_Sem
+ ("subprogram name is a type mark (missing apostrophe)", Name);
+
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute =>
+ if Actual /= Null_Iir then
+ Finish_Sem_Signal_Attribute (Prefix_Name, Prefix, Actual);
+ Set_Named_Entity (Name, Prefix);
+ else
+ Error_Msg_Sem ("bad attribute parameter", Name);
+ Set_Named_Entity (Name, Error_Mark);
+ end if;
+ return;
+
+ when Iir_Kinds_Procedure_Declaration =>
+ Error_Msg_Sem ("function name is a procedure", Name);
+
+ when Iir_Kinds_Process_Statement
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Type_Conversion =>
+ Error_Msg_Sem
+ (Disp_Node (Prefix) & " cannot be indexed or sliced", Name);
+ Res := Null_Iir;
+
+ when Iir_Kind_Psl_Declaration =>
+ Res := Sem_Psl.Sem_Psl_Name (Name);
+
+ when Iir_Kinds_Library_Unit_Declaration =>
+ Error_Msg_Sem ("function name is a design unit", Name);
+
+ when others =>
+ Error_Kind ("sem_parenthesis_name", Prefix);
+ end case;
+
+ if Res = Null_Iir then
+ Res := Error_Mark;
+ end if;
+ Set_Named_Entity (Name, Res);
+ end Sem_Parenthesis_Name;
+
+ procedure Sem_Selected_By_All_Name (Name : Iir_Selected_By_All_Name)
+ is
+ Prefix : Iir;
+ Prefix_Name : Iir;
+ Res : Iir;
+
+ procedure Sem_As_Selected_By_All_Name (Sub_Name : Iir)
+ is
+ Base_Type : Iir;
+ R, R1 : Iir;
+ begin
+ -- Only accept prefix of access type.
+ Base_Type := Get_Base_Type (Get_Type (Sub_Name));
+ if Get_Kind (Base_Type) /= Iir_Kind_Access_Type_Definition then
+ return;
+ end if;
+
+ if not Maybe_Function_Call (Sub_Name) then
+ return;
+ end if;
+
+ R1 := Maybe_Insert_Function_Call (Get_Prefix (Name), Sub_Name);
+
+ R := Create_Iir (Iir_Kind_Dereference);
+ Location_Copy (R, Name);
+ Set_Prefix (R, R1);
+ -- FIXME: access subtype.
+ Set_Type (R, Get_Designated_Type (Base_Type));
+ Add_Result (Res, R);
+ end Sem_As_Selected_By_All_Name;
+ begin
+ Prefix := Get_Prefix (Name);
+ Sem_Name (Prefix);
+ Prefix_Name := Prefix;
+ Prefix := Get_Named_Entity (Prefix);
+ if Prefix = Null_Iir then
+ return;
+ end if;
+ Res := Null_Iir;
+
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Overload_List =>
+ declare
+ Prefix_List : Iir_List;
+ El : Iir;
+ begin
+ Prefix_List := Get_Overload_List (Prefix);
+ for I in Natural loop
+ El := Get_Nth_Element (Prefix_List, I);
+ exit when El = Null_Iir;
+ Sem_As_Selected_By_All_Name (El);
+ end loop;
+ end;
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Function_Call =>
+ Sem_As_Selected_By_All_Name (Prefix);
+ when Iir_Kinds_Function_Declaration =>
+ Prefix := Sem_As_Function_Call (Name => Prefix_Name,
+ Spec => Prefix,
+ Assoc_Chain => Null_Iir);
+ Sem_As_Selected_By_All_Name (Prefix);
+ when Iir_Kind_Error =>
+ Set_Named_Entity (Name, Error_Mark);
+ return;
+ when others =>
+ Error_Kind ("sem_selected_by_all_name", Prefix);
+ end case;
+ if Res = Null_Iir then
+ Error_Msg_Sem ("prefix is not an access", Name);
+ Res := Error_Mark;
+ end if;
+ Set_Named_Entity (Name, Res);
+ end Sem_Selected_By_All_Name;
+
+ function Sem_Base_Attribute (Attr : Iir_Attribute_Name) return Iir
+ is
+ Prefix_Name : Iir;
+ Prefix : Iir;
+ Res : Iir;
+ Base_Type : Iir;
+ Type_Decl : Iir;
+ begin
+ Prefix_Name := Finish_Sem_Name (Get_Prefix (Attr));
+ -- FIXME: handle error
+ Prefix := Get_Named_Entity (Prefix_Name);
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Type_Declaration =>
+ Base_Type := Get_Type_Definition (Prefix);
+ when Iir_Kind_Subtype_Declaration =>
+ Base_Type := Get_Base_Type (Get_Type (Prefix));
+ -- Get the first subtype. FIXME: ref?
+ Type_Decl := Get_Type_Declarator (Base_Type);
+ if Get_Kind (Type_Decl) = Iir_Kind_Anonymous_Type_Declaration then
+ Base_Type := Get_Subtype_Definition (Type_Decl);
+ end if;
+ when others =>
+ Error_Msg_Sem
+ ("prefix of 'base attribute must be a type or a subtype", Attr);
+ return Error_Mark;
+ end case;
+ Res := Create_Iir (Iir_Kind_Base_Attribute);
+ Location_Copy (Res, Attr);
+ Set_Prefix (Res, Prefix_Name);
+ Set_Type (Res, Base_Type);
+ return Res;
+ end Sem_Base_Attribute;
+
+ function Sem_User_Attribute (Attr : Iir_Attribute_Name) return Iir
+ is
+ Prefix : Iir;
+ Value : Iir;
+ Attr_Id : Name_Id;
+ Spec : Iir_Attribute_Specification;
+ begin
+ Prefix := Get_Named_Entity (Get_Prefix (Attr));
+
+ -- LRM93 6.6
+ -- If the attribute name denotes an alias, then the attribute name
+ -- denotes an attribute of the aliased name and not the alias itself,
+ -- except when the attribute designator denotes any of the predefined
+ -- attributes 'simple_name, 'path_name, or 'instance_name.
+ if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then
+ -- GHDL: according to 4.3.3, the name cannot be an alias.
+ Prefix := Strip_Denoting_Name (Get_Name (Prefix));
+ end if;
+
+ -- LRM93 6.6
+ -- If the attribute designator denotes a user-defined attribute, the
+ -- prefix cannot denote a subelement or a slice of an object.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name =>
+ Error_Msg_Sem ("prefix of user defined attribute cannot be an "
+ & "object subelement", Attr);
+ return Error_Mark;
+ when Iir_Kind_Dereference =>
+ Error_Msg_Sem ("prefix of user defined attribute cannot be an "
+ & "anonymous object", Attr);
+ return Error_Mark;
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kinds_Function_Declaration
+ | Iir_Kinds_Procedure_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kinds_Sequential_Statement
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kind_Component_Declaration
+ | Iir_Kinds_Library_Unit_Declaration =>
+ -- FIXME: to complete
+ null;
+ when others =>
+ Error_Kind ("sem_user_attribute", Prefix);
+ end case;
+
+ Attr_Id := Get_Identifier (Attr);
+ Value := Get_Attribute_Value_Chain (Prefix);
+ while Value /= Null_Iir loop
+ Spec := Get_Attribute_Specification (Value);
+ exit when Get_Identifier (Get_Attribute_Designator (Spec)) = Attr_Id;
+ Value := Get_Chain (Value);
+ end loop;
+ if Value = Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (Prefix) & " was not annotated with attribute '"
+ & Name_Table.Image (Attr_Id) & ''', Attr);
+ if Attr_Id = Std_Names.Name_First or Attr_Id = Std_Names.Name_Last
+ then
+ -- Nice (?) message for Ada users.
+ Error_Msg_Sem
+ ("(you may use 'high, 'low, 'left or 'right attribute)", Attr);
+ end if;
+ return Error_Mark;
+ end if;
+
+ Xref_Ref (Attr, Value);
+
+ return Value;
+ end Sem_User_Attribute;
+
+ -- The prefix of scalar type attributes is a type name (or 'base), and
+ -- therefore isn't overloadable. So at the end of the function, the
+ -- analyze is finished.
+ function Sem_Scalar_Type_Attribute (Attr : Iir_Attribute_Name)
+ return Iir
+ is
+ use Std_Names;
+ Prefix_Name : constant Iir := Get_Prefix (Attr);
+ Id : constant Name_Id := Get_Identifier (Attr);
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ Res : Iir;
+ begin
+ Prefix := Get_Named_Entity (Prefix_Name);
+
+ -- LRM93 14.1
+ -- Prefix: Any discrete or physical type of subtype T.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Type_Declaration =>
+ Prefix_Type := Get_Type_Definition (Prefix);
+ when Iir_Kind_Subtype_Declaration =>
+ Prefix_Type := Get_Type (Prefix);
+ when Iir_Kind_Base_Attribute =>
+ Prefix_Type := Get_Type (Prefix);
+ when others =>
+ Error_Msg_Sem ("prefix of '" & Name_Table.Image (Id)
+ & " attribute must be a type", Attr);
+ return Error_Mark;
+ end case;
+
+ case Id is
+ when Name_Image
+ | Name_Value =>
+ if Get_Kind (Prefix_Type) not in Iir_Kinds_Scalar_Type_Definition
+ then
+ Error_Msg_Sem
+ ("prefix of '" & Name_Table.Image (Id)
+ & " attribute must be a scalar type", Attr);
+ Error_Msg_Sem
+ ("found " & Disp_Node (Prefix_Type)
+ & " defined at " & Disp_Location (Prefix_Type), Attr);
+ return Error_Mark;
+ end if;
+ when others =>
+ case Get_Kind (Prefix_Type) is
+ when Iir_Kinds_Discrete_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ ("prefix of '" & Name_Table.Image (Id)
+ & " attribute must be discrete or physical type", Attr);
+ Error_Msg_Sem
+ ("found " & Disp_Node (Prefix_Type)
+ & " defined at " & Disp_Location (Prefix_Type), Attr);
+ return Error_Mark;
+ end case;
+ end case;
+
+ -- Create the resulting node.
+ case Get_Identifier (Attr) is
+ when Name_Pos =>
+ Res := Create_Iir (Iir_Kind_Pos_Attribute);
+ when Name_Val =>
+ Res := Create_Iir (Iir_Kind_Val_Attribute);
+ when Name_Succ =>
+ Res := Create_Iir (Iir_Kind_Succ_Attribute);
+ when Name_Pred =>
+ Res := Create_Iir (Iir_Kind_Pred_Attribute);
+ when Name_Leftof =>
+ Res := Create_Iir (Iir_Kind_Leftof_Attribute);
+ when Name_Rightof =>
+ Res := Create_Iir (Iir_Kind_Rightof_Attribute);
+ when Name_Image =>
+ Res := Create_Iir (Iir_Kind_Image_Attribute);
+ when Name_Value =>
+ Res := Create_Iir (Iir_Kind_Value_Attribute);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Location_Copy (Res, Attr);
+ Set_Prefix (Res, Prefix_Name);
+ Set_Base_Name (Res, Res);
+
+ case Get_Identifier (Attr) is
+ when Name_Pos =>
+ -- LRM93 14.1
+ -- Result type: universal_integer.
+ Set_Type (Res, Convertible_Integer_Type_Definition);
+ when Name_Val =>
+ -- LRM93 14.1
+ -- Result type: the base type of T
+ Set_Type (Res, Get_Base_Type (Prefix_Type));
+ when Name_Succ
+ | Name_Pred
+ | Name_Leftof
+ | Name_Rightof =>
+ -- LRM93 14.1
+ -- Result type: the base type of T.
+ Set_Type (Res, Get_Base_Type (Prefix_Type));
+ when Name_Image =>
+ -- LRM93 14.1
+ -- Result type: type string
+ Set_Type (Res, String_Type_Definition);
+ when Name_Value =>
+ -- LRM93 14.1
+ -- Result type: the base type of T.
+ Set_Type (Res, Get_Base_Type (Prefix_Type));
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Sem_Scalar_Type_Attribute;
+
+ -- Analyze attributes whose prefix is a type or a subtype and result is
+ -- a value (not a function).
+ function Sem_Predefined_Type_Attribute (Attr : Iir_Attribute_Name)
+ return Iir
+ is
+ use Std_Names;
+ Prefix_Name : constant Iir := Get_Prefix (Attr);
+ Id : constant Name_Id := Get_Identifier (Attr);
+ Res : Iir;
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ begin
+ case Id is
+ when Name_Left =>
+ Res := Create_Iir (Iir_Kind_Left_Type_Attribute);
+ when Name_Right =>
+ Res := Create_Iir (Iir_Kind_Right_Type_Attribute);
+ when Name_High =>
+ Res := Create_Iir (Iir_Kind_High_Type_Attribute);
+ when Name_Low =>
+ Res := Create_Iir (Iir_Kind_Low_Type_Attribute);
+ when Name_Ascending =>
+ Res := Create_Iir (Iir_Kind_Ascending_Type_Attribute);
+ when Name_Range
+ | Name_Reverse_Range =>
+ Error_Msg_Sem
+ ("prefix of range attribute must be an array type or object",
+ Attr);
+ return Error_Mark;
+ when others =>
+ Error_Msg_Sem ("Attribute '" & Name_Table.Image (Id)
+ & " not valid on this type", Attr);
+ return Error_Mark;
+ end case;
+ Location_Copy (Res, Attr);
+ Set_Base_Name (Res, Res);
+
+ Prefix := Get_Named_Entity (Prefix_Name);
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ Prefix := Finish_Sem_Name (Prefix_Name, Prefix);
+ Prefix_Type := Get_Type (Prefix);
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix));
+ when Iir_Kind_Base_Attribute =>
+ -- Base_Attribute is already finished.
+ Prefix_Type := Get_Type (Prefix);
+ Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type));
+ when others =>
+ Prefix := Sem_Type_Mark (Prefix_Name);
+ Prefix_Type := Get_Type (Prefix);
+ Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type));
+ end case;
+ Set_Prefix (Res, Prefix);
+
+ case Get_Identifier (Attr) is
+ when Name_Ascending =>
+ -- LRM93 14.1
+ -- Result Type: type boolean.
+ Set_Type (Res, Boolean_Type_Definition);
+ when others =>
+ -- LRM 14.1
+ -- Result Type: Same type as T.
+ Set_Type (Res, Prefix_Type);
+ end case;
+ return Res;
+ end Sem_Predefined_Type_Attribute;
+
+ -- Called for attributes Length, Left, Right, High, Low, Range,
+ -- Reverse_Range, Ascending.
+ -- FIXME: handle overload
+ function Sem_Array_Attribute_Name (Attr : Iir_Attribute_Name) return Iir
+ is
+ use Std_Names;
+ Prefix: Iir;
+ Prefix_Name : constant Iir := Get_Prefix (Attr);
+ Prefix_Type : Iir;
+ Res : Iir;
+ Res_Type : Iir;
+ begin
+ Prefix := Get_Named_Entity (Prefix_Name);
+
+ -- LRM93 14.1
+ -- Prefix: Any prefix A that is appropriate for an array object, or an
+ -- alias thereof, or that denotes a constrained array subtype.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Dereference
+ | Iir_Kinds_Object_Declaration
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Image_Attribute =>
+ -- FIXME: list of expr.
+ Prefix_Type := Get_Type (Prefix);
+ case Get_Kind (Prefix_Type) is
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ declare
+ Designated_Type : Iir;
+ begin
+ Designated_Type :=
+ Get_Designated_Type (Get_Base_Type (Prefix_Type));
+ Prefix := Insert_Implicit_Dereference (Prefix, Attr);
+ Prefix_Type := Designated_Type;
+ end;
+ when Iir_Kinds_Array_Type_Definition =>
+ null;
+ when others =>
+ Error_Msg_Sem ("object prefix must be an array", Attr);
+ return Error_Mark;
+ end case;
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Base_Attribute =>
+ Prefix_Type := Get_Type (Prefix);
+ if not Is_Fully_Constrained_Type (Prefix_Type) then
+ Error_Msg_Sem ("prefix type is not constrained", Attr);
+ -- We continue using the unconstrained array type.
+ -- At least, this type is valid; and even if the array was
+ -- constrained, the base type would be the same.
+ end if;
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ -- For names such as pfx'Range'Left.
+ -- Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir);
+ Prefix_Type := Get_Type (Prefix);
+ when Iir_Kind_Process_Statement =>
+ Error_Msg_Sem
+ (Disp_Node (Prefix) & " is not an appropriate prefix for '"
+ & Name_Table.Image (Get_Identifier (Attr))
+ & " attribute",
+ Attr);
+ return Error_Mark;
+ when others =>
+ Error_Msg_Sem ("prefix must denote an array object or type", Attr);
+ return Error_Mark;
+ end case;
+
+ case Get_Kind (Prefix_Type) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ -- Note: prefix is a scalar type or subtype.
+ return Sem_Predefined_Type_Attribute (Attr);
+ when Iir_Kinds_Array_Type_Definition =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ ("prefix of '"
+ & Name_Table.Image (Get_Identifier (Attr))
+ & " attribute must denote a constrained array subtype",
+ Attr);
+ return Error_Mark;
+ end case;
+
+ -- Type of the attribute. This is correct unless there is a parameter,
+ -- and furthermore 'range and 'reverse_range has to be handled
+ -- specially because the result is a range and not a value.
+ Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0);
+
+ -- Create the node for the attribute.
+ case Get_Identifier (Attr) is
+ when Name_Left =>
+ Res := Create_Iir (Iir_Kind_Left_Array_Attribute);
+ when Name_Right =>
+ Res := Create_Iir (Iir_Kind_Right_Array_Attribute);
+ when Name_High =>
+ Res := Create_Iir (Iir_Kind_High_Array_Attribute);
+ when Name_Low =>
+ Res := Create_Iir (Iir_Kind_Low_Array_Attribute);
+ when Name_Range =>
+ Res := Create_Iir (Iir_Kind_Range_Array_Attribute);
+ when Name_Reverse_Range =>
+ Res := Create_Iir (Iir_Kind_Reverse_Range_Array_Attribute);
+ when Name_Length =>
+ Res := Create_Iir (Iir_Kind_Length_Array_Attribute);
+ -- FIXME: Error if ambiguous
+ Res_Type := Convertible_Integer_Type_Definition;
+ when Name_Ascending =>
+ Res := Create_Iir (Iir_Kind_Ascending_Array_Attribute);
+ -- FIXME: Error if ambiguous
+ Res_Type := Boolean_Type_Definition;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Location_Copy (Res, Attr);
+ Set_Prefix (Res, Prefix);
+ Set_Type (Res, Res_Type);
+ return Res;
+ end Sem_Array_Attribute_Name;
+
+ function Sem_Signal_Signal_Attribute
+ (Attr : Iir_Attribute_Name; Kind : Iir_Kind)
+ return Iir
+ is
+ Res : Iir;
+ Prefix : Iir;
+ begin
+ Prefix := Get_Named_Entity (Get_Prefix (Attr));
+ Res := Create_Iir (Kind);
+ if Kind = Iir_Kind_Delayed_Attribute then
+ Set_Type (Res, Get_Type (Prefix));
+ elsif Kind = Iir_Kind_Transaction_Attribute then
+ Set_Type (Res, Bit_Type_Definition);
+ else
+ Set_Type (Res, Boolean_Type_Definition);
+ end if;
+ Set_Base_Name (Res, Res);
+
+ if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration then
+ -- LRM93 2.1.1.2 / LRM08 4.2.2.3
+ --
+ -- It is an error if signal-valued attributes 'STABLE , 'QUIET,
+ -- 'TRANSACTION, and 'DELAYED of formal signal paramaters of any
+ -- mode are read within a subprogram.
+ case Get_Kind (Get_Parent (Prefix)) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Error_Msg_Sem
+ ("'" & Name_Table.Image (Get_Identifier (Attr)) &
+ " is not allowed for a signal parameter", Attr);
+ when others =>
+ null;
+ end case;
+ end if;
+ Sem_Stmts.Add_Declaration_For_Implicit_Signal (Res);
+ return Res;
+ end Sem_Signal_Signal_Attribute;
+
+ function Sem_Signal_Attribute (Attr : Iir_Attribute_Name) return Iir
+ is
+ use Std_Names;
+ Prefix: Iir;
+ Res : Iir;
+ Base : Iir;
+ begin
+ Prefix := Get_Named_Entity (Get_Prefix (Attr));
+ Base := Get_Object_Prefix (Prefix);
+ case Get_Kind (Base) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kinds_Signal_Attribute =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ ("prefix of '"
+ & Name_Table.Image (Get_Identifier (Attr))
+ & " attribute must denote a signal", Attr);
+ return Error_Mark;
+ end case;
+ case Get_Identifier (Attr) is
+ when Name_Stable =>
+ Res := Sem_Signal_Signal_Attribute
+ (Attr, Iir_Kind_Stable_Attribute);
+ when Name_Quiet =>
+ Res := Sem_Signal_Signal_Attribute
+ (Attr, Iir_Kind_Quiet_Attribute);
+ when Name_Delayed =>
+ Res := Sem_Signal_Signal_Attribute
+ (Attr, Iir_Kind_Delayed_Attribute);
+ when Name_Transaction =>
+ Res := Sem_Signal_Signal_Attribute
+ (Attr, Iir_Kind_Transaction_Attribute);
+ when Name_Event =>
+ Res := Create_Iir (Iir_Kind_Event_Attribute);
+ Set_Type (Res, Boolean_Type_Definition);
+ when Name_Active =>
+ Res := Create_Iir (Iir_Kind_Active_Attribute);
+ Set_Type (Res, Boolean_Type_Definition);
+ when Name_Last_Value =>
+ Res := Create_Iir (Iir_Kind_Last_Value_Attribute);
+ Set_Type (Res, Get_Type (Prefix));
+ when Name_Last_Event =>
+ Res := Create_Iir (Iir_Kind_Last_Event_Attribute);
+ Set_Type (Res, Time_Type_Definition);
+ when Name_Last_Active =>
+ Res := Create_Iir (Iir_Kind_Last_Active_Attribute);
+ Set_Type (Res, Time_Type_Definition);
+ when Name_Driving_Value =>
+ Res := Create_Iir (Iir_Kind_Driving_Value_Attribute);
+ Set_Type (Res, Get_Type (Prefix));
+ -- FIXME: check restrictions.
+ when Name_Driving =>
+ Res := Create_Iir (Iir_Kind_Driving_Attribute);
+ Set_Type (Res, Boolean_Type_Definition);
+ -- FIXME: check restrictions.
+ when others =>
+ -- Not yet implemented attribute, or really an internal error.
+ raise Internal_Error;
+ end case;
+ Location_Copy (Res, Attr);
+
+ -- LRM 4.3.2
+ -- The value of an object is said to be read when one of the following
+ -- conditions is satisfied:
+ -- [...]
+ -- * When the object is a signal and the value of any of its predefined
+ -- attributes 'STABLE, 'QUIET, 'DELAYED, 'TRANSACTION, 'EVENT,
+ -- 'ACTIVE, 'LAST_EVENT, 'LAST_ACTIVE, or 'LAST_VALUE is read.
+
+ -- LRM 14.1
+ -- S'Driving Restrictions:
+ -- S'Driving_Value Restrictions:
+ -- This attribute is available only from within a process, a
+ -- concurrent statement with an equivalent process, or a subprogram.
+ -- If the prefix denotes a port, it is an error if the port does not
+ -- have a mode of INOUT, OUT or BUFFER. It is also an error if the
+ -- attribute name appears in a subprogram body that is not a declarative
+ -- item contained within a process statement and the prefix is not a
+ -- formal parameter of the given subprogram or of a parent of that
+ -- subprogram. Finally, it is an error if the prefix denotes a
+ -- subprogram formal parameter whose mode is not INOUT or OUT, or if
+ -- S'Driving is False at the time of the evaluation of S'Driving_Value.
+ case Get_Kind (Res) is
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_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 =>
+ Check_Read (Prefix);
+ when Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute =>
+ -- FIXME: complete checks.
+ if Get_Current_Concurrent_Statement = Null_Iir then
+ Error_Msg_Sem
+ ("'driving or 'driving_value is available only within a "
+ & "concurrent statement", Attr);
+ else
+ case Get_Kind (Get_Current_Concurrent_Statement) is
+ when Iir_Kinds_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ ("'driving or 'driving_value not available within "
+ & "this concurrent statement", Attr);
+ end case;
+ end if;
+
+ case Get_Kind (Base) is
+ when Iir_Kind_Signal_Declaration =>
+ null;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ case Get_Mode (Base) is
+ when Iir_Buffer_Mode
+ | Iir_Inout_Mode
+ | Iir_Out_Mode =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ ("mode of 'driving or 'driving_value prefix must "
+ & "be out, inout or buffer", Attr);
+ end case;
+ when others =>
+ Error_Msg_Sem
+ ("bad prefix for 'driving or 'driving_value", Attr);
+ end case;
+ when others =>
+ null;
+ end case;
+
+ -- According to LRM 7.4, signal attributes are not static expressions
+ -- since the prefix (a signal) is not a static expression.
+ Set_Expr_Staticness (Res, None);
+
+ -- LRM 6.1
+ -- A name is said to be a static name if and only if at least one of
+ -- the following conditions holds:
+ -- [...]
+ -- - The name is a attribute name whose prefix is a static signal name
+ -- and whose suffix is one of the predefined attributes 'DELAYED,
+ -- 'STABLE, 'QUIET or 'TRANSACTION.
+ -- According to LRM 6.1, attributes are not static names.
+ if Flags.Vhdl_Std = Vhdl_93c or Flags.Vhdl_Std >= Vhdl_02 then
+ case Get_Kind (Res) is
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ Set_Name_Staticness (Res, Get_Name_Staticness (Prefix));
+ when others =>
+ Set_Name_Staticness (Res, None);
+ end case;
+ else
+ Set_Name_Staticness (Res, None);
+ end if;
+
+ Set_Prefix (Res, Prefix);
+
+ -- Set has_active_flag when activity is read.
+ case Get_Kind (Res) is
+ when Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Active_Attribute =>
+ Set_Has_Active_Flag (Base, True);
+ when others =>
+ null;
+ end case;
+
+ return Res;
+ end Sem_Signal_Attribute;
+
+ -- 'Simple_name, 'instance_name and 'path_name.
+ function Sem_Name_Attribute (Attr : Iir_Attribute_Name) return Iir
+ is
+ use Std_Names;
+ Prefix_Name : constant Iir := Get_Prefix (Attr);
+ Prefix: Iir;
+ Res : Iir;
+ Attr_Type : Iir;
+ begin
+ Prefix := Get_Named_Entity (Prefix_Name);
+ Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix));
+
+ -- LRM 14.1 Predefined attributes
+ -- E'SIMPLE_NAME
+ -- Prefix: Any named entity as defined in 5.1
+ -- E'INSTANCE_NAME
+ -- Prefix: Any named entity other than the local ports and generics
+ -- of a component declaration.
+ -- E'PATH_NAME
+ -- Prefix: Any named entity other than the local ports and generics
+ -- of a component declaration.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kinds_Library_Unit_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Constant_Declaration =>
+ if Get_Identifier (Attr) /= Name_Simple_Name
+ and then Get_Kind (Get_Parent (Prefix))
+ = Iir_Kind_Component_Declaration
+ then
+ Error_Msg_Sem
+ ("local ports or generics of a component cannot be a prefix",
+ Attr);
+ end if;
+ when others =>
+ Error_Msg_Sem (Disp_Node (Prefix) & " is not a named entity",
+ Attr);
+ end case;
+
+ case Get_Identifier (Attr) is
+ when Name_Simple_Name =>
+ Res := Create_Iir (Iir_Kind_Simple_Name_Attribute);
+ Eval_Simple_Name (Get_Identifier (Prefix));
+ Set_Simple_Name_Identifier (Res, Name_Table.Get_Identifier);
+ Attr_Type := Create_Unidim_Array_By_Length
+ (String_Type_Definition,
+ Iir_Int64 (Name_Table.Name_Length),
+ Attr);
+ Set_Simple_Name_Subtype (Res, Attr_Type);
+ Set_Expr_Staticness (Res, Locally);
+
+ when Name_Path_Name =>
+ Res := Create_Iir (Iir_Kind_Path_Name_Attribute);
+ Set_Expr_Staticness (Res, Globally);
+ Attr_Type := String_Type_Definition;
+
+ when Name_Instance_Name =>
+ Res := Create_Iir (Iir_Kind_Instance_Name_Attribute);
+ Set_Expr_Staticness (Res, Globally);
+ Attr_Type := String_Type_Definition;
+
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Location_Copy (Res, Attr);
+ Set_Prefix (Res, Prefix_Name);
+ Set_Type (Res, Attr_Type);
+ return Res;
+ end Sem_Name_Attribute;
+
+ procedure Sem_Attribute_Name (Attr : Iir_Attribute_Name)
+ is
+ use Std_Names;
+ Prefix : Iir;
+ Res : Iir;
+ Sig : Iir_Signature;
+ begin
+ -- LRM93 6.6 Attribute names
+ -- The meaning of the prefix of an attribute name must be determinable
+ -- independently of the attribute designator and independently of the
+ -- fact that it is the prefix of an attribute.
+ Prefix := Get_Prefix (Attr);
+
+ -- LRM93 6.6
+ -- If the prefix of an attribute name denotes an alias, then the
+ -- attribute name denotes an attribute of the aliased name and not the
+ -- alias itself, except when the attribute designator denotes any of
+ -- the predefined attributes 'Simple_Name, 'Path_Name or 'Instance_Name.
+ -- If the prefix of an attribute name denotes an alias and the
+ -- attribute designator denotes any of the predefined attributes
+ -- 'Simple_Name, 'Path_Name or 'Instance_Name, then the attribute name
+ -- denotes the attribute of the alias and not of the aliased name.
+ if Flags.Vhdl_Std > Vhdl_87
+ and then Get_Identifier (Attr) in Name_Id_Name_Attributes
+ then
+ Sem_Name (Prefix, True);
+ else
+ Sem_Name (Prefix, False);
+ end if;
+ Prefix := Get_Named_Entity (Prefix);
+
+ if Prefix = Error_Mark then
+ Set_Named_Entity (Attr, Prefix);
+ return;
+ end if;
+
+ -- LRM93 6.6
+ -- A signature may follow the prefix if and only if the prefix denotes
+ -- a subprogram or enumeration literal, or an alias thereof.
+ -- In this case, the signature is required to match (see Section 2.3.2)
+ -- the parameter and result type profile of exactly one visible
+ -- subprogram or enumeration literal, as is appropriate to the prefix.
+ -- GHDL: this is done by Sem_Signature.
+ Sig := Get_Attribute_Signature (Attr);
+ if Sig /= Null_Iir then
+ Prefix := Sem_Signature (Prefix, Sig);
+ if Prefix = Null_Iir then
+ Set_Named_Entity (Attr, Error_Mark);
+ return;
+ end if;
+ Set_Named_Entity (Get_Prefix (Attr), Prefix);
+ end if;
+
+ if Get_Kind (Prefix) = Iir_Kind_Overload_List then
+ -- FIXME: this should be allowed.
+ Error_Msg_Sem ("prefix of attribute is overloaded", Attr);
+ Set_Named_Entity (Attr, Error_Mark);
+ return;
+ end if;
+
+ -- Set_Prefix (Attr, Finish_Sem_Name (Get_Prefix (Attr), Prefix));
+
+ case Get_Identifier (Attr) is
+ when Name_Base =>
+ Res := Sem_Base_Attribute (Attr);
+ when Name_Image
+ | Name_Value =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Res := Sem_Scalar_Type_Attribute (Attr);
+ else
+ Res := Sem_User_Attribute (Attr);
+ end if;
+
+ when Name_Pos
+ | Name_Val
+ | Name_Succ
+ | Name_Pred
+ | Name_Rightof
+ | Name_Leftof =>
+ Res := Sem_Scalar_Type_Attribute (Attr);
+
+ when Name_Length
+ | Name_Left
+ | Name_Right
+ | Name_High
+ | Name_Low
+ | Name_Range
+ | Name_Reverse_Range =>
+ Res := Sem_Array_Attribute_Name (Attr);
+
+ when Name_Ascending =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Res := Sem_Array_Attribute_Name (Attr);
+ else
+ Res := Sem_User_Attribute (Attr);
+ end if;
+
+ when Name_Stable
+ | Name_Event
+ | Name_Last_Value
+ | Name_Delayed
+ | Name_Quiet
+ | Name_Transaction
+ | Name_Active
+ | Name_Last_Active
+ | Name_Last_Event =>
+ Res := Sem_Signal_Attribute (Attr);
+
+ when Name_Driving
+ | Name_Driving_Value =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Res := Sem_Signal_Attribute (Attr);
+ else
+ Res := Sem_User_Attribute (Attr);
+ end if;
+
+ when Name_Simple_Name
+ | Name_Path_Name
+ | Name_Instance_Name =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Res := Sem_Name_Attribute (Attr);
+ else
+ Res := Sem_User_Attribute (Attr);
+ end if;
+
+ when others =>
+ Res := Sem_User_Attribute (Attr);
+ end case;
+
+ if Res = Null_Iir then
+ Error_Kind ("sem_attribute_name", Attr);
+ end if;
+ Set_Named_Entity (Attr, Res);
+ end Sem_Attribute_Name;
+
+ -- LRM93 �6
+ procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False) is
+ begin
+ -- Exit now if NAME was already semantized.
+ if Get_Named_Entity (Name) /= Null_Iir then
+ return;
+ end if;
+
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Operator_Symbol =>
+ -- String_Literal may be a symbol_operator.
+ Sem_Simple_Name (Name, Keep_Alias, Soft => False);
+ when Iir_Kind_Selected_Name =>
+ Sem_Selected_Name (Name, Keep_Alias);
+ when Iir_Kind_Parenthesis_Name =>
+ Sem_Parenthesis_Name (Name);
+ when Iir_Kind_Selected_By_All_Name =>
+ Sem_Selected_By_All_Name (Name);
+ when Iir_Kind_Attribute_Name =>
+ Sem_Attribute_Name (Name);
+ when others =>
+ Error_Kind ("sem_name", Name);
+ end case;
+ end Sem_Name;
+
+ procedure Sem_Name_Soft (Name : Iir)
+ is
+ begin
+ -- Exit now if NAME was already semantized.
+ if Get_Named_Entity (Name) /= Null_Iir then
+ return;
+ end if;
+
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Operator_Symbol =>
+ -- String_Literal may be a symbol_operator.
+ Sem_Simple_Name (Name, False, Soft => True);
+ when others =>
+ Error_Kind ("sem_name_soft", Name);
+ end case;
+ end Sem_Name_Soft;
+
+ procedure Sem_Name_Clean (Name : Iir)
+ is
+ N : Iir;
+ Next_N : Iir;
+ Named_Entity : Iir;
+ Atype : Iir;
+ begin
+ N := Name;
+ while N /= Null_Iir loop
+ case Get_Kind (N) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Operator_Symbol =>
+ Next_N := Null_Iir;
+ when others =>
+ Error_Kind ("sem_name_clean", N);
+ end case;
+
+ -- Clear and free overload lists of Named_entity and type.
+ Named_Entity := Get_Named_Entity (N);
+ Set_Named_Entity (N, Null_Iir);
+ if Named_Entity /= Null_Iir
+ and then Is_Overload_List (Named_Entity)
+ then
+ Free_Iir (Named_Entity);
+ end if;
+
+ Atype := Get_Type (N);
+ Set_Type (N, Null_Iir);
+ if Atype /= Null_Iir
+ and then Is_Overload_List (Atype)
+ then
+ Free_Iir (Atype);
+ end if;
+
+ N := Next_N;
+ end loop;
+ end Sem_Name_Clean;
+
+ -- Remove procedure specification from LIST.
+ function Remove_Procedures_From_List (Expr : Iir) return Iir
+ is
+ El : Iir;
+ P : Natural;
+ List : Iir_List;
+ begin
+ if not Is_Overload_List (Expr) then
+ return Expr;
+ end if;
+ List := Get_Overload_List (Expr);
+ P := 0;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ case Get_Kind (El) is
+ when Iir_Kinds_Procedure_Declaration =>
+ null;
+ when Iir_Kinds_Function_Declaration =>
+ if Maybe_Function_Call (El) then
+ Replace_Nth_Element (List, P, El);
+ P := P + 1;
+ end if;
+ when others =>
+ Replace_Nth_Element (List, P, El);
+ P := P + 1;
+ end case;
+ end loop;
+ case P is
+ when 0 =>
+ Free_Iir (Expr);
+ return Null_Iir;
+ when 1 =>
+ El := Get_First_Element (List);
+ Free_Iir (Expr);
+ return El;
+ when others =>
+ Set_Nbr_Elements (List, P);
+ return Expr;
+ end case;
+ end Remove_Procedures_From_List;
+
+ -- Convert name EXPR to an expression (ie, create function call).
+ -- A_TYPE is the expected type of the expression.
+ -- Returns NULL_IIR in case of error.
+ function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir
+ is
+ Ret_Type : Iir;
+ Res_Type : Iir;
+ Expr : Iir;
+ Expr_List : Iir_List;
+ Res : Iir;
+ El : Iir;
+ begin
+ Expr := Get_Named_Entity (Name);
+ if Get_Kind (Expr) = Iir_Kind_Error then
+ return Null_Iir;
+ end if;
+ if Check_Is_Expression (Expr, Name) = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- Note: EXPR may contain procedure names...
+ Expr := Remove_Procedures_From_List (Expr);
+ Set_Named_Entity (Name, Expr);
+ if Expr = Null_Iir then
+ Error_Msg_Sem ("procedure name " & Disp_Node (Name)
+ & " cannot be used as expression", Name);
+ return Null_Iir;
+ end if;
+
+ if not Is_Overload_List (Expr) then
+ Res := Finish_Sem_Name (Name);
+ pragma Assert (Res /= Null_Iir);
+ if A_Type /= Null_Iir then
+ Res_Type := Get_Type (Res);
+ if Res_Type = Null_Iir then
+ return Null_Iir;
+ end if;
+ if not Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type)
+ then
+ Error_Not_Match (Res, A_Type, Name);
+ return Null_Iir;
+ end if;
+ -- Fall through.
+ end if;
+ else
+ -- EXPR is an overloaded name.
+ Expr_List := Get_Overload_List (Expr);
+
+ if A_Type /= Null_Iir then
+ -- Find the name returning A_TYPE.
+ Res := Null_Iir;
+ for I in Natural loop
+ El := Get_Nth_Element (Expr_List, I);
+ exit when El = Null_Iir;
+ if Are_Basetypes_Compatible (Get_Base_Type (Get_Type (El)),
+ A_Type)
+ then
+ Add_Result (Res, El);
+ end if;
+ end loop;
+ if Res = Null_Iir then
+ Error_Not_Match (Name, A_Type, Name);
+ return Null_Iir;
+ elsif Is_Overload_List (Res) then
+ Error_Overload (Name);
+ Disp_Overload_List (Get_Overload_List (Res), Name);
+ return Null_Iir;
+ else
+ -- Free results
+ Sem_Name_Free_Result (Expr, Res);
+
+ Ret_Type := Get_Type (Name);
+ if Ret_Type /= Null_Iir then
+ pragma Assert (Is_Overload_List (Ret_Type));
+ Free_Overload_List (Ret_Type);
+ end if;
+
+ Set_Named_Entity (Name, Res);
+ Res := Finish_Sem_Name (Name);
+ -- Fall through.
+ end if;
+ else
+ -- Create a list of type.
+ Ret_Type := Create_List_Of_Types (Expr_List);
+ if Ret_Type = Null_Iir or else not Is_Overload_List (Ret_Type) then
+ -- There is either no types or one type for
+ -- several meanings.
+ Error_Overload (Name);
+ Disp_Overload_List (Expr_List, Name);
+ --Free_Iir (Ret_Type);
+ return Null_Iir;
+ end if;
+ Set_Type (Name, Ret_Type);
+ return Name;
+ end if;
+ end if;
+
+ -- NAME has only one meaning, which is RES.
+ case Get_Kind (Res) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Selected_Name =>
+ Expr := Get_Named_Entity (Res);
+ case Get_Kind (Expr) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Function_Declaration =>
+ if Maybe_Function_Call (Expr) then
+ Expr := Sem_As_Function_Call (Res, Expr, Null_Iir);
+ if Get_Kind (Expr) /= Iir_Kind_Function_Call then
+ raise Internal_Error;
+ end if;
+ Finish_Sem_Function_Call (Expr, Res);
+ return Expr;
+ else
+ Error_Msg_Sem
+ (Disp_Node (Expr) & " requires parameters", Res);
+ Set_Type (Res, Get_Type (Expr));
+ Set_Expr_Staticness (Res, None);
+ return Res;
+ end if;
+ when others =>
+ null;
+ end case;
+ Set_Type (Res, Get_Type (Expr));
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr));
+ --Set_Name_Staticness (Name, Get_Name_Staticness (Expr));
+ --Set_Base_Name (Name, Get_Base_Name (Expr));
+ return Res;
+ when Iir_Kind_Function_Call
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Attribute_Name =>
+ return Eval_Expr_If_Static (Res);
+ when Iir_Kind_Dereference =>
+ -- Never static.
+ return Res;
+ when Iir_Kinds_Array_Attribute =>
+ -- FIXME: exclude range and reverse_range.
+ return Eval_Expr_If_Static (Res);
+ when Iir_Kinds_Signal_Attribute
+ | Iir_Kinds_Signal_Value_Attribute =>
+ -- Never static
+ return Res;
+ when Iir_Kinds_Type_Attribute
+ | Iir_Kinds_Scalar_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ return Eval_Expr_If_Static (Res);
+ when Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Selected_By_All_Name =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("name_to_expression", Res);
+ end case;
+ end Name_To_Expression;
+
+ function Name_To_Range (Name : Iir) return Iir
+ is
+ Expr : Iir;
+ begin
+ Expr := Get_Named_Entity (Name);
+ if Get_Kind (Expr) = Iir_Kind_Error then
+ return Error_Mark;
+ end if;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration =>
+ Expr := Sem_Type_Mark (Name);
+ Set_Expr_Staticness
+ (Expr, Get_Type_Staticness (Get_Type (Expr)));
+ return Expr;
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ if Get_Parameter (Expr) = Null_Iir then
+ Finish_Sem_Array_Attribute (Name, Expr, Null_Iir);
+ end if;
+ if Get_Kind (Name) = Iir_Kind_Attribute_Name then
+ Free_Iir (Name);
+ else
+ Free_Iir (Get_Prefix (Name));
+ Free_Parenthesis_Name (Name, Expr);
+ end if;
+ return Expr;
+ when others =>
+ Error_Msg_Sem ("name " & Disp_Node (Name)
+ & " doesn't denote a range", Name);
+ return Error_Mark;
+ end case;
+ end Name_To_Range;
+
+ function Is_Object_Name (Name : Iir) return Boolean is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_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_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Dereference
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Function_Call
+ | Iir_Kinds_Attribute =>
+ return True;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return False;
+ when others =>
+ return False;
+ end case;
+ end Is_Object_Name;
+
+ function Name_To_Object (Name : Iir) return Iir is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_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_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Dereference
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Function_Call
+ | Iir_Kinds_Signal_Attribute =>
+ return Name;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Name_To_Object (Get_Named_Entity (Name));
+ when others =>
+ return Null_Iir;
+ end case;
+ end Name_To_Object;
+
+ function Create_Error_Name (Orig : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Error);
+ Set_Expr_Staticness (Res, None);
+ Set_Error_Origin (Res, Orig);
+ Location_Copy (Res, Orig);
+ return Res;
+ end Create_Error_Name;
+
+ function Sem_Denoting_Name (Name: Iir) return Iir
+ is
+ Res: Iir;
+ begin
+ pragma Assert (Get_Kind (Name) in Iir_Kinds_Denoting_Name);
+
+ Sem_Name (Name);
+ Res := Get_Named_Entity (Name);
+
+ case Get_Kind (Res) is
+ when Iir_Kind_Error =>
+ -- A message must have been displayed.
+ return Name;
+ when Iir_Kind_Overload_List =>
+ Error_Overload (Res);
+ Set_Named_Entity (Name, Create_Error_Name (Name));
+ return Name;
+ when Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kinds_Object_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kinds_Subprogram_Declaration
+ | Iir_Kind_Component_Declaration =>
+ Res := Finish_Sem_Name (Name, Res);
+ pragma Assert (Get_Kind (Res) in Iir_Kinds_Denoting_Name);
+ return Res;
+ when Iir_Kind_Selected_Element =>
+ -- An error (to be diagnosticed by the caller).
+ return Name;
+ when others =>
+ Error_Kind ("sem_denoting_name", Res);
+ end case;
+ end Sem_Denoting_Name;
+
+ function Sem_Terminal_Name (Name : Iir) return Iir
+ is
+ Res : Iir;
+ Ent : Iir;
+ begin
+ Res := Sem_Denoting_Name (Name);
+ Ent := Get_Named_Entity (Res);
+ if Get_Kind (Ent) /= Iir_Kind_Terminal_Declaration then
+ Error_Class_Match (Name, "terminal");
+ Set_Named_Entity (Res, Create_Error_Name (Name));
+ end if;
+ return Res;
+ end Sem_Terminal_Name;
+
+ procedure Error_Class_Match (Name : Iir; Class_Name : String)
+ is
+ Ent : constant Iir := Get_Named_Entity (Name);
+ begin
+ if Is_Error (Ent) then
+ Error_Msg_Sem (Class_Name & " name expected", Name);
+ else
+ Error_Msg_Sem
+ (Class_Name & " name expected, found "
+ & Disp_Node (Get_Named_Entity (Name)), Name);
+ end if;
+ end Error_Class_Match;
+end Sem_Names;
diff --git a/src/sem_names.ads b/src/sem_names.ads
new file mode 100644
index 000000000..3bc85305d
--- /dev/null
+++ b/src/sem_names.ads
@@ -0,0 +1,159 @@
+-- Semantic analysis.
+-- 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 Sem_Names is
+ -- In VHDL, most of name notations are ambiguous:
+ -- P.N is either
+ -- an expanded name or
+ -- a selected name for an element (with a possible implicit dereference)
+ -- P (A1, A2, ...) can be
+ -- an indexed name (with a possible implicit dereference)
+ -- a slice name (with a possible implicit dereference)
+ -- a subprogram call
+ -- a type conversion
+
+ -- The name analysis resolves two ambiguities: notation and overload.
+ -- In a first pass, all possible meaning are collected as an overload
+ -- list in the Named_Entity field of the name. Prefixes in that list
+ -- are always declarations and not simple or expanded names. This is done
+ -- to avoid creating nodes for simple or expanded names, as they cannot be
+ -- shared in the prefixes because they can have several meanings.
+ --
+ -- In a second pass, when the caller has resolved the overloading (using
+ -- the context), the name is rewritten: parenthesis and selected names are
+ -- replaced (by slice, index, call, element selection...). Prefixes are
+ -- simple or expanded names (and never declarations). Checks are also
+ -- performed on the result (pure, all sensitized).
+ --
+ -- The result of the name analysis may not be a name: a function_call or
+ -- a type conversion are not names.
+
+ -- Analyze NAME: perform the first pass only. In case of error, a message
+ -- is displayed and the named entity is error_mark.
+ procedure Sem_Name (Name : Iir; Keep_Alias : Boolean := False);
+
+ -- Finish semantisation of NAME, if necessary. The named entity must not
+ -- be an overload list (ie the overload resolution must have been done).
+ -- This make remaining checks, transforms function names into calls...
+ function Finish_Sem_Name (Name : Iir) return Iir;
+
+ -- Analyze NAME as a type mark. NAME must be either a simple name or an
+ -- expanded name, and the denoted entity must be either a type or a subtype
+ -- declaration. Return the name (possibly modified) and set named_entity
+ -- and type. In case of error, the type is error_mark. NAME may have
+ -- already been analyzed by Sem_Name.
+ -- Incomplete types are allowed only if INCOMPLETE is True.
+ function Sem_Type_Mark (Name : Iir; Incomplete : Boolean := False)
+ return Iir;
+
+ -- Same as Sem_Name but without any side-effect:
+ -- * do not report error
+ -- * do not set xrefs
+ -- Currently, only simple names (and expanded names) are handled.
+ -- This is to be used during sem of associations. Because there is no side
+ -- effect, NAME is not modified.
+ procedure Sem_Name_Soft (Name : Iir);
+
+ -- Remove every named_entity of NAME.
+ -- If NAME is Null_Iir then this is no op.
+ -- To be used only for names (weakly) semantized by sem_name_soft.
+ procedure Sem_Name_Clean (Name : Iir);
+
+ -- Return TRUE if NAME is a name that designate an object (ie a constant,
+ -- a variable, a signal or a file).
+ function Is_Object_Name (Name : Iir) return Boolean;
+
+ -- Return an object node if NAME designates an object (ie either is an
+ -- object or a name for an object).
+ -- Otherwise, returns NULL_IIR.
+ function Name_To_Object (Name : Iir) return Iir;
+
+ -- If NAME is a selected name whose prefix is a protected variable, set
+ -- method_object of CALL.
+ procedure Name_To_Method_Object (Call : Iir; Name : Iir);
+
+ -- Convert name NAME to an expression (ie, can create function call).
+ -- A_TYPE is the expected type of the expression.
+ -- FIXME: it is unclear wether the result must be an expression or not
+ -- (ie, it *must* have a type, but may be a range).
+ function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir;
+
+ -- Finish analyze of NAME and expect a range (either a type or subtype
+ -- declaration or a range attribute). Return Error_Mark in case of error.
+ function Name_To_Range (Name : Iir) return Iir;
+
+ -- Return true if AN_IIR is an overload list.
+ function Is_Overload_List (An_Iir: Iir) return Boolean;
+ pragma Inline (Is_Overload_List);
+
+ -- Create an overload list, that must be destroyed by Destroy_Overload_List.
+ function Get_Overload_List return Iir_Overload_List;
+ pragma Inline (Get_Overload_List);
+
+ function Create_Overload_List (List : Iir_List) return Iir_Overload_List;
+ pragma Inline (Create_Overload_List);
+
+ -- Free the list node (and the list itself).
+ procedure Free_Overload_List (N : in out Iir_Overload_List);
+
+ -- Display an error message if the overload resolution for EXPR find more
+ -- than one interpretation.
+ procedure Error_Overload (Expr: Iir);
+
+ -- Disp the overload list LIST.
+ procedure Disp_Overload_List (List : Iir_List; Loc : Iir);
+
+ -- Convert a list to either Null_Iir, an element or an overload list.
+ function Simplify_Overload_List (List : Iir_List) return Iir;
+
+ -- Add new interpretation DECL to RES.
+ -- Create an overload_list if necessary.
+ -- Before the first call, RES should be set to NULL_IIR.
+ procedure Add_Result (Res : in out Iir; Decl : Iir);
+
+ -- Free a Parenthesis_Name. This is a special case as in general the
+ -- Association_Chain field must be freed too.
+ procedure Free_Parenthesis_Name (Name : Iir; Res : Iir);
+
+ -- Return TRUE iff TYPE1 and TYPE2 are closely related.
+ function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean;
+
+ -- From the list LIST of function or enumeration literal, extract the
+ -- list of (return) types.
+ -- If there is only one type, return it.
+ -- If there is no types, return NULL.
+ -- Otherwise, return the list as an overload list.
+ function Create_List_Of_Types (List : Iir_List) return Iir;
+
+ function Sem_Index_Specification (Name : Iir_Parenthesis_Name; Itype : Iir)
+ return Iir;
+
+ -- Analyze denoting name NAME. NAME must be either a simple name or an
+ -- expanded name and so is the result.
+ function Sem_Denoting_Name (Name: Iir) return Iir;
+
+ -- Like Sem_Denoting_Name but expect a terminal name.
+ function Sem_Terminal_Name (Name : Iir) return Iir;
+
+ -- Emit an error for NAME that doesn't match its class CLASS_NAME.
+ procedure Error_Class_Match (Name : Iir; Class_Name : String);
+
+ -- Create an error node for name ORIG; set its expr staticness to none.
+ function Create_Error_Name (Orig : Iir) return Iir;
+end Sem_Names;
diff --git a/src/sem_psl.adb b/src/sem_psl.adb
new file mode 100644
index 000000000..cae63f740
--- /dev/null
+++ b/src/sem_psl.adb
@@ -0,0 +1,617 @@
+-- Semantic analysis 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 PSL.Nodes; use PSL.Nodes;
+with PSL.Subsets;
+with PSL.Hash;
+
+with Sem_Expr;
+with Sem_Stmts; use Sem_Stmts;
+with Sem_Scopes;
+with Sem_Names;
+with Std_Names;
+with Iirs_Utils; use Iirs_Utils;
+with Std_Package;
+with Ieee.Std_Logic_1164;
+with Errorout; use Errorout;
+with Xrefs; use Xrefs;
+
+package body Sem_Psl is
+ -- Return TRUE iff Atype is a PSL boolean type.
+ -- See PSL1.1 5.1.2 Boolean expressions
+ function Is_Psl_Bool_Type (Atype : Iir) return Boolean
+ is
+ Btype : Iir;
+ begin
+ if Atype = Null_Iir then
+ return False;
+ end if;
+ Btype := Get_Base_Type (Atype);
+ return Btype = Std_Package.Boolean_Type_Definition
+ or else Btype = Std_Package.Bit_Type_Definition
+ or else Btype = Ieee.Std_Logic_1164.Std_Ulogic_Type;
+ end Is_Psl_Bool_Type;
+
+ -- Return TRUE if EXPR type is a PSL boolean type.
+ function Is_Psl_Bool_Expr (Expr : Iir) return Boolean is
+ begin
+ return Is_Psl_Bool_Type (Get_Type (Expr));
+ end Is_Psl_Bool_Expr;
+
+ -- Convert VHDL and/or/not nodes to PSL nodes.
+ function Convert_Bool (Expr : Iir) return Node
+ is
+ use Std_Names;
+ Impl : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kinds_Dyadic_Operator =>
+ declare
+ Left : Iir;
+ Right : Iir;
+
+ function Build_Op (Kind : Nkind) return Node
+ is
+ N : Node;
+ begin
+ N := Create_Node (Kind);
+ Set_Location (N, Get_Location (Expr));
+ Set_Left (N, Convert_Bool (Left));
+ Set_Right (N, Convert_Bool (Right));
+ Free_Iir (Expr);
+ return N;
+ end Build_Op;
+ begin
+ Impl := Get_Implementation (Expr);
+ Left := Get_Left (Expr);
+ Right := Get_Right (Expr);
+ if Impl /= Null_Iir
+ and then Is_Psl_Bool_Expr (Left)
+ and then Is_Psl_Bool_Expr (Right)
+ then
+ if Get_Identifier (Impl) = Name_And then
+ return Build_Op (N_And_Bool);
+ elsif Get_Identifier (Impl) = Name_Or then
+ return Build_Op (N_Or_Bool);
+ end if;
+ end if;
+ end;
+ when Iir_Kinds_Monadic_Operator =>
+ declare
+ Operand : Iir;
+
+ function Build_Op (Kind : Nkind) return Node
+ is
+ N : Node;
+ begin
+ N := Create_Node (Kind);
+ Set_Location (N, Get_Location (Expr));
+ Set_Boolean (N, Convert_Bool (Operand));
+ Free_Iir (Expr);
+ return N;
+ end Build_Op;
+ begin
+ Impl := Get_Implementation (Expr);
+ Operand := Get_Operand (Expr);
+ if Impl /= Null_Iir
+ and then Is_Psl_Bool_Expr (Operand)
+ then
+ if Get_Identifier (Impl) = Name_Not then
+ return Build_Op (N_Not_Bool);
+ end if;
+ end if;
+ end;
+ when Iir_Kinds_Name =>
+ -- Get the named entity for names in order to hash it.
+ declare
+ Name : Iir;
+ begin
+ Name := Get_Named_Entity (Expr);
+ if Name /= Null_Iir then
+ return PSL.Hash.Get_PSL_Node (HDL_Node (Name));
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+ return PSL.Hash.Get_PSL_Node (HDL_Node (Expr));
+ end Convert_Bool;
+
+ -- Semantize an HDL expression. This may mostly a wrapper except in the
+ -- case when the expression is in fact a PSL expression.
+ function Sem_Hdl_Expr (N : Node) return Node
+ is
+ use Sem_Names;
+
+ Expr : Iir;
+ Name : Iir;
+ Decl : Node;
+ Res : Node;
+ begin
+ Expr := Get_HDL_Node (N);
+ if Get_Kind (Expr) in Iir_Kinds_Name then
+ Sem_Name (Expr);
+ Expr := Finish_Sem_Name (Expr);
+ Set_HDL_Node (N, Expr);
+
+ if Get_Kind (Expr) in Iir_Kinds_Denoting_Name then
+ Name := Get_Named_Entity (Expr);
+ else
+ Name := Expr;
+ end if;
+
+ case Get_Kind (Name) is
+ when Iir_Kind_Error =>
+ return N;
+ when Iir_Kind_Overload_List =>
+ -- FIXME: todo.
+ raise Internal_Error;
+ when Iir_Kind_Psl_Declaration =>
+ Decl := Get_Psl_Declaration (Name);
+ case Get_Kind (Decl) is
+ when N_Sequence_Declaration =>
+ Res := Create_Node (N_Sequence_Instance);
+ when N_Endpoint_Declaration =>
+ Res := Create_Node (N_Endpoint_Instance);
+ when N_Property_Declaration =>
+ Res := Create_Node (N_Property_Instance);
+ when N_Boolean_Parameter
+ | N_Sequence_Parameter
+ | N_Const_Parameter
+ | N_Property_Parameter =>
+ -- FIXME: create a n_name
+ Free_Node (N);
+ Free_Iir (Expr);
+ return Decl;
+ when others =>
+ Error_Kind ("sem_hdl_expr(2)", Decl);
+ end case;
+ Set_Location (Res, Get_Location (N));
+ Set_Declaration (Res, Decl);
+ if Get_Parameter_List (Decl) /= Null_Node then
+ Error_Msg_Sem ("no actual for instantiation", Res);
+ end if;
+ Free_Node (N);
+ Free_Iir (Expr);
+ return Res;
+ when Iir_Kind_Psl_Expression =>
+ -- Remove the two bridge nodes: from PSL to HDL and from
+ -- HDL to PSL.
+ Free_Node (N);
+ Res := Get_Psl_Expression (Name);
+ Free_Iir (Expr);
+ if Name /= Expr then
+ Free_Iir (Name);
+ end if;
+ return Res;
+ when others =>
+ Expr := Name;
+ end case;
+ else
+ Expr := Sem_Expr.Sem_Expression (Expr, Null_Iir);
+ end if;
+
+ if Expr = Null_Iir then
+ return N;
+ end if;
+ Free_Node (N);
+ if not Is_Psl_Bool_Expr (Expr) then
+ Error_Msg_Sem ("type of expression must be boolean", Expr);
+ return PSL.Hash.Get_PSL_Node (HDL_Node (Expr));
+ else
+ return Convert_Bool (Expr);
+ end if;
+ end Sem_Hdl_Expr;
+
+ -- Sem a boolean node.
+ function Sem_Boolean (Bool : Node) return Node is
+ begin
+ case Get_Kind (Bool) is
+ when N_HDL_Expr =>
+ return Sem_Hdl_Expr (Bool);
+ when N_And_Bool
+ | N_Or_Bool =>
+ Set_Left (Bool, Sem_Boolean (Get_Left (Bool)));
+ Set_Right (Bool, Sem_Boolean (Get_Right (Bool)));
+ return Bool;
+ when others =>
+ Error_Kind ("psl.sem_boolean", Bool);
+ end case;
+ end Sem_Boolean;
+
+ -- Used by Sem_Property to rewrite a property logical operator to a
+ -- boolean logical operator.
+ function Reduce_Logic_Node (Prop : Node; Bool_Kind : Nkind) return Node
+ is
+ Res : Node;
+ begin
+ Res := Create_Node (Bool_Kind);
+ Set_Location (Res, Get_Location (Prop));
+ Set_Left (Res, Get_Left (Prop));
+ Set_Right (Res, Get_Right (Prop));
+ Free_Node (Prop);
+ return Res;
+ end Reduce_Logic_Node;
+
+ function Sem_Sequence (Seq : Node) return Node
+ is
+ Res : Node;
+ L, R : Node;
+ begin
+ case Get_Kind (Seq) is
+ when N_Braced_SERE =>
+ Res := Sem_Sequence (Get_SERE (Seq));
+ Set_SERE (Seq, Res);
+ return Seq;
+ when N_Concat_SERE
+ | N_Fusion_SERE
+ | N_Within_SERE
+ | N_Or_Seq
+ | N_And_Seq
+ | N_Match_And_Seq =>
+ L := Sem_Sequence (Get_Left (Seq));
+ Set_Left (Seq, L);
+ R := Sem_Sequence (Get_Right (Seq));
+ Set_Right (Seq, R);
+ return Seq;
+ when N_Star_Repeat_Seq =>
+ Res := Get_Sequence (Seq);
+ if Res /= Null_Node then
+ Res := Sem_Sequence (Get_Sequence (Seq));
+ Set_Sequence (Seq, Res);
+ end if;
+ -- FIXME: range.
+ return Seq;
+ when N_Plus_Repeat_Seq =>
+ Res := Get_Sequence (Seq);
+ if Res /= Null_Node then
+ Res := Sem_Sequence (Get_Sequence (Seq));
+ Set_Sequence (Seq, Res);
+ end if;
+ return Seq;
+ when N_And_Bool
+ | N_Or_Bool
+ | N_Not_Bool =>
+ return Sem_Boolean (Seq);
+ when N_HDL_Expr =>
+ return Sem_Hdl_Expr (Seq);
+ when others =>
+ Error_Kind ("psl.sem_sequence", Seq);
+ end case;
+ end Sem_Sequence;
+
+ function Sem_Property (Prop : Node; Top : Boolean := False) return Node
+ is
+ Res : Node;
+ L, R : Node;
+ begin
+ case Get_Kind (Prop) is
+ when N_Braced_SERE =>
+ return Sem_Sequence (Prop);
+ when N_Always
+ | N_Never =>
+ -- By extension, clock_event is allowed within outermost
+ -- always/never.
+ Res := Sem_Property (Get_Property (Prop), Top);
+ Set_Property (Prop, Res);
+ return Prop;
+ when N_Eventually =>
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ return Prop;
+ when N_Clock_Event =>
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ Res := Sem_Boolean (Get_Boolean (Prop));
+ Set_Boolean (Prop, Res);
+ if not Top then
+ Error_Msg_Sem ("inner clock event not supported", Prop);
+ end if;
+ return Prop;
+ when N_Abort =>
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ Res := Sem_Boolean (Get_Boolean (Prop));
+ Set_Boolean (Prop, Res);
+ return Prop;
+ when N_Until
+ | N_Before =>
+ Res := Sem_Property (Get_Left (Prop));
+ Set_Left (Prop, Res);
+ Res := Sem_Property (Get_Right (Prop));
+ Set_Right (Prop, Res);
+ return Prop;
+ when N_Log_Imp_Prop
+ | N_And_Prop
+ | N_Or_Prop =>
+ L := Sem_Property (Get_Left (Prop));
+ Set_Left (Prop, L);
+ R := Sem_Property (Get_Right (Prop));
+ Set_Right (Prop, R);
+ if Get_Psl_Type (L) = Type_Boolean
+ and then Get_Psl_Type (R) = Type_Boolean
+ then
+ case Get_Kind (Prop) is
+ when N_And_Prop =>
+ return Reduce_Logic_Node (Prop, N_And_Bool);
+ when N_Or_Prop =>
+ return Reduce_Logic_Node (Prop, N_Or_Bool);
+ when N_Log_Imp_Prop =>
+ return Reduce_Logic_Node (Prop, N_Imp_Bool);
+ when others =>
+ Error_Kind ("psl.sem_property(log)", Prop);
+ end case;
+ end if;
+ return Prop;
+ when N_Overlap_Imp_Seq
+ | N_Imp_Seq =>
+ Res := Sem_Sequence (Get_Sequence (Prop));
+ Set_Sequence (Prop, Res);
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ return Prop;
+ when N_Next =>
+ -- FIXME: number.
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ return Prop;
+ when N_Next_A =>
+ -- FIXME: range.
+ Res := Sem_Property (Get_Property (Prop));
+ Set_Property (Prop, Res);
+ return Prop;
+ when N_HDL_Expr =>
+ Res := Sem_Hdl_Expr (Prop);
+ if not Top and then Get_Kind (Res) = N_Property_Instance then
+ declare
+ Decl : constant Node := Get_Declaration (Res);
+ begin
+ if Decl /= Null_Node
+ and then Get_Global_Clock (Decl) /= Null_Node
+ then
+ Error_Msg_Sem ("property instance already has a clock",
+ Prop);
+ end if;
+ end;
+ end if;
+ return Res;
+ when others =>
+ Error_Kind ("psl.sem_property", Prop);
+ end case;
+ end Sem_Property;
+
+ -- Extract the clock from PROP.
+ procedure Extract_Clock (Prop : in out Node; Clk : out Node)
+ is
+ Child : Node;
+ begin
+ Clk := Null_Node;
+ case Get_Kind (Prop) is
+ when N_Clock_Event =>
+ Clk := Get_Boolean (Prop);
+ Prop := Get_Property (Prop);
+ when N_Always
+ | N_Never =>
+ Child := Get_Property (Prop);
+ if Get_Kind (Child) = N_Clock_Event then
+ Set_Property (Prop, Get_Property (Child));
+ Clk := Get_Boolean (Child);
+ end if;
+ when N_Property_Instance =>
+ Child := Get_Declaration (Prop);
+ Clk := Get_Global_Clock (Child);
+ when others =>
+ null;
+ end case;
+ end Extract_Clock;
+
+ -- Sem a property/sequence/endpoint declaration.
+ procedure Sem_Psl_Declaration (Stmt : Iir)
+ is
+ use Sem_Scopes;
+ Decl : Node;
+ Prop : Node;
+ Clk : Node;
+ Formal : Node;
+ El : Iir;
+ begin
+ Sem_Scopes.Add_Name (Stmt);
+ Xref_Decl (Stmt);
+
+ Decl := Get_Psl_Declaration (Stmt);
+
+ Open_Declarative_Region;
+
+ -- Make formal parameters visible.
+ Formal := Get_Parameter_List (Decl);
+ while Formal /= Null_Node loop
+ El := Create_Iir (Iir_Kind_Psl_Declaration);
+ Set_Location (El, Get_Location (Formal));
+ Set_Identifier (El, Get_Identifier (Formal));
+ Set_Psl_Declaration (El, Formal);
+
+ Sem_Scopes.Add_Name (El);
+ Xref_Decl (El);
+ Set_Visible_Flag (El, True);
+
+ Formal := Get_Chain (Formal);
+ end loop;
+
+ case Get_Kind (Decl) is
+ when N_Property_Declaration =>
+ -- FIXME: sem formal list
+ Prop := Get_Property (Decl);
+ Prop := Sem_Property (Prop, True);
+ Extract_Clock (Prop, Clk);
+ Set_Property (Decl, Prop);
+ Set_Global_Clock (Decl, Clk);
+ -- Check simple subset restrictions.
+ PSL.Subsets.Check_Simple (Prop);
+ when N_Sequence_Declaration
+ | N_Endpoint_Declaration =>
+ -- FIXME: sem formal list, do not allow property parameter.
+ Prop := Get_Sequence (Decl);
+ Prop := Sem_Sequence (Prop);
+ Set_Sequence (Decl, Prop);
+ PSL.Subsets.Check_Simple (Prop);
+ when others =>
+ Error_Kind ("sem_psl_declaration", Decl);
+ end case;
+ Set_Visible_Flag (Stmt, True);
+
+ Close_Declarative_Region;
+ end Sem_Psl_Declaration;
+
+ procedure Sem_Psl_Assert_Statement (Stmt : Iir)
+ is
+ Prop : Node;
+ Clk : Node;
+ begin
+ Prop := Get_Psl_Property (Stmt);
+ Prop := Sem_Property (Prop, True);
+ Extract_Clock (Prop, Clk);
+ Set_Psl_Property (Stmt, Prop);
+
+ -- Sem report and severity expressions.
+ Sem_Report_Statement (Stmt);
+
+ -- Properties must be clocked.
+ if Clk = Null_Node then
+ if Current_Psl_Default_Clock = Null_Iir then
+ Error_Msg_Sem ("no clock for PSL assert", Stmt);
+ Clk := Null_Node;
+ else
+ Clk := Get_Psl_Boolean (Current_Psl_Default_Clock);
+ end if;
+ end if;
+ Set_PSL_Clock (Stmt, Clk);
+
+ -- Check simple subset restrictions.
+ PSL.Subsets.Check_Simple (Prop);
+ end Sem_Psl_Assert_Statement;
+
+ procedure Sem_Psl_Default_Clock (Stmt : Iir)
+ is
+ Expr : Node;
+ begin
+ if Current_Psl_Default_Clock /= Null_Iir
+ and then Get_Parent (Current_Psl_Default_Clock) = Get_Parent (Stmt)
+ then
+ Error_Msg_Sem
+ ("redeclaration of PSL default clock in the same region", Stmt);
+ Error_Msg_Sem (" (previous default clock declaration)",
+ Current_Psl_Default_Clock);
+ end if;
+ Expr := Sem_Boolean (Get_Psl_Boolean (Stmt));
+ Set_Psl_Boolean (Stmt, Expr);
+ Current_Psl_Default_Clock := Stmt;
+ end Sem_Psl_Default_Clock;
+
+ function Sem_Psl_Instance_Name (Name : Iir) return Iir
+ is
+ Prefix : Iir;
+ Ent : Iir;
+ Decl : Node;
+ Formal : Node;
+ Assoc : Iir;
+ Res : Node;
+ Last_Assoc : Node;
+ Assoc2 : Node;
+ Actual : Iir;
+ Psl_Actual : Node;
+ Res2 : Iir;
+ begin
+ Prefix := Get_Prefix (Name);
+ Ent := Get_Named_Entity (Prefix);
+ pragma Assert (Get_Kind (Ent) = Iir_Kind_Psl_Declaration);
+ Decl := Get_Psl_Declaration (Ent);
+ case Get_Kind (Decl) is
+ when N_Property_Declaration =>
+ Res := Create_Node (N_Property_Instance);
+ when N_Sequence_Declaration =>
+ Res := Create_Node (N_Sequence_Instance);
+ when N_Endpoint_Declaration =>
+ Res := Create_Node (N_Endpoint_Instance);
+ when others =>
+ Error_Msg_Sem ("can only instantiate a psl declaration", Name);
+ return Null_Iir;
+ end case;
+ Set_Declaration (Res, Decl);
+ Set_Location (Res, Get_Location (Name));
+ Formal := Get_Parameter_List (Decl);
+ Assoc := Get_Association_Chain (Name);
+ Last_Assoc := Null_Node;
+
+ while Formal /= Null_Node loop
+ if Assoc = Null_Iir then
+ Error_Msg_Sem ("not enough association", Name);
+ exit;
+ end if;
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then
+ Error_Msg_Sem
+ ("open or individual association not allowed", Assoc);
+ elsif Get_Formal (Assoc) /= Null_Iir then
+ Error_Msg_Sem ("named association not allowed in psl", Assoc);
+ else
+ Actual := Get_Actual (Assoc);
+ -- FIXME: currently only boolean are parsed.
+ Actual := Sem_Expr.Sem_Expression (Actual, Null_Iir);
+ if Get_Kind (Actual) in Iir_Kinds_Name then
+ Actual := Get_Named_Entity (Actual);
+ end if;
+ Psl_Actual := PSL.Hash.Get_PSL_Node (HDL_Node (Actual));
+ end if;
+
+ Assoc2 := Create_Node (N_Actual);
+ Set_Location (Assoc2, Get_Location (Assoc));
+ Set_Formal (Assoc2, Formal);
+ Set_Actual (Assoc2, Psl_Actual);
+ if Last_Assoc = Null_Node then
+ Set_Association_Chain (Res, Assoc2);
+ else
+ Set_Chain (Last_Assoc, Assoc2);
+ end if;
+ Last_Assoc := Assoc2;
+
+ Formal := Get_Chain (Formal);
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ if Assoc /= Null_Iir then
+ Error_Msg_Sem ("too many association", Name);
+ end if;
+
+ Res2 := Create_Iir (Iir_Kind_Psl_Expression);
+ Set_Psl_Expression (Res2, Res);
+ Location_Copy (Res2, Name);
+ return Res2;
+ end Sem_Psl_Instance_Name;
+
+ -- Called by sem_names to semantize a psl name.
+ function Sem_Psl_Name (Name : Iir) return Iir is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Parenthesis_Name =>
+ return Sem_Psl_Instance_Name (Name);
+ when others =>
+ Error_Kind ("sem_psl_name", Name);
+ end case;
+ return Null_Iir;
+ end Sem_Psl_Name;
+
+end Sem_Psl;
diff --git a/src/sem_psl.ads b/src/sem_psl.ads
new file mode 100644
index 000000000..59df96f7f
--- /dev/null
+++ b/src/sem_psl.ads
@@ -0,0 +1,26 @@
+-- Semantic analysis 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 Iirs; use Iirs;
+
+package Sem_Psl is
+ procedure Sem_Psl_Declaration (Stmt : Iir);
+ procedure Sem_Psl_Assert_Statement (Stmt : Iir);
+ procedure Sem_Psl_Default_Clock (Stmt : Iir);
+ function Sem_Psl_Name (Name : Iir) return Iir;
+end Sem_Psl;
diff --git a/src/sem_scopes.adb b/src/sem_scopes.adb
new file mode 100644
index 000000000..71c758575
--- /dev/null
+++ b/src/sem_scopes.adb
@@ -0,0 +1,1412 @@
+-- Semantic analysis.
+-- 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 GNAT.Table;
+with Flags; use Flags;
+with Name_Table; -- use Name_Table;
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Sem_Scopes is
+ -- FIXME: names:
+ -- scopes => regions ?
+
+ -- Debugging subprograms.
+ procedure Disp_All_Names;
+ pragma Unreferenced (Disp_All_Names);
+
+ procedure Disp_Scopes;
+ pragma Unreferenced (Disp_Scopes);
+
+ procedure Disp_Detailed_Interpretations (Ident : Name_Id);
+ pragma Unreferenced (Disp_Detailed_Interpretations);
+
+ -- An interpretation cell is the element of the simply linked list
+ -- of interpratation for an identifier.
+ -- DECL is visible declaration;
+ -- NEXT is the next element of the list.
+ -- Interpretation cells are stored in a stack, Interpretations.
+ type Interpretation_Cell is record
+ Decl: Iir;
+ Is_Potential : Boolean;
+ Pad_0 : Boolean;
+ Next: Name_Interpretation_Type;
+ end record;
+ pragma Pack (Interpretation_Cell);
+
+ -- To manage the list of interpretation and to add informations to this
+ -- list, a stack is used.
+ -- Elements of stack can be of kind:
+ -- Save_Cell:
+ -- the element contains the interpretation INTER for the indentifier ID
+ -- for the outer declarative region.
+ -- A save cell is always each time a declaration is added to save the
+ -- previous interpretation.
+ -- Region_Start:
+ -- A new declarative region start at interpretation INTER. Here, INTER
+ -- is used as an index in the interpretations stack (table).
+ -- ID is used as an index into the unidim_array stack.
+ -- Barrier_start, Barrier_end:
+ -- All currents interpretations are saved between both INTER, and
+ -- are cleared. This is used to call semantic during another semantic.
+
+ type Scope_Cell_Kind_Type is
+ (Save_Cell, Hide_Cell, Region_Start, Barrier_Start, Barrier_End);
+
+ type Scope_Cell is record
+ Kind: Scope_Cell_Kind_Type;
+
+ -- Usage of Inter:
+ -- Save_Cell: previous value of name_table (id).info
+ -- Hide_Cell: interpretation hidden.
+ -- Region_Start: previous value of Current_Scope_Start.
+ -- Barrier_Start: previous value of current_scope_start.
+ -- Barrier_End: last index of interpretations table.
+ Inter: Name_Interpretation_Type;
+
+ -- Usage of Id:
+ -- Save_Cell: ID whose interpretations are saved.
+ -- Hide_Cell: not used.
+ -- Region_Start: previous value of the last index of visible_types.
+ -- Barrier_Start: previous value of CURRENT_BARRIER.
+ -- Barrier_End: previous value of Current_composite_types_start.
+ Id: Name_Id;
+ end record;
+
+ package Interpretations is new GNAT.Table
+ (Table_Component_Type => Interpretation_Cell,
+ Table_Index_Type => Name_Interpretation_Type,
+ Table_Low_Bound => First_Valid_Interpretation,
+ Table_Initial => 128,
+ Table_Increment => 50);
+
+ package Scopes is new GNAT.Table
+ (Table_Component_Type => Scope_Cell,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 128,
+ Table_Increment => 50);
+
+ -- Index into Interpretations marking the last interpretation of
+ -- the previous (immediate) declarative region.
+ Current_Scope_Start: Name_Interpretation_Type := No_Name_Interpretation;
+
+ function Valid_Interpretation (Inter : Name_Interpretation_Type)
+ return Boolean is
+ begin
+ return Inter >= First_Valid_Interpretation;
+ end Valid_Interpretation;
+
+ -- Get and Set the info field of the table table for a
+ -- name_interpretation.
+ function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type is
+ begin
+ return Name_Interpretation_Type (Name_Table.Get_Info (Id));
+ end Get_Interpretation;
+
+ procedure Set_Interpretation (Id: Name_Id; Inter: Name_Interpretation_Type)
+ is
+ begin
+ Name_Table.Set_Info (Id, Int32 (Inter));
+ end Set_Interpretation;
+
+ function Get_Under_Interpretation (Id : Name_Id)
+ return Name_Interpretation_Type
+ is
+ Inter : Name_Interpretation_Type;
+ begin
+ Inter := Name_Interpretation_Type (Name_Table.Get_Info (Id));
+
+ -- ID has no interpretation.
+ -- So, there is no 'under' interpretation (FIXME: prove it).
+ if not Valid_Interpretation (Inter) then
+ return No_Name_Interpretation;
+ end if;
+ for I in reverse Scopes.First .. Scopes.Last loop
+ declare
+ S : Scope_Cell renames Scopes.Table (I);
+ begin
+ case S.Kind is
+ when Save_Cell =>
+ if S.Id = Id then
+ -- This is the previous one, return it.
+ return S.Inter;
+ end if;
+ when Region_Start
+ | Hide_Cell =>
+ null;
+ when Barrier_Start
+ | Barrier_End =>
+ return No_Name_Interpretation;
+ end case;
+ end;
+ end loop;
+ return No_Name_Interpretation;
+ end Get_Under_Interpretation;
+
+ procedure Check_Interpretations;
+ pragma Unreferenced (Check_Interpretations);
+
+ procedure Check_Interpretations
+ is
+ Inter: Name_Interpretation_Type;
+ Last : Name_Interpretation_Type;
+ Err : Boolean;
+ begin
+ Last := Interpretations.Last;
+ Err := False;
+ for I in 0 .. Name_Table.Last_Name_Id loop
+ Inter := Get_Interpretation (I);
+ if Inter > Last then
+ Ada.Text_IO.Put_Line
+ ("bad interpretation for " & Name_Table.Image (I));
+ Err := True;
+ end if;
+ end loop;
+ if Err then
+ raise Internal_Error;
+ end if;
+ end Check_Interpretations;
+
+ -- Create a new declarative region.
+ -- Simply push a region_start cell and update current_scope_start.
+ procedure Open_Declarative_Region is
+ begin
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) := (Kind => Region_Start,
+ Inter => Current_Scope_Start,
+ Id => Null_Identifier);
+ Current_Scope_Start := Interpretations.Last;
+ end Open_Declarative_Region;
+
+ -- Close a declarative region.
+ -- Update interpretation of identifiers.
+ procedure Close_Declarative_Region is
+ begin
+ loop
+ case Scopes.Table (Scopes.Last).Kind is
+ when Region_Start =>
+ -- Discard interpretations cells added in this scopes.
+ Interpretations.Set_Last (Current_Scope_Start);
+ -- Restore Current_Scope_Start.
+ Current_Scope_Start := Scopes.Table (Scopes.Last).Inter;
+ Scopes.Decrement_Last;
+ return;
+ when Save_Cell =>
+ -- Restore a previous interpretation.
+ Set_Interpretation (Scopes.Table (Scopes.Last).Id,
+ Scopes.Table (Scopes.Last).Inter);
+ when Hide_Cell =>
+ -- Unhide previous interpretation.
+ declare
+ H, S : Name_Interpretation_Type;
+ begin
+ H := Scopes.Table (Scopes.Last).Inter;
+ S := Interpretations.Table (H).Next;
+ Interpretations.Table (H).Next :=
+ Interpretations.Table (S).Next;
+ Interpretations.Table (S).Next := H;
+ end;
+ when Barrier_Start
+ | Barrier_End =>
+ -- Barrier cannot exist inside a declarative region.
+ raise Internal_Error;
+ end case;
+ Scopes.Decrement_Last;
+ end loop;
+ end Close_Declarative_Region;
+
+ procedure Open_Scope_Extension renames Open_Declarative_Region;
+ procedure Close_Scope_Extension renames Close_Declarative_Region;
+
+ function Get_Next_Interpretation (Ni: Name_Interpretation_Type)
+ return Name_Interpretation_Type is
+ begin
+ if not Valid_Interpretation (Ni) then
+ raise Internal_Error;
+ end if;
+ return Interpretations.Table (Ni).Next;
+ end Get_Next_Interpretation;
+
+ function Get_Declaration (Ni: Name_Interpretation_Type)
+ return Iir is
+ begin
+ if not Valid_Interpretation (Ni) then
+ raise Internal_Error;
+ end if;
+ return Interpretations.Table (Ni).Decl;
+ end Get_Declaration;
+
+ function Strip_Non_Object_Alias (Decl : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Decl;
+ if Get_Kind (Res) = Iir_Kind_Non_Object_Alias_Declaration then
+ Res := Get_Named_Entity (Get_Name (Res));
+ end if;
+ return Res;
+ end Strip_Non_Object_Alias;
+
+ function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type)
+ return Iir is
+ begin
+ return Strip_Non_Object_Alias (Get_Declaration (Ni));
+ end Get_Non_Alias_Declaration;
+
+ -- Pointer just past the last barrier_end in the scopes stack.
+ Current_Barrier : Integer := 0;
+
+ procedure Push_Interpretations is
+ begin
+ -- Add a barrier_start.
+ -- Save current_scope_start and current_barrier.
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) := (Kind => Barrier_Start,
+ Inter => Current_Scope_Start,
+ Id => Name_Id (Current_Barrier));
+
+ -- Save all the current name interpretations.
+ -- (For each name that have interpretations, there is a save_cell
+ -- containing the interpretations for the outer scope).
+ -- FIXME: maybe we should only save the name_table info.
+ for I in Current_Barrier .. Scopes.Last - 1 loop
+ if Scopes.Table (I).Kind = Save_Cell then
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) :=
+ (Kind => Save_Cell,
+ Inter => Get_Interpretation (Scopes.Table (I).Id),
+ Id => Scopes.Table (I).Id);
+ Set_Interpretation (Scopes.Table (I).Id, No_Name_Interpretation);
+ end if;
+ end loop;
+
+ -- Add a barrier_end.
+ -- Save interpretations.last.
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) :=
+ (Kind => Barrier_End,
+ Inter => Interpretations.Last,
+ Id => Null_Identifier);
+
+ -- Start a completly new scope.
+ Current_Scope_Start := Interpretations.Last + 1;
+
+ -- Keep the last barrier.
+ Current_Barrier := Scopes.Last + 1;
+
+ pragma Debug (Name_Table.Assert_No_Infos);
+ end Push_Interpretations;
+
+ procedure Pop_Interpretations is
+ begin
+ -- clear all name interpretations set by the current barrier.
+ for I in Current_Barrier .. Scopes.Last loop
+ if Scopes.Table (I).Kind = Save_Cell then
+ Set_Interpretation (Scopes.Table (I).Id, No_Name_Interpretation);
+ end if;
+ end loop;
+ Scopes.Set_Last (Current_Barrier - 1);
+ if Scopes.Table (Scopes.Last).Kind /= Barrier_End then
+ raise Internal_Error;
+ end if;
+
+ pragma Debug (Name_Table.Assert_No_Infos);
+
+ -- Restore the stack pointer of interpretations.
+ Interpretations.Set_Last (Scopes.Table (Scopes.Last).Inter);
+ Scopes.Decrement_Last;
+
+ -- Restore all name interpretations.
+ while Scopes.Table (Scopes.Last).Kind /= Barrier_Start loop
+ Set_Interpretation (Scopes.Table (Scopes.Last).Id,
+ Scopes.Table (Scopes.Last).Inter);
+ Scopes.Decrement_Last;
+ end loop;
+
+ -- Restore current_scope_start and current_barrier.
+ Current_Scope_Start := Scopes.Table (Scopes.Last).Inter;
+ Current_Barrier := Natural (Scopes.Table (Scopes.Last).Id);
+
+ Scopes.Decrement_Last;
+ end Pop_Interpretations;
+
+ -- Return TRUE if INTER was made directly visible via a use clause.
+ function Is_Potentially_Visible (Inter: Name_Interpretation_Type)
+ return Boolean
+ is
+ begin
+ return Interpretations.Table (Inter).Is_Potential;
+ end Is_Potentially_Visible;
+
+ -- Return TRUE iif DECL can be overloaded.
+ function Is_Overloadable (Decl: Iir) return Boolean is
+ begin
+ -- LRM93 �10.3:
+ -- The overloaded declarations considered in this chapter are those for
+ -- subprograms and enumeration literals.
+ case Get_Kind (Decl) is
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kinds_Function_Declaration
+ | Iir_Kinds_Procedure_Declaration =>
+ return True;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ case Get_Kind (Get_Named_Entity (Get_Name (Decl))) is
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kinds_Function_Declaration
+ | Iir_Kinds_Procedure_Declaration =>
+ return True;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ raise Internal_Error;
+ when others =>
+ return False;
+ end case;
+ when others =>
+ return False;
+ end case;
+ end Is_Overloadable;
+
+ -- Return TRUE if INTER was made direclty visible in the current
+ -- declarative region.
+ function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type)
+ return Boolean is
+ begin
+ return Inter > Current_Scope_Start;
+ end Is_In_Current_Declarative_Region;
+
+ -- Called when CURR is being declared in the same declarative region as
+ -- PREV, using the same identifier.
+ -- The function assumes CURR and PREV are both overloadable.
+ -- Return TRUE if this redeclaration is allowed.
+-- function Redeclaration_Allowed (Prev, Curr : Iir) return Boolean is
+-- begin
+-- case Get_Kind (Curr) is
+-- when Iir_Kinds_Function_Specification
+-- | Iir_Kinds_Procedure_Specification =>
+-- if ((Get_Kind (Prev) in Iir_Kinds_User_Function_Specification
+-- and then
+-- Get_Kind (Curr) in Iir_Kinds_User_Function_Specification)
+-- or else
+-- (Get_Kind (Prev) in Iir_Kinds_User_Procedure_Specification
+-- and then
+-- Get_Kind (Curr) in Iir_Kinds_User_Procedure_Specification))
+-- then
+-- return not Iirs_Utils.Is_Same_Profile (Prev, Curr);
+-- else
+-- return True;
+-- end if;
+-- when Iir_Kind_Enumeration_Literal =>
+-- if Get_Kind (Prev) /= Get_Kind (Curr) then
+-- -- FIXME: PREV may be a function returning the type of the
+-- -- literal.
+-- return True;
+-- end if;
+-- return Get_Type (Prev) /= Get_Type (Curr);
+-- when others =>
+-- return False;
+-- end case;
+-- end Redeclaration_Allowed;
+
+ -- Add interpretation DECL to the identifier of DECL.
+ -- POTENTIALLY is true if the identifier comes from a use clause.
+ procedure Add_Name (Decl: Iir; Ident: Name_Id; Potentially: Boolean)
+ is
+ -- Current interpretation of ID. This is the one before DECL is
+ -- added (if so).
+ Current_Inter: Name_Interpretation_Type;
+ Current_Decl : Iir;
+
+ -- Before adding a new interpretation, the current interpretation
+ -- must be saved so that it could be restored when the current scope
+ -- is removed. That must be done only once per scope and per
+ -- interpretation. Note that the saved interpretation is not removed
+ -- from the chain of interpretations.
+ procedure Save_Current_Interpretation is
+ begin
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) :=
+ (Kind => Save_Cell, Id => Ident, Inter => Current_Inter);
+ end Save_Current_Interpretation;
+
+ -- Add DECL in the chain of interpretation for the identifier.
+ procedure Add_New_Interpretation is
+ begin
+ Interpretations.Increment_Last;
+ Interpretations.Table (Interpretations.Last) :=
+ (Decl => Decl, Next => Current_Inter,
+ Is_Potential => Potentially, Pad_0 => False);
+ Set_Interpretation (Ident, Interpretations.Last);
+ end Add_New_Interpretation;
+ begin
+ Current_Inter := Get_Interpretation (Ident);
+
+ if Current_Inter = No_Name_Interpretation
+ or else (Current_Inter = Conflict_Interpretation and not Potentially)
+ then
+ -- Very simple: no hidding, no overloading.
+ -- (current interpretation is Conflict_Interpretation if there is
+ -- only potentially visible declarations that are not made directly
+ -- visible).
+ -- Note: in case of conflict interpretation, it may be unnecessary
+ -- to save the current interpretation (but it is simpler to always
+ -- save it).
+ Save_Current_Interpretation;
+ Add_New_Interpretation;
+ return;
+ end if;
+
+ if Potentially then
+ if Current_Inter = Conflict_Interpretation then
+ -- Yet another conflicting interpretation.
+ return;
+ end if;
+
+ -- Do not re-add a potential decl. This handles cases like:
+ -- 'use p.all; use p.all;'.
+ -- FIXME: add a flag (or reuse Visible_Flag) to avoid walking all
+ -- the interpretations.
+ declare
+ Inter: Name_Interpretation_Type := Current_Inter;
+ begin
+ while Valid_Interpretation (Inter) loop
+ if Get_Declaration (Inter) = Decl then
+ return;
+ end if;
+ Inter := Get_Next_Interpretation (Inter);
+ end loop;
+ end;
+ end if;
+
+ -- LRM 10.3 Visibility
+ -- Each of two declarations is said to be a homograph of the other if
+ -- both declarations have the same identifier, operator symbol, or
+ -- character literal, and overloading is allowed for at most one
+ -- of the two.
+ --
+ -- GHDL: the condition 'overloading is allowed for at most one of the
+ -- two' is false iff overloading is allowed for both; this is a nand.
+
+ -- Note: at this stage, current_inter is valid.
+ Current_Decl := Get_Declaration (Current_Inter);
+
+ if Is_Overloadable (Current_Decl) and then Is_Overloadable (Decl) then
+ -- Current_Inter and Decl overloads (well, they have the same
+ -- designator).
+
+ -- LRM 10.3 Visibility
+ -- If overloading is allowed for both declarations, then each of the
+ -- two is a homograph of the other if they have the same identifier,
+ -- operator symbol or character literal, as well as the same
+ -- parameter and result profile.
+
+ declare
+ Homograph : Name_Interpretation_Type;
+ Prev_Homograph : Name_Interpretation_Type;
+
+ -- Add DECL in the chain of interpretation, and save the current
+ -- one if necessary.
+ procedure Maybe_Save_And_Add_New_Interpretation is
+ begin
+ if not Is_In_Current_Declarative_Region (Current_Inter) then
+ Save_Current_Interpretation;
+ end if;
+ Add_New_Interpretation;
+ end Maybe_Save_And_Add_New_Interpretation;
+
+ -- Hide HOMOGRAPH (ie unlink it from the chain of interpretation).
+ procedure Hide_Homograph
+ is
+ S : Name_Interpretation_Type;
+ begin
+ if Prev_Homograph = No_Name_Interpretation then
+ Prev_Homograph := Interpretations.Last;
+ end if;
+ if Interpretations.Table (Prev_Homograph).Next /= Homograph
+ then
+ -- PREV_HOMOGRAPH must be the interpretation just before
+ -- HOMOGRAPH.
+ raise Internal_Error;
+ end if;
+
+ -- Hide previous interpretation.
+ S := Interpretations.Table (Homograph).Next;
+ Interpretations.Table (Homograph).Next := Prev_Homograph;
+ Interpretations.Table (Prev_Homograph).Next := S;
+ Scopes.Increment_Last;
+ Scopes.Table (Scopes.Last) :=
+ (Kind => Hide_Cell,
+ Id => Null_Identifier, Inter => Homograph);
+ end Hide_Homograph;
+
+ function Get_Hash_Non_Alias (D : Iir) return Iir_Int32 is
+ begin
+ return Get_Subprogram_Hash (Strip_Non_Object_Alias (D));
+ end Get_Hash_Non_Alias;
+
+ -- Return True iff D is an implicit declaration (either a
+ -- subprogram or an implicit alias).
+ function Is_Implicit_Declaration (D : Iir) return Boolean is
+ begin
+ case Get_Kind (D) is
+ when Iir_Kinds_Implicit_Subprogram_Declaration =>
+ return True;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ return Get_Implicit_Alias_Flag (D);
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ return False;
+ when others =>
+ Error_Kind ("is_implicit_declaration", D);
+ end case;
+ end Is_Implicit_Declaration;
+
+ -- Return TRUE iff D is an implicit alias of an implicit
+ -- subprogram.
+ function Is_Implicit_Alias (D : Iir) return Boolean is
+ begin
+ -- FIXME: Is it possible to have an implicit alias of an
+ -- explicit subprogram ? Yes for enumeration literal and
+ -- physical units.
+ return Get_Kind (D) = Iir_Kind_Non_Object_Alias_Declaration
+ and then Get_Implicit_Alias_Flag (D)
+ and then (Get_Kind (Get_Named_Entity (Get_Name (D)))
+ in Iir_Kinds_Implicit_Subprogram_Declaration);
+ end Is_Implicit_Alias;
+
+ -- Replace the homograph of DECL by DECL.
+ procedure Replace_Homograph is
+ begin
+ Interpretations.Table (Homograph).Decl := Decl;
+ end Replace_Homograph;
+
+ Decl_Hash : Iir_Int32;
+ Hash : Iir_Int32;
+ begin
+ Decl_Hash := Get_Hash_Non_Alias (Decl);
+ if Decl_Hash = 0 then
+ -- The hash must have been computed.
+ raise Internal_Error;
+ end if;
+
+ -- Find an homograph of this declaration (and also keep the
+ -- interpretation just before it in the chain),
+ Homograph := Current_Inter;
+ Prev_Homograph := No_Name_Interpretation;
+ while Homograph /= No_Name_Interpretation loop
+ Current_Decl := Get_Declaration (Homograph);
+ Hash := Get_Hash_Non_Alias (Current_Decl);
+ exit when Decl_Hash = Hash
+ and then Is_Same_Profile (Decl, Current_Decl);
+ Prev_Homograph := Homograph;
+ Homograph := Get_Next_Interpretation (Homograph);
+ end loop;
+
+ if Homograph = No_Name_Interpretation then
+ -- Simple case: no homograph.
+ Maybe_Save_And_Add_New_Interpretation;
+ return;
+ end if;
+
+ -- There is an homograph.
+ if Potentially then
+ -- Added DECL would be made potentially visible.
+
+ -- LRM93 10.4 1) / LRM08 12.4 a) Use Clauses
+ -- 1. A potentially visible declaration is not made
+ -- directly visible if the place considered is within the
+ -- immediate scope of a homograph of the declaration.
+ if Is_In_Current_Declarative_Region (Homograph) then
+ if not Is_Potentially_Visible (Homograph) then
+ return;
+ end if;
+ end if;
+
+ -- LRM08 12.4 Use Clauses
+ -- b) If two potentially visible declarations are homograph
+ -- and one is explicitly declared and the other is
+ -- implicitly declared, then the implicit declaration is
+ -- not made directly visible.
+ if (Flags.Flag_Explicit or else Flags.Vhdl_Std >= Vhdl_08)
+ and then Is_Potentially_Visible (Homograph)
+ then
+ declare
+ Implicit_Current_Decl : constant Boolean :=
+ Is_Implicit_Declaration (Current_Decl);
+ Implicit_Decl : constant Boolean :=
+ Is_Implicit_Declaration (Decl);
+ begin
+ if Implicit_Current_Decl and then not Implicit_Decl then
+ if Is_In_Current_Declarative_Region (Homograph) then
+ Replace_Homograph;
+ else
+ -- Hide homoraph and insert decl.
+ Maybe_Save_And_Add_New_Interpretation;
+ Hide_Homograph;
+ end if;
+ return;
+ elsif not Implicit_Current_Decl and then Implicit_Decl
+ then
+ -- Discard decl.
+ return;
+ elsif Strip_Non_Object_Alias (Decl)
+ = Strip_Non_Object_Alias (Current_Decl)
+ then
+ -- This rule is not written clearly in the LRM, but
+ -- if two designators denote the same named entity,
+ -- no need to make both visible.
+ return;
+ end if;
+ end;
+ end if;
+
+ -- GHDL: if the homograph is in the same declarative
+ -- region than DECL, it must be an implicit declaration
+ -- to be hidden.
+ -- FIXME: this rule is not in the LRM93, but it is necessary
+ -- so that explicit declaration hides the implicit one.
+ if Flags.Vhdl_Std < Vhdl_08
+ and then not Flags.Flag_Explicit
+ and then Get_Parent (Decl) = Get_Parent (Current_Decl)
+ then
+ declare
+ Implicit_Current_Decl : constant Boolean :=
+ (Get_Kind (Current_Decl)
+ in Iir_Kinds_Implicit_Subprogram_Declaration);
+ Implicit_Decl : constant Boolean :=
+ (Get_Kind (Decl)
+ in Iir_Kinds_Implicit_Subprogram_Declaration);
+ begin
+ if Implicit_Current_Decl and not Implicit_Decl then
+ -- Note: no need to save previous interpretation, as
+ -- it is in the same declarative region.
+ -- Replace the previous homograph with DECL.
+ Replace_Homograph;
+ return;
+ elsif not Implicit_Current_Decl and Implicit_Decl then
+ -- As we have replaced the homograph, it is possible
+ -- than the implicit declaration is re-added (by
+ -- a new use clause). Discard it.
+ return;
+ end if;
+ end;
+ end if;
+
+ -- The homograph was made visible in an outer declarative
+ -- region. Therefore, it must not be hidden.
+ Maybe_Save_And_Add_New_Interpretation;
+
+ return;
+ else
+ -- Added DECL would be made directly visible.
+
+ if not Is_Potentially_Visible (Homograph) then
+ -- The homograph was also declared in that declarative
+ -- region or in an inner one.
+ if Is_In_Current_Declarative_Region (Homograph) then
+ -- ... and was declared in the same region
+
+ -- To sum up: at this point both DECL and CURRENT_DECL
+ -- are overloadable, have the same profile (but may be
+ -- aliases) and are declared in the same declarative
+ -- region.
+
+ -- LRM08 12.3 Visibility
+ -- LRM93 10.3 Visibility
+ -- Two declarations that occur immediately within
+ -- the same declarative regions [...] shall not be
+ -- homograph, unless exactely one of them is the
+ -- implicit declaration of a predefined operation,
+
+ -- LRM08 12.3 Visibility
+ -- or is an implicit alias of such implicit declaration.
+ --
+ -- GHDL: FIXME: 'implicit alias'
+
+ -- LRM08 12.3 Visibility
+ -- LRM93 10.3 Visibility
+ -- Each of two declarations is said to be a
+ -- homograph of the other if and only if both
+ -- declarations have the same designator, [...]
+ --
+ -- LRM08 12.3 Visibility
+ -- [...] and they denote different named entities,
+ -- and [...]
+ declare
+ Is_Decl_Implicit : Boolean;
+ Is_Current_Decl_Implicit : Boolean;
+ begin
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ Is_Current_Decl_Implicit :=
+ (Get_Kind (Current_Decl) in
+ Iir_Kinds_Implicit_Subprogram_Declaration)
+ or else Is_Implicit_Alias (Current_Decl);
+ Is_Decl_Implicit :=
+ (Get_Kind (Decl) in
+ Iir_Kinds_Implicit_Subprogram_Declaration)
+ or else Is_Implicit_Alias (Decl);
+
+ -- If they denote the same entity, they aren't
+ -- homograph.
+ if Strip_Non_Object_Alias (Decl)
+ = Strip_Non_Object_Alias (Current_Decl)
+ then
+ if Is_Current_Decl_Implicit
+ and then not Is_Decl_Implicit
+ then
+ -- They aren't homograph but DECL is stronger
+ -- (at it is not an implicit declaration)
+ -- than CURRENT_DECL
+ Replace_Homograph;
+ end if;
+
+ return;
+ end if;
+
+ if Is_Decl_Implicit
+ and then not Is_Current_Decl_Implicit
+ then
+ -- Re-declaration of an implicit subprogram via
+ -- an implicit alias is simply discarded.
+ return;
+ end if;
+ else
+ -- Can an implicit subprogram declaration appears
+ -- after an explicit one in vhdl 93? I don't
+ -- think so.
+ Is_Decl_Implicit :=
+ (Get_Kind (Decl)
+ in Iir_Kinds_Implicit_Subprogram_Declaration);
+ Is_Current_Decl_Implicit :=
+ (Get_Kind (Current_Decl)
+ in Iir_Kinds_Implicit_Subprogram_Declaration);
+ end if;
+
+ if not (Is_Decl_Implicit xor Is_Current_Decl_Implicit)
+ then
+ Error_Msg_Sem
+ ("redeclaration of " & Disp_Node (Current_Decl) &
+ " defined at " & Disp_Location (Current_Decl),
+ Decl);
+ return;
+ end if;
+ end;
+ else
+ -- GHDL: hide directly visible declaration declared in
+ -- an outer region.
+ null;
+ end if;
+ else
+ -- LRM 10.4 Use Clauses
+ -- 1. A potentially visible declaration is not made
+ -- directly visible if the place considered is within the
+ -- immediate scope of a homograph of the declaration.
+
+ -- GHDL: hide the potentially visible declaration.
+ null;
+ end if;
+ Maybe_Save_And_Add_New_Interpretation;
+
+ Hide_Homograph;
+ return;
+ end if;
+ end;
+ end if;
+
+ -- The current interpretation and the new one aren't overloadable, ie
+ -- they are homograph (well almost).
+
+ if Is_In_Current_Declarative_Region (Current_Inter) then
+ -- They are perhaps visible in the same declarative region.
+ if Is_Potentially_Visible (Current_Inter) then
+ if Potentially then
+ -- LRM93 10.4 2) / LRM08 12.4 c) Use clauses
+ -- Potentially visible declarations that have the same
+ -- designator are not made directly visible unless each of
+ -- them is either an enumeration literal specification or
+ -- the declaration of a subprogram.
+ if Decl = Get_Declaration (Current_Inter) then
+ -- The rule applies only for distinct declaration.
+ -- This handles 'use p.all; use P.all;'.
+ -- FIXME: this should have been handled at the start of
+ -- this subprogram.
+ raise Internal_Error;
+ return;
+ end if;
+
+ -- LRM08 12.3 Visibility
+ -- Each of two declarations is said to be a homograph of the
+ -- other if and only if both declarations have the same
+ -- designator; and they denote different named entities, [...]
+ if Flags.Vhdl_Std >= Vhdl_08 then
+ if Strip_Non_Object_Alias (Decl)
+ = Strip_Non_Object_Alias (Current_Decl)
+ then
+ return;
+ end if;
+ end if;
+
+ Save_Current_Interpretation;
+ Set_Interpretation (Ident, Conflict_Interpretation);
+ return;
+ else
+ -- LRM93 �10.4 item #1
+ -- A potentially visible declaration is not made directly
+ -- visible if the place considered is within the immediate
+ -- scope of a homograph of the declaration.
+ -- GHDL: Discard the current potentially visible declaration,
+ -- only if it is not an entity declaration, since it is used
+ -- to find default binding.
+ if Get_Kind (Current_Decl) = Iir_Kind_Design_Unit
+ and then Get_Kind (Get_Library_Unit (Current_Decl))
+ = Iir_Kind_Entity_Declaration
+ then
+ Save_Current_Interpretation;
+ end if;
+ Current_Inter := No_Name_Interpretation;
+ Add_New_Interpretation;
+ return;
+ end if;
+ else
+ -- There is already a declaration in the current scope.
+ if Potentially then
+ -- LRM93 �10.4 item #1
+ -- Discard the new and potentially visible declaration.
+ -- However, add the type.
+ -- FIXME: Add_In_Visible_List (Ident, Decl);
+ return;
+ else
+ -- LRM93 11.2
+ -- If two or more logical names having the same
+ -- identifier appear in library clauses in the same
+ -- context, the second and subsequent occurences of the
+ -- logical name have no effect. The same is true of
+ -- logical names appearing both in the context clause
+ -- of a primary unit and in the context clause of a
+ -- corresponding secondary unit.
+ -- GHDL: we apply this rule with VHDL-87, because of implicits
+ -- library clauses STD and WORK.
+ if Get_Kind (Decl) = Iir_Kind_Library_Declaration
+ and then
+ Get_Kind (Current_Decl) = Iir_Kind_Library_Declaration
+ then
+ return;
+ end if;
+
+ -- None of the two declarations are potentially visible, ie
+ -- both are visible.
+ -- LRM �10.3:
+ -- Two declarations that occur immediately within the same
+ -- declarative region must not be homographs,
+ -- FIXME: unless one of them is the implicit declaration of a
+ -- predefined operation.
+ Error_Msg_Sem ("identifier '" & Name_Table.Image (Ident)
+ & "' already used for a declaration",
+ Decl);
+ Error_Msg_Sem
+ ("previous declaration: " & Disp_Node (Current_Decl),
+ Current_Decl);
+ return;
+ end if;
+ end if;
+ end if;
+
+ -- Homograph, not in the same scope.
+ -- LRM �10.3:
+ -- A declaration is said to be hidden within (part of) an inner
+ -- declarative region if the inner region contains an homograph
+ -- of this declaration; the outer declaration is the hidden
+ -- within the immediate scope of the inner homograph.
+ Save_Current_Interpretation;
+ Current_Inter := No_Name_Interpretation; -- Hid.
+ Add_New_Interpretation;
+ end Add_Name;
+
+ procedure Add_Name (Decl: Iir) is
+ begin
+ Add_Name (Decl, Get_Identifier (Decl), False);
+ end Add_Name;
+
+ procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir)
+ is
+ Inter : Name_Interpretation_Type;
+ begin
+ Inter := Get_Interpretation (Id);
+ loop
+ exit when Get_Declaration (Inter) = Old;
+ Inter := Get_Next_Interpretation (Inter);
+ if not Valid_Interpretation (Inter) then
+ raise Internal_Error;
+ end if;
+ end loop;
+ Interpretations.Table (Inter).Decl := Decl;
+ if Get_Next_Interpretation (Inter) /= No_Name_Interpretation then
+ raise Internal_Error;
+ end if;
+ end Replace_Name;
+
+ procedure Name_Visible (Decl : Iir) is
+ begin
+ if Get_Visible_Flag (Decl) then
+ -- A name can be made visible only once.
+ raise Internal_Error;
+ end if;
+ Set_Visible_Flag (Decl, True);
+ end Name_Visible;
+
+ procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type)
+ is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Enumeration_Literal -- By use clause
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement =>
+ Handle_Decl (Decl, Arg);
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ if not Is_Second_Subprogram_Specification (Decl) then
+ Handle_Decl (Decl, Arg);
+ end if;
+ when Iir_Kind_Type_Declaration =>
+ declare
+ Def : Iir;
+ List : Iir_List;
+ El : Iir;
+ begin
+ Def := Get_Type_Definition (Decl);
+
+ -- Handle incomplete type declaration.
+ if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then
+ return;
+ end if;
+
+ Handle_Decl (Decl, Arg);
+
+ if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then
+ List := Get_Enumeration_Literal_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Handle_Decl (El, Arg);
+ end loop;
+ end if;
+ end;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Handle_Decl (Decl, Arg);
+
+ declare
+ Def : Iir;
+ El : Iir;
+ begin
+ Def := Get_Type_Definition (Decl);
+
+ if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then
+ El := Get_Unit_Chain (Def);
+ while El /= Null_Iir loop
+ Handle_Decl (El, Arg);
+ El := Get_Chain (El);
+ end loop;
+ end if;
+ end;
+ when Iir_Kind_Use_Clause =>
+ Handle_Decl (Decl, Arg);
+ when Iir_Kind_Library_Clause =>
+ Handle_Decl (Decl, Arg);
+-- El := Get_Library_Declaration (Decl);
+-- if El /= Null_Iir then
+-- -- May be empty.
+-- Handle_Decl (El, Arg);
+-- end if;
+
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ null;
+
+ when Iir_Kind_Attribute_Specification
+ | Iir_Kind_Configuration_Specification
+ | Iir_Kind_Disconnection_Specification =>
+ null;
+ when Iir_Kinds_Signal_Attribute =>
+ null;
+
+ when Iir_Kind_Protected_Type_Body =>
+ -- FIXME: allowed only in debugger (if the current scope is
+ -- within a package body) ?
+ null;
+
+ when others =>
+ Error_Kind ("iterator_decl", Decl);
+ end case;
+ end Iterator_Decl;
+
+ -- Make POTENTIALLY (or not) visible DECL.
+ procedure Add_Name_Decl (Decl : Iir; Potentially : Boolean) is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ if not Potentially then
+ Add_Use_Clause (Decl);
+ end if;
+ when Iir_Kind_Library_Clause =>
+ Add_Name (Get_Library_Declaration (Decl),
+ Get_Identifier (Decl), Potentially);
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ null;
+ when others =>
+ Add_Name (Decl, Get_Identifier (Decl), Potentially);
+ end case;
+ end Add_Name_Decl;
+
+ procedure Add_Declaration is
+ new Iterator_Decl (Arg_Type => Boolean, Handle_Decl => Add_Name_Decl);
+
+ procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type)
+ is
+ Decl: Iir;
+ begin
+ if Decl_List = Null_Iir_List then
+ return;
+ end if;
+ for I in Natural loop
+ Decl := Get_Nth_Element (Decl_List, I);
+ exit when Decl = Null_Iir;
+ Handle_Decl (Decl, Arg);
+ end loop;
+ end Iterator_Decl_List;
+
+ procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type)
+ is
+ Decl: Iir;
+ begin
+ Decl := Chain_First;
+ while Decl /= Null_Iir loop
+ Handle_Decl (Decl, Arg);
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Iterator_Decl_Chain;
+
+ procedure Add_Declarations_1 is new Iterator_Decl_Chain
+ (Arg_Type => Boolean, Handle_Decl => Add_Declaration);
+
+ procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False)
+ renames Add_Declarations_1;
+
+ procedure Add_Declarations_List is new Iterator_Decl_List
+ (Arg_Type => Boolean, Handle_Decl => Add_Declaration);
+
+ procedure Add_Declarations_From_Interface_Chain (Chain : Iir)
+ is
+ El: Iir;
+ begin
+ El := Chain;
+ while El /= Null_Iir loop
+ Add_Name (El, Get_Identifier (El), False);
+ El := Get_Chain (El);
+ end loop;
+ end Add_Declarations_From_Interface_Chain;
+
+ procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir)
+ is
+ El: Iir;
+ Label: Name_Id;
+ begin
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ Label := Get_Label (El);
+ if Label /= Null_Identifier then
+ Add_Name (El, Get_Identifier (El), False);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Add_Declarations_Of_Concurrent_Statement;
+
+ procedure Add_Context_Clauses (Unit : Iir_Design_Unit) is
+ begin
+ Add_Declarations (Get_Context_Items (Unit), False);
+ end Add_Context_Clauses;
+
+ -- Add declarations from an entity into the current declarative region.
+ -- This is needed when an architecture is analysed.
+ procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration)
+ is
+ begin
+ Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Entity));
+ Add_Declarations_From_Interface_Chain (Get_Port_Chain (Entity));
+ Add_Declarations (Get_Declaration_Chain (Entity), False);
+ Add_Declarations_Of_Concurrent_Statement (Entity);
+ end Add_Entity_Declarations;
+
+ -- Add declarations from a package into the current declarative region.
+ -- (for a use clause or when a package body is analyzed)
+ procedure Add_Package_Declarations
+ (Decl: Iir_Package_Declaration; Potentially : Boolean)
+ is
+ Header : constant Iir := Get_Package_Header (Decl);
+ begin
+ -- LRM08 12.1 Declarative region
+ -- d) A package declaration together with the corresponding body
+ --
+ -- GHDL: the formal generic declarations are considered to be in the
+ -- same declarative region as the package declarations (and therefore
+ -- in the same scope), even if they don't occur immediately within a
+ -- package declaration.
+ if Header /= Null_Iir then
+ Add_Declarations (Get_Generic_Chain (Header), Potentially);
+ end if;
+
+ Add_Declarations (Get_Declaration_Chain (Decl), Potentially);
+ end Add_Package_Declarations;
+
+ procedure Add_Package_Instantiation_Declarations
+ (Decl: Iir; Potentially : Boolean) is
+ begin
+ -- LRM08 4.9 Package instantiation declarations
+ -- The package instantiation declaration is equivalent to declaration of
+ -- a generic-mapped package, consisting of a package declaration [...]
+ Add_Declarations (Get_Generic_Chain (Decl), Potentially);
+ Add_Declarations (Get_Declaration_Chain (Decl), Potentially);
+ end Add_Package_Instantiation_Declarations;
+
+ -- Add declarations from a package into the current declarative region.
+ -- This is needed when a package body is analysed.
+ procedure Add_Package_Declarations (Decl: Iir_Package_Declaration) is
+ begin
+ Add_Package_Declarations (Decl, False);
+ end Add_Package_Declarations;
+
+ procedure Add_Component_Declarations (Component: Iir_Component_Declaration)
+ is
+ begin
+ Add_Declarations_From_Interface_Chain (Get_Generic_Chain (Component));
+ Add_Declarations_From_Interface_Chain (Get_Port_Chain (Component));
+ end Add_Component_Declarations;
+
+ procedure Add_Protected_Type_Declarations
+ (Decl : Iir_Protected_Type_Declaration) is
+ begin
+ Add_Declarations (Get_Declaration_Chain (Decl), False);
+ end Add_Protected_Type_Declarations;
+
+ procedure Extend_Scope_Of_Block_Declarations (Decl : Iir) is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Architecture_Body =>
+ Add_Context_Clauses (Get_Design_Unit (Decl));
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ -- FIXME: formal, iterator ?
+ null;
+ when others =>
+ Error_Kind ("extend_scope_of_block_declarations", Decl);
+ end case;
+ Add_Declarations (Get_Declaration_Chain (Decl), False);
+ Add_Declarations_Of_Concurrent_Statement (Decl);
+ end Extend_Scope_Of_Block_Declarations;
+
+ procedure Use_Library_All (Library : Iir_Library_Declaration)
+ is
+ Design_File : Iir_Design_File;
+ Design_Unit : Iir_Design_Unit;
+ Library_Unit : Iir;
+ begin
+ Design_File := Get_Design_File_Chain (Library);
+ 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_Package_Body then
+ Add_Name (Design_Unit, Get_Identifier (Design_Unit), True);
+ end if;
+ Design_Unit := Get_Chain (Design_Unit);
+ end loop;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+ end Use_Library_All;
+
+ procedure Use_Selected_Name (Name : Iir) is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Overload_List =>
+ Add_Declarations_List (Get_Overload_List (Name), True);
+ when Iir_Kind_Error =>
+ null;
+ when others =>
+ Add_Declaration (Name, True);
+ end case;
+ end Use_Selected_Name;
+
+ procedure Use_All_Names (Name: Iir) is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Library_Declaration =>
+ Use_Library_All (Name);
+ when Iir_Kind_Package_Declaration =>
+ Add_Package_Declarations (Name, True);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Add_Package_Instantiation_Declarations (Name, True);
+ when Iir_Kind_Interface_Package_Declaration =>
+ -- LRM08 6.5.5 Interface package declarations
+ -- Within an entity declaration, an architecture body, a
+ -- component declaration, or an uninstantiated subprogram or
+ -- package declaration that declares a given interface package,
+ -- the name of the given interface package denotes an undefined
+ -- instance of the uninstantiated package.
+ Add_Package_Instantiation_Declarations (Name, True);
+ when Iir_Kind_Error =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Use_All_Names;
+
+ procedure Add_Use_Clause (Clause : Iir_Use_Clause)
+ is
+ Name : Iir;
+ Cl : Iir_Use_Clause;
+ begin
+ Cl := Clause;
+ loop
+ Name := Get_Selected_Name (Cl);
+ if Get_Kind (Name) = Iir_Kind_Selected_By_All_Name then
+ Use_All_Names (Get_Named_Entity (Get_Prefix (Name)));
+ else
+ Use_Selected_Name (Get_Named_Entity (Name));
+ end if;
+ Cl := Get_Use_Clause_Chain (Cl);
+ exit when Cl = Null_Iir;
+ end loop;
+ end Add_Use_Clause;
+
+ -- Debugging
+ procedure Disp_Detailed_Interpretations (Ident : Name_Id)
+ is
+ use Ada.Text_IO;
+ use Name_Table;
+
+ Inter: Name_Interpretation_Type;
+ Decl : Iir;
+ begin
+ Put (Name_Table.Image (Ident));
+ Put_Line (":");
+
+ Inter := Get_Interpretation (Ident);
+ while Valid_Interpretation (Inter) loop
+ Put (Name_Interpretation_Type'Image (Inter));
+ if Is_Potentially_Visible (Inter) then
+ Put (" (use)");
+ end if;
+ Put (": ");
+ Decl := Get_Declaration (Inter);
+ Put (Iir_Kind'Image (Get_Kind (Decl)));
+ Put_Line (", loc: " & Get_Location_Str (Get_Location (Decl)));
+ if Get_Kind (Decl) in Iir_Kinds_Subprogram_Declaration then
+ Put_Line (" " & Disp_Subprg (Decl));
+ end if;
+ Inter := Get_Next_Interpretation (Inter);
+ end loop;
+ end Disp_Detailed_Interpretations;
+
+ procedure Disp_All_Interpretations
+ (Interpretation: Name_Interpretation_Type)
+ is
+ use Ada.Text_IO;
+ Inter: Name_Interpretation_Type;
+ begin
+ Inter := Interpretation;
+ while Valid_Interpretation (Inter) loop
+ Put (Name_Interpretation_Type'Image (Inter));
+ Put ('.');
+ Put (Iir_Kind'Image (Get_Kind (Get_Declaration (Inter))));
+ Inter := Get_Next_Interpretation (Inter);
+ end loop;
+ New_Line;
+ end Disp_All_Interpretations;
+
+ procedure Disp_All_Names
+ is
+ use Ada.Text_IO;
+ Inter: Name_Interpretation_Type;
+ begin
+ for I in 0 .. Name_Table.Last_Name_Id loop
+ Inter := Get_Interpretation (I);
+ if Valid_Interpretation (Inter) then
+ Put (Name_Table.Image (I));
+ Put (Name_Id'Image (I));
+ Put (':');
+ Disp_All_Interpretations (Inter);
+ end if;
+ end loop;
+ Put_Line ("interprations.last = "
+ & Name_Interpretation_Type'Image (Interpretations.Last));
+ Put_Line ("current_scope_start ="
+ & Name_Interpretation_Type'Image (Current_Scope_Start));
+ end Disp_All_Names;
+
+ procedure Disp_Scopes
+ is
+ use Ada.Text_IO;
+ begin
+ for I in reverse Scopes.First .. Scopes.Last loop
+ declare
+ S : Scope_Cell renames Scopes.Table (I);
+ begin
+ case S.Kind is
+ when Save_Cell =>
+ Put ("save_cell: '");
+ Put (Name_Table.Image (S.Id));
+ Put ("', old inter:");
+ when Hide_Cell =>
+ Put ("hide_cell: to be inserted after ");
+ when Region_Start =>
+ Put ("region_start at");
+ when Barrier_Start =>
+ Put ("barrier_start at");
+ when Barrier_End =>
+ Put ("barrier_end at");
+ end case;
+ Put_Line (Name_Interpretation_Type'Image (S.Inter));
+ end;
+ end loop;
+ end Disp_Scopes;
+end Sem_Scopes;
diff --git a/src/sem_scopes.ads b/src/sem_scopes.ads
new file mode 100644
index 000000000..76faaf191
--- /dev/null
+++ b/src/sem_scopes.ads
@@ -0,0 +1,217 @@
+-- Semantic analysis.
+-- 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 Types; use Types;
+
+package Sem_Scopes is
+
+ -- The purpose of SEM_NAME package is to handle association between
+ -- identifiers and declarations.
+ -- Roughly speacking, it implements ch10 of LRM: scope and visibility.
+ --
+ -- Basic elements are: declarations and declarative region.
+ -- Declaration should be understood in the large meaning: any textual
+ -- construction declaring an identifier, which can be a label.
+ -- A declarative region contains declarations and possibly other
+ -- declarative regions.
+ --
+ -- Rules are scope, visibility and overloading.
+ --
+
+ -- Create and close a declarative region.
+ -- By closing a declarative region, all declarations made in this region
+ -- are discarded.
+ procedure Open_Declarative_Region;
+ procedure Close_Declarative_Region;
+
+ -- Add meaning DECL for its identifier to the current declarative region.
+ procedure Add_Name (Decl: Iir);
+ pragma Inline (Add_Name);
+
+ -- Add meaning DECL to the identifier IDENT.
+ -- POTENTIALLY is true if the identifier comes from a use clause.
+ procedure Add_Name (Decl: Iir; Ident : Name_Id; Potentially: Boolean);
+
+ -- Set the visible_flag of DECL to true.
+ procedure Name_Visible (Decl : Iir);
+
+ -- Replace the interpretation OLD of ID by DECL.
+ -- ID must have a uniq interpretation OLD (ie, it must not be overloaded).
+ -- The interpretation must have been done in the current scope.
+ --
+ -- This procedure is used when the meaning of a name is changed due to its
+ -- analysis, eg: when a concurrent_procedure_call_statement becomes
+ -- a component_instantiation_statement.
+ procedure Replace_Name (Id: Name_Id; Old : Iir; Decl: Iir);
+
+ -- Interpretation is a simply linked list of what an identifier means.
+ -- In LRM08 12.3 Visibility, the sentence is 'the declaration defines a
+ -- possible meaning of this occurrence'.
+ -- FIXME: replace Interpretation by Meaning.
+ type Name_Interpretation_Type is private;
+
+ -- Return true if INTER is a valid interpretation, ie has a corresponding
+ -- declaration. There are only two invalids interpretations, which
+ -- are declared just below as constants.
+ function Valid_Interpretation (Inter : Name_Interpretation_Type)
+ return Boolean;
+ pragma Inline (Valid_Interpretation);
+
+ -- This pseudo interpretation marks the end of the interpretation chain,
+ -- and means there is no (more) interpretations for the name.
+ -- Unless you need to discriminate between an absence of declaration and
+ -- a conflict between potential declarations, you should use the
+ -- VALID_INTERPRETATION function.
+ No_Name_Interpretation : constant Name_Interpretation_Type;
+
+ -- This pseudo interpretation means the name has only conflicting potential
+ -- declarations, and also terminates the chain of interpretations.
+ -- Unless you need to discriminate between an absence of declaration and
+ -- a conflict between potential declarations, you should use the
+ -- VALID_INTERPRETATION function.
+ Conflict_Interpretation : constant Name_Interpretation_Type;
+
+ -- Get the first interpretation of identifier ID.
+ function Get_Interpretation (Id: Name_Id) return Name_Interpretation_Type;
+ pragma Inline (Get_Interpretation);
+
+ -- Get the next interpretation from an interpretation.
+ function Get_Next_Interpretation (Ni: Name_Interpretation_Type)
+ return Name_Interpretation_Type;
+ pragma Inline (Get_Next_Interpretation);
+
+ -- Get a declaration associated with an interpretation.
+ function Get_Declaration (Ni: Name_Interpretation_Type) return Iir;
+ pragma Inline (Get_Declaration);
+
+ -- Same as Get_Declaration, but get the name of non-object alias.
+ -- (ie, can never returns an object alias).
+ function Get_Non_Alias_Declaration (Ni: Name_Interpretation_Type)
+ return Iir;
+
+ -- Get the previous interpretation of identifier ID, ie the interpretation
+ -- for ID before the current interpretation of ID.
+ function Get_Under_Interpretation (Id : Name_Id)
+ return Name_Interpretation_Type;
+
+ -- Return TRUE if INTER was made directly visible via a use clause.
+ function Is_Potentially_Visible (Inter: Name_Interpretation_Type)
+ return Boolean;
+ pragma Inline (Is_Potentially_Visible);
+
+ -- Return TRUE if INTER was made direclty visible in the current
+ -- declarative region. Note this is different from being declared in the
+ -- current declarative region because of use clauses.
+ function Is_In_Current_Declarative_Region (Inter: Name_Interpretation_Type)
+ return Boolean;
+ pragma Inline (Is_In_Current_Declarative_Region);
+
+ -- Push and pop all interpretations.
+ -- This can be used to suspend name interpretation, in case of recursive
+ -- semantics.
+ -- After a push, all names have no_name_interpretation.
+ -- Pop restore the previous state.
+ procedure Pop_Interpretations;
+ procedure Push_Interpretations;
+
+ -- Execute a use clause on NAME.
+ -- Make potentially directly visible declarations of NAMES.
+ --procedure Use_Selected_Name (Name : Iir);
+ procedure Use_All_Names (Name: Iir);
+
+ -- Achieves visibility of the selected_name of use clause CLAUSE.
+ procedure Add_Use_Clause (Clause : Iir_Use_Clause);
+
+ -- Add declarations for a context clause into the current declarative
+ -- regions.
+ procedure Add_Context_Clauses (Unit : Iir_Design_Unit);
+
+ -- Add declarations from an entity into the current declarative region.
+ -- This is needed when an architecture is analysed.
+ procedure Add_Entity_Declarations (Entity : Iir_Entity_Declaration);
+
+ -- Add declarations from a package into the current declarative region.
+ -- This is needed when a package body is analysed.
+ -- FIXME: this must be done as if the declarative region was extended.
+ procedure Add_Package_Declarations (Decl: Iir_Package_Declaration);
+
+ -- Add interfaces declaration of a component into the current declarative
+ -- region.
+ procedure Add_Component_Declarations
+ (Component : Iir_Component_Declaration);
+
+ -- Add declarations from a protected type declaration into the current
+ -- declaration region (which is expected to be the region of the protected
+ -- type body).
+ procedure Add_Protected_Type_Declarations
+ (Decl : Iir_Protected_Type_Declaration);
+
+ -- Add declarations of interface chain CHAIN into the current
+ -- declarative region.
+ procedure Add_Declarations_From_Interface_Chain (Chain : Iir);
+
+ -- Add all declarations for concurrent statements declared in PARENT.
+ procedure Add_Declarations_Of_Concurrent_Statement (Parent : Iir);
+
+ -- Add declarations of a declaration chain CHAIN.
+ procedure Add_Declarations (Chain : Iir; Potentially : Boolean := False);
+
+ -- Scope extension area contains declarations from another declarative
+ -- region. These area are abstract and only used to be able to add
+ -- and remove declarations.
+ procedure Open_Scope_Extension;
+ procedure Close_Scope_Extension;
+
+ -- Add any declarations that include the end of the declarative part of
+ -- the given block BLOCK. This follow rules of LRM93 10.2
+ -- FIXME: BLOCK must be an architecture at first, then blocks declared
+ -- inside this architecture, then a block declared inside this block...
+ -- This procedure must be called after an Open_Scope_Extension and
+ -- declarations added can be removed with Close_Scope_Extension.
+ procedure Extend_Scope_Of_Block_Declarations (Decl : Iir);
+
+ -- Call HANDLE_DECL for each declaration found in DECL.
+ -- This will generally call HANDLE_DECL with DECL.
+ -- For types, HANDLE_DECL is first called with the type declaration, then
+ -- with implicit functions, with element literals for enumeration type,
+ -- and units for physical type.
+ generic
+ type Arg_Type is private;
+ with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type);
+ procedure Iterator_Decl (Decl : Iir; Arg : Arg_Type);
+
+ -- Call HANDLE_DECL for each declaration found in DECL_LIST.
+ -- Generally, HANDLE_DECL must be an ITERATOR_DECL; this is not
+ -- automatically done, since the user might be interested in using the
+ -- ITERATOR_DECL.
+ generic
+ type Arg_Type is private;
+ with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type);
+ procedure Iterator_Decl_List (Decl_List : Iir_List; Arg : Arg_Type);
+
+ generic
+ type Arg_Type is private;
+ with procedure Handle_Decl (Decl : Iir; Arg : Arg_Type);
+ procedure Iterator_Decl_Chain (Chain_First : Iir; Arg : Arg_Type);
+
+private
+ type Name_Interpretation_Type is new Int32 range 0 .. (2 ** 30) - 1;
+ No_Name_Interpretation : constant Name_Interpretation_Type := 0;
+ Conflict_Interpretation : constant Name_Interpretation_Type := 1;
+ First_Valid_Interpretation : constant Name_Interpretation_Type := 2;
+end Sem_Scopes;
diff --git a/src/sem_specs.adb b/src/sem_specs.adb
new file mode 100644
index 000000000..ca821b27e
--- /dev/null
+++ b/src/sem_specs.adb
@@ -0,0 +1,1731 @@
+-- Semantic analysis.
+-- 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_Utils; use Iirs_Utils;
+with Sem_Expr; use Sem_Expr;
+with Sem_Names; use Sem_Names;
+with Evaluation; use Evaluation;
+with Std_Package; use Std_Package;
+with Errorout; use Errorout;
+with Sem; use Sem;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Assocs; use Sem_Assocs;
+with Libraries;
+with Iir_Chains; use Iir_Chains;
+with Flags; use Flags;
+with Name_Table;
+with Std_Names;
+with Sem_Decls;
+with Xrefs; use Xrefs;
+with Back_End;
+
+package body Sem_Specs is
+ function Get_Entity_Class_Kind (Decl : Iir) return Tokens.Token_Type
+ is
+ use Tokens;
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Entity_Declaration =>
+ return Tok_Entity;
+ when Iir_Kind_Architecture_Body =>
+ return Tok_Architecture;
+ when Iir_Kind_Configuration_Declaration =>
+ return Tok_Configuration;
+ when Iir_Kind_Package_Declaration =>
+ return Tok_Package;
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ return Tok_Procedure;
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ return Tok_Function;
+ when Iir_Kind_Type_Declaration =>
+ return Tok_Type;
+ when Iir_Kind_Subtype_Declaration =>
+ return Tok_Subtype;
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration =>
+ return Tok_Constant;
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ return Tok_Signal;
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration =>
+ return Tok_Variable;
+ when Iir_Kind_Component_Declaration =>
+ return Tok_Component;
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Null_Statement =>
+ return Tok_Label;
+ when Iir_Kind_Enumeration_Literal =>
+ return Tok_Literal;
+ when Iir_Kind_Unit_Declaration =>
+ return Tok_Units;
+ when Iir_Kind_Group_Declaration =>
+ return Tok_Group;
+ when Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return Tok_File;
+ when Iir_Kind_Attribute_Declaration =>
+ -- Even if an attribute can't have a attribute...
+ -- Because an attribute declaration can appear in a declaration
+ -- region.
+ return Tok_Attribute;
+ when others =>
+ Error_Kind ("get_entity_class_kind", Decl);
+ end case;
+ return Tok_Invalid;
+ end Get_Entity_Class_Kind;
+
+ -- Decorate DECL with attribute ATTR.
+ -- If CHECK_CLASS is true, class of DECL must be class of ATTR, otherwise
+ -- returns silently.
+ -- If CHECK_DEFINED is true, DECL must not have been decorated, otherwise
+ -- returns silently.
+ procedure Attribute_A_Decl
+ (Decl : Iir;
+ Attr : Iir_Attribute_Specification;
+ Check_Class : Boolean;
+ Check_Defined : Boolean)
+ is
+ use Tokens;
+ El : Iir_Attribute_Value;
+
+ -- Attribute declaration corresponding to ATTR.
+ -- Due to possible error, it is not required to be an attribute decl,
+ -- it may be a simple name.
+ Attr_Decl : Iir;
+ begin
+ -- LRM93 5.1
+ -- It is an error if the class of those names is not the same as that
+ -- denoted by the entity class.
+ if Get_Entity_Class_Kind (Decl) /= Get_Entity_Class (Attr) then
+ if Check_Class then
+ Error_Msg_Sem (Disp_Node (Decl) & " is not of class '"
+ & Tokens.Image (Get_Entity_Class (Attr)) & ''',
+ Attr);
+ if Get_Kind (Decl) = Iir_Kind_Subtype_Declaration
+ and then Get_Entity_Class (Attr) = Tok_Type
+ and then Get_Type (Decl) /= Null_Iir
+ and then Get_Base_Type (Get_Type (Decl)) /= Null_Iir
+ and then Get_Kind
+ (Get_Type_Declarator (Get_Base_Type (Get_Type (Decl))))
+ = Iir_Kind_Anonymous_Type_Declaration
+ then
+ -- The type declaration declares an anonymous type
+ -- and a named subtype.
+ Error_Msg_Sem
+ ("'" & Image_Identifier (Decl)
+ & "' declares both an anonymous type and a named subtype",
+ Decl);
+ end if;
+ end if;
+ return;
+ end if;
+
+ -- LRM93 �5.1
+ -- An attribute specification for an attribute of a design unit
+ -- (ie an entity declaration, an architecture, a configuration, or a
+ -- package) must appear immediately within the declarative part of
+ -- that design unit.
+ case Get_Entity_Class (Attr) is
+ when Tok_Entity
+ | Tok_Architecture
+ | Tok_Configuration
+ | Tok_Package =>
+ if Get_Design_Unit (Decl) /= Get_Current_Design_Unit then
+ Error_Msg_Sem (Disp_Node (Attr) & " must appear immediatly "
+ & "within " & Disp_Node (Decl), Attr);
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+
+ Attr_Decl := Get_Named_Entity (Get_Attribute_Designator (Attr));
+
+ -- LRM93 5.1
+ -- It is an error if a given attribute is associated more than once with
+ -- a given named entity.
+ -- LRM 5.1
+ -- Similarly, it is an error if two different attributes with the
+ -- same simple name (wether predefined or user-defined) are both
+ -- associated with a given named entity.
+ El := Get_Attribute_Value_Chain (Decl);
+ while El /= Null_Iir loop
+ declare
+ El_Attr : constant Iir_Attribute_Declaration :=
+ Get_Named_Entity (Get_Attribute_Designator
+ (Get_Attribute_Specification (El)));
+ begin
+ if El_Attr = Attr_Decl then
+ if Get_Attribute_Specification (El) = Attr then
+ -- Was already specified with the same attribute value.
+ -- This is possible only in one case:
+ --
+ -- signal S1 : real;
+ -- alias S1_too : real is S1;
+ -- attribute ATTR : T1;
+ -- attribute ATTR of ALL : signal is '1';
+ return;
+ end if;
+ if Check_Defined then
+ Error_Msg_Sem
+ (Disp_Node (Decl) & " has already " & Disp_Node (Attr),
+ Attr);
+ Error_Msg_Sem ("previous attribute specification at "
+ & Disp_Location (El), Attr);
+ end if;
+ return;
+ elsif Get_Identifier (El_Attr) = Get_Identifier (Attr_Decl) then
+ Error_Msg_Sem
+ (Disp_Node (Decl) & " is already decorated with an "
+ & Disp_Node (El_Attr), Attr);
+ Error_Msg_Sem
+ ("(previous attribute specification was here)", El);
+ return;
+ end if;
+ end;
+ El := Get_Chain (El);
+ end loop;
+
+ El := Create_Iir (Iir_Kind_Attribute_Value);
+ Location_Copy (El, Attr);
+ Set_Name_Staticness (El, None);
+ Set_Attribute_Specification (El, Attr);
+ -- FIXME: create an expr_error node?
+ declare
+ Expr : Iir;
+ begin
+ Expr := Get_Expression (Attr);
+ if Expr = Error_Mark then
+ Set_Expr_Staticness (El, Locally);
+ else
+ Set_Expr_Staticness (El, Get_Expr_Staticness (Expr));
+ end if;
+ end;
+ Set_Designated_Entity (El, Decl);
+ Set_Type (El, Get_Type (Attr_Decl));
+ Set_Base_Name (El, El);
+ Set_Chain (El, Get_Attribute_Value_Chain (Decl));
+ Set_Attribute_Value_Chain (Decl, El);
+ Set_Spec_Chain (El, Get_Attribute_Value_Spec_Chain (Attr));
+ Set_Attribute_Value_Spec_Chain (Attr, El);
+
+ if (Flags.Vhdl_Std >= Vhdl_93c
+ and then Attr_Decl = Foreign_Attribute)
+ or else
+ (Flags.Vhdl_Std <= Vhdl_93c
+ and then Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign)
+ then
+ -- LRM93 12.4
+ -- The 'FOREIGN attribute may be associated only with
+ -- architectures or with subprograms.
+ case Get_Entity_Class (Attr) is
+ when Tok_Architecture =>
+ null;
+
+ when Tok_Function
+ | Tok_Procedure =>
+ -- LRM93 12.4
+ -- In the latter case, the attribute specification must
+ -- appear in the declarative part in which the subprogram
+ -- is declared.
+ -- GHDL: huh, this is the case for any attributes.
+ null;
+
+ when others =>
+ Error_Msg_Sem
+ ("'FOREIGN allowed only for architectures and subprograms",
+ Attr);
+ return;
+ end case;
+
+ Set_Foreign_Flag (Decl, True);
+
+ declare
+ use Back_End;
+ begin
+ if Sem_Foreign /= null then
+ Sem_Foreign.all (Decl);
+ end if;
+ end;
+ end if;
+ end Attribute_A_Decl;
+
+ -- IS_DESIGNATORS if true if the entity name list is a list of designators.
+ -- Return TRUE if an entity was attributed.
+ function Sem_Named_Entities
+ (Scope : Iir;
+ Name : Iir;
+ Attr : Iir_Attribute_Specification;
+ Is_Designators : Boolean;
+ Check_Defined : Boolean)
+ return Boolean
+ is
+ Res : Boolean;
+
+ -- If declaration DECL matches then named entity ENT, apply attribute
+ -- specification and returns TRUE. Otherwise, return FALSE.
+ -- Note: ENT and DECL are different for aliases.
+ function Sem_Named_Entity1 (Ent : Iir; Decl : Iir) return Boolean
+ is
+ Ent_Id : constant Name_Id := Get_Identifier (Ent);
+ begin
+ if (Name = Null_Iir or else Ent_Id = Get_Identifier (Name))
+ and then Ent_Id /= Null_Identifier
+ then
+ if Is_Designators then
+ Xref_Ref (Name, Ent);
+ end if;
+ if Get_Visible_Flag (Ent) = False then
+ Error_Msg_Sem
+ (Disp_Node (Ent) & " is not yet visible", Attr);
+ else
+ Attribute_A_Decl (Decl, Attr, Is_Designators, Check_Defined);
+ return True;
+ end if;
+ end if;
+ return False;
+ end Sem_Named_Entity1;
+
+ procedure Sem_Named_Entity (Ent : Iir) is
+ begin
+ case Get_Kind (Ent) is
+ when Iir_Kinds_Library_Unit_Declaration
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kinds_Sequential_Statement
+ | Iir_Kinds_Non_Alias_Object_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ Res := Res or Sem_Named_Entity1 (Ent, Ent);
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if not Is_Second_Subprogram_Specification (Ent) then
+ Res := Res or Sem_Named_Entity1 (Ent, Ent);
+ end if;
+ when Iir_Kind_Object_Alias_Declaration =>
+ -- LRM93 5.1
+ -- An entity designator that denotes an alias of an object is
+ -- required to denote the entire object, and not a subelement
+ -- or slice thereof.
+ declare
+ Decl : constant Iir := Get_Name (Ent);
+ Base : constant Iir := Get_Object_Prefix (Decl, False);
+ Applied : Boolean;
+ begin
+ Applied := Sem_Named_Entity1 (Ent, Base);
+ -- FIXME: check the alias denotes a local entity...
+ if Applied
+ and then Base /= Strip_Denoting_Name (Decl)
+ then
+ Error_Msg_Sem
+ (Disp_Node (Ent) & " does not denote the entire object",
+ Attr);
+ end if;
+ Res := Res or Applied;
+ end;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ Res := Res
+ or Sem_Named_Entity1 (Ent, Get_Named_Entity (Get_Name (Ent)));
+ when Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Configuration_Specification
+ | Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ null;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("sem_named_entity", Ent);
+ end case;
+ end Sem_Named_Entity;
+
+ procedure Sem_Named_Entity_Chain (Chain_First : Iir)
+ is
+ El : Iir;
+ Def : Iir;
+ begin
+ El := Chain_First;
+ while El /= Null_Iir loop
+ exit when El = Attr;
+ Sem_Named_Entity (El);
+ case Get_Kind (El) is
+ when Iir_Kind_Type_Declaration =>
+ Def := Get_Type_Definition (El);
+ if Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition then
+ declare
+ List : Iir_List;
+ El1 : Iir;
+ begin
+ List := Get_Enumeration_Literal_List (Def);
+ for I in Natural loop
+ El1 := Get_Nth_Element (List, I);
+ exit when El1 = Null_Iir;
+ Sem_Named_Entity (El1);
+ end loop;
+ end;
+ end if;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Def := Get_Type_Definition (El);
+ if Get_Kind (Def) = Iir_Kind_Physical_Type_Definition then
+ declare
+ El1 : Iir;
+ begin
+ El1 := Get_Unit_Chain (Def);
+ while El1 /= Null_Iir loop
+ Sem_Named_Entity (El1);
+ El1 := Get_Chain (El1);
+ end loop;
+ end;
+ end if;
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement =>
+ Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (El));
+ when Iir_Kind_If_Statement =>
+ declare
+ Clause : Iir;
+ begin
+ Clause := El;
+ while Clause /= Null_Iir loop
+ Sem_Named_Entity_Chain
+ (Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ end loop;
+ end;
+ when Iir_Kind_Case_Statement =>
+ declare
+ El1 : Iir;
+ begin
+ El1 := Get_Case_Statement_Alternative_Chain (El);
+ while El1 /= Null_Iir loop
+ Sem_Named_Entity_Chain (Get_Associated_Chain (El1));
+ El1 := Get_Chain (El1);
+ end loop;
+ end;
+
+ when Iir_Kind_Generate_Statement =>
+ -- INT-1991/issue 27
+ -- Generate statements represent declarative region and
+ -- have implicit declarative parts.
+ -- Was: There is no declarative part in generate statement
+ -- for VHDL 87.
+ if False and then Flags.Vhdl_Std = Vhdl_87 then
+ Sem_Named_Entity_Chain
+ (Get_Concurrent_Statement_Chain (El));
+ end if;
+
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Sem_Named_Entity_Chain;
+ begin
+ Res := False;
+
+ -- LRM 5.1 Attribute specification
+ -- o If a list of entity designators is supplied, then the
+ -- attribute specification applies to the named entities denoted
+ -- by those designators.
+ --
+ -- o If the reserved word OTHERS is supplied, then the attribute
+ -- specification applies to named entities of the specified class
+ -- that are declared in the immediately enclosing declarative
+ -- part [...]
+ --
+ -- o If the reserved word ALL is supplied, then the attribute
+ -- specification applies to all named entities of the specified
+ -- class that are declared in the immediatly enclosing
+ -- declarative part.
+
+ -- NOTE: therefore, ALL/OTHERS do not apply to named entities declared
+ -- beyond the immediate declarative part, such as design unit or
+ -- interfaces.
+ if Is_Designators then
+ -- LRM 5.1 Attribute specification
+ -- An attribute specification for an attribute of a design unit
+ -- (i.e. an entity declaration, an architecture, a configuration
+ -- or a package) must appear immediatly within the declarative part
+ -- of that design unit.
+ case Get_Kind (Scope) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Package_Declaration =>
+ Sem_Named_Entity (Scope);
+ when others =>
+ null;
+ end case;
+
+ -- LRM 5.1 Attribute specification
+ -- Similarly, an attribute specification for an attribute of an
+ -- interface object of a design unit, subprogram or block statement
+ -- must appear immediatly within the declarative part of that design
+ -- unit, subprogram, or block statement.
+ case Get_Kind (Scope) is
+ when Iir_Kind_Entity_Declaration =>
+ Sem_Named_Entity_Chain (Get_Generic_Chain (Scope));
+ Sem_Named_Entity_Chain (Get_Port_Chain (Scope));
+ when Iir_Kind_Block_Statement =>
+ declare
+ Header : constant Iir := Get_Block_Header (Scope);
+ begin
+ if Header /= Null_Iir then
+ Sem_Named_Entity_Chain (Get_Generic_Chain (Header));
+ Sem_Named_Entity_Chain (Get_Port_Chain (Header));
+ end if;
+ end;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ declare
+ Spec : Iir;
+ begin
+ Spec := Get_Subprogram_Specification (Scope);
+ Sem_Named_Entity_Chain
+ (Get_Interface_Declaration_Chain (Spec));
+ end;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ case Get_Kind (Scope) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Generate_Statement =>
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope));
+ when Iir_Kind_Block_Statement =>
+ declare
+ Guard : constant Iir := Get_Guard_Decl (Scope);
+ begin
+ if Guard /= Null_Iir then
+ Sem_Named_Entity (Guard);
+ end if;
+ end;
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ Sem_Named_Entity_Chain (Get_Concurrent_Statement_Chain (Scope));
+ when Iir_Kind_Configuration_Declaration =>
+ null;
+ when Iir_Kind_Package_Declaration =>
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ when Iir_Kinds_Process_Statement =>
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope));
+ when Iir_Kind_Package_Body =>
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Sem_Named_Entity_Chain (Get_Declaration_Chain (Scope));
+ Sem_Named_Entity_Chain (Get_Sequential_Statement_Chain (Scope));
+ when others =>
+ Error_Kind ("sem_named_entities", Scope);
+ end case;
+ return Res;
+ end Sem_Named_Entities;
+
+ procedure Sem_Signature_Entity_Designator
+ (Sig : Iir_Signature; Attr : Iir_Attribute_Specification)
+ is
+ Prefix : Iir;
+ Inter : Name_Interpretation_Type;
+ List : Iir_List;
+ Name : Iir;
+ begin
+ List := Create_Iir_List;
+
+ -- Sem_Name cannot be used here (at least not directly) because only
+ -- the declarations of the current scope are considered.
+ Prefix := Get_Signature_Prefix (Sig);
+ Inter := Get_Interpretation (Get_Identifier (Prefix));
+ while Valid_Interpretation (Inter) loop
+ exit when not Is_In_Current_Declarative_Region (Inter);
+ if not Is_Potentially_Visible (Inter) then
+ Name := Get_Declaration (Inter);
+ -- LRM 5.1 Attribute Specification
+ -- The entity tag of an entity designator containing a signature
+ -- must denote the name of one or more subprograms or enumeration
+ -- literals.
+ case Get_Kind (Name) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Enumeration_Literal =>
+ Append_Element (List, Name);
+ when others =>
+ Error_Msg_Sem
+ ("entity tag must denote a subprogram or a literal", Sig);
+ end case;
+ end if;
+ Inter := Get_Next_Interpretation (Inter);
+ end loop;
+
+ Name := Sem_Decls.Sem_Signature (Create_Overload_List (List), Sig);
+ if Name = Null_Iir then
+ return;
+ end if;
+
+ Set_Named_Entity (Prefix, Name);
+ Prefix := Finish_Sem_Name (Prefix);
+ Set_Signature_Prefix (Sig, Prefix);
+
+ Attribute_A_Decl (Name, Attr, True, True);
+ end Sem_Signature_Entity_Designator;
+
+ procedure Sem_Attribute_Specification
+ (Spec : Iir_Attribute_Specification;
+ Scope : Iir)
+ is
+ use Tokens;
+
+ Name : Iir;
+ Attr : Iir_Attribute_Declaration;
+ List : Iir_List;
+ Expr : Iir;
+ Res : Boolean;
+ begin
+ -- LRM93 5.1
+ -- The attribute designator must denote an attribute.
+ Name := Sem_Denoting_Name (Get_Attribute_Designator (Spec));
+ Set_Attribute_Designator (Spec, Name);
+
+ Attr := Get_Named_Entity (Name);
+ if Get_Kind (Attr) /= Iir_Kind_Attribute_Declaration then
+ Error_Class_Match (Name, "attribute");
+ return;
+ end if;
+
+ -- LRM 5.1
+ -- The type of the expression in the attribute specification must be
+ -- the same as (or implicitly convertible to) the type mark in the
+ -- corresponding attribute declaration.
+ Expr := Sem_Expression (Get_Expression (Spec), Get_Type (Attr));
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Set_Expression (Spec, Eval_Expr_If_Static (Expr));
+
+ -- LRM 5.1
+ -- If the entity name list denotes an entity declaration,
+ -- architecture body or configuration declaration, then the
+ -- expression is required to be locally static.
+ -- GHDL: test based on the entity_class.
+ case Get_Entity_Class (Spec) is
+ when Tok_Entity
+ | Tok_Architecture
+ | Tok_Configuration =>
+ if Get_Expr_Staticness (Expr) /= Locally then
+ Error_Msg_Sem
+ ("attribute expression for "
+ & Image (Get_Entity_Class (Spec))
+ & " must be locally static", Spec);
+ end if;
+ when others =>
+ null;
+ end case;
+ else
+ Set_Expression (Spec, Error_Mark);
+ end if;
+
+ -- LRM 5.1
+ -- The entity name list identifies those named entities, both
+ -- implicitly and explicitly defined, that inherit the attribute, as
+ -- defined below:
+ List := Get_Entity_Name_List (Spec);
+ if List = Iir_List_All then
+ -- o If the reserved word ALL is supplied, then the attribute
+ -- specification applies to all named entities of the specified
+ -- class that are declared in the immediatly enclosing
+ -- declarative part.
+ Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, True);
+ if Res = False and then Flags.Warn_Specs then
+ Warning_Msg_Sem
+ ("attribute specification apply to no named entity", Spec);
+ end if;
+ elsif List = Iir_List_Others then
+ -- o If the reserved word OTHERS is supplied, then the attribute
+ -- specification applies to named entities of the specified class
+ -- that are declared in the immediately enclosing declarative
+ -- part, provided that each such entity is not explicitly named
+ -- in the entity name list of a previous attribute specification
+ -- for the given attribute.
+ Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, False);
+ if Res = False and then Flags.Warn_Specs then
+ Warning_Msg_Sem
+ ("attribute specification apply to no named entity", Spec);
+ end if;
+ else
+ -- o If a list of entity designators is supplied, then the
+ -- attribute specification applies to the named entities denoted
+ -- by those designators.
+ declare
+ El : Iir;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Get_Kind (El) = Iir_Kind_Signature then
+ Sem_Signature_Entity_Designator (El, Spec);
+ else
+ -- LRM 5.1
+ -- It is an error if the class of those names is not the
+ -- same as that denoted by entity class.
+ if not Sem_Named_Entities (Scope, El, Spec, True, True) then
+ Error_Msg_Sem
+ ("no named entities '" & Image_Identifier (El)
+ & "' in declarative part", El);
+ end if;
+ end if;
+ end loop;
+ end;
+ end if;
+ end Sem_Attribute_Specification;
+
+ procedure Check_Post_Attribute_Specification
+ (Attr_Spec_Chain : Iir; Decl : Iir)
+ is
+ use Tokens;
+
+ Has_Error : Boolean;
+ Spec : Iir;
+ Decl_Class : Token_Type;
+ Decl_Class2 : Token_Type;
+ Ent_Class : Token_Type;
+ begin
+ -- Some declaration items can never be attributed.
+ Decl_Class2 := Tok_Eof;
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kinds_Signal_Attribute
+ | Iir_Kind_Disconnection_Specification =>
+ return;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ -- A physical type definition declares units.
+ if Get_Kind (Get_Type_Definition (Decl))
+ = Iir_Kind_Physical_Type_Definition
+ then
+ Decl_Class := Tok_Units;
+ else
+ return;
+ end if;
+ when Iir_Kind_Attribute_Specification =>
+ Decl_Class := Get_Entity_Class (Decl);
+ when Iir_Kind_Type_Declaration =>
+ Decl_Class := Tok_Type;
+ -- An enumeration type declares literals.
+ if Get_Kind (Get_Type_Definition (Decl))
+ = Iir_Kind_Enumeration_Type_Definition
+ then
+ Decl_Class2 := Tok_Literal;
+ end if;
+ when Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ Decl_Class := Get_Entity_Class_Kind (Get_Name (Decl));
+ -- NOTE: for non-object alias that declares an enumeration type
+ -- or a physical type, no need to set decl_class2, since
+ -- all implicit aliases are checked.
+ when others =>
+ Decl_Class := Get_Entity_Class_Kind (Decl);
+ end case;
+
+ Spec := Attr_Spec_Chain;
+ -- Skip itself (newly added, therefore first of the chain).
+ if Spec = Decl then
+ Spec := Get_Attribute_Specification_Chain (Spec);
+ end if;
+ while Spec /= Null_Iir loop
+ pragma Assert (Get_Entity_Name_List (Spec) in Iir_Lists_All_Others);
+ Ent_Class := Get_Entity_Class (Spec);
+ if Ent_Class = Decl_Class or Ent_Class = Decl_Class2 then
+ Has_Error := False;
+
+ if Get_Kind (Decl) = Iir_Kind_Attribute_Specification then
+ -- LRM 5.1 Attribute specifications
+ -- An attribute specification with the entity name list OTHERS
+ -- or ALL for a given entity class that appears in a
+ -- declarative part must be the last such specification for the
+ -- given attribute for the given entity class in that
+ -- declarative part.
+ if Get_Identifier (Get_Attribute_Designator (Decl))
+ = Get_Identifier (Get_Attribute_Designator (Spec))
+ then
+ Error_Msg_Sem
+ ("no attribute specification may follow an "
+ & "all/others spec", Decl);
+ Has_Error := True;
+ end if;
+ else
+ -- LRM 5.1 Attribute specifications
+ -- It is an error if a named entity in the specificied entity
+ -- class is declared in a given declarative part following such
+ -- an attribute specification.
+ Error_Msg_Sem
+ ("no named entity may follow an all/others attribute "
+ & "specification", Decl);
+ Has_Error := True;
+ end if;
+ if Has_Error then
+ Error_Msg_Sem
+ ("(previous all/others specification for the given "
+ &"entity class)", Spec);
+ end if;
+ end if;
+ Spec := Get_Attribute_Specification_Chain (Spec);
+ end loop;
+ end Check_Post_Attribute_Specification;
+
+ -- Compare ATYPE and TYPE_MARK.
+ -- ATYPE is a type definition, which can be anonymous.
+ -- TYPE_MARK is a subtype definition, established from a type mark.
+ -- Therefore, it is the name of a type or a subtype.
+ -- Return TRUE iff the type mark of ATYPE is TYPE_MARK.
+ function Is_Same_Type_Mark (Atype : Iir; Type_Mark : Iir)
+ return Boolean is
+ begin
+ if Get_Kind (Atype) in Iir_Kinds_Subtype_Definition
+ and then Is_Anonymous_Type_Definition (Atype)
+ then
+ -- FIXME: to be removed; used to catch uninitialized type_mark.
+ if Get_Subtype_Type_Mark (Atype) = Null_Iir then
+ raise Internal_Error;
+ end if;
+ return Get_Type (Get_Subtype_Type_Mark (Atype)) = Type_Mark;
+ else
+ return Atype = Type_Mark;
+ end if;
+ end Is_Same_Type_Mark;
+
+ procedure Sem_Disconnection_Specification
+ (Dis : Iir_Disconnection_Specification)
+ is
+ Type_Mark : Iir;
+ Atype : Iir;
+ Time_Expr : Iir;
+ List : Iir_List;
+ El : Iir;
+ Sig : Iir;
+ Prefix : Iir;
+ begin
+ -- Sem type mark.
+ Type_Mark := Get_Type_Mark (Dis);
+ Type_Mark := Sem_Type_Mark (Type_Mark);
+ Set_Type_Mark (Dis, Type_Mark);
+ Atype := Get_Type (Type_Mark);
+
+ -- LRM93 5.3
+ -- The time expression in a disconnection specification must be static
+ -- and must evaluate to a non-negative value.
+ Time_Expr := Sem_Expression
+ (Get_Expression (Dis), Time_Subtype_Definition);
+ if Time_Expr /= Null_Iir then
+ Check_Read (Time_Expr);
+ Set_Expression (Dis, Time_Expr);
+ if Get_Expr_Staticness (Time_Expr) < Globally then
+ Error_Msg_Sem ("time expression must be static", Time_Expr);
+ end if;
+ end if;
+
+ List := Get_Signal_List (Dis);
+ if List = Iir_List_All or List = Iir_List_Others then
+ -- FIXME: checks todo
+ null;
+ else
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+
+ Sem_Name (El);
+ El := Finish_Sem_Name (El);
+ Replace_Nth_Element (List, I, El);
+
+ Sig := Get_Named_Entity (El);
+ Sig := Name_To_Object (Sig);
+ if Sig /= Null_Iir then
+ Set_Type (El, Get_Type (Sig));
+ Prefix := Get_Object_Prefix (Sig);
+ -- LRM93 5.3
+ -- Each signal name in a signal list in a guarded signal
+ -- specification must be a locally static name that
+ -- denotes a guarded signal.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ null;
+ when others =>
+ Error_Msg_Sem ("object must be a signal", El);
+ return;
+ end case;
+ if Get_Name_Staticness (Sig) /= Locally then
+ Error_Msg_Sem ("signal name must be locally static", El);
+ end if;
+ if Get_Signal_Kind (Prefix) = Iir_No_Signal_Kind then
+ Error_Msg_Sem ("signal must be a guarded signal", El);
+ end if;
+ Set_Has_Disconnect_Flag (Prefix, True);
+
+ -- LRM93 5.3
+ -- If the guarded signal is a declared signal or a slice of
+ -- thereof, the type mark must be the same as the type mark
+ -- indicated in the guarded signal specification.
+ -- If the guarded signal is an array element of an explicitly
+ -- declared signal, the type mark must be the same as the
+ -- element subtype indication in the (explicit or implicit)
+ -- array type declaration that declares the base type of the
+ -- explicitly declared signal.
+ -- If the guarded signal is a record element of an explicitly
+ -- declared signal, then the type mark must be the same as
+ -- the type mark in the element subtype definition of the
+ -- record type declaration that declares the type of the
+ -- explicitly declared signal.
+ -- FIXME: to be checked: the expression type (as set by
+ -- sem_expression) may be a base type instead of a type mark.
+ if not Is_Same_Type_Mark (Get_Type (Sig), Atype) then
+ Error_Msg_Sem ("type mark and signal type mismatch", El);
+ end if;
+
+ -- LRM93 5.3
+ -- Each signal must be declared in the declarative part
+ -- enclosing the disconnection specification.
+ -- FIXME: todo.
+ elsif Get_Designated_Entity (El) /= Error_Mark then
+ Error_Msg_Sem ("name must designate a signal", El);
+ end if;
+ end loop;
+ end if;
+ end Sem_Disconnection_Specification;
+
+ -- Semantize entity aspect ASPECT and return the entity declaration.
+ -- Return NULL_IIR if not found.
+ function Sem_Entity_Aspect (Aspect : Iir) return Iir is
+ begin
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ declare
+ Entity_Name : Iir;
+ Entity : Iir;
+ Arch_Name : Iir;
+ Arch_Unit : Iir;
+ begin
+ Entity_Name := Sem_Denoting_Name (Get_Entity_Name (Aspect));
+ Set_Entity_Name (Aspect, Entity_Name);
+ Entity := Get_Named_Entity (Entity_Name);
+ if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then
+ Error_Class_Match (Entity_Name, "entity");
+ return Null_Iir;
+ end if;
+ -- Note: dependency is added by Sem_Denoting_Name.
+
+ -- Check architecture.
+ Arch_Name := Get_Architecture (Aspect);
+ if Arch_Name /= Null_Iir then
+ Arch_Unit := Libraries.Find_Secondary_Unit
+ (Get_Design_Unit (Entity), Get_Identifier (Arch_Name));
+ Set_Named_Entity (Arch_Name, Arch_Unit);
+ if Arch_Unit /= Null_Iir then
+ Xref_Ref (Arch_Name, Arch_Unit);
+ end if;
+
+ -- FIXME: may emit a warning if the architecture does not
+ -- exist.
+ -- Note: the design needs the architecture.
+ Add_Dependence (Aspect);
+ end if;
+ return Entity;
+ end;
+
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ declare
+ Conf_Name : Iir;
+ Conf : Iir;
+ begin
+ Conf_Name :=
+ Sem_Denoting_Name (Get_Configuration_Name (Aspect));
+ Set_Configuration_Name (Aspect, Conf_Name);
+ Conf := Get_Named_Entity (Conf_Name);
+ if Get_Kind (Conf) /= Iir_Kind_Configuration_Declaration then
+ Error_Class_Match (Conf, "configuration");
+ return Null_Iir;
+ end if;
+
+ return Get_Entity (Conf);
+ end;
+
+ when Iir_Kind_Entity_Aspect_Open =>
+ return Null_Iir;
+
+ when others =>
+ Error_Kind ("sem_entity_aspect", Aspect);
+ end case;
+ end Sem_Entity_Aspect;
+
+ procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication;
+ Comp : Iir_Component_Declaration;
+ Parent : Iir;
+ Primary_Entity_Aspect : Iir)
+ is
+ Entity_Aspect : Iir;
+ Entity : Iir_Entity_Declaration;
+ begin
+ if Bind = Null_Iir then
+ raise Internal_Error;
+ end if;
+
+ Entity_Aspect := Get_Entity_Aspect (Bind);
+ if Entity_Aspect /= Null_Iir then
+ Entity := Sem_Entity_Aspect (Entity_Aspect);
+
+ -- LRM93 5.2.1 Binding Indication
+ -- An incremental binding indication must not have an entity aspect.
+ if Primary_Entity_Aspect /= Null_Iir then
+ Error_Msg_Sem
+ ("entity aspect not allowed for incremental binding", Bind);
+ end if;
+
+ -- Return now in case of error.
+ if Entity = Null_Iir then
+ return;
+ end if;
+ else
+ -- LRM93 5.2.1
+ -- When a binding indication is used in an explicit configuration
+ -- specification, it is an error if the entity aspect is absent.
+ case Get_Kind (Parent) is
+ when Iir_Kind_Component_Configuration =>
+ if Primary_Entity_Aspect = Null_Iir then
+ Entity := Null_Iir;
+ else
+ case Get_Kind (Primary_Entity_Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Entity := Get_Entity (Primary_Entity_Aspect);
+ when others =>
+ Error_Kind
+ ("sem_binding_indication", Primary_Entity_Aspect);
+ end case;
+ end if;
+ when Iir_Kind_Configuration_Specification =>
+ Error_Msg_Sem
+ ("entity aspect required in a configuration specification",
+ Bind);
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ if Entity = Null_Iir
+ or else Get_Kind (Entity) = Iir_Kind_Entity_Aspect_Open
+ then
+ -- LRM 5.2.1.1 Entity aspect
+ -- The third form of entity aspect is used to specify that the
+ -- indiciation of the design entity is to be defined. In this case,
+ -- the immediatly enclosing binding indication is said to not
+ -- imply any design entity. Furthermore, the immediatly enclosing
+ -- binding indication must not include a generic map aspect or a
+ -- port map aspect.
+ if Get_Generic_Map_Aspect_Chain (Bind) /= Null_Iir
+ or else Get_Port_Map_Aspect_Chain (Bind) /= Null_Iir
+ then
+ Error_Msg_Sem
+ ("map aspect not allowed for open entity aspect", Bind);
+ return;
+ end if;
+ else
+ Sem_Generic_Port_Association_Chain (Entity, Bind);
+
+ -- LRM 5.2.1 Binding Indication
+ -- If the generic map aspect or port map aspect of a binding
+ -- indication is not present, then the default rules as described
+ -- in 5.2.2 apply.
+ if Get_Generic_Map_Aspect_Chain (Bind) = Null_Iir
+ and then Primary_Entity_Aspect = Null_Iir
+ then
+ Set_Default_Generic_Map_Aspect_Chain
+ (Bind,
+ Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent));
+ end if;
+ if Get_Port_Map_Aspect_Chain (Bind) = Null_Iir
+ and then Primary_Entity_Aspect = Null_Iir
+ then
+ Set_Default_Port_Map_Aspect_Chain
+ (Bind,
+ Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent));
+ end if;
+ end if;
+ end Sem_Binding_Indication;
+
+ -- Set configuration_specification or component_configuration SPEC to
+ -- component instantiation COMP.
+ procedure Apply_Configuration_Specification
+ (Comp : Iir_Component_Instantiation_Statement;
+ Spec : Iir;
+ Primary_Entity_Aspect : in out Iir)
+ is
+ Prev_Spec : Iir;
+ Prev_Conf : Iir;
+
+ procedure Prev_Spec_Error is
+ begin
+ Error_Msg_Sem
+ (Disp_Node (Comp)
+ & " is alreay bound by a configuration specification", Spec);
+ Error_Msg_Sem
+ ("(previous is " & Disp_Node (Prev_Spec) & ")", Prev_Spec);
+ end Prev_Spec_Error;
+
+ Prev_Binding : Iir_Binding_Indication;
+ Prev_Entity_Aspect : Iir;
+ begin
+ Prev_Spec := Get_Configuration_Specification (Comp);
+ if Prev_Spec /= Null_Iir then
+ case Get_Kind (Spec) is
+ when Iir_Kind_Configuration_Specification =>
+ Prev_Spec_Error;
+ return;
+ when Iir_Kind_Component_Configuration =>
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Prev_Spec_Error;
+ Error_Msg_Sem
+ ("(incremental binding is not allowed in vhdl87)", Spec);
+ return;
+ end if;
+ -- Incremental binding.
+ Prev_Binding := Get_Binding_Indication (Prev_Spec);
+ if Prev_Binding /= Null_Iir then
+ Prev_Entity_Aspect := Get_Entity_Aspect (Prev_Binding);
+ if Primary_Entity_Aspect = Null_Iir then
+ Primary_Entity_Aspect := Prev_Entity_Aspect;
+ else
+ -- FIXME: checks to do ?
+ null;
+ end if;
+ end if;
+ when others =>
+ Error_Kind ("apply_configuration_specification", Spec);
+ end case;
+ end if;
+ Prev_Conf := Get_Component_Configuration (Comp);
+ if Prev_Conf /= Null_Iir then
+ case Get_Kind (Spec) is
+ when Iir_Kind_Configuration_Specification =>
+ -- How can this happen ?
+ raise Internal_Error;
+ when Iir_Kind_Component_Configuration =>
+ Error_Msg_Sem
+ (Disp_Node (Comp)
+ & " is already bound by a component configuration",
+ Spec);
+ Error_Msg_Sem
+ ("(previous is " & Disp_Node (Prev_Conf) & ")", Prev_Conf);
+ return;
+ when others =>
+ Error_Kind ("apply_configuration_specification(2)", Spec);
+ end case;
+ end if;
+ if Get_Kind (Spec) = Iir_Kind_Configuration_Specification then
+ Set_Configuration_Specification (Comp, Spec);
+ end if;
+ Set_Component_Configuration (Comp, Spec);
+ end Apply_Configuration_Specification;
+
+ -- Semantize component_configuration or configuration_specification SPEC.
+ -- STMTS is the concurrent statement list related to SPEC.
+ procedure Sem_Component_Specification
+ (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir)
+ is
+ function Apply_Component_Specification
+ (Chain : Iir; Check_Applied : Boolean)
+ return Boolean
+ is
+ Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Spec));
+ El : Iir;
+ Res : Boolean;
+ begin
+ El := Get_Concurrent_Statement_Chain (Chain);
+ Res := False;
+ 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
+ and then
+ (not Check_Applied
+ or else Get_Component_Configuration (El) = Null_Iir)
+ then
+ Apply_Configuration_Specification
+ (El, Spec, Primary_Entity_Aspect);
+ Res := True;
+ end if;
+ when Iir_Kind_Generate_Statement =>
+ if False and then Flags.Vhdl_Std = Vhdl_87 then
+ Res := Res
+ or Apply_Component_Specification (El, Check_Applied);
+ end if;
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ return Res;
+ end Apply_Component_Specification;
+
+ List : Iir_List;
+ El : Iir;
+ Inter : Sem_Scopes.Name_Interpretation_Type;
+ Comp : Iir;
+ Comp_Name : Iir;
+ Inst : Iir;
+ Inst_Unit : Iir;
+ begin
+ Primary_Entity_Aspect := Null_Iir;
+ Comp_Name := Sem_Denoting_Name (Get_Component_Name (Spec));
+ Set_Component_Name (Spec, Comp_Name);
+ Comp := Get_Named_Entity (Comp_Name);
+ if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
+ Error_Class_Match (Comp_Name, "component");
+ return;
+ end if;
+
+ List := Get_Instantiation_List (Spec);
+ if List = Iir_List_All then
+ -- LRM93 5.2
+ -- * If the reserved word ALL is supplied, then the configuration
+ -- specification applies to all instances of the specified
+ -- component declaration whose labels are (implicitly) declared
+ -- in the immediately enclosing declarative region part.
+ -- This rule applies only to those component instantiation
+ -- statements whose corresponding instantiated units name
+ -- component.
+ if not Apply_Component_Specification (Parent_Stmts, False)
+ and then Flags.Warn_Specs
+ then
+ Warning_Msg_Sem
+ ("component specification applies to no instance", Spec);
+ end if;
+ elsif List = Iir_List_Others then
+ -- LRM93 5.2
+ -- * If the reserved word OTHERS is supplied, then the
+ -- configuration specification applies to instances of the
+ -- specified component declaration whoce labels are (implicitly)
+ -- declared in the immediatly enclosing declarative part,
+ -- provided that each such component instance is not explicitly
+ -- names in the instantiation list of a previous configuration
+ -- specification.
+ -- This rule applies only to those component instantiation
+ -- statements whose corresponding instantiated units name
+ -- components.
+ if not Apply_Component_Specification (Parent_Stmts, True)
+ and then Flags.Warn_Specs
+ then
+ Warning_Msg_Sem
+ ("component specification applies to no instance", Spec);
+ end if;
+ else
+ -- LRM93 5.2
+ -- * If a list of instantiation labels is supplied, then the
+ -- configuration specification applies to the corresponding
+ -- component instances.
+ -- Such labels must be (implicitly) declared within the
+ -- immediatly enclosing declarative part.
+ -- It is an error if these component instances are not instances
+ -- of the component declaration named in the component
+ -- specification.
+ -- It is also an error if any of the labels denote a component
+ -- instantiation statement whose corresponding instantiated unit
+ -- does not name a component.
+ -- FIXME: error message are *really* cryptic.
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Inter := Sem_Scopes.Get_Interpretation (Get_Identifier (El));
+ if not Valid_Interpretation (Inter) then
+ Error_Msg_Sem ("no component instantation with label '"
+ & Image_Identifier (El) & ''', El);
+ elsif not Is_In_Current_Declarative_Region (Inter) then
+ -- FIXME.
+ Error_Msg_Sem ("label not in block declarative part", El);
+ else
+ Inst := Get_Declaration (Inter);
+ if Get_Kind (Inst) /= Iir_Kind_Component_Instantiation_Statement
+ then
+ Error_Msg_Sem ("label does not denote an instantiation", El);
+ else
+ Inst_Unit := Get_Instantiated_Unit (Inst);
+ if Is_Entity_Instantiation (Inst)
+ or else (Get_Kind (Get_Named_Entity (Inst_Unit))
+ /= Iir_Kind_Component_Declaration)
+ then
+ Error_Msg_Sem
+ ("specification does not apply to direct instantiation",
+ El);
+ elsif Get_Named_Entity (Inst_Unit) /= Comp then
+ Error_Msg_Sem ("component names mismatch", El);
+ else
+ Apply_Configuration_Specification
+ (Inst, Spec, Primary_Entity_Aspect);
+ Xref_Ref (El, Inst);
+ Set_Named_Entity (El, Inst);
+ end if;
+ end if;
+ end if;
+ end loop;
+ end if;
+ end Sem_Component_Specification;
+
+ procedure Sem_Configuration_Specification
+ (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification)
+ is
+ Primary_Entity_Aspect : Iir;
+ Component : Iir;
+ begin
+ Sem_Component_Specification (Parent_Stmts, Conf, Primary_Entity_Aspect);
+ Component := Get_Named_Entity (Get_Component_Name (Conf));
+
+ -- Return now in case of error.
+ if Get_Kind (Component) /= Iir_Kind_Component_Declaration then
+ return;
+ end if;
+ -- Extend scope of component interface declaration.
+ Sem_Scopes.Open_Scope_Extension;
+ Sem_Scopes.Add_Component_Declarations (Component);
+ Sem_Binding_Indication (Get_Binding_Indication (Conf),
+ Component, Conf, Primary_Entity_Aspect);
+ -- FIXME: check default port and generic association.
+ Sem_Scopes.Close_Scope_Extension;
+ end Sem_Configuration_Specification;
+
+ function Sem_Create_Default_Binding_Indication
+ (Comp : Iir_Component_Declaration;
+ Entity_Unit : Iir_Design_Unit;
+ Parent : Iir;
+ Force : Boolean)
+ return Iir_Binding_Indication
+ is
+ Entity : Iir_Entity_Declaration;
+ Entity_Name : Iir;
+ Aspect : Iir;
+ Res : Iir;
+ Design_Unit : Iir_Design_Unit;
+ begin
+ -- LRM 5.2.2
+ -- The default binding indication consists of a default entity aspect,
+ -- together with a default generic map aspect and a default port map
+ -- aspect, as appropriate.
+
+ if Entity_Unit = Null_Iir then
+ if not Force then
+ return Null_Iir;
+ end if;
+
+ -- LRM 5.2.2
+ -- If no visible entity declaration has the same simple name as that
+ -- of the instantiated component, then the default entity aspect is
+ -- OPEN.
+ Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Open);
+ Location_Copy (Aspect, Comp);
+ Res := Create_Iir (Iir_Kind_Binding_Indication);
+ Set_Entity_Aspect (Res, Aspect);
+ return Res;
+ else
+ -- LRM 5.2.2
+ -- Otherwise, the default entity aspect is of the form:
+ -- ENTITY entity_name ( architecture_identifier)
+ -- where the entity name is the simple name of the instantiated
+ -- component and the architecture identifier is the same as the
+ -- simple name of the most recently analyzed architecture body
+ -- associated with the entity declaration.
+ --
+ -- If this rule is applied either to a binding indication contained
+ -- within a configuration specification or to a component
+ -- configuration that does not contain an explicit inner block
+ -- configuration, then the architecture identifier is determined
+ -- during elaboration of the design hierarchy containing the binding
+ -- indication.
+ --
+ -- Likewise, if a component instantiation statement contains an
+ -- instantiated unit containing the reserved word ENTITY, but does
+ -- not contain an explicitly specified architecture identifier, this
+ -- rule is applied during the elaboration of the design hierarchy
+ -- containing a component instantiation statement.
+ --
+ -- In all other cases, this rule is applied during analysis of the
+ -- binding indication.
+ --
+ -- It is an error if there is no architecture body associated with
+ -- the entity declaration denoted by an entity name that is the
+ -- simple name of the instantiated component.
+ null;
+ end if;
+
+ Design_Unit := Libraries.Load_Primary_Unit
+ (Get_Library (Get_Design_File (Entity_Unit)),
+ Get_Identifier (Get_Library_Unit (Entity_Unit)),
+ Parent);
+ if Design_Unit = Null_Iir then
+ -- Found an entity which is not in the library.
+ raise Internal_Error;
+ end if;
+
+ Entity := Get_Library_Unit (Design_Unit);
+
+ Res := Create_Iir (Iir_Kind_Binding_Indication);
+ Aspect := Create_Iir (Iir_Kind_Entity_Aspect_Entity);
+ Location_Copy (Aspect, Parent);
+
+ Entity_Name := Create_Iir (Iir_Kind_Simple_Name);
+ Location_Copy (Entity_Name, Parent);
+ Set_Named_Entity (Entity_Name, Entity);
+
+ Set_Entity_Name (Aspect, Entity_Name);
+ Set_Entity_Aspect (Res, Aspect);
+
+ -- LRM 5.2.2
+ -- The default binding indication includes a default generic map aspect
+ -- if the design entity implied by the entity aspect contains formal
+ -- generics.
+ Set_Generic_Map_Aspect_Chain
+ (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Generic, Parent));
+
+ -- LRM 5.2.2
+ -- The default binding indication includes a default port map aspect
+ -- if the design entity implied by the entity aspect contains formal
+ -- ports.
+ Set_Port_Map_Aspect_Chain
+ (Res, Create_Default_Map_Aspect (Comp, Entity, Map_Port, Parent));
+
+ return Res;
+ end Sem_Create_Default_Binding_Indication;
+
+ -- LRM 5.2.2
+ -- The default binding indication includes a default generic map aspect
+ -- if the design entity implied by the entity aspect contains formal
+ -- generics.
+ --
+ -- The default generic map aspect associates each local generic in
+ -- the corresponding component instantiation (if any) with a formal
+ -- of the same simple name.
+ -- It is an error if such a formal does not exist, or if its mode and
+ -- type are not appropriate for such an association.
+ -- Any remaining unassociated formals are associated with the actual
+ -- designator OPEN.
+
+ -- LRM 5.2.2
+ -- The default binding indication includes a default port map aspect
+ -- if the design entity implied by the entity aspect contains formal
+ -- ports.
+ --
+ -- The default port map aspect associates each local port in the
+ -- corresponding component instantiation (if any) with a formal of
+ -- the same simple name.
+ -- It is an error if such a formal does not exist, or if its mode
+ -- and type are not appropriate for such an association.
+ -- Any remaining unassociated formals are associated with the actual
+ -- designator OPEN.
+ function Create_Default_Map_Aspect
+ (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir)
+ return Iir
+ is
+ Res, Last : Iir;
+ Comp_El, Ent_El : Iir;
+ Assoc : Iir;
+ Found : Natural;
+ Comp_Chain : Iir;
+ Ent_Chain : Iir;
+ Error : Boolean;
+ begin
+ case Kind is
+ when Map_Generic =>
+ Ent_Chain := Get_Generic_Chain (Entity);
+ Comp_Chain := Get_Generic_Chain (Comp);
+ when Map_Port =>
+ Ent_Chain := Get_Port_Chain (Entity);
+ Comp_Chain := Get_Port_Chain (Comp);
+ end case;
+
+ -- If no formal, then there is no association list.
+ if Ent_Chain = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- No error found yet.
+ Error := False;
+
+ Sub_Chain_Init (Res, Last);
+ Found := 0;
+ Ent_El := Ent_Chain;
+ while Ent_El /= Null_Iir loop
+ -- Find the component generic/port with the same name.
+ Comp_El := Find_Name_In_Chain (Comp_Chain, Get_Identifier (Ent_El));
+ if Comp_El = Null_Iir then
+ Assoc := Create_Iir (Iir_Kind_Association_Element_Open);
+ Location_Copy (Assoc, Parent);
+ else
+ if not Are_Nodes_Compatible (Comp_El, Ent_El) then
+ if not Error then
+ Error_Msg_Sem
+ ("for default port binding of " & Disp_Node (Parent)
+ & ":", Parent);
+ end if;
+ Error_Msg_Sem
+ ("type of " & Disp_Node (Comp_El)
+ & " declarared at " & Disp_Location (Comp_El), Parent);
+ Error_Msg_Sem
+ ("not compatible with type of " & Disp_Node (Ent_El)
+ & " declarared at " & Disp_Location (Ent_El), Parent);
+ Error := True;
+ elsif Kind = Map_Port
+ and then not Check_Port_Association_Restriction
+ (Ent_El, Comp_El, Null_Iir)
+ then
+ if not Error then
+ Error_Msg_Sem
+ ("for default port binding of " & Disp_Node (Parent)
+ & ":", Parent);
+ end if;
+ Error_Msg_Sem
+ ("cannot associate "
+ & Get_Mode_Name (Get_Mode (Ent_El))
+ & " " & Disp_Node (Ent_El)
+ & " declarared at " & Disp_Location (Ent_El), Parent);
+ Error_Msg_Sem
+ ("with actual port of mode "
+ & Get_Mode_Name (Get_Mode (Comp_El))
+ & " declared at " & Disp_Location (Comp_El), Parent);
+ Error := True;
+ end if;
+ Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression);
+ Location_Copy (Assoc, Parent);
+ Set_Actual (Assoc, Comp_El);
+ Found := Found + 1;
+ end if;
+ Set_Whole_Association_Flag (Assoc, True);
+ Set_Formal (Assoc, Ent_El);
+ if Kind = Map_Port
+ and then not Error
+ and then Comp_El /= Null_Iir
+ then
+ Set_Collapse_Signal_Flag
+ (Assoc, Can_Collapse_Signals (Assoc, Ent_El));
+ end if;
+ Sub_Chain_Append (Res, Last, Assoc);
+ Ent_El := Get_Chain (Ent_El);
+ end loop;
+ if Iir_Chains.Get_Chain_Length (Comp_Chain) /= Found then
+ -- At least one component generic/port cannot be associated with
+ -- the entity one.
+ Error := True;
+ -- Disp unassociated interfaces.
+ Comp_El := Comp_Chain;
+ while Comp_El /= Null_Iir loop
+ Ent_El := Find_Name_In_Chain (Ent_Chain, Get_Identifier (Comp_El));
+ if Ent_El = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Comp_El) & " has no association in "
+ & Disp_Node (Entity), Parent);
+ end if;
+ Comp_El := Get_Chain (Comp_El);
+ end loop;
+ end if;
+ if Error then
+ return Null_Iir;
+ else
+ return Res;
+ end if;
+ end Create_Default_Map_Aspect;
+
+ -- LRM93 �5.2.2
+ function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration)
+ return Iir_Design_Unit
+ is
+ function Is_Entity_Declaration (Decl : Iir) return Boolean is
+ begin
+ return Get_Kind (Decl) = Iir_Kind_Design_Unit and then
+ Get_Kind (Get_Library_Unit (Decl)) = Iir_Kind_Entity_Declaration;
+ end Is_Entity_Declaration;
+
+ Inter : Name_Interpretation_Type;
+ Name : Name_Id;
+ Decl : Iir;
+ Target_Lib : Iir;
+ begin
+ Name := Get_Identifier (Comp);
+ Inter := Get_Interpretation (Name);
+
+ if Valid_Interpretation (Inter) then
+ -- A visible entity declaration is either:
+ --
+ -- a) An entity declaration that has the same simple name as that of
+ -- the instantiated component and that is directly visible
+ -- (see 10.3),
+ Decl := Get_Declaration (Inter);
+ if Is_Entity_Declaration (Decl) then
+ return Decl;
+ end if;
+
+ -- b) An entity declaration that has the same simple name that of
+ -- the instantiated component and that would be directly
+ -- visible in the absence of a directly visible (see 10.3)
+ -- component declaration with the same simple name as that
+ -- of the entity declaration, or
+ if Get_Kind (Decl) = Iir_Kind_Component_Declaration then
+ Inter := Get_Under_Interpretation (Name);
+ if Valid_Interpretation (Inter) then
+ Decl := Get_Declaration (Inter);
+ if Is_Entity_Declaration (Decl) then
+ return Decl;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- VHDL02:
+ -- c) An entity declaration denoted by "L.C", where L is the target
+ -- library and C is the simple name of the instantiated component.
+ -- The target library is the library logical name of the library
+ -- containing the design unit in which the component C is
+ -- declared.
+ if Flags.Flag_Syn_Binding
+ or Flags.Vhdl_Std >= Vhdl_02
+ or Flags.Vhdl_Std = Vhdl_93c
+ then
+ -- Find target library.
+ Target_Lib := Comp;
+ while Get_Kind (Target_Lib) /= Iir_Kind_Library_Declaration loop
+ Target_Lib := Get_Parent (Target_Lib);
+ end loop;
+
+ Decl := Libraries.Find_Primary_Unit (Target_Lib, Name);
+ if Decl /= Null_Iir and then Is_Entity_Declaration (Decl) then
+ return Decl;
+ end if;
+ end if;
+
+ -- --syn-binding
+ -- Search for any entity.
+ if Flags.Flag_Syn_Binding then
+ Decl := Libraries.Find_Entity_For_Component (Name);
+ if Decl /= Null_Iir then
+ return Decl;
+ end if;
+ end if;
+
+ return Null_Iir;
+ end Get_Visible_Entity_Declaration;
+
+ -- Explain why there is no default binding for COMP.
+ procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration)
+ is
+ Inter : Name_Interpretation_Type;
+ Name : Name_Id;
+ Decl : Iir;
+ begin
+ Name := Get_Identifier (Comp);
+ Inter := Get_Interpretation (Name);
+
+ if Valid_Interpretation (Inter) then
+ -- A visible entity declaration is either:
+ --
+ -- a) An entity declaration that has the same simple name as that of
+ -- the instantiated component and that is directly visible
+ -- (see 10.3),
+ Decl := Get_Declaration (Inter);
+ Warning_Msg_Elab ("visible declaration for " & Name_Table.Image (Name)
+ & " is " & Disp_Node (Decl), Decl);
+
+ -- b) An entity declaration that has the same simple name that of
+ -- the instantiated component and that would be directly
+ -- visible in the absence of a directly visible (see 10.3)
+ -- component declaration with the same simple name as that
+ -- of the entity declaration, or
+ if Get_Kind (Decl) = Iir_Kind_Component_Declaration then
+ Inter := Get_Under_Interpretation (Name);
+ if Valid_Interpretation (Inter) then
+ Decl := Get_Declaration (Inter);
+ Warning_Msg_Elab ("interpretation behind the component is "
+ & Disp_Node (Decl), Comp);
+ end if;
+ end if;
+ end if;
+
+ -- VHDL02:
+ -- c) An entity declaration denoted by "L.C", where L is the target
+ -- library and C is the simple name of the instantiated component.
+ -- The target library is the library logical name of the library
+ -- containing the design unit in which the component C is
+ -- declared.
+ if Flags.Vhdl_Std >= Vhdl_02
+ or else Flags.Vhdl_Std = Vhdl_93c
+ then
+ Decl := Comp;
+ while Get_Kind (Decl) /= Iir_Kind_Library_Declaration loop
+ Decl := Get_Parent (Decl);
+ end loop;
+
+ Warning_Msg_Elab ("no entity """ & Name_Table.Image (Name) & """ in "
+ & Disp_Node (Decl), Comp);
+ end if;
+ end Explain_No_Visible_Entity;
+
+ procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir)
+ is
+ Decl: Iir;
+ begin
+ Decl := Get_Declaration_Chain (Decls_Parent);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Configuration_Specification =>
+ Sem_Configuration_Specification (Parent_Stmts, Decl);
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Sem_Specification_Chain;
+end Sem_Specs;
diff --git a/src/sem_specs.ads b/src/sem_specs.ads
new file mode 100644
index 000000000..c27207b01
--- /dev/null
+++ b/src/sem_specs.ads
@@ -0,0 +1,88 @@
+-- Semantic analysis.
+-- 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 Tokens;
+
+package Sem_Specs is
+ function Get_Entity_Class_Kind (Decl : Iir) return Tokens.Token_Type;
+
+ procedure Sem_Attribute_Specification
+ (Spec : Iir_Attribute_Specification; Scope : Iir);
+
+ -- Check declarations following an ALL/OTHERS attribute specification.
+ -- ATTR_SPEC_CHAIN is the linked list of all attribute specifications whith
+ -- the entity name list ALL or OTHERS until the current declaration DECL.
+ -- So no specification in the chain must match the declaration.
+ procedure Check_Post_Attribute_Specification
+ (Attr_Spec_Chain : Iir; Decl : Iir);
+
+ procedure Sem_Disconnection_Specification
+ (Dis : Iir_Disconnection_Specification);
+
+ procedure Sem_Configuration_Specification
+ (Parent_Stmts : Iir; Conf : Iir_Configuration_Specification);
+
+ -- Analyze binding indication BIND of configuration specification or
+ -- component configuration PARENT.
+ -- PRIMARY_ENTITY_ASPECT is not Null_Iir for an incremental binding.
+ procedure Sem_Binding_Indication (Bind : Iir_Binding_Indication;
+ Comp : Iir_Component_Declaration;
+ Parent : Iir;
+ Primary_Entity_Aspect : Iir);
+
+ -- Semantize entity aspect ASPECT and return the entity declaration.
+ -- Return NULL_IIR if not found.
+ function Sem_Entity_Aspect (Aspect : Iir) return Iir;
+
+ -- Semantize component_configuration or configuration_specification SPEC.
+ -- STMTS is the concurrent statement list related to SPEC.
+ procedure Sem_Component_Specification
+ (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir);
+
+ -- Create a default binding indication for component COMP which will be
+ -- bound with entity ENTITY_UNIT.
+ -- If ENTITY_UNIT is NULL_IIR, the component is not bound.
+ -- If FORCE is True, a binding indication will be created even if the
+ -- component is not bound (this is an open binding indication).
+ -- PARENT is used to report error.
+ function Sem_Create_Default_Binding_Indication
+ (Comp : Iir_Component_Declaration;
+ Entity_Unit : Iir_Design_Unit;
+ Parent : Iir;
+ Force : Boolean)
+ return Iir_Binding_Indication;
+
+ -- Create a default generic or port map aspect that associates all elements
+ -- of ENTITY (if any) to elements of COMP with the same name or to
+ -- an open association.
+ -- If KIND is GENERIC_MAP, apply this on generics, if KIND is PORT_MAP,
+ -- apply this on ports.
+ -- PARENT is used to report errors.
+ type Map_Kind_Type is (Map_Generic, Map_Port);
+ function Create_Default_Map_Aspect
+ (Comp : Iir; Entity : Iir; Kind : Map_Kind_Type; Parent : Iir)
+ return Iir;
+
+ -- Explain why there is no default binding for COMP.
+ procedure Explain_No_Visible_Entity (Comp: Iir_Component_Declaration);
+
+ function Get_Visible_Entity_Declaration (Comp: Iir_Component_Declaration)
+ return Iir_Design_Unit;
+
+ procedure Sem_Specification_Chain (Decls_Parent : Iir; Parent_Stmts: Iir);
+end Sem_Specs;
diff --git a/src/sem_stmts.adb b/src/sem_stmts.adb
new file mode 100644
index 000000000..b5912fbc6
--- /dev/null
+++ b/src/sem_stmts.adb
@@ -0,0 +1,2007 @@
+-- Semantic analysis.
+-- 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 Errorout; use Errorout;
+with Types; use Types;
+with Flags; use Flags;
+with Sem_Specs; use Sem_Specs;
+with Std_Package; use Std_Package;
+with Sem; use Sem;
+with Sem_Decls; use Sem_Decls;
+with Sem_Expr; use Sem_Expr;
+with Sem_Names; use Sem_Names;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Types;
+with Sem_Psl;
+with Std_Names;
+with Evaluation; use Evaluation;
+with Iirs_Utils; use Iirs_Utils;
+with Xrefs; use Xrefs;
+
+package body Sem_Stmts is
+ -- Process is the scope, this is also the process for which drivers can
+ -- be created.
+ -- Note: FIRST_STMT is the first statement, which can be get by:
+ -- get_sequential_statement_chain (usual)
+ -- get_associated_chain (for case statement).
+ procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir);
+
+ -- Access to the current subprogram or process.
+ Current_Subprogram: Iir := Null_Iir;
+
+ function Get_Current_Subprogram return Iir is
+ begin
+ return Current_Subprogram;
+ end Get_Current_Subprogram;
+
+ -- Access to the current concurrent statement.
+ -- Null_iir if no one.
+ Current_Concurrent_Statement : Iir := Null_Iir;
+
+ function Get_Current_Concurrent_Statement return Iir is
+ begin
+ return Current_Concurrent_Statement;
+ end Get_Current_Concurrent_Statement;
+
+ Current_Declarative_Region_With_Signals :
+ Implicit_Signal_Declaration_Type := (Null_Iir, Null_Iir);
+
+ procedure Push_Signals_Declarative_Part
+ (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir) is
+ begin
+ Cell := Current_Declarative_Region_With_Signals;
+ Current_Declarative_Region_With_Signals := (Decls_Parent, Null_Iir);
+ end Push_Signals_Declarative_Part;
+
+ procedure Pop_Signals_Declarative_Part
+ (Cell: in Implicit_Signal_Declaration_Type) is
+ begin
+ Current_Declarative_Region_With_Signals := Cell;
+ end Pop_Signals_Declarative_Part;
+
+ procedure Add_Declaration_For_Implicit_Signal (Sig : Iir)
+ is
+ Last : Iir renames
+ Current_Declarative_Region_With_Signals.Last_Decl;
+ begin
+ if Current_Declarative_Region_With_Signals.Decls_Parent = Null_Iir then
+ raise Internal_Error;
+ end if;
+ if Last = Null_Iir then
+ Last := Get_Declaration_Chain
+ (Current_Declarative_Region_With_Signals.Decls_Parent);
+ end if;
+ if Last = Null_Iir then
+ Set_Declaration_Chain
+ (Current_Declarative_Region_With_Signals.Decls_Parent, Sig);
+ else
+ while Get_Chain (Last) /= Null_Iir loop
+ Last := Get_Chain (Last);
+ end loop;
+ Set_Chain (Last, Sig);
+ end if;
+ Last := Sig;
+ end Add_Declaration_For_Implicit_Signal;
+
+ -- LRM 8 Sequential statements.
+ -- All statements may be labeled.
+ -- Such labels are implicitly declared at the beginning of the declarative
+ -- part of the innermost enclosing process statement of subprogram body.
+ procedure Sem_Sequential_Labels (First_Stmt : Iir)
+ is
+ Stmt: Iir;
+ Label: Name_Id;
+ begin
+ Stmt := First_Stmt;
+ while Stmt /= Null_Iir loop
+ Label := Get_Label (Stmt);
+ if Label /= Null_Identifier then
+ Sem_Scopes.Add_Name (Stmt);
+ Name_Visible (Stmt);
+ Xref_Decl (Stmt);
+ end if;
+
+ -- Some statements have sub-lists of statements.
+ case Get_Kind (Stmt) is
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement =>
+ Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Stmt));
+ when Iir_Kind_If_Statement =>
+ declare
+ Clause : Iir;
+ begin
+ Clause := Stmt;
+ while Clause /= Null_Iir loop
+ Sem_Sequential_Labels
+ (Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ end loop;
+ end;
+ when Iir_Kind_Case_Statement =>
+ declare
+ El : Iir;
+ begin
+ El := Get_Case_Statement_Alternative_Chain (Stmt);
+ while El /= Null_Iir loop
+ Sem_Sequential_Labels (Get_Associated_Chain (El));
+ El := Get_Chain (El);
+ end loop;
+ end;
+ when others =>
+ null;
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Sem_Sequential_Labels;
+
+ procedure Fill_Array_From_Aggregate_Associated
+ (Chain : Iir; Nbr : in out Natural; Arr : Iir_Array_Acc)
+ is
+ El : Iir;
+ Ass : Iir;
+ begin
+ El := Chain;
+ while El /= Null_Iir loop
+ Ass := Get_Associated_Expr (El);
+ if Get_Kind (Ass) = Iir_Kind_Aggregate then
+ Fill_Array_From_Aggregate_Associated
+ (Get_Association_Choices_Chain (Ass), Nbr, Arr);
+ else
+ if Arr /= null then
+ Arr (Nbr) := Ass;
+ end if;
+ Nbr := Nbr + 1;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Fill_Array_From_Aggregate_Associated;
+
+ -- Return TRUE iff there is no common elements designed by N1 and N2.
+ -- N1 and N2 are static names.
+ -- FIXME: The current implementation is completly wrong; should check from
+ -- prefix to suffix.
+ function Is_Disjoint (N1, N2: Iir) return Boolean
+ is
+ List1, List2 : Iir_List;
+ El1, El2 : Iir;
+ begin
+ if N1 = N2 then
+ return False;
+ end if;
+ if Get_Kind (N1) = Iir_Kind_Indexed_Name
+ and then Get_Kind (N2) = Iir_Kind_Indexed_Name
+ then
+ if Is_Disjoint (Get_Prefix (N1), Get_Prefix (N2)) then
+ return True;
+ end if;
+ -- Check indexes.
+ List1 := Get_Index_List (N1);
+ List2 := Get_Index_List (N2);
+ for I in Natural loop
+ El1 := Get_Nth_Element (List1, I);
+ El2 := Get_Nth_Element (List2, I);
+ exit when El1 = Null_Iir;
+ El1 := Eval_Expr (El1);
+ Replace_Nth_Element (List1, I, El1);
+ El2 := Eval_Expr (El2);
+ Replace_Nth_Element (List2, I, El2);
+ -- EL are of discrete type.
+ if Get_Value (El1) /= Get_Value (El2) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ elsif Get_Kind (N1) in Iir_Kinds_Denoting_Name
+ and then Get_Kind (N2) in Iir_Kinds_Denoting_Name
+ then
+ return Get_Named_Entity (N1) /= Get_Named_Entity (N2);
+ else
+ return True;
+ end if;
+ end Is_Disjoint;
+
+ procedure Check_Uniq_Aggregate_Associated
+ (Aggr : Iir_Aggregate; Nbr : Natural)
+ is
+ Index : Natural;
+ Arr : Iir_Array_Acc;
+ Chain : Iir;
+ V_I, V_J : Iir;
+ begin
+ Chain := Get_Association_Choices_Chain (Aggr);
+ -- Count number of associated values, and create the array.
+ -- Already done: use nbr.
+ -- Fill_Array_From_Aggregate_Associated (List, Nbr, null);
+ Arr := new Iir_Array (0 .. Nbr - 1);
+ -- Fill the array.
+ Index := 0;
+ Fill_Array_From_Aggregate_Associated (Chain, Index, Arr);
+ if Index /= Nbr then
+ -- Should be the same.
+ raise Internal_Error;
+ end if;
+ -- Check each element is uniq.
+ for I in Arr.all'Range loop
+ V_I := Name_To_Object (Arr (I));
+ if Get_Name_Staticness (V_I) = Locally then
+ for J in 0 .. I - 1 loop
+ V_J := Name_To_Object (Arr (J));
+ if Get_Name_Staticness (V_J) = Locally
+ and then not Is_Disjoint (V_I, V_J)
+ then
+ Error_Msg_Sem ("target is assigned more than once", Arr (I));
+ Error_Msg_Sem (" (previous assignment is here)", Arr (J));
+ Free (Arr);
+ return;
+ end if;
+ end loop;
+ end if;
+ end loop;
+ Free (Arr);
+ return;
+ end Check_Uniq_Aggregate_Associated;
+
+ -- Do checks for the target of an assignment.
+ procedure Check_Simple_Signal_Target
+ (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness);
+ -- STMT is used to localize the error (if any).
+ procedure Check_Simple_Variable_Target
+ (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness);
+
+ -- Semantic associed with signal mode.
+ -- See �4.3.3
+ type Boolean_Array_Of_Iir_Mode is array (Iir_Mode) of Boolean;
+ Iir_Mode_Readable : constant Boolean_Array_Of_Iir_Mode :=
+ (Iir_Unknown_Mode => False,
+ Iir_In_Mode => True,
+ Iir_Out_Mode => False,
+ Iir_Inout_Mode => True,
+ Iir_Buffer_Mode => True,
+ Iir_Linkage_Mode => False);
+ Iir_Mode_Writable : constant Boolean_Array_Of_Iir_Mode :=
+ (Iir_Unknown_Mode => False,
+ Iir_In_Mode => False,
+ Iir_Out_Mode => True,
+ Iir_Inout_Mode => True,
+ Iir_Buffer_Mode => True,
+ Iir_Linkage_Mode => False);
+
+ procedure Check_Aggregate_Target
+ (Stmt : Iir; Target : Iir; Nbr : in out Natural)
+ is
+ Choice : Iir;
+ Ass : Iir;
+ begin
+ Choice := Get_Association_Choices_Chain (Target);
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Range =>
+ -- LRM93 8.4
+ -- It is an error if an element association in such an
+ -- aggregate contains an OTHERS choice or a choice that is
+ -- a discrete range.
+ Error_Msg_Sem ("discrete range choice not allowed for target",
+ Choice);
+ when Iir_Kind_Choice_By_Others =>
+ -- LRM93 8.4
+ -- It is an error if an element association in such an
+ -- aggregate contains an OTHERS choice or a choice that is
+ -- a discrete range.
+ Error_Msg_Sem ("others choice not allowed for target", Choice);
+ when Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Name
+ | Iir_Kind_Choice_By_None =>
+ -- LRM93 9.4
+ -- Such a target may not only contain locally static signal
+ -- names [...]
+ Ass := Get_Associated_Expr (Choice);
+ if Get_Kind (Ass) = Iir_Kind_Aggregate then
+ Check_Aggregate_Target (Stmt, Ass, Nbr);
+ else
+ if Get_Kind (Stmt) = Iir_Kind_Variable_Assignment_Statement
+ then
+ Check_Simple_Variable_Target (Stmt, Ass, Locally);
+ else
+ Check_Simple_Signal_Target (Stmt, Ass, Locally);
+ end if;
+ Nbr := Nbr + 1;
+ end if;
+ when others =>
+ Error_Kind ("check_aggregate_target", Choice);
+ end case;
+ Choice := Get_Chain (Choice);
+ end loop;
+ end Check_Aggregate_Target;
+
+ procedure Check_Simple_Signal_Target
+ (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness)
+ is
+ Target_Object : Iir;
+ Target_Prefix : Iir;
+ Guarded_Target : Tri_State_Type;
+ Targ_Obj_Kind : Iir_Kind;
+ begin
+ Target_Object := Name_To_Object (Target);
+ if Target_Object = Null_Iir then
+ Error_Msg_Sem ("target is not a signal name", Target);
+ return;
+ end if;
+
+ Target_Prefix := Get_Object_Prefix (Target_Object);
+ Targ_Obj_Kind := Get_Kind (Target_Prefix);
+ case Targ_Obj_Kind is
+ when Iir_Kind_Interface_Signal_Declaration =>
+ if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then
+ Error_Msg_Sem
+ (Disp_Node (Target_Prefix) & " can't be assigned", Target);
+ else
+ Sem_Add_Driver (Target_Object, Stmt);
+ end if;
+ when Iir_Kind_Signal_Declaration =>
+ Sem_Add_Driver (Target_Object, Stmt);
+ when Iir_Kind_Guard_Signal_Declaration =>
+ Error_Msg_Sem ("implicit GUARD signal cannot be assigned", Stmt);
+ return;
+ when others =>
+ Error_Msg_Sem ("target (" & Disp_Node (Get_Base_Name (Target))
+ & ") is not a signal", Stmt);
+ return;
+ end case;
+ if Get_Name_Staticness (Target_Object) < Staticness then
+ Error_Msg_Sem ("signal name must be static", Stmt);
+ end if;
+
+ -- LRM93 2.1.1.2
+ -- A formal signal parameter is a guarded signal if and only if
+ -- it is associated with an actual signal that is a guarded
+ -- signal.
+ -- GHDL: a formal signal interface of a subprogram has no static
+ -- kind. This is determined at run-time, according to the actual
+ -- associated with the formal.
+ -- GHDL: parent of target cannot be a function.
+ if Targ_Obj_Kind = Iir_Kind_Interface_Signal_Declaration
+ and then
+ Get_Kind (Get_Parent (Target_Prefix)) = Iir_Kind_Procedure_Declaration
+ then
+ Guarded_Target := Unknown;
+ else
+ if Get_Signal_Kind (Target_Prefix) /= Iir_No_Signal_Kind then
+ Guarded_Target := True;
+ else
+ Guarded_Target := False;
+ end if;
+ end if;
+
+ case Get_Guarded_Target_State (Stmt) is
+ when Unknown =>
+ Set_Guarded_Target_State (Stmt, Guarded_Target);
+ when True
+ | False =>
+ if Get_Guarded_Target_State (Stmt) /= Guarded_Target then
+ -- LRM93 9.5
+ -- It is an error if the target of a concurrent signal
+ -- assignment is neither a guarded target nor an
+ -- unguarded target.
+ Error_Msg_Sem ("guarded and unguarded target", Target);
+ end if;
+ end case;
+ end Check_Simple_Signal_Target;
+
+ procedure Check_Simple_Variable_Target
+ (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness)
+ is
+ Target_Object : Iir;
+ Target_Prefix : Iir;
+ begin
+ Target_Object := Name_To_Object (Target);
+ if Target_Object = Null_Iir then
+ Error_Msg_Sem ("target is not a variable name", Stmt);
+ return;
+ end if;
+ Target_Prefix := Get_Object_Prefix (Target_Object);
+ case Get_Kind (Target_Prefix) is
+ when Iir_Kind_Interface_Variable_Declaration =>
+ if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then
+ Error_Msg_Sem (Disp_Node (Target_Prefix)
+ & " cannot be written (bad mode)", Target);
+ return;
+ end if;
+ when Iir_Kind_Variable_Declaration =>
+ null;
+ when Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Dereference =>
+ -- LRM 3.3
+ -- An object designated by an access type is always an object of
+ -- class variable.
+ null;
+ when others =>
+ Error_Msg_Sem (Disp_Node (Target_Prefix)
+ & " is not a variable to be assigned", Stmt);
+ return;
+ end case;
+ if Get_Name_Staticness (Target_Object) < Staticness then
+ Error_Msg_Sem
+ ("element of aggregate of variables must be a static name", Target);
+ end if;
+ end Check_Simple_Variable_Target;
+
+ procedure Check_Target (Stmt : Iir; Target : Iir)
+ is
+ Nbr : Natural;
+ begin
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ Nbr := 0;
+ Check_Aggregate_Target (Stmt, Target, Nbr);
+ Check_Uniq_Aggregate_Associated (Target, Nbr);
+ else
+ if Get_Kind (Stmt) = Iir_Kind_Variable_Assignment_Statement then
+ Check_Simple_Variable_Target (Stmt, Target, None);
+ else
+ Check_Simple_Signal_Target (Stmt, Target, None);
+ end if;
+ end if;
+ end Check_Target;
+
+ -- Return FALSE in case of error.
+ function Sem_Signal_Assignment_Target_And_Option (Stmt: Iir; Sig_Type : Iir)
+ return Boolean
+ is
+ -- The target of the assignment.
+ Target: Iir;
+ -- The value that will be assigned.
+ Expr: Iir;
+ Ok : Boolean;
+ begin
+ Ok := True;
+ -- Find the signal.
+ Target := Get_Target (Stmt);
+
+ if Sig_Type = Null_Iir
+ and then Get_Kind (Target) = Iir_Kind_Aggregate
+ then
+ -- Do not try to analyze an aggregate if its type is unknown.
+ -- A target cannot be a qualified type and its type should be
+ -- determine by the context (LRM93 7.3.2 Aggregates).
+ Ok := False;
+ else
+ -- Analyze the target
+ Target := Sem_Expression (Target, Sig_Type);
+ if Target /= Null_Iir then
+ Set_Target (Stmt, Target);
+ Check_Target (Stmt, Target);
+ Sem_Types.Set_Type_Has_Signal (Get_Type (Target));
+ else
+ Ok := False;
+ end if;
+ end if;
+
+ Expr := Get_Reject_Time_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Expr := Sem_Expression (Expr, Time_Type_Definition);
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Set_Reject_Time_Expression (Stmt, Expr);
+ else
+ Ok := False;
+ end if;
+ end if;
+ return Ok;
+ end Sem_Signal_Assignment_Target_And_Option;
+
+ -- Semantize a waveform_list WAVEFORM_LIST that is assigned via statement
+ -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL.
+ procedure Sem_Waveform_Chain
+ (Assign_Stmt: Iir;
+ Waveform_Chain : Iir_Waveform_Element;
+ Waveform_Type : in out Iir)
+ is
+ pragma Unreferenced (Assign_Stmt);
+ Expr: Iir;
+ We: Iir_Waveform_Element;
+ Time, Last_Time : Iir_Int64;
+ begin
+ if Waveform_Chain = Null_Iir then
+ -- Unaffected.
+ return;
+ end if;
+
+ -- Start with -1 to allow after 0 ns.
+ Last_Time := -1;
+ We := Waveform_Chain;
+ while We /= Null_Iir loop
+ Expr := Get_We_Value (We);
+ if Get_Kind (Expr) = Iir_Kind_Null_Literal then
+ -- GHDL: allowed only if target is guarded; this is checked by
+ -- sem_check_waveform_list.
+ null;
+ else
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ and then Waveform_Type = Null_Iir
+ then
+ Error_Msg_Sem
+ ("type of waveform is unknown, use qualified type", Expr);
+ else
+ Expr := Sem_Expression (Expr, Waveform_Type);
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Set_We_Value (We, Eval_Expr_If_Static (Expr));
+ if Waveform_Type = Null_Iir then
+ Waveform_Type := Get_Type (Expr);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ if Get_Time (We) /= Null_Iir then
+ Expr := Sem_Expression (Get_Time (We), Time_Type_Definition);
+ if Expr /= Null_Iir then
+ Set_Time (We, Expr);
+ Check_Read (Expr);
+
+ if Get_Expr_Staticness (Expr) = Locally
+ or else (Get_Kind (Expr) = Iir_Kind_Physical_Int_Literal
+ and then Flags.Flag_Time_64)
+ then
+ -- LRM 8.4
+ -- It is an error if the time expression in a waveform
+ -- element evaluates to a negative value.
+ --
+ -- LRM 8.4.1
+ -- It is an error if the sequence of new transactions is not
+ -- in ascending order with repect to time.
+ -- GHDL: this must be checked at run-time, but this is also
+ -- checked now for static expressions.
+ if Get_Expr_Staticness (Expr) = Locally then
+ -- The expression is static, and therefore may be
+ -- evaluated.
+ Expr := Eval_Expr (Expr);
+ Set_Time (We, Expr);
+ Time := Get_Value (Expr);
+ else
+ -- The expression is a physical literal (common case).
+ -- Extract its value.
+ Time := Get_Physical_Value (Expr);
+ end if;
+ if Time < 0 then
+ Error_Msg_Sem
+ ("waveform time expression must be >= 0", Expr);
+ elsif Time <= Last_Time then
+ Error_Msg_Sem
+ ("time must be greather than previous transaction",
+ Expr);
+ else
+ Last_Time := Time;
+ end if;
+ end if;
+ end if;
+ else
+ if We /= Waveform_Chain then
+ -- Time expression must be in ascending order.
+ Error_Msg_Sem ("time expression required here", We);
+ end if;
+
+ -- LRM93 12.6.4
+ -- It is an error if the execution of any postponed process causes
+ -- a delta cycle to occur immediatly after the current simulation
+ -- cycle.
+ -- GHDL: try to warn for such an error; note the context may be
+ -- a procedure body.
+ if Current_Concurrent_Statement /= Null_Iir then
+ case Get_Kind (Current_Concurrent_Statement) is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ if Get_Postponed_Flag (Current_Concurrent_Statement) then
+ Warning_Msg_Sem
+ ("waveform may cause a delta cycle in a " &
+ "postponed process", We);
+ end if;
+ when others =>
+ -- Context is a subprogram.
+ null;
+ end case;
+ end if;
+
+ Last_Time := 0;
+ end if;
+ We := Get_Chain (We);
+ end loop;
+ return;
+ end Sem_Waveform_Chain;
+
+ -- Semantize a waveform chain WAVEFORM_CHAIN that is assigned via statement
+ -- ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL.
+ procedure Sem_Check_Waveform_Chain
+ (Assign_Stmt: Iir; Waveform_Chain: Iir_Waveform_Element)
+ is
+ We: Iir_Waveform_Element;
+ Expr : Iir;
+ Targ_Type : Iir;
+ begin
+ if Waveform_Chain = Null_Iir then
+ return;
+ end if;
+
+ Targ_Type := Get_Type (Get_Target (Assign_Stmt));
+
+ We := Waveform_Chain;
+ while We /= Null_Iir loop
+ Expr := Get_We_Value (We);
+ if Get_Kind (Expr) = Iir_Kind_Null_Literal then
+ -- This is a null waveform element.
+ -- LRM93 8.4.1
+ -- It is an error if the target of a signal assignment statement
+ -- containing a null waveform is not a guarded signal or an
+ -- aggregate of guarded signals.
+ if Get_Guarded_Target_State (Assign_Stmt) = False then
+ Error_Msg_Sem
+ ("null transactions can be assigned only to guarded signals",
+ Assign_Stmt);
+ end if;
+ else
+ if not Check_Implicit_Conversion (Targ_Type, Expr) then
+ Error_Msg_Sem
+ ("length of value does not match length of target", We);
+ end if;
+ end if;
+ We := Get_Chain (We);
+ end loop;
+ end Sem_Check_Waveform_Chain;
+
+ procedure Sem_Signal_Assignment (Stmt: Iir)
+ is
+ Target : Iir;
+ Waveform_Type : Iir;
+ begin
+ Target := Get_Target (Stmt);
+ if Get_Kind (Target) /= Iir_Kind_Aggregate then
+ if not Sem_Signal_Assignment_Target_And_Option (Stmt, Null_Iir) then
+ return;
+ end if;
+
+ -- check the expression.
+ Waveform_Type := Get_Type (Get_Target (Stmt));
+ if Waveform_Type /= Null_Iir then
+ Sem_Waveform_Chain
+ (Stmt, Get_Waveform_Chain (Stmt), Waveform_Type);
+ Sem_Check_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt));
+ end if;
+ else
+ Waveform_Type := Null_Iir;
+ Sem_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt), Waveform_Type);
+ if Waveform_Type = Null_Iir
+ or else
+ not Sem_Signal_Assignment_Target_And_Option (Stmt, Waveform_Type)
+ then
+ return;
+ end if;
+ Sem_Check_Waveform_Chain (Stmt, Get_Waveform_Chain (Stmt));
+ end if;
+ end Sem_Signal_Assignment;
+
+ procedure Sem_Variable_Assignment (Stmt: Iir) is
+ Target: Iir;
+ Expr: Iir;
+ Target_Type : Iir;
+ begin
+ -- Find the variable.
+ Target := Get_Target (Stmt);
+ Expr := Get_Expression (Stmt);
+
+ -- LRM93 8.5 Variable assignment statement
+ -- If the target of the variable assignment statement is in the form of
+ -- an aggregate, then the type of the aggregate must be determinable
+ -- from the context, excluding the aggregate itself but including the
+ -- fact that the type of the aggregate must be a composite type. The
+ -- base type of the expression on the right-hand side must be the
+ -- same as the base type of the aggregate.
+ --
+ -- GHDL: this means that the type can only be deduced from the
+ -- expression (and not from the target).
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ if Get_Kind (Expr) = Iir_Kind_Aggregate then
+ Error_Msg_Sem ("can't determine type, use type qualifier", Expr);
+ return;
+ end if;
+ Expr := Sem_Composite_Expression (Get_Expression (Stmt));
+ if Expr = Null_Iir then
+ return;
+ end if;
+ Check_Read (Expr);
+ Set_Expression (Stmt, Expr);
+ Target_Type := Get_Type (Expr);
+
+ -- An aggregate cannot be analyzed without a type.
+ -- FIXME: partially analyze the aggregate ?
+ if Target_Type = Null_Iir then
+ return;
+ end if;
+
+ -- FIXME: check elements are identified at most once.
+ else
+ Target_Type := Null_Iir;
+ end if;
+
+ Target := Sem_Expression (Target, Target_Type);
+ if Target = Null_Iir then
+ return;
+ end if;
+ Set_Target (Stmt, Target);
+
+ Check_Target (Stmt, Target);
+
+ if Get_Kind (Target) /= Iir_Kind_Aggregate then
+ Expr := Sem_Expression (Expr, Get_Type (Target));
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Expr := Eval_Expr_If_Static (Expr);
+ Set_Expression (Stmt, Expr);
+ end if;
+ end if;
+ if not Check_Implicit_Conversion (Get_Type (Target), Expr) then
+ Warning_Msg_Sem
+ ("expression length does not match target length", Stmt);
+ end if;
+ end Sem_Variable_Assignment;
+
+ procedure Sem_Return_Statement (Stmt: Iir_Return_Statement) is
+ Expr: Iir;
+ begin
+ if Current_Subprogram = Null_Iir then
+ Error_Msg_Sem ("return statement not in a subprogram body", Stmt);
+ return;
+ end if;
+ Expr := Get_Expression (Stmt);
+ case Get_Kind (Current_Subprogram) is
+ when Iir_Kind_Procedure_Declaration =>
+ if Expr /= Null_Iir then
+ Error_Msg_Sem
+ ("return in a procedure can't have an expression", Stmt);
+ end if;
+ return;
+ when Iir_Kind_Function_Declaration =>
+ if Expr = Null_Iir then
+ Error_Msg_Sem
+ ("return in a function must have an expression", Stmt);
+ return;
+ end if;
+ when Iir_Kinds_Process_Statement =>
+ Error_Msg_Sem ("return statement not allowed in a process", Stmt);
+ return;
+ when others =>
+ Error_Kind ("sem_return_statement", Stmt);
+ end case;
+ Set_Type (Stmt, Get_Return_Type (Current_Subprogram));
+ Expr := Sem_Expression (Expr, Get_Return_Type (Current_Subprogram));
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Set_Expression (Stmt, Eval_Expr_If_Static (Expr));
+ end if;
+ end Sem_Return_Statement;
+
+ -- Sem for concurrent and sequential assertion statements.
+ procedure Sem_Report_Statement (Stmt : Iir)
+ is
+ Expr : Iir;
+ begin
+ Expr := Get_Report_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Expr := Sem_Expression (Expr, String_Type_Definition);
+ Check_Read (Expr);
+ Expr := Eval_Expr_If_Static (Expr);
+ Set_Report_Expression (Stmt, Expr);
+ end if;
+
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Expr := Sem_Expression (Expr, Severity_Level_Type_Definition);
+ Check_Read (Expr);
+ Set_Severity_Expression (Stmt, Expr);
+ end if;
+ end Sem_Report_Statement;
+
+ procedure Sem_Assertion_Statement (Stmt: Iir)
+ is
+ Expr : Iir;
+ begin
+ Expr := Get_Assertion_Condition (Stmt);
+ Expr := Sem_Condition (Expr);
+ Expr := Eval_Expr_If_Static (Expr);
+ Set_Assertion_Condition (Stmt, Expr);
+
+ Sem_Report_Statement (Stmt);
+ end Sem_Assertion_Statement;
+
+ -- Semantize a list of case choice LIST, and check for correct CHOICE type.
+ procedure Sem_Case_Choices
+ (Choice : Iir; Chain : in out Iir; Loc : Location_Type)
+ is
+ -- Check restrictions on the expression of a One-Dimensional Character
+ -- Array Type (ODCAT) given by LRM 8.8
+ -- Return FALSE in case of violation.
+ function Check_Odcat_Expression (Expr : Iir) return Boolean
+ is
+ Expr_Type : constant Iir := Get_Type (Expr);
+ begin
+ -- LRM 8.8 Case Statement
+ -- If the expression is of a one-dimensional character array type,
+ -- then the expression must be one of the following:
+ case Get_Kind (Expr) is
+ when Iir_Kinds_Object_Declaration
+ | Iir_Kind_Selected_Element =>
+ -- FIXME: complete the list.
+ -- * the name of an object whose subtype is locally static.
+ if Get_Type_Staticness (Expr_Type) /= Locally then
+ Error_Msg_Sem ("object subtype is not locally static",
+ Choice);
+ return False;
+ end if;
+ when Iir_Kind_Indexed_Name =>
+ -- LRM93
+ -- * an indexed name whose prefix is one of the members of
+ -- this list and whose indexing expressions are locally
+ -- static expression.
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Sem ("indexed name not allowed here in vhdl87",
+ Expr);
+ return False;
+ end if;
+ if not Check_Odcat_Expression (Get_Prefix (Expr)) then
+ return False;
+ end if;
+ -- GHDL: I don't understand why the indexing expressions
+ -- must be locally static. So I don't check this in 93c.
+ if Flags.Vhdl_Std /= Vhdl_93c
+ and then
+ Get_Expr_Staticness (Get_First_Element
+ (Get_Index_List (Expr))) /= Locally
+ then
+ Error_Msg_Sem ("indexing expression must be locally static",
+ Expr);
+ return False;
+ end if;
+ when Iir_Kind_Slice_Name =>
+ -- LRM93
+ -- * a slice name whose prefix is one of the members of this
+ -- list and whose discrete range is a locally static
+ -- discrete range.
+
+ -- LRM87/INT1991 IR96
+ -- then the expression must be either a slice name whose
+ -- discrete range is locally static, or ..
+ if False and Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Sem
+ ("slice not allowed as case expression in vhdl87", Expr);
+ return False;
+ end if;
+ if not Check_Odcat_Expression (Get_Prefix (Expr)) then
+ return False;
+ end if;
+ if Get_Type_Staticness (Expr_Type) /= Locally then
+ Error_Msg_Sem ("slice discrete range must be locally static",
+ Expr);
+ return False;
+ end if;
+ when Iir_Kind_Function_Call =>
+ -- LRM93
+ -- * a function call whose return type mark denotes a
+ -- locally static subtype.
+ if Flags.Vhdl_Std = Vhdl_87 then
+ Error_Msg_Sem ("function call not allowed here in vhdl87",
+ Expr);
+ return False;
+ end if;
+ if Get_Type_Staticness (Expr_Type) /= Locally then
+ Error_Msg_Sem ("function call type is not locally static",
+ Expr);
+ end if;
+ when Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion =>
+ -- * a qualified expression or type conversion whose type mark
+ -- denotes a locally static subtype.
+ if Get_Type_Staticness (Expr_Type) /= Locally then
+ Error_Msg_Sem ("type mark is not a locally static subtype",
+ Expr);
+ return False;
+ end if;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Check_Odcat_Expression (Get_Named_Entity (Expr));
+ when others =>
+ Error_Msg_Sem ("bad form of case expression (refer to LRM 8.8)",
+ Choice);
+ return False;
+ end case;
+ return True;
+ end Check_Odcat_Expression;
+
+ Choice_Type : Iir;
+ Low, High : Iir;
+ El_Type : Iir;
+ begin
+ -- LRM 8.8 Case Statement
+ -- The expression must be of a discrete type, or of a one-dimensional
+ -- array type whose element base type is a character type.
+ Choice_Type := Get_Type (Choice);
+ case Get_Kind (Choice_Type) is
+ when Iir_Kinds_Discrete_Type_Definition =>
+ Sem_Choices_Range
+ (Chain, Choice_Type, False, True, Loc, Low, High);
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ if not Is_One_Dimensional_Array_Type (Choice_Type) then
+ Error_Msg_Sem
+ ("expression must be of a one-dimensional array type",
+ Choice);
+ return;
+ end if;
+ El_Type := Get_Base_Type (Get_Element_Subtype (Choice_Type));
+ if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition then
+ -- FIXME: check character.
+ Error_Msg_Sem
+ ("element type of the expression must be a character type",
+ Choice);
+ return;
+ end if;
+ if not Check_Odcat_Expression (Choice) then
+ return;
+ end if;
+ Sem_String_Choices_Range (Chain, Choice);
+ when others =>
+ Error_Msg_Sem ("type of expression must be discrete", Choice);
+ end case;
+ end Sem_Case_Choices;
+
+ procedure Sem_Case_Statement (Stmt: Iir_Case_Statement)
+ is
+ Expr: Iir;
+ Chain : Iir;
+ El: Iir;
+ begin
+ Expr := Get_Expression (Stmt);
+ -- FIXME: overload.
+ Expr := Sem_Case_Expression (Expr);
+ if Expr = Null_Iir then
+ return;
+ end if;
+ Check_Read (Expr);
+ Set_Expression (Stmt, Expr);
+ Chain := Get_Case_Statement_Alternative_Chain (Stmt);
+ Sem_Case_Choices (Expr, Chain, Get_Location (Stmt));
+ Set_Case_Statement_Alternative_Chain (Stmt, Chain);
+ -- Sem on associated.
+ El := Chain;
+ while El /= Null_Iir loop
+ Sem_Sequential_Statements_Internal (Get_Associated_Chain (El));
+ El := Get_Chain (El);
+ end loop;
+ end Sem_Case_Statement;
+
+ -- Sem the sensitivity list LIST.
+ procedure Sem_Sensitivity_List (List: Iir_Designator_List)
+ is
+ El: Iir;
+ Res: Iir;
+ Prefix : Iir;
+ begin
+ if List = Iir_List_All then
+ return;
+ end if;
+
+ for I in Natural loop
+ -- El is an iir_identifier.
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+
+ Sem_Name (El);
+
+ Res := Get_Named_Entity (El);
+ if Res = Error_Mark then
+ null;
+ elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then
+ Error_Msg_Sem ("a sensitivity element must be a signal name", El);
+ else
+ Res := Finish_Sem_Name (El);
+ Prefix := Get_Object_Prefix (Res);
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kinds_Signal_Attribute =>
+ null;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ if not Iir_Mode_Readable (Get_Mode (Prefix)) then
+ Error_Msg_Sem
+ (Disp_Node (Res) & " of mode out"
+ & " can't be in a sensivity list", El);
+ end if;
+ when others =>
+ Error_Msg_Sem (Disp_Node (Res)
+ & " is neither a signal nor a port", El);
+ end case;
+ -- LRM 9.2
+ -- Only static signal names (see section 6.1) for which reading
+ -- is permitted may appear in the sensitivity list of a process
+ -- statement.
+
+ -- LRM 8.1 Wait statement
+ -- Each signal name in the sensitivity list must be a static
+ -- signal name, and each name must denote a signal for which
+ -- reading is permitted.
+ if Get_Name_Staticness (Res) < Globally then
+ Error_Msg_Sem ("sensitivity element " & Disp_Node (Res)
+ & " must be a static name", El);
+ end if;
+
+ Replace_Nth_Element (List, I, Res);
+ end if;
+ end loop;
+ end Sem_Sensitivity_List;
+
+ procedure Sem_Wait_Statement (Stmt: Iir_Wait_Statement)
+ is
+ Expr: Iir;
+ Sensitivity_List : Iir_List;
+ begin
+ -- Check validity.
+ case Get_Kind (Current_Subprogram) is
+ when Iir_Kind_Process_Statement =>
+ null;
+ when Iir_Kinds_Function_Declaration =>
+ -- LRM93 �8.2
+ -- It is an error if a wait statement appears in a function
+ -- subprogram [...]
+ Error_Msg_Sem
+ ("wait statement not allowed in a function subprogram", Stmt);
+ return;
+ when Iir_Kinds_Procedure_Declaration =>
+ -- LRM93 �8.2
+ -- [It is an error ...] or in a procedure that has a parent that
+ -- is a function subprogram.
+ -- LRM93 �8.2
+ -- [...] or in a procedure that has a parent that is such a
+ -- process statement.
+ -- GHDL: this is checked at the end of analysis or during
+ -- elaboration.
+ Set_Wait_State (Current_Subprogram, True);
+ when Iir_Kind_Sensitized_Process_Statement =>
+ -- LRM93 �8.2
+ -- Furthermore, it is an error if a wait statement appears in an
+ -- explicit process statement that includes a sensitivity list,
+ -- [...]
+ Error_Msg_Sem
+ ("wait statement not allowed in a sensitized process", Stmt);
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Sensitivity_List := Get_Sensitivity_List (Stmt);
+ if Sensitivity_List /= Null_Iir_List then
+ Sem_Sensitivity_List (Sensitivity_List);
+ end if;
+ Expr := Get_Condition_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Expr := Sem_Condition (Expr);
+ Set_Condition_Clause (Stmt, Expr);
+ end if;
+ Expr := Get_Timeout_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Expr := Sem_Expression (Expr, Time_Type_Definition);
+ if Expr /= Null_Iir then
+ Check_Read (Expr);
+ Expr := Eval_Expr_If_Static (Expr);
+ Set_Timeout_Clause (Stmt, Expr);
+ if Get_Expr_Staticness (Expr) = Locally
+ and then Get_Value (Expr) < 0
+ then
+ Error_Msg_Sem ("timeout value must be positive", Stmt);
+ end if;
+ end if;
+ end if;
+ end Sem_Wait_Statement;
+
+ procedure Sem_Exit_Next_Statement (Stmt : Iir)
+ is
+ Cond: Iir;
+ Loop_Label : Iir;
+ Loop_Stmt: Iir;
+ P : Iir;
+ begin
+ Cond := Get_Condition (Stmt);
+ if Cond /= Null_Iir then
+ Cond := Sem_Condition (Cond);
+ Set_Condition (Stmt, Cond);
+ end if;
+
+ Loop_Label := Get_Loop_Label (Stmt);
+ if Loop_Label /= Null_Iir then
+ Loop_Label := Sem_Denoting_Name (Loop_Label);
+ Set_Loop_Label (Stmt, Loop_Label);
+ Loop_Stmt := Get_Named_Entity (Loop_Label);
+ case Get_Kind (Loop_Stmt) is
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement =>
+ null;
+ when others =>
+ Error_Class_Match (Loop_Label, "loop statement");
+ Loop_Stmt := Null_Iir;
+ end case;
+ else
+ Loop_Stmt := Null_Iir;
+ end if;
+
+ -- Check the current statement is inside the labeled loop.
+ P := Stmt;
+ loop
+ P := Get_Parent (P);
+ case Get_Kind (P) is
+ when Iir_Kind_While_Loop_Statement
+ | Iir_Kind_For_Loop_Statement =>
+ if Loop_Stmt = Null_Iir or else P = Loop_Stmt then
+ exit;
+ end if;
+ when Iir_Kind_If_Statement
+ | Iir_Kind_Elsif
+ | Iir_Kind_Case_Statement =>
+ null;
+ when others =>
+ -- FIXME: should emit a message for label mismatch.
+ Error_Msg_Sem ("exit/next must be inside a loop", Stmt);
+ exit;
+ end case;
+ end loop;
+ end Sem_Exit_Next_Statement;
+
+ -- Process is the scope, this is also the process for which drivers can
+ -- be created.
+ procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir)
+ is
+ Stmt: Iir;
+ begin
+ Stmt := First_Stmt;
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Null_Statement =>
+ null;
+ when Iir_Kind_If_Statement =>
+ declare
+ Clause: Iir := Stmt;
+ Cond: Iir;
+ begin
+ while Clause /= Null_Iir loop
+ Cond := Get_Condition (Clause);
+ if Cond /= Null_Iir then
+ Cond := Sem_Condition (Cond);
+ Set_Condition (Clause, Cond);
+ end if;
+ Sem_Sequential_Statements_Internal
+ (Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ end loop;
+ end;
+ when Iir_Kind_For_Loop_Statement =>
+ declare
+ Iterator: Iir;
+ begin
+ -- LRM 10.1 Declarative region
+ -- 9. A loop statement.
+ Open_Declarative_Region;
+
+ Set_Is_Within_Flag (Stmt, True);
+ Iterator := Get_Parameter_Specification (Stmt);
+ Sem_Scopes.Add_Name (Iterator);
+ Sem_Iterator (Iterator, None);
+ Set_Visible_Flag (Iterator, True);
+ Sem_Sequential_Statements_Internal
+ (Get_Sequential_Statement_Chain (Stmt));
+ Set_Is_Within_Flag (Stmt, False);
+
+ Close_Declarative_Region;
+ end;
+ when Iir_Kind_While_Loop_Statement =>
+ declare
+ Cond: Iir;
+ begin
+ Cond := Get_Condition (Stmt);
+ if Cond /= Null_Iir then
+ Cond := Sem_Condition (Cond);
+ Set_Condition (Stmt, Cond);
+ end if;
+ Sem_Sequential_Statements_Internal
+ (Get_Sequential_Statement_Chain (Stmt));
+ end;
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Sem_Signal_Assignment (Stmt);
+ if Current_Concurrent_Statement /= Null_Iir and then
+ Get_Kind (Current_Concurrent_Statement)
+ in Iir_Kinds_Process_Statement
+ and then Get_Passive_Flag (Current_Concurrent_Statement)
+ then
+ Error_Msg_Sem
+ ("signal statement forbidden in passive process", Stmt);
+ end if;
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Sem_Variable_Assignment (Stmt);
+ when Iir_Kind_Return_Statement =>
+ Sem_Return_Statement (Stmt);
+ when Iir_Kind_Assertion_Statement =>
+ Sem_Assertion_Statement (Stmt);
+ when Iir_Kind_Report_Statement =>
+ Sem_Report_Statement (Stmt);
+ when Iir_Kind_Case_Statement =>
+ Sem_Case_Statement (Stmt);
+ when Iir_Kind_Wait_Statement =>
+ Sem_Wait_Statement (Stmt);
+ when Iir_Kind_Procedure_Call_Statement =>
+ Sem_Procedure_Call (Get_Procedure_Call (Stmt), Stmt);
+ when Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement =>
+ Sem_Exit_Next_Statement (Stmt);
+ when others =>
+ Error_Kind ("sem_sequential_statements_Internal", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Sem_Sequential_Statements_Internal;
+
+ procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir)
+ is
+ Outer_Subprogram: Iir;
+ begin
+ Outer_Subprogram := Current_Subprogram;
+ Current_Subprogram := Decl;
+
+ -- Sem declarations
+ Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent));
+ Sem_Declaration_Chain (Body_Parent);
+ Sem_Specification_Chain (Body_Parent, Null_Iir);
+
+ -- Sem statements.
+ Sem_Sequential_Statements_Internal
+ (Get_Sequential_Statement_Chain (Body_Parent));
+
+ Check_Full_Declaration (Body_Parent, Body_Parent);
+
+ Current_Subprogram := Outer_Subprogram;
+ end Sem_Sequential_Statements;
+
+ -- Sem the instantiated unit of STMT and return the node constaining
+ -- ports and generics (either a entity_declaration or a component
+ -- declaration).
+ function Sem_Instantiated_Unit
+ (Stmt : Iir_Component_Instantiation_Statement)
+ return Iir
+ is
+ Inst : Iir;
+ Comp_Name : Iir;
+ Comp : Iir;
+ begin
+ Inst := Get_Instantiated_Unit (Stmt);
+
+ if Get_Kind (Inst) in Iir_Kinds_Denoting_Name then
+ Comp := Get_Named_Entity (Inst);
+ if Comp /= Null_Iir then
+ -- Already semantized before, while trying to separate
+ -- concurrent procedure calls from instantiation stmts.
+ pragma Assert (Get_Kind (Comp) = Iir_Kind_Component_Declaration);
+ return Comp;
+ end if;
+ -- The component may be an entity or a configuration.
+ Comp_Name := Sem_Denoting_Name (Inst);
+ Set_Instantiated_Unit (Stmt, Comp_Name);
+ Comp := Get_Named_Entity (Comp_Name);
+ if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
+ Error_Class_Match (Comp_Name, "component");
+ return Null_Iir;
+ end if;
+ return Comp;
+ else
+ return Sem_Entity_Aspect (Inst);
+ end if;
+ end Sem_Instantiated_Unit;
+
+ procedure Sem_Component_Instantiation_Statement
+ (Stmt: Iir_Component_Instantiation_Statement; Is_Passive : Boolean)
+ is
+ Decl : Iir;
+ Entity_Unit : Iir_Design_Unit;
+ Bind : Iir_Binding_Indication;
+ begin
+ -- FIXME: move this check in parse ?
+ if Is_Passive then
+ Error_Msg_Sem ("component instantiation forbidden in entity", Stmt);
+ end if;
+
+ -- Check for label.
+ -- This cannot be moved in parse since a procedure_call may be revert
+ -- into a component instantiation.
+ if Get_Label (Stmt) = Null_Identifier then
+ Error_Msg_Sem ("component instantiation requires a label", Stmt);
+ end if;
+
+ -- Look for the component.
+ Decl := Sem_Instantiated_Unit (Stmt);
+ if Decl = Null_Iir then
+ return;
+ end if;
+
+ -- The association
+ Sem_Generic_Port_Association_Chain (Decl, Stmt);
+
+ -- FIXME: add sources for signals, in order to detect multiple sources
+ -- to unresolved signals.
+ -- What happen if the component is not bound ?
+
+ -- Create a default binding indication if necessary.
+ if Get_Component_Configuration (Stmt) = Null_Iir
+ and then Get_Kind (Decl) = Iir_Kind_Component_Declaration
+ then
+ Entity_Unit := Get_Visible_Entity_Declaration (Decl);
+ if Entity_Unit = Null_Iir then
+ if Flags.Warn_Default_Binding
+ and then not Flags.Flag_Elaborate
+ then
+ Warning_Msg_Sem ("no default binding for instantiation of "
+ & Disp_Node (Decl), Stmt);
+ Explain_No_Visible_Entity (Decl);
+ end if;
+ elsif Flags.Flag_Elaborate
+ and then (Flags.Flag_Elaborate_With_Outdated
+ or else Get_Date (Entity_Unit) in Date_Valid)
+ then
+ Bind := Sem_Create_Default_Binding_Indication
+ (Decl, Entity_Unit, Stmt, False);
+ Set_Default_Binding_Indication (Stmt, Bind);
+ end if;
+ end if;
+ end Sem_Component_Instantiation_Statement;
+
+ -- Note: a statement such as
+ -- label1: name;
+ -- can be parsed as a procedure call statement or as a
+ -- component instantiation statement.
+ -- Check now and revert in case of error.
+ function Sem_Concurrent_Procedure_Call_Statement
+ (Stmt : Iir; Is_Passive : Boolean) return Iir
+ is
+ Call : Iir_Procedure_Call;
+ Decl : Iir;
+ Label : Name_Id;
+ N_Stmt : Iir_Component_Instantiation_Statement;
+ Imp : Iir;
+ begin
+ Call := Get_Procedure_Call (Stmt);
+ if Get_Parameter_Association_Chain (Call) = Null_Iir then
+ Imp := Get_Prefix (Call);
+ Sem_Name (Imp);
+ Set_Prefix (Call, Imp);
+
+ Decl := Get_Named_Entity (Imp);
+ if Get_Kind (Decl) = Iir_Kind_Component_Declaration then
+ N_Stmt := Create_Iir (Iir_Kind_Component_Instantiation_Statement);
+ Label := Get_Label (Stmt);
+ Set_Label (N_Stmt, Label);
+ Set_Parent (N_Stmt, Get_Parent (Stmt));
+ Set_Instantiated_Unit (N_Stmt, Finish_Sem_Name (Imp));
+ Location_Copy (N_Stmt, Stmt);
+
+ if Label /= Null_Identifier then
+ -- A component instantiation statement must have
+ -- a label, this condition is checked during the
+ -- sem of the statement.
+ Sem_Scopes.Replace_Name (Label, Stmt, N_Stmt);
+ end if;
+
+ Free_Iir (Stmt);
+ Free_Iir (Call);
+
+ Sem_Component_Instantiation_Statement (N_Stmt, Is_Passive);
+ return N_Stmt;
+ end if;
+ end if;
+ Sem_Procedure_Call (Call, Stmt);
+
+ if Is_Passive then
+ Imp := Get_Implementation (Call);
+ if Get_Kind (Imp) = Iir_Kind_Procedure_Declaration then
+ Decl := Get_Interface_Declaration_Chain (Imp);
+ while Decl /= Null_Iir loop
+ if Get_Mode (Decl) in Iir_Out_Modes then
+ Error_Msg_Sem (Disp_Node (Imp) & " is not passive", Stmt);
+ exit;
+ end if;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end if;
+ end if;
+
+ return Stmt;
+ end Sem_Concurrent_Procedure_Call_Statement;
+
+ procedure Sem_Block_Statement (Stmt: Iir_Block_Statement)
+ is
+ Expr: Iir;
+ Guard : Iir_Guard_Signal_Declaration;
+ Header : Iir_Block_Header;
+ Generic_Chain : Iir;
+ Port_Chain : Iir;
+ begin
+ -- LRM 10.1 Declarative region.
+ -- 7. A block statement.
+ Open_Declarative_Region;
+
+ Set_Is_Within_Flag (Stmt, True);
+
+ Header := Get_Block_Header (Stmt);
+ if Header /= Null_Iir then
+ Generic_Chain := Get_Generic_Chain (Header);
+ Sem_Interface_Chain (Generic_Chain, Generic_Interface_List);
+ Port_Chain := Get_Port_Chain (Header);
+ Sem_Interface_Chain (Port_Chain, Port_Interface_List);
+
+ -- LRM 9.1
+ -- Such actuals are evaluated in the context of the enclosing
+ -- declarative region.
+ -- GHDL: close the declarative region...
+ Set_Is_Within_Flag (Stmt, False);
+ Close_Declarative_Region;
+
+ Sem_Generic_Port_Association_Chain (Header, Header);
+
+ -- ... and reopen-it.
+ Open_Declarative_Region;
+ Set_Is_Within_Flag (Stmt, True);
+ Add_Declarations_From_Interface_Chain (Generic_Chain);
+ Add_Declarations_From_Interface_Chain (Port_Chain);
+ end if;
+
+ -- LRM93 9.1
+ -- If a guard expression appears after the reserved word BLOCK, then a
+ -- signal with the simple name GUARD of predefined type BOOLEAN is
+ -- implicitly declared at the beginning of the declarative part of the
+ -- block, and the guard expression defined the value of that signal at
+ -- any given time.
+ Guard := Get_Guard_Decl (Stmt);
+ if Guard /= Null_Iir then
+ -- LRM93 9.1
+ -- The type of the guard expression must be type BOOLEAN.
+ -- GHDL: guard expression must be semantized before creating the
+ -- implicit GUARD signal, since the expression may reference GUARD.
+ Set_Expr_Staticness (Guard, None);
+ Set_Name_Staticness (Guard, Locally);
+ Expr := Get_Guard_Expression (Guard);
+ Expr := Sem_Condition (Expr);
+ if Expr /= Null_Iir then
+ Set_Guard_Expression (Guard, Expr);
+ end if;
+
+ -- FIXME: should extract sensivity now and set the has_active flag
+ -- on signals, since the guard expression is evaluated when one of
+ -- its signal is active. However, how can a bug be introduced by
+ -- evaluating only when signals have events ?
+
+ -- the guard expression is an implicit definition of a signal named
+ -- GUARD. Create this definition. This is necessary for the type.
+ Set_Identifier (Guard, Std_Names.Name_Guard);
+ Set_Type (Guard, Boolean_Type_Definition);
+ Set_Block_Statement (Guard, Stmt);
+ Sem_Scopes.Add_Name (Guard);
+ Set_Visible_Flag (Guard, True);
+ end if;
+
+ Sem_Block (Stmt, True);
+ Set_Is_Within_Flag (Stmt, False);
+ Close_Declarative_Region;
+ end Sem_Block_Statement;
+
+ procedure Sem_Generate_Statement (Stmt : Iir_Generate_Statement)
+ is
+ Scheme : Iir;
+ begin
+ -- LRM93 10.1 Declarative region.
+ -- 12. A generate statement.
+ Open_Declarative_Region;
+
+ Scheme := Get_Generation_Scheme (Stmt);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Sem_Scopes.Add_Name (Scheme);
+ -- LRM93 �7.4.2 (Globally Static Primaries)
+ -- 4. a generate parameter;
+ Sem_Iterator (Scheme, Globally);
+ Set_Visible_Flag (Scheme, True);
+ -- LRM93 �9.7
+ -- The discrete range in a generation scheme of the first form must
+ -- be a static discrete range;
+ if Get_Type (Scheme) /= Null_Iir
+ and then Get_Type_Staticness (Get_Type (Scheme)) < Globally
+ then
+ Error_Msg_Sem ("range must be a static discrete range", Stmt);
+ end if;
+ else
+ Scheme := Sem_Condition (Scheme);
+ -- LRM93 �9.7
+ -- the condition in a generation scheme of the second form must be
+ -- a static expression.
+ if Scheme /= Null_Iir
+ and then Get_Expr_Staticness (Scheme) < Globally
+ then
+ Error_Msg_Sem ("condition must be a static expression", Stmt);
+ else
+ Set_Generation_Scheme (Stmt, Scheme);
+ end if;
+ end if;
+
+ Sem_Block (Stmt, True); -- Flags.Vhdl_Std /= Vhdl_87);
+ Close_Declarative_Region;
+ end Sem_Generate_Statement;
+
+ procedure Sem_Process_Statement (Proc: Iir) is
+ begin
+ Set_Is_Within_Flag (Proc, True);
+
+ -- LRM 10.1
+ -- 8. A process statement
+ Open_Declarative_Region;
+
+ -- Sem declarations
+ Sem_Sequential_Statements (Proc, Proc);
+
+ Close_Declarative_Region;
+
+ Set_Is_Within_Flag (Proc, False);
+
+ if Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement
+ and then Get_Callees_List (Proc) /= Null_Iir_List
+ then
+ -- Check there is no wait statement in subprograms called.
+ -- Also in the case of all-sensitized process, check that package
+ -- subprograms don't read signals.
+ Sem.Add_Analysis_Checks_List (Proc);
+ end if;
+ end Sem_Process_Statement;
+
+ procedure Sem_Sensitized_Process_Statement
+ (Proc: Iir_Sensitized_Process_Statement) is
+ begin
+ Sem_Sensitivity_List (Get_Sensitivity_List (Proc));
+ Sem_Process_Statement (Proc);
+ end Sem_Sensitized_Process_Statement;
+
+ procedure Sem_Guard (Stmt: Iir)
+ is
+ Guard: Iir;
+ Guard_Interpretation : Name_Interpretation_Type;
+ begin
+ Guard := Get_Guard (Stmt);
+ if Guard = Null_Iir then
+ -- This assignment is not guarded.
+
+ -- LRM93 9.5
+ -- It is an error if a concurrent signal assignment is not a guarded
+ -- assignment, and the target of the concurrent signal assignment
+ -- is a guarded target.
+ if Get_Guarded_Target_State (Stmt) = True then
+ Error_Msg_Sem
+ ("not a guarded assignment for a guarded target", Stmt);
+ end if;
+ return;
+ end if;
+ if Guard /= Stmt then
+ -- if set, guard must be equal to stmt here.
+ raise Internal_Error;
+ end if;
+ Guard_Interpretation := Get_Interpretation (Std_Names.Name_Guard);
+ if not Valid_Interpretation (Guard_Interpretation) then
+ Error_Msg_Sem ("no guard signals for this guarded assignment", Stmt);
+ return;
+ end if;
+
+ Guard := Get_Declaration (Guard_Interpretation);
+ -- LRM93 9.5:
+ -- The signal GUARD [...] an explicitly declared signal of type
+ -- BOOLEAN that is visible at the point of the concurrent signal
+ -- assignment statement
+ -- FIXME.
+ case Get_Kind (Guard) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ null;
+ when others =>
+ Error_Msg_Sem ("visible GUARD object is not a signal", Stmt);
+ Error_Msg_Sem ("GUARD object is " & Disp_Node (Guard), Stmt);
+ return;
+ end case;
+
+ if Get_Type (Guard) /= Boolean_Type_Definition then
+ Error_Msg_Sem ("GUARD is not of boolean type", Guard);
+ end if;
+ Set_Guard (Stmt, Guard);
+ end Sem_Guard;
+
+ procedure Sem_Concurrent_Conditional_Signal_Assignment
+ (Stmt: Iir_Concurrent_Conditional_Signal_Assignment)
+ is
+ Cond_Wf : Iir_Conditional_Waveform;
+ Expr : Iir;
+ Wf_Chain : Iir_Waveform_Element;
+ Target_Type : Iir;
+ Target : Iir;
+ begin
+ Target := Get_Target (Stmt);
+ if Get_Kind (Target) /= Iir_Kind_Aggregate then
+ if not Sem_Signal_Assignment_Target_And_Option (Stmt, Null_Iir) then
+ return;
+ end if;
+ Target := Get_Target (Stmt);
+ Target_Type := Get_Type (Target);
+ else
+ Target_Type := Null_Iir;
+ end if;
+
+ Cond_Wf := Get_Conditional_Waveform_Chain (Stmt);
+ while Cond_Wf /= Null_Iir loop
+ Wf_Chain := Get_Waveform_Chain (Cond_Wf);
+ Sem_Waveform_Chain (Stmt, Wf_Chain, Target_Type);
+ Sem_Check_Waveform_Chain (Stmt, Wf_Chain);
+ Expr := Get_Condition (Cond_Wf);
+ if Expr /= Null_Iir then
+ Expr := Sem_Condition (Expr);
+ if Expr /= Null_Iir then
+ Set_Condition (Cond_Wf, Expr);
+ end if;
+ end if;
+ Cond_Wf := Get_Chain (Cond_Wf);
+ end loop;
+ Sem_Guard (Stmt);
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ if not Sem_Signal_Assignment_Target_And_Option (Stmt, Target_Type)
+ then
+ return;
+ end if;
+ end if;
+ end Sem_Concurrent_Conditional_Signal_Assignment;
+
+ procedure Sem_Concurrent_Selected_Signal_Assignment (Stmt: Iir)
+ is
+ Expr: Iir;
+ Chain : Iir;
+ El: Iir;
+ Waveform_Type : Iir;
+ Target : Iir;
+ Assoc_El : Iir;
+ begin
+ Target := Get_Target (Stmt);
+ Chain := Get_Selected_Waveform_Chain (Stmt);
+ Waveform_Type := Null_Iir;
+
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ -- LRM 9.5 Concurrent Signal Assgnment Statements.
+ -- The process statement equivalent to a concurrent signal assignment
+ -- statement [...] is constructed as follows: [...]
+ --
+ -- LRM 9.5.2 Selected Signa Assignment
+ -- The characteristics of the selected expression, the waveforms and
+ -- the choices in the selected assignment statement must be such that
+ -- the case statement in the equivalent statement is a legal
+ -- statement
+
+ -- Find the first waveform that will appear in the equivalent
+ -- process statement, and extract type from it.
+ Assoc_El := Null_Iir;
+ El := Chain;
+
+ while El /= Null_Iir loop
+ Assoc_El := Get_Associated_Expr (El);
+ exit when Assoc_El /= Null_Iir;
+ El := Get_Chain (El);
+ end loop;
+ if Assoc_El = Null_Iir then
+ Error_Msg_Sem
+ ("cannot determine type of the aggregate target", Target);
+ else
+ Sem_Waveform_Chain (Stmt, Assoc_El, Waveform_Type);
+ end if;
+ if Waveform_Type = Null_Iir then
+ -- Type of target still unknown.
+ -- Since the target is an aggregate, we won't be able to
+ -- semantize it.
+ -- Avoid a crash.
+ return;
+ end if;
+ end if;
+ if not Sem_Signal_Assignment_Target_And_Option (Stmt, Waveform_Type) then
+ return;
+ end if;
+ Waveform_Type := Get_Type (Get_Target (Stmt));
+
+ -- Sem on associated.
+ if Waveform_Type /= Null_Iir then
+ El := Chain;
+ while El /= Null_Iir loop
+ Sem_Waveform_Chain
+ (Stmt, Get_Associated_Chain (El), Waveform_Type);
+ Sem_Check_Waveform_Chain (Stmt, Get_Associated_Chain (El));
+ El := Get_Chain (El);
+ end loop;
+ end if;
+
+ -- The choices.
+ Expr := Sem_Case_Expression (Get_Expression (Stmt));
+ if Expr = Null_Iir then
+ return;
+ end if;
+ Check_Read (Expr);
+ Set_Expression (Stmt, Expr);
+ Sem_Case_Choices (Expr, Chain, Get_Location (Stmt));
+ Set_Selected_Waveform_Chain (Stmt, Chain);
+
+ Sem_Guard (Stmt);
+ end Sem_Concurrent_Selected_Signal_Assignment;
+
+ procedure Simple_Simultaneous_Statement (Stmt : Iir) is
+ Left, Right : Iir;
+ Res_Type : Iir;
+ begin
+ Left := Get_Simultaneous_Left (Stmt);
+ Right := Get_Simultaneous_Right (Stmt);
+
+ Left := Sem_Expression_Ov (Left, Null_Iir);
+ Right := Sem_Expression_Ov (Right, Null_Iir);
+
+ -- Give up in case of error
+ if Left = Null_Iir or else Right = Null_Iir then
+ return;
+ end if;
+
+ Res_Type := Search_Compatible_Type (Get_Type (Left), Get_Type (Right));
+ if Res_Type = Null_Iir then
+ Error_Msg_Sem ("types of left and right expressions are incompatible",
+ Stmt);
+ return;
+ end if;
+
+ -- FIXME: check for nature type...
+ end Simple_Simultaneous_Statement;
+
+ procedure Sem_Concurrent_Statement_Chain (Parent : Iir)
+ is
+ Is_Passive : constant Boolean :=
+ Get_Kind (Parent) = Iir_Kind_Entity_Declaration;
+ El: Iir;
+ Prev_El : Iir;
+ Prev_Concurrent_Statement : Iir;
+ Prev_Psl_Default_Clock : Iir;
+ begin
+ Prev_Concurrent_Statement := Current_Concurrent_Statement;
+ Prev_Psl_Default_Clock := Current_Psl_Default_Clock;
+
+ El := Get_Concurrent_Statement_Chain (Parent);
+ Prev_El := Null_Iir;
+ while El /= Null_Iir loop
+ Current_Concurrent_Statement := El;
+
+ case Get_Kind (El) is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ if Is_Passive then
+ Error_Msg_Sem ("signal assignment forbidden in entity", El);
+ end if;
+ Sem_Concurrent_Conditional_Signal_Assignment (El);
+ when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ if Is_Passive then
+ Error_Msg_Sem ("signal assignment forbidden in entity", El);
+ end if;
+ Sem_Concurrent_Selected_Signal_Assignment (El);
+ when Iir_Kind_Sensitized_Process_Statement =>
+ Set_Passive_Flag (El, Is_Passive);
+ Sem_Sensitized_Process_Statement (El);
+ when Iir_Kind_Process_Statement =>
+ Set_Passive_Flag (El, Is_Passive);
+ Sem_Process_Statement (El);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Sem_Component_Instantiation_Statement (El, Is_Passive);
+ when Iir_Kind_Concurrent_Assertion_Statement =>
+ -- FIXME: must check assertion expressions does not contain
+ -- non-passive subprograms ??
+ Sem_Assertion_Statement (El);
+ when Iir_Kind_Block_Statement =>
+ if Is_Passive then
+ Error_Msg_Sem ("block forbidden in entity", El);
+ end if;
+ Sem_Block_Statement (El);
+ when Iir_Kind_Generate_Statement =>
+ if Is_Passive then
+ Error_Msg_Sem ("generate statement forbidden in entity", El);
+ end if;
+ Sem_Generate_Statement (El);
+ when Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ declare
+ Next_El : Iir;
+ N_Stmt : Iir;
+ begin
+ Next_El := Get_Chain (El);
+ N_Stmt := Sem_Concurrent_Procedure_Call_Statement
+ (El, Is_Passive);
+ if N_Stmt /= El then
+ -- Replace this node.
+ El := N_Stmt;
+ if Prev_El = Null_Iir then
+ Set_Concurrent_Statement_Chain (Parent, El);
+ else
+ Set_Chain (Prev_El, El);
+ end if;
+ Set_Chain (El, Next_El);
+ end if;
+ end;
+ when Iir_Kind_Psl_Declaration =>
+ Sem_Psl.Sem_Psl_Declaration (El);
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Sem_Psl.Sem_Psl_Assert_Statement (El);
+ when Iir_Kind_Psl_Default_Clock =>
+ Sem_Psl.Sem_Psl_Default_Clock (El);
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ Simple_Simultaneous_Statement (El);
+ when others =>
+ Error_Kind ("sem_concurrent_statement_chain", El);
+ end case;
+ Prev_El := El;
+ El := Get_Chain (El);
+ end loop;
+
+ Current_Concurrent_Statement := Prev_Concurrent_Statement;
+ Current_Psl_Default_Clock := Prev_Psl_Default_Clock;
+ end Sem_Concurrent_Statement_Chain;
+
+ -- Put labels in declarative region.
+ procedure Sem_Labels_Chain (Parent : Iir)
+ is
+ Stmt: Iir;
+ Label: Name_Id;
+ begin
+ Stmt := Get_Concurrent_Statement_Chain (Parent);
+ while Stmt /= Null_Iir loop
+
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Psl_Declaration =>
+ -- Special case for in-lined PSL declarations.
+ null;
+ when others =>
+ Label := Get_Label (Stmt);
+
+ if Label /= Null_Identifier then
+ Sem_Scopes.Add_Name (Stmt);
+ Name_Visible (Stmt);
+ Xref_Decl (Stmt);
+ end if;
+ end case;
+
+ -- INT-1991/issue report 27
+ -- Generate statements represent declarative region and have
+ -- implicit declarative part.
+ if False
+ and then Flags.Vhdl_Std = Vhdl_87
+ and then Get_Kind (Stmt) = Iir_Kind_Generate_Statement
+ then
+ Sem_Labels_Chain (Stmt);
+ end if;
+
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Sem_Labels_Chain;
+
+ procedure Sem_Block (Blk: Iir; Sem_Decls : Boolean)
+ is
+ Implicit : Implicit_Signal_Declaration_Type;
+ begin
+ Push_Signals_Declarative_Part (Implicit, Blk);
+
+ if Sem_Decls then
+ Sem_Labels_Chain (Blk);
+ Sem_Declaration_Chain (Blk);
+ end if;
+
+ Sem_Concurrent_Statement_Chain (Blk);
+
+ if Sem_Decls then
+ -- FIXME: do it only if there is conf. spec. in the declarative
+ -- part.
+ Sem_Specification_Chain (Blk, Blk);
+ Check_Full_Declaration (Blk, Blk);
+ end if;
+
+ Pop_Signals_Declarative_Part (Implicit);
+ end Sem_Block;
+
+ -- Add a driver for SIG.
+ -- STMT is used in case of error (it is the statement that creates the
+ -- driver).
+ -- Do nothing if:
+ -- The current statement list does not belong to a process,
+ -- SIG is a formal signal interface.
+ procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir)
+ is
+ Sig_Object : Iir;
+ Sig_Object_Type : Iir;
+ begin
+ if Sig = Null_Iir then
+ return;
+ end if;
+ Sig_Object := Get_Object_Prefix (Sig);
+ Sig_Object_Type := Get_Type (Sig_Object);
+
+ -- LRM 4.3.1.2 Signal Declaration
+ -- It is an error if, after the elaboration of a description, a
+ -- signal has multiple sources and it is not a resolved signal.
+
+ -- Check for multiple driver for a unresolved signal declaration.
+ -- Do this only if the object is a non-composite signal declaration.
+ -- NOTE: THIS IS DISABLED, since the assignment may be within a
+ -- generate statement.
+ if False
+ and then Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration
+ and then Get_Kind (Sig_Object_Type)
+ not in Iir_Kinds_Composite_Type_Definition
+ and then not Get_Resolved_Flag (Sig_Object_Type)
+ then
+ if Get_Signal_Driver (Sig_Object) /= Null_Iir and then
+ Get_Signal_Driver (Sig_Object) /= Current_Concurrent_Statement
+ then
+ Error_Msg_Sem ("unresolved " & Disp_Node (Sig_Object)
+ & " has already a driver at "
+ & Disp_Location (Get_Signal_Driver (Sig_Object)),
+ Stmt);
+ else
+ Set_Signal_Driver (Sig_Object, Current_Concurrent_Statement);
+ end if;
+ end if;
+
+ -- LRM 8.4.1
+ -- If a given procedure is declared by a declarative item that is not
+ -- contained within a process statement, and if a signal assignment
+ -- statement appears in that procedure, then the target of the
+ -- assignment statement must be a formal parameter of the given
+ -- procedure or of a parent of that procedure, or an aggregate of such
+ -- formal parameters.
+ -- Similarly, if a given procedure is declared by a declarative item
+ -- that is not contained within a process statement and if a signal is
+ -- associated with an INOUT or OUT mode signal parameter in a
+ -- subprogram call within that procedure, then the signal so associated
+ -- must be a formal parameter of the given procedure or of a parent of
+ -- that procedure.
+ if Current_Concurrent_Statement = Null_Iir
+ or else (Get_Kind (Current_Concurrent_Statement)
+ not in Iir_Kinds_Process_Statement)
+ then
+ -- Not within a process statement.
+ if Current_Subprogram = Null_Iir then
+ -- not within a subprogram: concurrent statement.
+ return;
+ end if;
+
+ -- Within a subprogram.
+ if Get_Kind (Sig_Object) = Iir_Kind_Signal_Declaration
+ or else (Get_Kind (Get_Parent (Sig_Object))
+ /= Iir_Kind_Procedure_Declaration)
+ then
+ Error_Msg_Sem
+ (Disp_Node (Sig_Object) & " is not a formal parameter", Stmt);
+ end if;
+ end if;
+ end Sem_Add_Driver;
+end Sem_Stmts;
diff --git a/src/sem_stmts.ads b/src/sem_stmts.ads
new file mode 100644
index 000000000..d3eeb8c09
--- /dev/null
+++ b/src/sem_stmts.ads
@@ -0,0 +1,87 @@
+-- Semantic analysis.
+-- 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 Sem_Stmts is
+ -- Semantize declarations and concurrent statements of BLK, which is
+ -- either an architecture_declaration, and entity_declaration or
+ -- a block_statement.
+ -- If SEM_DECLS is true, then semantize the declarations of BLK.
+ procedure Sem_Block (Blk: Iir; Sem_Decls : Boolean);
+
+ -- Analyze the concurrent statements of PARENT.
+ procedure Sem_Concurrent_Statement_Chain (Parent : Iir);
+
+ -- Some signals are implicitly declared. This is the case for signals
+ -- declared by an attribute ('stable, 'quiet and 'transaction).
+ -- Note: guard signals are also implicitly declared, but with a guard
+ -- expression, which is located.
+ -- Since these signals need resources and are not easily located (can be
+ -- nearly in every expression), it is useful to add a node into a
+ -- declaration list to declare them.
+ -- However, only a few declaration_list can declare signals. These
+ -- declarations lists must register and unregister themselves with
+ -- push_declarative_region_with_signals and
+ -- pop_declarative_region_with_signals.
+ type Implicit_Signal_Declaration_Type is private;
+
+ procedure Push_Signals_Declarative_Part
+ (Cell: out Implicit_Signal_Declaration_Type; Decls_Parent : Iir);
+
+ procedure Pop_Signals_Declarative_Part
+ (Cell: in Implicit_Signal_Declaration_Type);
+
+ -- Declare an implicit signal.
+ procedure Add_Declaration_For_Implicit_Signal (Sig : Iir);
+
+ -- Semantize declaration chain and sequential statement chain
+ -- of BODY_PARENT.
+ -- DECL is the declaration for these chains (DECL is the declaration, which
+ -- is different from the bodies).
+ -- This is used by processes and subprograms semantization.
+ procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir);
+
+ -- Sem for concurrent and sequential assertion statements.
+ procedure Sem_Report_Statement (Stmt : Iir);
+
+ -- Get the current subprogram or process.
+ function Get_Current_Subprogram return Iir;
+ pragma Inline (Get_Current_Subprogram);
+
+ -- Get the current concurrent statement, or NULL_IIR if none.
+ function Get_Current_Concurrent_Statement return Iir;
+ pragma Inline (Get_Current_Concurrent_Statement);
+
+ -- Current PSL default_clock declaration.
+ -- Automatically saved and restore while analyzing concurrent statements.
+ Current_Psl_Default_Clock : Iir;
+
+ -- Add a driver for SIG.
+ -- STMT is used in case of error (it is the statement that creates the
+ -- driver).
+ -- Do nothing if:
+ -- The current statement list does not belong to a process,
+ -- SIG is a formal signal interface.
+ procedure Sem_Add_Driver (Sig : Iir; Stmt : Iir);
+private
+ type Implicit_Signal_Declaration_Type is record
+ Decls_Parent : Iir;
+ Last_Decl : Iir;
+ end record;
+
+end Sem_Stmts;
diff --git a/src/sem_types.adb b/src/sem_types.adb
new file mode 100644
index 000000000..12f276be1
--- /dev/null
+++ b/src/sem_types.adb
@@ -0,0 +1,2210 @@
+-- Semantic analysis.
+-- 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 Flags; use Flags;
+with Types; use Types;
+with Errorout; use Errorout;
+with Evaluation; use Evaluation;
+with Sem;
+with Sem_Expr; use Sem_Expr;
+with Sem_Scopes; use Sem_Scopes;
+with Sem_Names; use Sem_Names;
+with Sem_Decls;
+with Sem_Inst;
+with Name_Table;
+with Std_Names;
+with Iirs_Utils; use Iirs_Utils;
+with Std_Package; use Std_Package;
+with Ieee.Std_Logic_1164;
+with Xrefs; use Xrefs;
+
+package body Sem_Types is
+ -- Mark the resolution function (this may be required by the back-end to
+ -- generate resolver).
+ procedure Mark_Resolution_Function (Subtyp : Iir)
+ is
+ Func : Iir_Function_Declaration;
+ begin
+ if not Get_Resolved_Flag (Subtyp) then
+ return;
+ end if;
+
+ Func := Has_Resolution_Function (Subtyp);
+ -- Maybe the type is resolved through its elements.
+ if Func /= Null_Iir then
+ Set_Resolution_Function_Flag (Func, True);
+ end if;
+ end Mark_Resolution_Function;
+
+ procedure Set_Type_Has_Signal (Atype : Iir)
+ is
+ Orig : Iir;
+ begin
+ -- Sanity check: ATYPE can be a signal type (eg: not an access type)
+ if not Get_Signal_Type_Flag (Atype) then
+ -- Do not crash since this may be called on an erroneous design.
+ return;
+ end if;
+
+ -- If the type is already marked, nothing to do.
+ if Get_Has_Signal_Flag (Atype) then
+ return;
+ end if;
+
+ -- This type is used to declare a signal.
+ Set_Has_Signal_Flag (Atype, True);
+
+ -- If this type was instantiated, also mark the origin.
+ Orig := Sem_Inst.Get_Origin (Atype);
+ if Orig /= Null_Iir then
+ Set_Type_Has_Signal (Orig);
+ end if;
+
+ -- Mark resolution function, and for composite types, also mark type
+ -- of elements.
+ case Get_Kind (Atype) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ null;
+ when Iir_Kinds_Scalar_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Set_Type_Has_Signal (Get_Base_Type (Atype));
+ Mark_Resolution_Function (Atype);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Set_Type_Has_Signal (Get_Base_Type (Atype));
+ Mark_Resolution_Function (Atype);
+ Set_Type_Has_Signal (Get_Element_Subtype (Atype));
+ when Iir_Kind_Array_Type_Definition =>
+ Set_Type_Has_Signal (Get_Element_Subtype (Atype));
+ when Iir_Kind_Record_Type_Definition =>
+ declare
+ El_List : constant Iir_List :=
+ Get_Elements_Declaration_List (Atype);
+ El : Iir;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Set_Type_Has_Signal (Get_Type (El));
+ end loop;
+ end;
+ when Iir_Kind_Error =>
+ null;
+ when Iir_Kind_Incomplete_Type_Definition =>
+ -- No need to copy the flag.
+ null;
+ when others =>
+ Error_Kind ("set_type_has_signal(2)", Atype);
+ end case;
+ end Set_Type_Has_Signal;
+
+ -- Sem a range expression that appears in an integer, real or physical
+ -- type definition.
+ --
+ -- Both left and right bounds must be of the same type class, ie
+ -- integer types, or if INT_ONLY is false, real types.
+ -- However, the two bounds need not have the same type.
+ function Sem_Type_Range_Expression (Expr : Iir; Int_Only : Boolean)
+ return Iir
+ is
+ Left, Right: Iir;
+ Bt_L_Kind, Bt_R_Kind : Iir_Kind;
+ begin
+ Left := Sem_Expression_Universal (Get_Left_Limit (Expr));
+ Right := Sem_Expression_Universal (Get_Right_Limit (Expr));
+ if Left = Null_Iir or Right = Null_Iir then
+ return Null_Iir;
+ end if;
+
+ -- Emit error message for overflow and replace with a value to avoid
+ -- error storm.
+ if Get_Kind (Left) = Iir_Kind_Overflow_Literal then
+ Error_Msg_Sem ("overflow in left bound", Left);
+ Left := Build_Extreme_Value
+ (Get_Direction (Expr) = Iir_Downto, Left);
+ end if;
+ if Get_Kind (Right) = Iir_Kind_Overflow_Literal then
+ Error_Msg_Sem ("overflow in right bound", Right);
+ Right := Build_Extreme_Value
+ (Get_Direction (Expr) = Iir_To, Right);
+ end if;
+ Set_Left_Limit (Expr, Left);
+ Set_Right_Limit (Expr, Right);
+
+ Set_Expr_Staticness (Expr, Min (Get_Expr_Staticness (Left),
+ Get_Expr_Staticness (Right)));
+
+ Bt_L_Kind := Get_Kind (Get_Base_Type (Get_Type (Left)));
+ Bt_R_Kind := Get_Kind (Get_Base_Type (Get_Type (Right)));
+
+ if Int_Only then
+ if Bt_L_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_R_Kind = Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("left bound must be an integer expression", Left);
+ return Null_Iir;
+ end if;
+ if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_L_Kind = Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("right bound must be an integer expression", Left);
+ return Null_Iir;
+ end if;
+ if Bt_R_Kind /= Iir_Kind_Integer_Type_Definition
+ and then Bt_L_Kind /= Iir_Kind_Integer_Type_Definition
+ then
+ Error_Msg_Sem ("each bound must be an integer expression", Expr);
+ return Null_Iir;
+ end if;
+ else
+ if Bt_L_Kind /= Bt_R_Kind then
+ Error_Msg_Sem
+ ("left and right bounds must be of the same type class", Expr);
+ return Null_Iir;
+ end if;
+ case Bt_L_Kind is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ null;
+ when others =>
+ -- Enumeration range are not allowed to define a new type.
+ Error_Msg_Sem
+ ("bad range type, only integer or float is allowed", Expr);
+ return Null_Iir;
+ end case;
+ end if;
+
+ return Expr;
+ end Sem_Type_Range_Expression;
+
+ function Create_Integer_Type (Loc : Iir; Constraint : Iir; Decl : Iir)
+ return Iir
+ is
+ Ntype: Iir_Integer_Subtype_Definition;
+ Ndef: Iir_Integer_Type_Definition;
+ begin
+ Ntype := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Location_Copy (Ntype, Loc);
+ Ndef := Create_Iir (Iir_Kind_Integer_Type_Definition);
+ Location_Copy (Ndef, Loc);
+ Set_Base_Type (Ndef, Ndef);
+ Set_Type_Declarator (Ndef, Decl);
+ Set_Type_Staticness (Ndef, Locally);
+ Set_Signal_Type_Flag (Ndef, True);
+ Set_Base_Type (Ntype, Ndef);
+ Set_Type_Declarator (Ntype, Decl);
+ Set_Range_Constraint (Ntype, Constraint);
+ Set_Type_Staticness (Ntype, Get_Expr_Staticness (Constraint));
+ Set_Resolved_Flag (Ntype, False);
+ Set_Signal_Type_Flag (Ntype, True);
+ if Get_Type_Staticness (Ntype) /= Locally then
+ Error_Msg_Sem ("range constraint of type must be locally static",
+ Decl);
+ end if;
+ return Ntype;
+ end Create_Integer_Type;
+
+ function Range_Expr_To_Type_Definition (Expr : Iir; Decl: Iir)
+ return Iir
+ is
+ Rng : Iir;
+ Res : Iir;
+ Base_Type : Iir;
+ begin
+ if Sem_Type_Range_Expression (Expr, False) = Null_Iir then
+ return Null_Iir;
+ end if;
+ Rng := Eval_Range_If_Static (Expr);
+ if Get_Expr_Staticness (Rng) /= Locally then
+ -- FIXME: create an artificial range to avoid error storm ?
+ null;
+ end if;
+
+ case Get_Kind (Get_Base_Type (Get_Type (Get_Left_Limit (Rng)))) is
+ when Iir_Kind_Integer_Type_Definition =>
+ Res := Create_Integer_Type (Expr, Rng, Decl);
+ when Iir_Kind_Floating_Type_Definition =>
+ declare
+ Ntype: Iir_Floating_Subtype_Definition;
+ Ndef: Iir_Floating_Type_Definition;
+ begin
+ Ntype := Create_Iir (Iir_Kind_Floating_Subtype_Definition);
+ Location_Copy (Ntype, Expr);
+ Ndef := Create_Iir (Iir_Kind_Floating_Type_Definition);
+ Location_Copy (Ndef, Expr);
+ Set_Base_Type (Ndef, Ndef);
+ Set_Type_Declarator (Ndef, Decl);
+ Set_Type_Staticness (Ndef, Get_Expr_Staticness (Expr));
+ Set_Signal_Type_Flag (Ndef, True);
+ Set_Base_Type (Ntype, Ndef);
+ Set_Type_Declarator (Ntype, Decl);
+ Set_Range_Constraint (Ntype, Rng);
+ Set_Resolved_Flag (Ntype, False);
+ Set_Type_Staticness (Ntype, Get_Expr_Staticness (Expr));
+ Set_Signal_Type_Flag (Ntype, True);
+ Res := Ntype;
+ end;
+ when others =>
+ -- sem_range_expression should catch such errors.
+ raise Internal_Error;
+ end case;
+
+ -- A type and a subtype were declared. The type of the bounds are now
+ -- used for the implicit subtype declaration. But the type of the
+ -- bounds aren't of the type of the type declaration (this is 'obvious'
+ -- because they exist before the type declaration). Override their
+ -- type. This is doable without destroying information as they are
+ -- either literals (of type convertible_xx_type_definition) or an
+ -- evaluated literal.
+ --
+ -- Overriding makes these implicit subtype homogenous with explicit
+ -- subtypes.
+ Base_Type := Get_Base_Type (Res);
+ Set_Type (Rng, Base_Type);
+ Set_Type (Get_Left_Limit (Rng), Base_Type);
+ Set_Type (Get_Right_Limit (Rng), Base_Type);
+
+ return Res;
+ end Range_Expr_To_Type_Definition;
+
+ function Create_Physical_Literal (Val : Iir_Int64; Unit : Iir) return Iir
+ is
+ Lit : Iir;
+ begin
+ Lit := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Value (Lit, Val);
+ Set_Unit_Name (Lit, Unit);
+ Set_Expr_Staticness (Lit, Locally);
+ Set_Type (Lit, Get_Type (Unit));
+ Location_Copy (Lit, Unit);
+ return Lit;
+ end Create_Physical_Literal;
+
+ -- Analyze a physical type definition. Create a subtype.
+ function Sem_Physical_Type_Definition (Range_Expr: Iir; Decl : Iir)
+ return Iir_Physical_Subtype_Definition
+ is
+ Unit: Iir_Unit_Declaration;
+ Unit_Name : Iir;
+ Def : Iir_Physical_Type_Definition;
+ Sub_Type: Iir_Physical_Subtype_Definition;
+ Range_Expr1: Iir;
+ Val : Iir;
+ Lit : Iir_Physical_Int_Literal;
+ begin
+ Def := Get_Type (Range_Expr);
+
+ -- LRM93 4.1
+ -- The simple name declared by a type declaration denotes the
+ -- declared type, unless the type declaration declares both a base
+ -- type and a subtype of the base type, in which case the simple name
+ -- denotes the subtype, and the base type is anonymous.
+ Set_Type_Declarator (Def, Decl);
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, False);
+ Set_Type_Staticness (Def, Locally);
+ Set_Signal_Type_Flag (Def, True);
+
+ -- Set the type definition of the type declaration (it was currently the
+ -- range expression). Do it early so that the units can be referenced
+ -- by expanded names.
+ Set_Type_Definition (Decl, Def);
+
+ -- LRM93 3.1.3
+ -- Each bound of a range constraint that is used in a physical type
+ -- definition must be a locally static expression of some integer type
+ -- but the two bounds need not have the same integer type.
+ case Get_Kind (Range_Expr) is
+ when Iir_Kind_Range_Expression =>
+ Range_Expr1 := Sem_Type_Range_Expression (Range_Expr, True);
+ when others =>
+ Error_Kind ("sem_physical_type_definition", Range_Expr);
+ end case;
+ if Range_Expr1 /= Null_Iir then
+ if Get_Expr_Staticness (Range_Expr1) /= Locally then
+ Error_Msg_Sem
+ ("range constraint for a physical type must be static",
+ Range_Expr1);
+ Range_Expr1 := Null_Iir;
+ else
+ Range_Expr1 := Eval_Range_If_Static (Range_Expr1);
+ end if;
+ end if;
+
+ -- Create the subtype.
+ Sub_Type := Create_Iir (Iir_Kind_Physical_Subtype_Definition);
+ Location_Copy (Sub_Type, Range_Expr);
+ Set_Base_Type (Sub_Type, Def);
+ Set_Signal_Type_Flag (Sub_Type, True);
+
+ -- Analyze the primary unit.
+ Unit := Get_Unit_Chain (Def);
+
+ Unit_Name := Build_Simple_Name (Unit, Unit);
+ Lit := Create_Physical_Literal (1, Unit_Name);
+ Set_Physical_Unit_Value (Unit, Lit);
+
+ Sem_Scopes.Add_Name (Unit);
+ Set_Type (Unit, Def);
+ Set_Expr_Staticness (Unit, Locally);
+ Set_Name_Staticness (Unit, Locally);
+ Set_Visible_Flag (Unit, True);
+ Xref_Decl (Unit);
+
+ if Range_Expr1 /= Null_Iir then
+ declare
+ -- Convert an integer literal to a physical literal.
+ -- This is used to convert bounds.
+ function Lit_To_Phys_Lit (Lim : Iir_Integer_Literal)
+ return Iir_Physical_Int_Literal
+ is
+ Res : Iir_Physical_Int_Literal;
+ begin
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Location_Copy (Res, Lim);
+ Set_Type (Res, Def);
+ Set_Value (Res, Get_Value (Lim));
+ Set_Unit_Name (Res, Get_Primary_Unit_Name (Def));
+ Set_Expr_Staticness (Res, Locally);
+ Set_Literal_Origin (Res, Lim);
+ return Res;
+ end Lit_To_Phys_Lit;
+
+ Phys_Range : Iir_Range_Expression;
+ begin
+ -- Create the physical range.
+ Phys_Range := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Phys_Range, Range_Expr1);
+ Set_Type (Phys_Range, Def);
+ Set_Direction (Phys_Range, Get_Direction (Range_Expr1));
+ Set_Left_Limit
+ (Phys_Range, Lit_To_Phys_Lit (Get_Left_Limit (Range_Expr1)));
+ Set_Right_Limit
+ (Phys_Range, Lit_To_Phys_Lit (Get_Right_Limit (Range_Expr1)));
+ Set_Expr_Staticness
+ (Phys_Range, Get_Expr_Staticness (Range_Expr1));
+
+ Set_Range_Constraint (Sub_Type, Phys_Range);
+ -- This must be locally...
+ Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1));
+
+ -- FIXME: the original range is not used. Reuse it ?
+ Free_Iir (Range_Expr);
+ end;
+ end if;
+ Set_Resolved_Flag (Sub_Type, False);
+
+ -- Analyze secondary units.
+ Unit := Get_Chain (Unit);
+ while Unit /= Null_Iir loop
+ Sem_Scopes.Add_Name (Unit);
+ Val := Sem_Expression (Get_Physical_Literal (Unit), Def);
+ if Val /= Null_Iir then
+ Set_Physical_Literal (Unit, Val);
+ Val := Eval_Physical_Literal (Val);
+ Set_Physical_Unit_Value (Unit, Val);
+
+ -- LRM93 �3.1
+ -- The position number of unit names need not lie within the range
+ -- specified by the range constraint.
+ -- GHDL: this was not true in VHDL87.
+ -- GHDL: This is not so simple if 1 is not included in the range.
+ if False and then Flags.Vhdl_Std = Vhdl_87
+ and then Range_Expr1 /= Null_Iir
+ then
+ if not Eval_Int_In_Range (Get_Value (Unit), Range_Expr1) then
+ Error_Msg_Sem
+ ("physical literal does not lie within the range", Unit);
+ end if;
+ end if;
+ else
+ -- Avoid errors storm.
+ Set_Physical_Literal (Unit, Get_Primary_Unit (Def));
+ Set_Physical_Unit_Value (Unit, Lit);
+ end if;
+
+ Set_Type (Unit, Def);
+ Set_Expr_Staticness (Unit, Locally);
+ Set_Name_Staticness (Unit, Locally);
+ Sem_Scopes.Name_Visible (Unit);
+ Xref_Decl (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ return Sub_Type;
+ end Sem_Physical_Type_Definition;
+
+ -- Return true iff decl is std.textio.text
+ function Is_Text_Type_Declaration (Decl : Iir_Type_Declaration)
+ return Boolean
+ is
+ use Std_Names;
+ P : Iir;
+ begin
+ if Get_Identifier (Decl) /= Name_Text then
+ return False;
+ end if;
+ P := Get_Parent (Decl);
+ if Get_Kind (P) /= Iir_Kind_Package_Declaration
+ or else Get_Identifier (P) /= Name_Textio
+ then
+ return False;
+ end if;
+ -- design_unit, design_file, library_declaration.
+ P := Get_Library (Get_Design_File (Get_Design_Unit (P)));
+ if P /= Libraries.Std_Library then
+ return False;
+ end if;
+ return True;
+ end Is_Text_Type_Declaration;
+
+ procedure Check_No_File_Type (El_Type : Iir; Loc : Iir) is
+ begin
+ case Get_Kind (El_Type) is
+ when Iir_Kind_File_Type_Definition =>
+ Error_Msg_Sem
+ ("element of file type is not allowed in a composite type", Loc);
+ when others =>
+ null;
+ end case;
+ end Check_No_File_Type;
+
+ -- Semantize the array_element type of array type DEF.
+ -- Set resolved_flag of DEF.
+ procedure Sem_Array_Element (Def : Iir)
+ is
+ El_Type : Iir;
+ begin
+ El_Type := Get_Element_Subtype_Indication (Def);
+ El_Type := Sem_Subtype_Indication (El_Type);
+ if El_Type = Null_Iir then
+ Set_Type_Staticness (Def, None);
+ Set_Resolved_Flag (Def, False);
+ return;
+ end if;
+ Set_Element_Subtype_Indication (Def, El_Type);
+
+ El_Type := Get_Type_Of_Subtype_Indication (El_Type);
+ Set_Element_Subtype (Def, El_Type);
+ Check_No_File_Type (El_Type, Def);
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (El_Type));
+
+ -- LRM93 �3.2.1.1
+ -- The same requirement exists [must define a constrained
+ -- array subtype] [...] for the element subtype indication
+ -- of an array type definition, if the type of the array
+ -- element is itself an array type.
+ if Vhdl_Std < Vhdl_08
+ and then not Is_Fully_Constrained_Type (El_Type)
+ then
+ Error_Msg_Sem ("array element of unconstrained "
+ & Disp_Node (El_Type) & " is not allowed", Def);
+ end if;
+ Set_Resolved_Flag (Def, Get_Resolved_Flag (El_Type));
+ end Sem_Array_Element;
+
+ procedure Sem_Protected_Type_Declaration (Type_Decl : Iir_Type_Declaration)
+ is
+ Decl : Iir_Protected_Type_Declaration;
+ El : Iir;
+ begin
+ Decl := Get_Type_Definition (Type_Decl);
+ Set_Base_Type (Decl, Decl);
+ Set_Resolved_Flag (Decl, False);
+ Set_Signal_Type_Flag (Decl, False);
+ Set_Type_Staticness (Decl, None);
+
+ -- LRM 10.3 Visibility
+ -- [...] except in the declaration of a design_unit or a protected type
+ -- declaration, in which case it starts immediatly after the reserved
+ -- word is occuring after the identifier of the design unit or
+ -- protected type declaration.
+ Set_Visible_Flag (Type_Decl, True);
+
+ -- LRM 10.1
+ -- n) A protected type declaration, together with the corresponding
+ -- body.
+ Open_Declarative_Region;
+
+ Sem_Decls.Sem_Declaration_Chain (Decl);
+ El := Get_Declaration_Chain (Decl);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause
+ | Iir_Kind_Attribute_Specification =>
+ null;
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ declare
+ Inter : Iir;
+ Inter_Type : Iir;
+ begin
+ Inter := Get_Interface_Declaration_Chain (El);
+ while Inter /= Null_Iir loop
+ Inter_Type := Get_Type (Inter);
+ if Inter_Type /= Null_Iir
+ and then Get_Signal_Type_Flag (Inter_Type) = False
+ and then Get_Kind (Inter_Type)
+ /= Iir_Kind_Protected_Type_Declaration
+ then
+ Error_Msg_Sem
+ ("formal parameter method must not be "
+ & "access or file type", Inter);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ if Get_Kind (El) = Iir_Kind_Function_Declaration then
+ Inter_Type := Get_Return_Type (El);
+ if Inter_Type /= Null_Iir
+ and then Get_Signal_Type_Flag (Inter_Type) = False
+ then
+ Error_Msg_Sem
+ ("method return type must not be access of file",
+ El);
+ end if;
+ end if;
+ end;
+ when others =>
+ Error_Msg_Sem
+ (Disp_Node (El)
+ & " are not allowed in protected type declaration", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ Close_Declarative_Region;
+ end Sem_Protected_Type_Declaration;
+
+ procedure Sem_Protected_Type_Body (Bod : Iir)
+ is
+ Inter : Name_Interpretation_Type;
+ Type_Decl : Iir;
+ Decl : Iir;
+ El : Iir;
+ begin
+ -- LRM 3.5 Protected types.
+ -- Each protected type declaration appearing immediatly within a given
+ -- declaration region must have exactly one corresponding protected type
+ -- body appearing immediatly within the same declarative region and
+ -- textually subsequent to the protected type declaration.
+ --
+ -- Similarly, each protected type body appearing immediatly within a
+ -- given declarative region must have exactly one corresponding
+ -- protected type declaration appearing immediatly within the same
+ -- declarative region and textually prior to the protected type body.
+ Inter := Get_Interpretation (Get_Identifier (Bod));
+ if Valid_Interpretation (Inter)
+ and then Is_In_Current_Declarative_Region (Inter)
+ then
+ Type_Decl := Get_Declaration (Inter);
+ if Get_Kind (Type_Decl) = Iir_Kind_Type_Declaration then
+ Decl := Get_Type_Definition (Type_Decl);
+ else
+ Decl := Null_Iir;
+ end if;
+ else
+ Decl := Null_Iir;
+ end if;
+
+ if Decl /= Null_Iir
+ and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Declaration
+ then
+ Set_Protected_Type_Declaration (Bod, Decl);
+ if Get_Protected_Type_Body (Decl) /= Null_Iir then
+ Error_Msg_Sem
+ ("protected type body already declared for "
+ & Disp_Node (Decl), Bod);
+ Error_Msg_Sem
+ ("(previous body)", Get_Protected_Type_Body (Decl));
+ Decl := Null_Iir;
+ elsif not Get_Visible_Flag (Type_Decl) then
+ -- Can this happen ?
+ Error_Msg_Sem
+ ("protected type declaration not yet visible", Bod);
+ Error_Msg_Sem
+ ("(location of protected type declaration)", Decl);
+ Decl := Null_Iir;
+ else
+ Set_Protected_Type_Body (Decl, Bod);
+ end if;
+ else
+ Error_Msg_Sem
+ ("no protected type declaration for this body", Bod);
+ if Decl /= Null_Iir then
+ Error_Msg_Sem
+ ("(found " & Disp_Node (Decl) & " declared here)", Decl);
+ Decl := Null_Iir;
+ end if;
+ end if;
+
+ -- LRM 10.1
+ -- n) A protected type declaration, together with the corresponding
+ -- body.
+ Open_Declarative_Region;
+
+ if Decl /= Null_Iir then
+ Xref_Body (Bod, Decl);
+ Add_Protected_Type_Declarations (Decl);
+ end if;
+
+ Sem_Decls.Sem_Declaration_Chain (Bod);
+
+ El := Get_Declaration_Chain (Bod);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ null;
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ null;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ null;
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration =>
+ null;
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when others =>
+ Error_Msg_Sem
+ (Disp_Node (El) & " not allowed in a protected type body",
+ El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ Sem_Decls.Check_Full_Declaration (Bod, Bod);
+
+ -- LRM 3.5.2 Protected type bodies
+ -- Each subprogram declaration appearing in a given protected type
+ -- declaration shall have a corresponding subprogram body appearing in
+ -- the corresponding protected type body.
+ if Decl /= Null_Iir then
+ Sem_Decls.Check_Full_Declaration (Decl, Bod);
+ end if;
+
+ Close_Declarative_Region;
+ end Sem_Protected_Type_Body;
+
+ -- Return the constraint state from CONST (the initial state) and ATYPE,
+ -- as if ATYPE was a new element of a record.
+ function Update_Record_Constraint (Const : Iir_Constraint; Atype : Iir)
+ return Iir_Constraint is
+ begin
+ if Get_Kind (Atype) not in Iir_Kinds_Composite_Type_Definition then
+ return Const;
+ end if;
+
+ case Const is
+ when Fully_Constrained
+ | Unconstrained =>
+ if Get_Constraint_State (Atype) = Const then
+ return Const;
+ else
+ return Partially_Constrained;
+ end if;
+ when Partially_Constrained =>
+ return Partially_Constrained;
+ end case;
+ end Update_Record_Constraint;
+
+ function Get_Array_Constraint (Def : Iir) return Iir_Constraint
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Def);
+ Index : constant Boolean :=
+ Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Index_Constraint_Flag (Def);
+ begin
+ if Get_Kind (El_Type) in Iir_Kinds_Composite_Type_Definition then
+ case Get_Constraint_State (El_Type) is
+ when Fully_Constrained =>
+ if Index then
+ return Fully_Constrained;
+ else
+ return Partially_Constrained;
+ end if;
+ when Partially_Constrained =>
+ return Partially_Constrained;
+ when Unconstrained =>
+ if not Index then
+ return Unconstrained;
+ else
+ return Partially_Constrained;
+ end if;
+ end case;
+ else
+ if Index then
+ return Fully_Constrained;
+ else
+ return Unconstrained;
+ end if;
+ end if;
+ end Get_Array_Constraint;
+
+ function Sem_Enumeration_Type_Definition (Def: Iir; Decl: Iir) return Iir
+ is
+ begin
+ Set_Base_Type (Def, Def);
+ Set_Type_Staticness (Def, Locally);
+ Set_Signal_Type_Flag (Def, True);
+
+ -- Makes all literal visible.
+ declare
+ El: Iir;
+ Literal_List: Iir_List;
+ Only_Characters : Boolean := True;
+ begin
+ Literal_List := Get_Enumeration_Literal_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (Literal_List, I);
+ exit when El = Null_Iir;
+ Set_Expr_Staticness (El, Locally);
+ Set_Name_Staticness (El, Locally);
+ Set_Type (El, Def);
+ Set_Enumeration_Decl (El, El);
+ Sem.Compute_Subprogram_Hash (El);
+ Sem_Scopes.Add_Name (El);
+ Name_Visible (El);
+ Xref_Decl (El);
+ if Only_Characters
+ and then not Name_Table.Is_Character (Get_Identifier (El))
+ then
+ Only_Characters := False;
+ end if;
+ end loop;
+ Set_Only_Characters_Flag (Def, Only_Characters);
+ end;
+ Set_Resolved_Flag (Def, False);
+
+ Create_Range_Constraint_For_Enumeration_Type (Def);
+
+ -- Identifier IEEE.Std_Logic_1164.Std_Ulogic.
+ if Get_Identifier (Decl) = Std_Names.Name_Std_Ulogic
+ and then
+ Get_Parent (Decl) = Ieee.Std_Logic_1164.Std_Logic_1164_Pkg
+ then
+ Ieee.Std_Logic_1164.Std_Ulogic_Type := Def;
+ end if;
+
+ return Def;
+ end Sem_Enumeration_Type_Definition;
+
+ function Sem_Record_Type_Definition (Def: Iir) return Iir
+ is
+ -- Semantized type of previous element
+ Last_Type : Iir;
+
+ El_List : constant Iir_List := Get_Elements_Declaration_List (Def);
+ El: Iir;
+ El_Type : Iir;
+ Resolved_Flag : Boolean;
+ Staticness : Iir_Staticness;
+ Constraint : Iir_Constraint;
+ begin
+ -- LRM 10.1
+ -- 5. A record type declaration,
+ Open_Declarative_Region;
+
+ Resolved_Flag := True;
+ Last_Type := Null_Iir;
+ Staticness := Locally;
+ Constraint := Fully_Constrained;
+ Set_Signal_Type_Flag (Def, True);
+
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+
+ El_Type := Get_Subtype_Indication (El);
+ if El_Type /= Null_Iir then
+ -- Be careful for a declaration list (r,g,b: integer).
+ El_Type := Sem_Subtype_Indication (El_Type);
+ Set_Subtype_Indication (El, El_Type);
+ El_Type := Get_Type_Of_Subtype_Indication (El_Type);
+ Last_Type := El_Type;
+ else
+ El_Type := Last_Type;
+ end if;
+ if El_Type /= Null_Iir then
+ Set_Type (El, El_Type);
+ Check_No_File_Type (El_Type, El);
+ if not Get_Signal_Type_Flag (El_Type) then
+ Set_Signal_Type_Flag (Def, False);
+ end if;
+
+ -- LRM93 3.2.1.1
+ -- The same requirement [must define a constrained array
+ -- subtype] exits for the subtype indication of an
+ -- element declaration, if the type of the record
+ -- element is an array type.
+ if Vhdl_Std < Vhdl_08
+ and then not Is_Fully_Constrained_Type (El_Type)
+ then
+ Error_Msg_Sem
+ ("element declaration of unconstrained "
+ & Disp_Node (El_Type) & " is not allowed", El);
+ end if;
+ Resolved_Flag :=
+ Resolved_Flag and Get_Resolved_Flag (El_Type);
+ Staticness := Min (Staticness,
+ Get_Type_Staticness (El_Type));
+ Constraint := Update_Record_Constraint
+ (Constraint, El_Type);
+ else
+ Staticness := None;
+ end if;
+ Sem_Scopes.Add_Name (El);
+ Name_Visible (El);
+ Xref_Decl (El);
+ end loop;
+ Close_Declarative_Region;
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, Resolved_Flag);
+ Set_Type_Staticness (Def, Staticness);
+ Set_Constraint_State (Def, Constraint);
+ return Def;
+ end Sem_Record_Type_Definition;
+
+ function Sem_Unbounded_Array_Type_Definition (Def: Iir) return Iir
+ is
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_Definition_List (Def);
+ Index_Type : Iir;
+ begin
+ Set_Base_Type (Def, Def);
+
+ for I in Natural loop
+ Index_Type := Get_Nth_Element (Index_List, I);
+ exit when Index_Type = Null_Iir;
+
+ Index_Type := Sem_Type_Mark (Index_Type);
+ Replace_Nth_Element (Index_List, I, Index_Type);
+
+ Index_Type := Get_Type (Index_Type);
+ if Get_Kind (Index_Type) not in Iir_Kinds_Discrete_Type_Definition
+ then
+ Error_Msg_Sem ("an index type of an array must be a discrete type",
+ Index_Type);
+ -- FIXME: disp type Index_Type ?
+ end if;
+ end loop;
+
+ Set_Index_Subtype_List (Def, Index_List);
+
+ Sem_Array_Element (Def);
+ Set_Constraint_State (Def, Get_Array_Constraint (Def));
+
+ -- According to LRM93 7.4.1, an unconstrained array type is not static.
+ Set_Type_Staticness (Def, None);
+
+ return Def;
+ end Sem_Unbounded_Array_Type_Definition;
+
+ -- Return the subtype declaration corresponding to the base type of ATYPE
+ -- (for integer and real types), or the type for enumerated types. To say
+ -- that differently, it returns the type or subtype which defines the
+ -- original range.
+ function Get_First_Subtype_Declaration (Atype : Iir) return Iir is
+ Base_Type : constant Iir := Get_Base_Type (Atype);
+ Base_Decl : constant Iir := Get_Type_Declarator (Base_Type);
+ begin
+ if Get_Kind (Base_Type) = Iir_Kind_Enumeration_Type_Definition then
+ pragma Assert (Get_Kind (Base_Decl) = Iir_Kind_Type_Declaration);
+ return Base_Decl;
+ else
+ return Get_Type_Declarator (Get_Subtype_Definition (Base_Decl));
+ end if;
+ end Get_First_Subtype_Declaration;
+
+ function Sem_Constrained_Array_Type_Definition (Def: Iir; Decl: Iir)
+ return Iir
+ is
+ Index_Type : Iir;
+ Index_Name : Iir;
+ Index_List : Iir_List;
+ Base_Index_List : Iir_List;
+ El_Type : Iir;
+ Staticness : Iir_Staticness;
+
+ -- array_type_definition, which is the same as the subtype,
+ -- but without any constraint in the indexes.
+ Base_Type: Iir;
+ begin
+ -- LRM08 5.3.2.1 Array types
+ -- A constrained array definition similarly defines both an array
+ -- type and a subtype of this type.
+ -- - The array type is an implicitely declared anonymous type,
+ -- this type is defined by an (implicit) unbounded array
+ -- definition in which the element subtype indication either
+ -- denotes the base type of the subtype denoted by the element
+ -- subtype indication of the constrained array definition, if
+ -- that subtype is a composite type, or otherwise is the
+ -- element subtype indication of the constrained array
+ -- definition, and in which the type mark of each index subtype
+ -- definition denotes the subtype defined by the corresponding
+ -- discrete range.
+ -- - The array subtype is the subtype obtained by imposition of
+ -- the index constraint on the array type and if the element
+ -- subtype indication of the constrained array definition
+ -- denotes a fully or partially constrained composite subtype,
+ -- imposition of the constraint of that subtype as an array
+ -- element constraint on the array type.
+
+ -- FIXME: all indexes must be either constrained or
+ -- unconstrained.
+ -- If all indexes are unconstrained, this is really a type
+ -- otherwise, this is a subtype.
+
+ -- Create a definition for the base type of subtype DEF.
+ Base_Type := Create_Iir (Iir_Kind_Array_Type_Definition);
+ Location_Copy (Base_Type, Def);
+ Set_Base_Type (Base_Type, Base_Type);
+ Set_Type_Declarator (Base_Type, Decl);
+ Base_Index_List := Create_Iir_List;
+ Set_Index_Subtype_Definition_List (Base_Type, Base_Index_List);
+ Set_Index_Subtype_List (Base_Type, Base_Index_List);
+
+ Staticness := Locally;
+ Index_List := Get_Index_Constraint_List (Def);
+ for I in Natural loop
+ Index_Type := Get_Nth_Element (Index_List, I);
+ exit when Index_Type = Null_Iir;
+
+ Index_Name := Sem_Discrete_Range_Integer (Index_Type);
+ if Index_Name /= Null_Iir then
+ Index_Name := Range_To_Subtype_Indication (Index_Name);
+ else
+ -- Avoid errors.
+ Index_Name :=
+ Build_Simple_Name (Natural_Subtype_Declaration, Index_Type);
+ Set_Type (Index_Name, Natural_Subtype_Definition);
+ end if;
+
+ Replace_Nth_Element (Index_List, I, Index_Name);
+
+ Index_Type := Get_Index_Type (Index_Name);
+ Staticness := Min (Staticness, Get_Type_Staticness (Index_Type));
+
+ -- Set the index subtype definition for the array base type.
+ if Get_Kind (Index_Name) in Iir_Kinds_Denoting_Name then
+ Index_Type := Index_Name;
+ else
+ pragma Assert
+ (Get_Kind (Index_Name) in Iir_Kinds_Subtype_Definition);
+ Index_Type := Get_Subtype_Type_Mark (Index_Name);
+ if Index_Type = Null_Iir then
+ -- From a range expression like '1 to 4' or from an attribute
+ -- name.
+ declare
+ Subtype_Decl : constant Iir :=
+ Get_First_Subtype_Declaration (Index_Name);
+ begin
+ Index_Type := Build_Simple_Name (Subtype_Decl, Index_Name);
+ Set_Type (Index_Type, Get_Type (Subtype_Decl));
+ end;
+ end if;
+ end if;
+ Append_Element (Base_Index_List, Index_Type);
+ end loop;
+ Set_Index_Subtype_List (Def, Index_List);
+
+ -- Element type.
+ Set_Element_Subtype_Indication (Base_Type, Get_Element_Subtype (Def));
+ Sem_Array_Element (Base_Type);
+ El_Type := Get_Element_Subtype (Base_Type);
+ Set_Element_Subtype (Def, El_Type);
+
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type));
+
+ -- According to LRM93 �7.4.1, an unconstrained array type
+ -- is not static.
+ Set_Type_Staticness (Base_Type, None);
+ Set_Type_Staticness (Def, Min (Staticness,
+ Get_Type_Staticness (El_Type)));
+
+ Set_Type_Declarator (Base_Type, Decl);
+ Set_Resolved_Flag (Base_Type, Get_Resolved_Flag (Def));
+ Set_Index_Constraint_Flag (Def, True);
+ Set_Constraint_State (Def, Get_Array_Constraint (Def));
+ Set_Constraint_State (Base_Type, Get_Array_Constraint (Base_Type));
+ Set_Base_Type (Def, Base_Type);
+ Set_Subtype_Type_Mark (Def, Null_Iir);
+ return Def;
+ end Sem_Constrained_Array_Type_Definition;
+
+ function Sem_Access_Type_Definition (Def: Iir) return Iir
+ is
+ D_Type : Iir;
+ begin
+ D_Type := Sem_Subtype_Indication
+ (Get_Designated_Subtype_Indication (Def), True);
+ Set_Designated_Subtype_Indication (Def, D_Type);
+
+ D_Type := Get_Type_Of_Subtype_Indication (D_Type);
+ if D_Type /= Null_Iir then
+ case Get_Kind (D_Type) is
+ when Iir_Kind_Incomplete_Type_Definition =>
+ Append_Element (Get_Incomplete_Type_List (D_Type), Def);
+ when Iir_Kind_File_Type_Definition =>
+ -- LRM 3.3
+ -- The designated type must not be a file type.
+ Error_Msg_Sem ("designated type must not be a file type", Def);
+ when others =>
+ null;
+ end case;
+ Set_Designated_Type (Def, D_Type);
+ end if;
+ Set_Base_Type (Def, Def);
+ Set_Type_Staticness (Def, None);
+ Set_Resolved_Flag (Def, False);
+ Set_Signal_Type_Flag (Def, False);
+ return Def;
+ end Sem_Access_Type_Definition;
+
+ function Sem_File_Type_Definition (Def: Iir; Decl: Iir) return Iir
+ is
+ Type_Mark : Iir;
+ begin
+ Type_Mark := Sem_Type_Mark (Get_File_Type_Mark (Def));
+ Set_File_Type_Mark (Def, Type_Mark);
+
+ Type_Mark := Get_Type (Type_Mark);
+
+ if Get_Kind (Type_Mark) = Iir_Kind_Error then
+ null;
+ elsif Get_Signal_Type_Flag (Type_Mark) = False then
+ -- LRM 3.4
+ -- The base type of this subtype must not be a file type
+ -- or an access type.
+ -- If the base type is a composite type, it must not
+ -- contain a subelement of an access type.
+ Error_Msg_Sem
+ (Disp_Node (Type_Mark) & " cannot be a file type", Def);
+ elsif Get_Kind (Type_Mark) in Iir_Kinds_Array_Type_Definition then
+ -- LRM 3.4
+ -- If the base type is an array type, it must be a one
+ -- dimensional array type.
+ if not Is_One_Dimensional_Array_Type (Type_Mark) then
+ Error_Msg_Sem
+ ("multi-dimensional " & Disp_Node (Type_Mark)
+ & " cannot be a file type", Def);
+ end if;
+ end if;
+
+ Set_Base_Type (Def, Def);
+ Set_Resolved_Flag (Def, False);
+ Set_Text_File_Flag (Def, Is_Text_Type_Declaration (Decl));
+ Set_Signal_Type_Flag (Def, False);
+ Set_Type_Staticness (Def, None);
+ return Def;
+ end Sem_File_Type_Definition;
+
+ function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Sem_Enumeration_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Range_Expression =>
+ if Get_Type (Def) /= Null_Iir then
+ return Sem_Physical_Type_Definition (Def, Decl);
+ else
+ return Range_Expr_To_Type_Definition (Def, Decl);
+ end if;
+
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Parenthesis_Name =>
+ if Get_Type (Def) /= Null_Iir then
+ return Sem_Physical_Type_Definition (Def, Decl);
+ end if;
+ -- Nb: the attribute is expected to be a 'range or
+ -- a 'reverse_range attribute.
+ declare
+ Res : Iir;
+ begin
+ Res := Sem_Discrete_Range_Expression (Def, Null_Iir, True);
+ if Res = Null_Iir then
+ return Null_Iir;
+ end if;
+ -- This cannot be a floating range.
+ return Create_Integer_Type (Def, Res, Decl);
+ end;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ return Sem_Constrained_Array_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Array_Type_Definition =>
+ return Sem_Unbounded_Array_Type_Definition (Def);
+
+ when Iir_Kind_Record_Type_Definition =>
+ return Sem_Record_Type_Definition (Def);
+
+ when Iir_Kind_Access_Type_Definition =>
+ return Sem_Access_Type_Definition (Def);
+
+ when Iir_Kind_File_Type_Definition =>
+ return Sem_File_Type_Definition (Def, Decl);
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ Sem_Protected_Type_Declaration (Decl);
+ return Def;
+
+ when others =>
+ Error_Kind ("sem_type_definition", Def);
+ return Def;
+ end case;
+ end Sem_Type_Definition;
+
+ function Range_To_Subtype_Indication (A_Range: Iir) return Iir
+ is
+ Sub_Type: Iir;
+ Range_Type : Iir;
+ begin
+ case Get_Kind (A_Range) is
+ when Iir_Kind_Range_Expression
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ -- Create a sub type.
+ Range_Type := Get_Type (A_Range);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return A_Range;
+ when Iir_Kinds_Discrete_Type_Definition =>
+ -- A_RANGE is already a subtype definition.
+ return A_Range;
+ when others =>
+ Error_Kind ("range_to_subtype_indication", A_Range);
+ return Null_Iir;
+ end case;
+
+ case Get_Kind (Range_Type) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ Sub_Type := Create_Iir (Iir_Kind_Floating_Subtype_Definition);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Location_Copy (Sub_Type, A_Range);
+ Set_Range_Constraint (Sub_Type, A_Range);
+ Set_Base_Type (Sub_Type, Get_Base_Type (Range_Type));
+ Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (A_Range));
+ Set_Signal_Type_Flag (Sub_Type, True);
+ return Sub_Type;
+ end Range_To_Subtype_Indication;
+
+ -- Return TRUE iff FUNC is a resolution function for ATYPE.
+ function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean
+ is
+ Decl: Iir;
+ Decl_Type : Iir;
+ Ret_Type : Iir;
+ begin
+ -- LRM93 2.4
+ -- A resolution function must be a [pure] function;
+ if Get_Kind (Func) not in Iir_Kinds_Function_Declaration then
+ return False;
+ end if;
+ Decl := Get_Interface_Declaration_Chain (Func);
+ -- LRM93 2.4
+ -- moreover, it must have a single input parameter of class constant
+ if Decl = Null_Iir or else Get_Chain (Decl) /= Null_Iir then
+ return False;
+ end if;
+ if Get_Kind (Decl) /= Iir_Kind_Interface_Constant_Declaration then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- that is a one-dimensional, unconstrained array
+ Decl_Type := Get_Type (Decl);
+ if Get_Kind (Decl_Type) /= Iir_Kind_Array_Type_Definition then
+ return False;
+ end if;
+ if not Is_One_Dimensional_Array_Type (Decl_Type) then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- whose element type is that of the resolved signal.
+ -- The type of the return value of the function must also be that of
+ -- the signal.
+ Ret_Type := Get_Return_Type (Func);
+ if Get_Base_Type (Get_Element_Subtype (Decl_Type))
+ /= Get_Base_Type (Ret_Type)
+ then
+ return False;
+ end if;
+ if Atype /= Null_Iir
+ and then Get_Base_Type (Ret_Type) /= Get_Base_Type (Atype)
+ then
+ return False;
+ end if;
+ -- LRM93 2.4
+ -- A resolution function must be a [pure] function;
+ if Flags.Vhdl_Std >= Vhdl_93 and then Get_Pure_Flag (Func) = False then
+ if Atype /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution " & Disp_Node (Func) & " must be pure", Atype);
+ end if;
+ return False;
+ end if;
+ return True;
+ end Is_A_Resolution_Function;
+
+ -- Note: this sets resolved_flag.
+ procedure Sem_Resolution_Function (Name : Iir; Atype : Iir)
+ is
+ Func : Iir;
+ Res: Iir;
+ El : Iir;
+ List : Iir_List;
+ Has_Error : Boolean;
+ Name1 : Iir;
+ begin
+ Sem_Name (Name);
+
+ Func := Get_Named_Entity (Name);
+ if Func = Error_Mark then
+ return;
+ end if;
+
+ Res := Null_Iir;
+
+ if Is_Overload_List (Func) then
+ List := Get_Overload_List (Func);
+ Has_Error := False;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Is_A_Resolution_Function (El, Atype) then
+ if Res /= Null_Iir then
+ if not Has_Error then
+ Has_Error := True;
+ Error_Msg_Sem
+ ("can't resolve overload for resolution function",
+ Atype);
+ Error_Msg_Sem ("candidate functions are:", Atype);
+ Error_Msg_Sem (" " & Disp_Subprg (Func), Func);
+ end if;
+ Error_Msg_Sem (" " & Disp_Subprg (El), El);
+ else
+ Res := El;
+ end if;
+ end if;
+ end loop;
+ Free_Overload_List (Func);
+ if Has_Error then
+ return;
+ end if;
+ Set_Named_Entity (Name, Res);
+ else
+ if Is_A_Resolution_Function (Func, Atype) then
+ Res := Func;
+ end if;
+ end if;
+
+ if Res = Null_Iir then
+ Error_Msg_Sem ("no matching resolution function for "
+ & Disp_Node (Name), Atype);
+ else
+ Name1 := Finish_Sem_Name (Name);
+ Mark_Subprogram_Used (Res);
+ Set_Resolved_Flag (Atype, True);
+ Set_Resolution_Indication (Atype, Name1);
+ end if;
+ end Sem_Resolution_Function;
+
+ -- Analyze the constraint DEF + RESOLUTION for type TYPE_MARK. The
+ -- result is always a subtype definition.
+ function Sem_Subtype_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir;
+
+ -- DEF is an incomplete subtype_indication or array_constraint,
+ -- TYPE_MARK is the base type of the subtype_indication.
+ function Sem_Array_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Type_Mark);
+ Res : Iir;
+ Type_Index, Subtype_Index: Iir;
+ Base_Type : Iir;
+ El_Def : Iir;
+ Staticness : Iir_Staticness;
+ Error_Seen : Boolean;
+ Type_Index_List : Iir_List;
+ Subtype_Index_List : Iir_List;
+ Resolv_Func : Iir := Null_Iir;
+ Resolv_El : Iir := Null_Iir;
+ Resolv_Ind : Iir;
+ begin
+ if Resolution /= Null_Iir then
+ -- A resolution indication is present.
+ case Get_Kind (Resolution) is
+ when Iir_Kinds_Denoting_Name =>
+ Resolv_Func := Resolution;
+ when Iir_Kind_Array_Element_Resolution =>
+ Resolv_El := Get_Resolution_Indication (Resolution);
+ when Iir_Kind_Record_Resolution =>
+ Error_Msg_Sem
+ ("record resolution not allowed for array subtype",
+ Resolution);
+ when others =>
+ Error_Kind ("sem_array_constraint(resolution)", Resolution);
+ end case;
+ end if;
+
+ if Def = Null_Iir then
+ -- There is no element_constraint.
+ pragma Assert (Resolution /= Null_Iir);
+ Res := Copy_Subtype_Indication (Type_Mark);
+ else
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ -- This is the case of "subtype new_array is [func] old_array".
+ -- def must be a constrained array.
+ if Get_Range_Constraint (Def) /= Null_Iir then
+ Error_Msg_Sem
+ ("cannot use a range constraint for array types", Def);
+ return Copy_Subtype_Indication (Type_Mark);
+ end if;
+
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- If the subtype indication does not include a constraint, the
+ -- subtype is the same as that denoted by the type mark.
+ if Resolution = Null_Iir then
+ -- FIXME: is it reachable ?
+ Free_Name (Def);
+ return Type_Mark;
+ end if;
+
+ Res := Copy_Subtype_Indication (Type_Mark);
+ Location_Copy (Res, Def);
+ Free_Name (Def);
+
+ -- No element constraint.
+ El_Def := Null_Iir;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- Case of a constraint for an array.
+ -- Check each index constraint against array type.
+
+ Base_Type := Get_Base_Type (Type_Mark);
+ Set_Base_Type (Def, Base_Type);
+ El_Def := Get_Element_Subtype (Def);
+
+ Staticness := Get_Type_Staticness (El_Type);
+ Error_Seen := False;
+ Type_Index_List :=
+ Get_Index_Subtype_Definition_List (Base_Type);
+ Subtype_Index_List := Get_Index_Constraint_List (Def);
+
+ -- LRM08 5.3.2.2
+ -- If an array constraint of the first form (including an index
+ -- constraint) applies to a type or subtype, then the type or
+ -- subtype shall be an unconstrained or partially constrained
+ -- array type with no index constraint applying to the index
+ -- subtypes, or an access type whose designated type is such
+ -- a type.
+ if Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Index_Constraint_Flag (Type_Mark)
+ then
+ Error_Msg_Sem ("constrained array cannot be re-constrained",
+ Def);
+ end if;
+ if Subtype_Index_List = Null_Iir_List then
+ -- Array is not constrained.
+ Set_Index_Constraint_Flag (Def, False);
+ Set_Index_Subtype_List (Def, Type_Index_List);
+ else
+ for I in Natural loop
+ Type_Index := Get_Nth_Element (Type_Index_List, I);
+ Subtype_Index := Get_Nth_Element (Subtype_Index_List, I);
+ exit when Type_Index = Null_Iir
+ and Subtype_Index = Null_Iir;
+
+ if Type_Index = Null_Iir then
+ Error_Msg_Sem
+ ("subtype has more indexes than "
+ & Disp_Node (Type_Mark)
+ & " defined at " & Disp_Location (Type_Mark),
+ Subtype_Index);
+ -- Forget extra indexes.
+ Set_Nbr_Elements (Subtype_Index_List, I);
+ exit;
+ end if;
+ if Subtype_Index = Null_Iir then
+ if not Error_Seen then
+ Error_Msg_Sem
+ ("subtype has less indexes than "
+ & Disp_Node (Type_Mark)
+ & " defined at "
+ & Disp_Location (Type_Mark), Def);
+ Error_Seen := True;
+ end if;
+ else
+ Subtype_Index := Sem_Discrete_Range_Expression
+ (Subtype_Index, Get_Index_Type (Type_Index), True);
+ if Subtype_Index /= Null_Iir then
+ Subtype_Index :=
+ Range_To_Subtype_Indication (Subtype_Index);
+ Staticness := Min
+ (Staticness,
+ Get_Type_Staticness
+ (Get_Type_Of_Subtype_Indication
+ (Subtype_Index)));
+ end if;
+ end if;
+ if Subtype_Index = Null_Iir then
+ -- Create a fake subtype from type_index.
+ -- FIXME: It is too fake.
+ Subtype_Index := Type_Index;
+ Staticness := None;
+ end if;
+ if Error_Seen then
+ Append_Element (Subtype_Index_List, Subtype_Index);
+ else
+ Replace_Nth_Element
+ (Subtype_Index_List, I, Subtype_Index);
+ end if;
+ end loop;
+ Set_Index_Subtype_List (Def, Subtype_Index_List);
+ Set_Index_Constraint_Flag (Def, True);
+ end if;
+ Set_Type_Staticness (Def, Staticness);
+ Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Type_Mark));
+ Res := Def;
+
+ when others =>
+ -- LRM93 3.2.1.1 / LRM08 5.3.2.2
+ -- Index Constraints and Discrete Ranges
+ --
+ -- If an index constraint appears after a type mark [...]
+ -- The type mark must denote either an unconstrained array
+ -- type, or an access type whose designated type is such
+ -- an array type.
+ Error_Msg_Sem
+ ("only unconstrained array type may be contrained "
+ &"by index", Def);
+ Error_Msg_Sem
+ (" (type mark is " & Disp_Node (Type_Mark) & ")",
+ Type_Mark);
+ return Type_Mark;
+ end case;
+ end if;
+
+ -- Element subtype.
+ if Resolv_El /= Null_Iir or else El_Def /= Null_Iir then
+ El_Def := Sem_Subtype_Constraint (El_Def, El_Type, Resolv_El);
+ end if;
+ if El_Def = Null_Iir then
+ El_Def := Get_Element_Subtype (Type_Mark);
+ end if;
+ Set_Element_Subtype (Res, El_Def);
+
+ Set_Constraint_State (Res, Get_Array_Constraint (Res));
+
+ if Resolv_Func /= Null_Iir then
+ Sem_Resolution_Function (Resolv_Func, Res);
+ elsif Resolv_El /= Null_Iir then
+ Set_Resolution_Indication (Res, Resolution);
+ -- FIXME: may a resolution indication for a record be incomplete ?
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (El_Def));
+ elsif Get_Kind (Type_Mark) = Iir_Kind_Array_Subtype_Definition then
+ Resolv_Ind := Get_Resolution_Indication (Type_Mark);
+ if Resolv_Ind /= Null_Iir then
+ case Get_Kind (Resolv_Ind) is
+ when Iir_Kinds_Denoting_Name =>
+ Error_Kind ("sem_array_constraint(resolution)", Resolv_Ind);
+ when Iir_Kind_Array_Element_Resolution =>
+ -- Already applied to the element.
+ Resolv_Ind := Null_Iir;
+ when others =>
+ Error_Kind ("sem_array_constraint(resolution2)", Resolv_Ind);
+ end case;
+ Set_Resolution_Indication (Res, Resolv_Ind);
+ end if;
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Type_Mark));
+ end if;
+
+ return Res;
+ end Sem_Array_Constraint;
+
+ function Reparse_As_Record_Element_Constraint (Name : Iir) return Iir
+ is
+ Prefix : Iir;
+ Parent : Iir;
+ El : Iir;
+ begin
+ if Get_Kind (Name) /= Iir_Kind_Parenthesis_Name then
+ Error_Msg_Sem ("record element constraint expected", Name);
+ return Null_Iir;
+ else
+ Prefix := Get_Prefix (Name);
+ Parent := Name;
+ while Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name loop
+ Parent := Prefix;
+ Prefix := Get_Prefix (Prefix);
+ end loop;
+ if Get_Kind (Prefix) /= Iir_Kind_Simple_Name then
+ Error_Msg_Sem ("record element name must be a simple name",
+ Prefix);
+ return Null_Iir;
+ else
+ El := Create_Iir (Iir_Kind_Record_Element_Constraint);
+ Location_Copy (El, Prefix);
+ Set_Identifier (El, Get_Identifier (Prefix));
+ Set_Type (El, Name);
+ Set_Prefix (Parent, Null_Iir);
+ Free_Name (Prefix);
+ return El;
+ end if;
+ end if;
+ end Reparse_As_Record_Element_Constraint;
+
+ function Reparse_As_Record_Constraint (Def : Iir) return Iir
+ is
+ Res : Iir;
+ Chain : Iir;
+ El_List : Iir_List;
+ El : Iir;
+ begin
+ if Get_Prefix (Def) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Location_Copy (Res, Def);
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ Chain := Get_Association_Chain (Def);
+ while Chain /= Null_Iir loop
+ if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression
+ or else Get_Formal (Chain) /= Null_Iir
+ then
+ Error_Msg_Sem ("badly formed record constraint", Chain);
+ else
+ El := Reparse_As_Record_Element_Constraint (Get_Actual (Chain));
+ if El /= Null_Iir then
+ Append_Element (El_List, El);
+ end if;
+ end if;
+ Chain := Get_Chain (Chain);
+ end loop;
+ return Res;
+ end Reparse_As_Record_Constraint;
+
+ function Reparse_As_Array_Constraint (Def : Iir; Def_Type : Iir) return Iir
+ is
+ Parent : Iir;
+ Name : Iir;
+ Prefix : Iir;
+ Res : Iir;
+ Chain : Iir;
+ El_List : Iir_List;
+ Def_El_Type : Iir;
+ begin
+ Name := Def;
+ Prefix := Get_Prefix (Name);
+ Parent := Null_Iir;
+ while Prefix /= Null_Iir
+ and then Get_Kind (Prefix) = Iir_Kind_Parenthesis_Name
+ loop
+ Parent := Name;
+ Name := Prefix;
+ Prefix := Get_Prefix (Name);
+ end loop;
+ -- Detach prefix.
+ if Parent /= Null_Iir then
+ Set_Prefix (Parent, Null_Iir);
+ end if;
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Location_Copy (Res, Name);
+ Chain := Get_Association_Chain (Name);
+ if Get_Kind (Chain) = Iir_Kind_Association_Element_Open then
+ if Get_Chain (Chain) /= Null_Iir then
+ Error_Msg_Sem ("'open' must be alone", Chain);
+ end if;
+ else
+ El_List := Create_Iir_List;
+ Set_Index_Constraint_List (Res, El_List);
+ while Chain /= Null_Iir loop
+ if Get_Kind (Chain) /= Iir_Kind_Association_Element_By_Expression
+ or else Get_Formal (Chain) /= Null_Iir
+ then
+ Error_Msg_Sem ("bad form of array constraint", Chain);
+ else
+ Append_Element (El_List, Get_Actual (Chain));
+ end if;
+ Chain := Get_Chain (Chain);
+ end loop;
+ end if;
+
+ Def_El_Type := Get_Element_Subtype (Def_Type);
+ if Parent /= Null_Iir then
+ case Get_Kind (Def_El_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ Set_Element_Subtype_Indication
+ (Res, Reparse_As_Array_Constraint (Def, Def_El_Type));
+ when others =>
+ Error_Kind ("reparse_as_array_constraint", Def_El_Type);
+ end case;
+ end if;
+ return Res;
+ end Reparse_As_Array_Constraint;
+
+ function Sem_Record_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ Res : Iir;
+ El_List, Tm_El_List : Iir_List;
+ El : Iir;
+ Tm_El : Iir;
+ Tm_El_Type : Iir;
+ El_Type : Iir;
+ Res_List : Iir_List;
+
+ Index_List : Iir_List;
+ Index_El : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Type_Mark));
+ Set_Type_Staticness (Res, Get_Type_Staticness (Type_Mark));
+ if Get_Kind (Type_Mark) = Iir_Kind_Record_Subtype_Definition then
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Type_Mark));
+ end if;
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ Free_Name (Def);
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+ Set_Constraint_State (Res, Get_Constraint_State (Type_Mark));
+ El_List := Null_Iir_List;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- Record constraints are parsed as array constraints.
+ if Get_Kind (Def) /= Iir_Kind_Array_Subtype_Definition then
+ raise Internal_Error;
+ end if;
+ Index_List := Get_Index_Constraint_List (Def);
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ for I in Natural loop
+ Index_El := Get_Nth_Element (Index_List, I);
+ exit when Index_El = Null_Iir;
+ El := Reparse_As_Record_Element_Constraint (Index_El);
+ if El /= Null_Iir then
+ Append_Element (El_List, El);
+ end if;
+ end loop;
+
+ when Iir_Kind_Record_Subtype_Definition =>
+ El_List := Get_Elements_Declaration_List (Def);
+ Set_Elements_Declaration_List (Res, El_List);
+
+ when others =>
+ Error_Kind ("sem_record_constraint", Def);
+ end case;
+
+ Res_List := Null_Iir_List;
+ if Resolution /= Null_Iir then
+ case Get_Kind (Resolution) is
+ when Iir_Kinds_Denoting_Name =>
+ null;
+ when Iir_Kind_Record_Subtype_Definition =>
+ Res_List := Get_Elements_Declaration_List (Resolution);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Error_Msg_Sem
+ ("resolution indication must be an array element resolution",
+ Resolution);
+ when others =>
+ Error_Kind ("sem_record_constraint(resolution)", Resolution);
+ end case;
+ end if;
+
+ Tm_El_List := Get_Elements_Declaration_List (Type_Mark);
+ if El_List /= Null_Iir_List or Res_List /= Null_Iir_List then
+ declare
+ Nbr_Els : constant Natural := Get_Nbr_Elements (Tm_El_List);
+ Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir);
+ Res_Els : Iir_Array (0 .. Nbr_Els - 1) := (others => Null_Iir);
+ Pos : Natural;
+ Constraint : Iir_Constraint;
+ begin
+ -- Fill ELS.
+ if El_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El));
+ if Tm_El = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Type_Mark)
+ & "has no " & Disp_Node (El), El);
+ else
+ Set_Element_Declaration (El, Tm_El);
+ Pos := Natural (Get_Element_Position (Tm_El));
+ if Els (Pos) /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (El) & " was already constrained", El);
+ Error_Msg_Sem
+ (" (location of previous constrained)", Els (Pos));
+ else
+ Els (Pos) := El;
+ Set_Parent (El, Res);
+ end if;
+ El_Type := Get_Type (El);
+ Tm_El_Type := Get_Type (Tm_El);
+ if Get_Kind (El_Type) = Iir_Kind_Parenthesis_Name then
+ case Get_Kind (Tm_El_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ El_Type := Reparse_As_Array_Constraint
+ (El_Type, Tm_El_Type);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ El_Type := Reparse_As_Record_Constraint
+ (El_Type);
+ when others =>
+ Error_Msg_Sem
+ ("only composite types may be constrained",
+ El_Type);
+ end case;
+ end if;
+ Set_Type (El, El_Type);
+ end if;
+ end loop;
+ Destroy_Iir_List (El_List);
+ end if;
+
+ -- Fill Res_Els.
+ if Res_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Res_List, I);
+ exit when El = Null_Iir;
+ Tm_El := Find_Name_In_List (Tm_El_List, Get_Identifier (El));
+ if Tm_El = Null_Iir then
+ Error_Msg_Sem (Disp_Node (Type_Mark)
+ & "has no " & Disp_Node (El), El);
+ else
+ Pos := Natural (Get_Element_Position (Tm_El));
+ if Res_Els (Pos) /= Null_Iir then
+ Error_Msg_Sem
+ (Disp_Node (El) & " was already resolved", El);
+ Error_Msg_Sem
+ (" (location of previous constrained)", Els (Pos));
+ else
+ Res_Els (Pos) := Get_Element_Declaration (El);
+ end if;
+ end if;
+ --Free_Iir (El);
+ end loop;
+ Destroy_Iir_List (Res_List);
+ end if;
+
+ -- Build elements list.
+ El_List := Create_Iir_List;
+ Set_Elements_Declaration_List (Res, El_List);
+ Constraint := Fully_Constrained;
+ for I in Els'Range loop
+ Tm_El := Get_Nth_Element (Tm_El_List, I);
+ if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then
+ El := Tm_El;
+ else
+ if Els (I) = Null_Iir then
+ El := Create_Iir (Iir_Kind_Record_Element_Constraint);
+ Location_Copy (El, Tm_El);
+ Set_Element_Declaration (El, Tm_El);
+ Set_Element_Position (El, Get_Element_Position (Tm_El));
+ El_Type := Null_Iir;
+ else
+ El := Els (I);
+ El_Type := Get_Type (El);
+ end if;
+ El_Type := Sem_Subtype_Constraint (El_Type,
+ Get_Type (Tm_El),
+ Res_Els (I));
+ Set_Type (El, El_Type);
+ end if;
+ Append_Element (El_List, El);
+ Constraint := Update_Record_Constraint
+ (Constraint, Get_Type (El));
+ end loop;
+ Set_Constraint_State (Res, Constraint);
+ end;
+ else
+ Set_Elements_Declaration_List (Res, Tm_El_List);
+ Set_Constraint_State (Res, Get_Constraint_State (Type_Mark));
+ end if;
+
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+
+ if Resolution /= Null_Iir
+ and then Get_Kind (Resolution) in Iir_Kinds_Denoting_Name
+ then
+ Sem_Resolution_Function (Resolution, Res);
+ end if;
+
+ return Res;
+ end Sem_Record_Constraint;
+
+ -- Return a scalar subtype definition (even in case of error).
+ function Sem_Range_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir
+ is
+ Res : Iir;
+ A_Range : Iir;
+ Tolerance : Iir;
+ begin
+ if Def = Null_Iir then
+ Res := Copy_Subtype_Indication (Type_Mark);
+ elsif Get_Kind (Def) /= Iir_Kind_Subtype_Definition then
+ -- FIXME: find the correct sentence from LRM
+ -- GHDL: subtype_definition may also be used just to add
+ -- a resolution function.
+ Error_Msg_Sem ("only scalar types may be constrained by range", Def);
+ Error_Msg_Sem (" (type mark is " & Disp_Node (Type_Mark) & ")",
+ Type_Mark);
+ Res := Copy_Subtype_Indication (Type_Mark);
+ else
+ Tolerance := Get_Tolerance (Def);
+
+ if Get_Range_Constraint (Def) = Null_Iir
+ and then Resolution = Null_Iir
+ and then Tolerance = Null_Iir
+ then
+ -- This defines an alias, and must have been handled just
+ -- before the case statment.
+ raise Internal_Error;
+ end if;
+
+ -- There are limits. Create a new subtype.
+ if Get_Kind (Type_Mark) = Iir_Kind_Enumeration_Type_Definition then
+ Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ else
+ Res := Create_Iir (Get_Kind (Type_Mark));
+ end if;
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Type_Mark));
+ Set_Resolution_Indication (Res, Get_Resolution_Indication (Def));
+ A_Range := Get_Range_Constraint (Def);
+ if A_Range = Null_Iir then
+ A_Range := Get_Range_Constraint (Type_Mark);
+ else
+ A_Range := Sem_Range_Expression (A_Range, Type_Mark, True);
+ if A_Range = Null_Iir then
+ -- Avoid error propagation.
+ A_Range := Get_Range_Constraint (Type_Mark);
+ end if;
+ end if;
+ Set_Range_Constraint (Res, A_Range);
+ Set_Type_Staticness (Res, Get_Expr_Staticness (A_Range));
+ Free_Name (Def);
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Type_Mark));
+ if Tolerance /= Null_Iir then
+ -- LRM93 4.2 Subtype declarations
+ -- It is an error in this case the subtype is not a nature
+ -- type
+ --
+ -- FIXME: should be moved into sem_subtype_indication
+ if Get_Kind (Res) /= Iir_Kind_Floating_Subtype_Definition then
+ Error_Msg_Sem ("tolerance allowed only for floating subtype",
+ Tolerance);
+ else
+ -- LRM93 4.2 Subtype declarations
+ -- If the subtype indication includes a tolerance aspect, then
+ -- the string expression must be a static expression
+ Tolerance := Sem_Expression (Tolerance, String_Type_Definition);
+ if Tolerance /= Null_Iir
+ and then Get_Expr_Staticness (Tolerance) /= Locally
+ then
+ Error_Msg_Sem ("tolerance must be a static string",
+ Tolerance);
+ end if;
+ Set_Tolerance (Res, Tolerance);
+ end if;
+ end if;
+ end if;
+
+ if Resolution /= Null_Iir then
+ -- LRM08 6.3 Subtype declarations.
+ if Get_Kind (Resolution) not in Iir_Kinds_Denoting_Name then
+ Error_Msg_Sem ("resolution indication must be a function name",
+ Resolution);
+ else
+ Sem_Resolution_Function (Resolution, Res);
+ end if;
+ end if;
+ return Res;
+ end Sem_Range_Constraint;
+
+ function Sem_Subtype_Constraint
+ (Def : Iir; Type_Mark : Iir; Resolution : Iir)
+ return Iir is
+ begin
+ case Get_Kind (Type_Mark) is
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ return Sem_Array_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition=>
+ return Sem_Range_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Sem_Record_Constraint (Def, Type_Mark, Resolution);
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ -- LRM93 4.2
+ -- A subtype indication denoting an access type [or a file type]
+ -- may not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for an access type", Def);
+ end if;
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Subtype_Definition =>
+ Free_Name (Def);
+ return Copy_Subtype_Indication (Type_Mark);
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- LRM93 3.3
+ -- The only form of constraint that is allowed after a name
+ -- of an access type in a subtype indication is an index
+ -- constraint.
+ declare
+ Sub_Type : Iir;
+ Base_Type : Iir;
+ Res : Iir;
+ begin
+ Base_Type := Get_Designated_Type (Type_Mark);
+ Sub_Type := Sem_Array_Constraint
+ (Def, Base_Type, Null_Iir);
+ Res := Create_Iir (Iir_Kind_Access_Subtype_Definition);
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Type_Mark);
+ Set_Designated_Subtype_Indication (Res, Sub_Type);
+ Set_Signal_Type_Flag (Res, False);
+ return Res;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Kind_File_Type_Definition =>
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting a subtype of [...] a file
+ -- type [...] shall not contain a constraint.
+ if Get_Kind (Def) /= Iir_Kind_Subtype_Definition
+ or else Get_Range_Constraint (Def) /= Null_Iir
+ then
+ Error_Msg_Sem ("file types can't be constrained", Def);
+ return Type_Mark;
+ end if;
+
+ -- LRM93 4.2
+ -- A subtype indication denoting [an access type or] a file type
+ -- may not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for file types", Def);
+ return Type_Mark;
+ end if;
+ Free_Name (Def);
+ return Type_Mark;
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting a subtype of [...] a protected
+ -- type [...] shall not contain a constraint.
+ if Get_Kind (Def) /= Iir_Kind_Subtype_Definition
+ or else Get_Range_Constraint (Def) /= Null_Iir
+ then
+ Error_Msg_Sem ("protected types can't be constrained", Def);
+ return Type_Mark;
+ end if;
+
+ -- LRM08 6.3 Subtype declarations
+ -- A subtype indication denoting [...] a protected type shall
+ -- not contain a resolution function.
+ if Resolution /= Null_Iir then
+ Error_Msg_Sem
+ ("resolution function not allowed for file types", Def);
+ return Type_Mark;
+ end if;
+ Free_Name (Def);
+ return Type_Mark;
+
+ when others =>
+ Error_Kind ("sem_subtype_constraint", Type_Mark);
+ return Type_Mark;
+ end case;
+ end Sem_Subtype_Constraint;
+
+ function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False)
+ return Iir
+ is
+ Type_Mark_Name : Iir;
+ Type_Mark: Iir;
+ Res : Iir;
+ begin
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- If the subtype indication does not include a constraint, the subtype
+ -- is the same as that denoted by the type mark.
+ if Get_Kind (Def) in Iir_Kinds_Denoting_Name then
+ Type_Mark := Sem_Type_Mark (Def, Incomplete);
+ return Type_Mark;
+ end if;
+
+ -- Semantize the type mark.
+ Type_Mark_Name := Get_Subtype_Type_Mark (Def);
+ Type_Mark_Name := Sem_Type_Mark (Type_Mark_Name);
+ Set_Subtype_Type_Mark (Def, Type_Mark_Name);
+ Type_Mark := Get_Type (Type_Mark_Name);
+ -- FIXME: incomplete type ?
+ if Get_Kind (Type_Mark) = Iir_Kind_Error then
+ -- FIXME: handle inversion such as "subtype BASETYPE RESOLV", which
+ -- should emit "resolution function must precede type name".
+
+ -- Discard the subtype definition and only keep the type mark.
+ return Type_Mark_Name;
+ end if;
+
+ Res := Sem_Subtype_Constraint
+ (Def, Type_Mark, Get_Resolution_Indication (Def));
+ Set_Subtype_Type_Mark (Res, Type_Mark_Name);
+ return Res;
+ end Sem_Subtype_Indication;
+
+ function Copy_Subtype_Indication (Def : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Res := Create_Iir (Get_Kind (Def));
+ Set_Range_Constraint (Res, Get_Range_Constraint (Def));
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Def));
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ Set_Range_Constraint (Res, Get_Range_Constraint (Def));
+
+ when Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Access_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Access_Subtype_Definition);
+ Set_Designated_Type (Res, Get_Designated_Type (Def));
+
+ when Iir_Kind_Array_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Index_Constraint_List (Res, Null_Iir_List);
+ Set_Index_Subtype_List
+ (Res, Get_Index_Subtype_Definition_List (Def));
+ Set_Element_Subtype (Res, Get_Element_Subtype (Def));
+ Set_Index_Constraint_Flag (Res, False);
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+ when Iir_Kind_Array_Subtype_Definition =>
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Resolution_Indication (Res, Get_Resolution_Indication (Def));
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Def));
+ Set_Element_Subtype (Res, Get_Element_Subtype (Def));
+ Set_Index_Constraint_Flag
+ (Res, Get_Index_Constraint_Flag (Def));
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ if Get_Kind (Def) = Iir_Kind_Record_Subtype_Definition then
+ Set_Resolution_Indication
+ (Res, Get_Resolution_Indication (Def));
+ end if;
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Def));
+ Set_Constraint_State (Res, Get_Constraint_State (Def));
+ Set_Elements_Declaration_List
+ (Res, Get_Elements_Declaration_List (Def));
+ when others =>
+ -- FIXME: todo (protected type ?)
+ Error_Kind ("copy_subtype_indication", Def);
+ end case;
+ Location_Copy (Res, Def);
+ Set_Base_Type (Res, Get_Base_Type (Def));
+ Set_Type_Staticness (Res, Get_Type_Staticness (Def));
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Def));
+ return Res;
+ end Copy_Subtype_Indication;
+
+ function Sem_Subnature_Indication (Def: Iir) return Iir
+ is
+ Nature_Mark: Iir;
+ Res : Iir;
+ begin
+ -- LRM 4.8 Nature declatation
+ --
+ -- If the subnature indication does not include a constraint, the
+ -- subnature is the same as that denoted by the type mark.
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ -- Used for reference declared by a nature
+ return Def;
+ when Iir_Kinds_Denoting_Name =>
+ Nature_Mark := Sem_Denoting_Name (Def);
+ Res := Get_Named_Entity (Nature_Mark);
+ if Get_Kind (Res) /= Iir_Kind_Scalar_Nature_Definition then
+ Error_Class_Match (Nature_Mark, "nature");
+ raise Program_Error; -- TODO
+ else
+ return Nature_Mark;
+ end if;
+ when others =>
+ raise Program_Error; -- TODO
+ end case;
+ end Sem_Subnature_Indication;
+
+end Sem_Types;
diff --git a/src/sem_types.ads b/src/sem_types.ads
new file mode 100644
index 000000000..8eb7de108
--- /dev/null
+++ b/src/sem_types.ads
@@ -0,0 +1,57 @@
+-- Semantic analysis.
+-- 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 Sem_Types is
+ -- Semantization of types (LRM93 3 / LRM08 5)
+
+ -- Semantize subtype indication DEF.
+ -- If INCOMPLETE is TRUE, then DEF may designate an incomplete type
+ -- definition. Return either a name (denoting a type) or an anonymous
+ -- subtype definition.
+ function Sem_Subtype_Indication (Def: Iir; Incomplete : Boolean := False)
+ return Iir;
+
+ procedure Sem_Protected_Type_Body (Bod : Iir);
+
+ function Sem_Type_Definition (Def: Iir; Decl: Iir) return Iir;
+
+ -- If A_RANGE is a range (range expression or range attribute), convert it
+ -- to a subtype definition. Otherwise return A_RANGE.
+ -- The result is a subtype indication: either a type name or a subtype
+ -- definition.
+ function Range_To_Subtype_Indication (A_Range: Iir) return Iir;
+
+ -- ATYPE is used to declare a signal.
+ -- Set (recursively) the Has_Signal_Flag on ATYPE and all types used by
+ -- ATYPE (basetype, elements...)
+ -- If ATYPE can have signal (eg: access or file type), then this procedure
+ -- returns silently.
+ procedure Set_Type_Has_Signal (Atype : Iir);
+
+ -- Return TRUE iff FUNC is a resolution function.
+ -- If ATYPE is not NULL_IIR, type must match.
+ function Is_A_Resolution_Function (Func: Iir; Atype: Iir) return Boolean;
+
+ -- Return a subtype definition copy of DEF.
+ -- This is used when an alias of DEF is required (eg: subtype a is b).
+ function Copy_Subtype_Indication (Def : Iir) return Iir;
+
+ -- Although a nature is not a type, it is patterned like a type.
+ function Sem_Subnature_Indication (Def: Iir) return Iir;
+end Sem_Types;
diff --git a/src/simulate/annotations.adb b/src/simulate/annotations.adb
new file mode 100644
index 000000000..d07a99818
--- /dev/null
+++ b/src/simulate/annotations.adb
@@ -0,0 +1,1236 @@
+-- Annotations for interpreted simulation
+-- 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 GNAT.Table;
+with Ada.Text_IO;
+with Std_Package;
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Annotations is
+ -- Current scope level.
+ Current_Scope_Level: Scope_Level_Type := Scope_Level_Global;
+
+ procedure Annotate_Declaration_List
+ (Block_Info: Sim_Info_Acc; Decl_Chain: Iir);
+ procedure Annotate_Sequential_Statement_Chain
+ (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir);
+ procedure Annotate_Concurrent_Statements_List
+ (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir);
+ procedure Annotate_Block_Configuration
+ (Block : Iir_Block_Configuration);
+ procedure Annotate_Subprogram_Interfaces_Type
+ (Block_Info : Sim_Info_Acc; Subprg: Iir);
+ procedure Annotate_Subprogram_Specification
+ (Block_Info : Sim_Info_Acc; Subprg: Iir);
+
+ procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir);
+
+ -- Annotate type definition DEF only if it is anonymous.
+ procedure Annotate_Anonymous_Type_Definition
+ (Block_Info: Sim_Info_Acc; Def: Iir);
+
+ -- Be sure the node contains no informations.
+ procedure Assert_No_Info (Node: in Iir) is
+ begin
+ if Get_Info (Node) /= null then
+ raise Internal_Error;
+ end if;
+ end Assert_No_Info;
+
+ procedure Increment_Current_Scope_Level is
+ begin
+ if Current_Scope_Level < Scope_Level_Global then
+ -- For a subprogram in a package
+ Current_Scope_Level := Scope_Level_Global + 1;
+ else
+ Current_Scope_Level := Current_Scope_Level + 1;
+ end if;
+ end Increment_Current_Scope_Level;
+
+ -- Add an annotation to object OBJ.
+ procedure Create_Object_Info
+ (Block_Info : Sim_Info_Acc;
+ Obj : Iir;
+ Obj_Kind : Sim_Info_Kind := Kind_Object)
+ is
+ Info : Sim_Info_Acc;
+ begin
+ Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1;
+ case Obj_Kind is
+ when Kind_Object =>
+ Info := new Sim_Info_Type'(Kind => Kind_Object,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_File =>
+ Info := new Sim_Info_Type'(Kind => Kind_File,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_Signal =>
+ Info := new Sim_Info_Type'(Kind => Kind_Signal,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ -- Reserve one more slot for default value.
+ Block_Info.Nbr_Objects := Block_Info.Nbr_Objects + 1;
+ when Kind_Terminal =>
+ Info := new Sim_Info_Type'(Kind => Kind_Terminal,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when Kind_Quantity =>
+ Info := new Sim_Info_Type'(Kind => Kind_Quantity,
+ Scope_Level => Current_Scope_Level,
+ Slot => Block_Info.Nbr_Objects);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Set_Info (Obj, Info);
+ end Create_Object_Info;
+
+ -- Add an annotation to SIGNAL.
+ procedure Add_Signal_Info (Block_Info: Sim_Info_Acc; Signal: Iir) is
+ begin
+ Create_Object_Info (Block_Info, Signal, Kind_Signal);
+ end Add_Signal_Info;
+
+ procedure Add_Terminal_Info (Block_Info: Sim_Info_Acc; Terminal : Iir) is
+ begin
+ Create_Object_Info (Block_Info, Terminal, Kind_Terminal);
+ end Add_Terminal_Info;
+
+ procedure Add_Quantity_Info (Block_Info: Sim_Info_Acc; Quantity : Iir) is
+ begin
+ Create_Object_Info (Block_Info, Quantity, Kind_Quantity);
+ end Add_Quantity_Info;
+
+ -- If EXPR has not a literal value, create one.
+ -- This is necessary for subtype bounds.
+ procedure Annotate_Range_Expression
+ (Block_Info: Sim_Info_Acc; Expr: Iir_Range_Expression)
+ is
+ begin
+ if Get_Info (Expr) /= null then
+ return;
+ end if;
+ Assert_No_Info (Expr);
+-- if Expr = null or else Get_Info (Expr) /= null then
+-- return;
+-- end if;
+ Create_Object_Info (Block_Info, Expr);
+ end Annotate_Range_Expression;
+
+ -- Annotate type definition DEF only if it is anonymous.
+ procedure Annotate_Anonymous_Type_Definition
+ (Block_Info: Sim_Info_Acc; Def: Iir)
+ is
+ begin
+ if Is_Anonymous_Type_Definition (Def) then
+ Annotate_Type_Definition (Block_Info, Def);
+ end if;
+ end Annotate_Anonymous_Type_Definition;
+
+ function Get_File_Signature_Length (Def : Iir) return Natural is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ return 1;
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ return 2
+ + Get_File_Signature_Length (Get_Element_Subtype (Def));
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir;
+ Res : Natural;
+ List : Iir_List;
+ begin
+ Res := 2;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Res := Res + Get_File_Signature_Length (Get_Type (El));
+ end loop;
+ return Res;
+ end;
+ when others =>
+ Error_Kind ("get_file_signature_length", Def);
+ end case;
+ end Get_File_Signature_Length;
+
+ procedure Get_File_Signature (Def : Iir;
+ Res : in out String;
+ Off : in out Natural)
+ is
+ Scalar_Map : constant array (Iir_Value_Scalars) of Character := "bEIF";
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ Res (Off) :=
+ Scalar_Map (Get_Info (Get_Base_Type (Def)).Scalar_Mode);
+ Off := Off + 1;
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ Res (Off) := '[';
+ Off := Off + 1;
+ Get_File_Signature (Get_Element_Subtype (Def), Res, Off);
+ Res (Off) := ']';
+ Off := Off + 1;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir;
+ List : Iir_List;
+ begin
+ Res (Off) := '<';
+ Off := Off + 1;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Get_File_Signature (Get_Type (El), Res, Off);
+ end loop;
+ Res (Off) := '>';
+ Off := Off + 1;
+ end;
+ when others =>
+ Error_Kind ("get_file_signature", Def);
+ end case;
+ end Get_File_Signature;
+
+ procedure Annotate_Protected_Type_Declaration (Block_Info : Sim_Info_Acc;
+ Prot: Iir)
+ is
+ Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level;
+ Decl : Iir;
+ begin
+ -- First the interfaces type (they are elaborated in their context).
+ Decl := Get_Declaration_Chain (Prot);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Annotate_Subprogram_Interfaces_Type (Block_Info, Decl);
+ when Iir_Kind_Use_Clause =>
+ null;
+ when others =>
+ -- FIXME: attribute
+ Error_Kind ("annotate_protected_type_declaration", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+
+ -- Then the interfaces object. Increment the scope to reserve a scope
+ -- for the protected object.
+ Increment_Current_Scope_Level;
+
+ Decl := Get_Declaration_Chain (Prot);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Annotate_Subprogram_Specification (Block_Info, Decl);
+ when Iir_Kind_Use_Clause =>
+ null;
+ when others =>
+ Error_Kind ("annotate_protected_type_declaration", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Protected_Type_Declaration;
+
+ procedure Annotate_Protected_Type_Body (Block_Info : Sim_Info_Acc;
+ Prot: Iir)
+ is
+ pragma Unreferenced (Block_Info);
+ Prot_Info: Sim_Info_Acc;
+ Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ Increment_Current_Scope_Level;
+
+ Assert_No_Info (Prot);
+
+ Prot_Info :=
+ new Sim_Info_Type'(Kind => Kind_Frame,
+ Inst_Slot => 0,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Prot, Prot_Info);
+
+ Annotate_Declaration_List
+ (Prot_Info, Get_Declaration_Chain (Prot));
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Protected_Type_Body;
+
+ procedure Annotate_Type_Definition (Block_Info: Sim_Info_Acc; Def: Iir)
+ is
+ El: Iir;
+ begin
+ -- Happen only with universal types.
+ if Def = Null_Iir then
+ return;
+ end if;
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ if Def = Std_Package.Boolean_Type_Definition
+ or else Def = Std_Package.Bit_Type_Definition
+ then
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_B1));
+ else
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_E32));
+ end if;
+ Annotate_Range_Expression (Block_Info, Get_Range_Constraint (Def));
+
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ El := Get_Range_Constraint (Def);
+ if El /= Null_Iir then
+ case Get_Kind (El) is
+ when Iir_Kind_Range_Expression =>
+ Annotate_Range_Expression (Block_Info, El);
+ -- A physical subtype may be defined by an integer range.
+ if Get_Kind (Def) = Iir_Kind_Physical_Subtype_Definition
+ then
+ null;
+ -- FIXME
+ -- Convert_Int_To_Phys (Get_Info (El).Value);
+ end if;
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ null;
+ when others =>
+ Error_Kind ("annotate_type_definition (rc)", El);
+ end case;
+ end if;
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Base_Type (Def));
+
+ when Iir_Kind_Integer_Type_Definition =>
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_I64));
+
+ when Iir_Kind_Floating_Type_Definition =>
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_F64));
+
+ when Iir_Kind_Physical_Type_Definition =>
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_Scalar_Type,
+ Scalar_Mode => Iir_Value_I64));
+
+ when Iir_Kind_Array_Type_Definition =>
+ El := Get_Element_Subtype (Def);
+ Annotate_Anonymous_Type_Definition (Block_Info, El);
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ declare
+ List : constant Iir_List := Get_Index_Subtype_List (Def);
+ begin
+ for I in Natural loop
+ El := Get_Index_Type (List, I);
+ exit when El = Null_Iir;
+ Annotate_Anonymous_Type_Definition (Block_Info, El);
+ end loop;
+ end;
+
+ when Iir_Kind_Record_Type_Definition =>
+ declare
+ List : constant Iir_List := Get_Elements_Declaration_List (Def);
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Type (El));
+ end loop;
+ end;
+
+ when Iir_Kind_Record_Subtype_Definition =>
+ null;
+
+ when Iir_Kind_Access_Type_Definition =>
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Designated_Type (Def));
+
+ when Iir_Kind_Access_Subtype_Definition =>
+ null;
+
+ when Iir_Kind_File_Type_Definition =>
+ declare
+ Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def));
+ Res : String_Acc;
+ begin
+ if Get_Text_File_Flag (Def)
+ or else
+ Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition
+ then
+ Res := null;
+ else
+ declare
+ Sig : String
+ (1 .. Get_File_Signature_Length (Type_Name) + 2);
+ Off : Natural := Sig'First;
+ begin
+ Get_File_Signature (Type_Name, Sig, Off);
+ Sig (Off + 0) := '.';
+ Sig (Off + 1) := ASCII.NUL;
+ Res := new String'(Sig);
+ end;
+ end if;
+ Set_Info (Def,
+ new Sim_Info_Type'(Kind => Kind_File_Type,
+ File_Signature => Res));
+ end;
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ Annotate_Protected_Type_Declaration (Block_Info, Def);
+
+ when Iir_Kind_Incomplete_Type_Definition =>
+ null;
+
+ when others =>
+ Error_Kind ("annotate_type_definition", Def);
+ end case;
+ end Annotate_Type_Definition;
+
+ procedure Annotate_Interface_List_Subtype
+ (Block_Info: Sim_Info_Acc; Decl_Chain: Iir)
+ is
+ El: Iir;
+ begin
+ El := Decl_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El));
+ when Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (El));
+ when others =>
+ Error_Kind ("annotate_interface_list", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Annotate_Interface_List_Subtype;
+
+ procedure Annotate_Create_Interface_List
+ (Block_Info: Sim_Info_Acc; Decl_Chain: Iir; With_Types : Boolean)
+ is
+ Decl : Iir;
+ N : Object_Slot_Type;
+ begin
+ Decl := Decl_Chain;
+ while Decl /= Null_Iir loop
+ if With_Types then
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ end if;
+ Assert_No_Info (Decl);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Add_Signal_Info (Block_Info, Decl);
+ when Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Create_Object_Info (Block_Info, Decl);
+ when others =>
+ Error_Kind ("annotate_create_interface_list", Decl);
+ end case;
+ N := Block_Info.Nbr_Objects;
+ -- Annotation of the default value must not create objects.
+ -- FIXME: Is it true ???
+ if Block_Info.Nbr_Objects /= N then
+ raise Internal_Error;
+ end if;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Annotate_Create_Interface_List;
+
+ procedure Annotate_Subprogram_Interfaces_Type
+ (Block_Info : Sim_Info_Acc; Subprg: Iir)
+ is
+ Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg);
+ begin
+ -- See LRM93 12.3.1.1 (Subprogram declarations and bodies). The type
+ -- of the interfaces are elaborated in the outer context.
+ Annotate_Interface_List_Subtype (Block_Info, Interfaces);
+
+ if Get_Kind (Subprg) in Iir_Kinds_Function_Declaration then
+ -- FIXME: can this create a new annotation ?
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Return_Type (Subprg));
+ end if;
+ end Annotate_Subprogram_Interfaces_Type;
+
+ procedure Annotate_Subprogram_Specification
+ (Block_Info : Sim_Info_Acc; Subprg: Iir)
+ is
+ pragma Unreferenced (Block_Info);
+ Subprg_Info: Sim_Info_Acc;
+ Interfaces : constant Iir := Get_Interface_Declaration_Chain (Subprg);
+ Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ Increment_Current_Scope_Level;
+
+ Assert_No_Info (Subprg);
+
+ Subprg_Info :=
+ new Sim_Info_Type'(Kind => Kind_Frame,
+ Inst_Slot => 0,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Subprg, Subprg_Info);
+
+ Annotate_Create_Interface_List (Subprg_Info, Interfaces, False);
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Subprogram_Specification;
+
+ procedure Annotate_Subprogram_Body
+ (Block_Info : Sim_Info_Acc; Subprg: Iir)
+ is
+ pragma Unreferenced (Block_Info);
+ Spec : constant Iir := Get_Subprogram_Specification (Subprg);
+ Subprg_Info : constant Sim_Info_Acc := Get_Info (Spec);
+ Prev_Scope_Level : constant Scope_Level_Type := Current_Scope_Level;
+ begin
+ -- Do not annotate body of foreign subprograms.
+ if Get_Foreign_Flag (Spec) then
+ return;
+ end if;
+
+ Current_Scope_Level := Subprg_Info.Frame_Scope_Level;
+
+ Annotate_Declaration_List
+ (Subprg_Info, Get_Declaration_Chain (Subprg));
+
+ Annotate_Sequential_Statement_Chain
+ (Subprg_Info, Get_Sequential_Statement_Chain (Subprg));
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Subprogram_Body;
+
+ procedure Annotate_Component_Declaration
+ (Comp: Iir_Component_Declaration)
+ is
+ Info: Sim_Info_Acc;
+ Prev_Scope_Level : Scope_Level_Type;
+ begin
+ Prev_Scope_Level := Current_Scope_Level;
+ Current_Scope_Level := Scope_Level_Component;
+
+ Assert_No_Info (Comp);
+
+ Info := new Sim_Info_Type'(Kind => Kind_Frame,
+ Inst_Slot => Invalid_Instance_Slot,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 1); -- For the instance.
+ Set_Info (Comp, Info);
+
+ Annotate_Create_Interface_List (Info, Get_Generic_Chain (Comp), True);
+ Annotate_Create_Interface_List (Info, Get_Port_Chain (Comp), True);
+
+ Current_Scope_Level := Prev_Scope_Level;
+ end Annotate_Component_Declaration;
+
+ procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Signal_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Add_Signal_Info (Block_Info, Decl);
+
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Iterator_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl);
+
+ when Iir_Kind_Constant_Declaration =>
+ if Get_Deferred_Declaration (Decl) = Null_Iir
+ or else Get_Deferred_Declaration_Flag (Decl)
+ then
+ -- Create the slot only if the constant is not a full constant
+ -- declaration.
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition
+ (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl);
+ else
+ Set_Info (Decl, Get_Info (Get_Deferred_Declaration (Decl)));
+ end if;
+
+ when Iir_Kind_File_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl, Kind_File);
+
+ when Iir_Kind_Terminal_Declaration =>
+ Assert_No_Info (Decl);
+ Add_Terminal_Info (Block_Info, Decl);
+ when Iir_Kinds_Branch_Quantity_Declaration =>
+ Assert_No_Info (Decl);
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Add_Quantity_Info (Block_Info, Decl);
+
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ Annotate_Type_Definition (Block_Info, Get_Type_Definition (Decl));
+ when Iir_Kind_Subtype_Declaration =>
+ Annotate_Type_Definition (Block_Info, Get_Type (Decl));
+
+ when Iir_Kind_Protected_Type_Body =>
+ Annotate_Protected_Type_Body (Block_Info, Decl);
+
+ when Iir_Kind_Component_Declaration =>
+ Annotate_Component_Declaration (Decl);
+
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if not Is_Second_Subprogram_Specification (Decl) then
+ Annotate_Subprogram_Interfaces_Type (Block_Info, Decl);
+ Annotate_Subprogram_Specification (Block_Info, Decl);
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Annotate_Subprogram_Body (Block_Info, Decl);
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl));
+ Create_Object_Info (Block_Info, Decl);
+
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_Attribute_Declaration =>
+ null;
+ when Iir_Kind_Attribute_Specification =>
+ declare
+ Value : Iir_Attribute_Value;
+ begin
+ Value := Get_Attribute_Value_Spec_Chain (Decl);
+ while Value /= Null_Iir loop
+ Create_Object_Info (Block_Info, Value);
+ Value := Get_Spec_Chain (Value);
+ end loop;
+ end;
+ when Iir_Kind_Disconnection_Specification =>
+ null;
+
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when Iir_Kind_Group_Template_Declaration =>
+ null;
+ when Iir_Kind_Group_Declaration =>
+ null;
+ when Iir_Kind_Use_Clause =>
+ null;
+
+ when Iir_Kind_Configuration_Specification =>
+ null;
+
+-- when Iir_Kind_Implicit_Signal_Declaration =>
+-- declare
+-- Nsig : Iir;
+-- begin
+-- Nsig := Decl;
+-- loop
+-- Nsig := Get_Implicit_Signal_Chain (Nsig);
+-- exit when Nsig = Null_Iir;
+-- Add_Signal_Info (Block_Info, Nsig);
+-- end loop;
+-- end;
+
+ when Iir_Kind_Implicit_Function_Declaration =>
+ null;
+
+ when Iir_Kind_Nature_Declaration =>
+ null;
+
+ when others =>
+ Error_Kind ("annotate_declaration", Decl);
+ end case;
+ end Annotate_Declaration;
+
+ procedure Annotate_Declaration_List
+ (Block_Info: Sim_Info_Acc; Decl_Chain: Iir)
+ is
+ El: Iir;
+ begin
+ El := Decl_Chain;
+ while El /= Null_Iir loop
+ Annotate_Declaration (Block_Info, El);
+ El := Get_Chain (El);
+ end loop;
+ end Annotate_Declaration_List;
+
+ procedure Annotate_Sequential_Statement_Chain
+ (Block_Info: Sim_Info_Acc; Stmt_Chain: Iir)
+ is
+ El: Iir;
+ Max_Nbr_Objects : Object_Slot_Type;
+ Current_Nbr_Objects : Object_Slot_Type;
+
+ procedure Save_Nbr_Objects is
+ begin
+ -- Objects used by loop statements can be reused later by
+ -- other (ie following) loop statements.
+ -- Furthermore, this allow to correctly check elaboration
+ -- order.
+ Max_Nbr_Objects := Object_Slot_Type'Max
+ (Block_Info.Nbr_Objects, Max_Nbr_Objects);
+ Block_Info.Nbr_Objects := Current_Nbr_Objects;
+ end Save_Nbr_Objects;
+ begin
+ Current_Nbr_Objects := Block_Info.Nbr_Objects;
+ Max_Nbr_Objects := Current_Nbr_Objects;
+
+ El := Stmt_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Null_Statement =>
+ null;
+ when Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement =>
+ null;
+ when Iir_Kind_Return_Statement =>
+ null;
+ when Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Variable_Assignment_Statement =>
+ null;
+ when Iir_Kind_Procedure_Call_Statement =>
+ null;
+ when Iir_Kind_Exit_Statement
+ | Iir_Kind_Next_Statement =>
+ null;
+ when Iir_Kind_Wait_Statement =>
+ null;
+
+ when Iir_Kind_If_Statement =>
+ declare
+ Clause: Iir := El;
+ begin
+ loop
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ exit when Clause = Null_Iir;
+ Save_Nbr_Objects;
+ end loop;
+ end;
+
+ when Iir_Kind_Case_Statement =>
+ declare
+ Assoc: Iir;
+ begin
+ Assoc := Get_Case_Statement_Alternative_Chain (El);
+ loop
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Associated_Chain (Assoc));
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ Save_Nbr_Objects;
+ end loop;
+ end;
+
+ when Iir_Kind_For_Loop_Statement =>
+ Annotate_Declaration
+ (Block_Info, Get_Parameter_Specification (El));
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Sequential_Statement_Chain (El));
+
+ when Iir_Kind_While_Loop_Statement =>
+ Annotate_Sequential_Statement_Chain
+ (Block_Info, Get_Sequential_Statement_Chain (El));
+
+ when others =>
+ Error_Kind ("annotate_sequential_statement_chain", El);
+ end case;
+
+ Save_Nbr_Objects;
+
+ El := Get_Chain (El);
+ end loop;
+ Block_Info.Nbr_Objects := Max_Nbr_Objects;
+ end Annotate_Sequential_Statement_Chain;
+
+ procedure Annotate_Block_Statement
+ (Block_Info : Sim_Info_Acc; Block : Iir_Block_Statement)
+ is
+ Info : Sim_Info_Acc;
+ Header : Iir_Block_Header;
+ Guard : Iir;
+ begin
+ Assert_No_Info (Block);
+
+ Increment_Current_Scope_Level;
+
+ Info := new Sim_Info_Type'(Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Block, Info);
+
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+
+ Guard := Get_Guard_Decl (Block);
+ if Guard /= Null_Iir then
+ Add_Signal_Info (Info, Guard);
+ end if;
+ Header := Get_Block_Header (Block);
+ if Header /= Null_Iir then
+ Annotate_Create_Interface_List
+ (Info, Get_Generic_Chain (Header), True);
+ Annotate_Create_Interface_List
+ (Info, Get_Port_Chain (Header), True);
+ end if;
+ Annotate_Declaration_List (Info, Get_Declaration_Chain (Block));
+ Annotate_Concurrent_Statements_List
+ (Info, Get_Concurrent_Statement_Chain (Block));
+
+ Current_Scope_Level := Current_Scope_Level - 1;
+ end Annotate_Block_Statement;
+
+ procedure Annotate_Generate_Statement
+ (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ Info : Sim_Info_Acc;
+ Scheme : constant Iir := Get_Generation_Scheme (Stmt);
+ Is_Iterative : constant Boolean :=
+ Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration;
+ begin
+ Assert_No_Info (Stmt);
+
+ Increment_Current_Scope_Level;
+
+ Info := new Sim_Info_Type'(Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Stmt, Info);
+
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+
+ if Is_Iterative then
+ Annotate_Declaration (Info, Scheme);
+ end if;
+ Annotate_Declaration_List (Info, Get_Declaration_Chain (Stmt));
+ Annotate_Concurrent_Statements_List
+ (Info, Get_Concurrent_Statement_Chain (Stmt));
+
+ Current_Scope_Level := Current_Scope_Level - 1;
+ end Annotate_Generate_Statement;
+
+ procedure Annotate_Component_Instantiation_Statement
+ (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ Info: Sim_Info_Acc;
+ begin
+ -- Add a slot just to put the instance.
+ Assert_No_Info (Stmt);
+ Info := new Sim_Info_Type'(Kind => Kind_Block,
+ Inst_Slot => Block_Info.Nbr_Instances,
+ Frame_Scope_Level => Current_Scope_Level + 1,
+ Nbr_Objects => 0,
+ Nbr_Instances => 1);
+ Set_Info (Stmt, Info);
+ Block_Info.Nbr_Instances := Block_Info.Nbr_Instances + 1;
+ end Annotate_Component_Instantiation_Statement;
+
+ procedure Annotate_Process_Statement (Block_Info : Sim_Info_Acc; Stmt : Iir)
+ is
+ pragma Unreferenced (Block_Info);
+ Info: Sim_Info_Acc;
+ begin
+ Increment_Current_Scope_Level;
+
+ -- Add a slot just to put the instance.
+ Assert_No_Info (Stmt);
+
+ Info := new Sim_Info_Type'(Kind => Kind_Process,
+ Inst_Slot => Invalid_Instance_Slot,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Stmt, Info);
+
+ Annotate_Declaration_List
+ (Info, Get_Declaration_Chain (Stmt));
+ Annotate_Sequential_Statement_Chain
+ (Info, Get_Sequential_Statement_Chain (Stmt));
+
+ Current_Scope_Level := Current_Scope_Level - 1;
+ end Annotate_Process_Statement;
+
+ procedure Annotate_Concurrent_Statements_List
+ (Block_Info: Sim_Info_Acc; Stmt_Chain : Iir)
+ is
+ El: Iir;
+ begin
+ El := Stmt_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ Annotate_Process_Statement (Block_Info, El);
+
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Annotate_Component_Instantiation_Statement (Block_Info, El);
+
+ when Iir_Kind_Block_Statement =>
+ Annotate_Block_Statement (Block_Info, El);
+
+ when Iir_Kind_Generate_Statement =>
+ Annotate_Generate_Statement (Block_Info, El);
+
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ null;
+
+ when others =>
+ Error_Kind ("annotate_concurrent_statements_list", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Annotate_Concurrent_Statements_List;
+
+ procedure Annotate_Entity (Decl: Iir_Entity_Declaration) is
+ Entity_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Current_Scope_Level := Scope_Level_Entity;
+
+ Entity_Info :=
+ new Sim_Info_Type'(Kind => Kind_Block,
+ Inst_Slot => Invalid_Instance_Slot,
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+ Set_Info (Decl, Entity_Info);
+
+ -- generic list.
+ Annotate_Create_Interface_List
+ (Entity_Info, Get_Generic_Chain (Decl), True);
+
+ -- Port list.
+ Annotate_Create_Interface_List
+ (Entity_Info, Get_Port_Chain (Decl), True);
+
+ -- declarations
+ Annotate_Declaration_List (Entity_Info, Get_Declaration_Chain (Decl));
+
+ -- processes.
+ Annotate_Concurrent_Statements_List
+ (Entity_Info, Get_Concurrent_Statement_Chain (Decl));
+ end Annotate_Entity;
+
+ procedure Annotate_Architecture (Decl: Iir_Architecture_Body)
+ is
+ Entity_Info: Sim_Info_Acc;
+ Arch_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Current_Scope_Level := Scope_Level_Entity;
+
+ Entity_Info := Get_Info (Get_Entity (Decl));
+
+ Arch_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => 0, -- Slot for a component
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => Entity_Info.Nbr_Objects,
+ Nbr_Instances => Entity_Info.Nbr_Instances); -- Should be 0.
+ Set_Info (Decl, Arch_Info);
+
+ -- FIXME: annotate the default configuration for the arch ?
+
+ -- declarations
+ Annotate_Declaration_List (Arch_Info, Get_Declaration_Chain (Decl));
+
+ -- processes.
+ Annotate_Concurrent_Statements_List
+ (Arch_Info, Get_Concurrent_Statement_Chain (Decl));
+ end Annotate_Architecture;
+
+ procedure Annotate_Package (Decl: Iir_Package_Declaration) is
+ Package_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Nbr_Packages := Nbr_Packages + 1;
+ Current_Scope_Level := Scope_Level_Type (-Nbr_Packages);
+
+ Package_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Instance_Slot_Type (Nbr_Packages),
+ Frame_Scope_Level => Current_Scope_Level,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+
+ Set_Info (Decl, Package_Info);
+
+ -- declarations
+ Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl));
+
+ Current_Scope_Level := Scope_Level_Global;
+ end Annotate_Package;
+
+ procedure Annotate_Package_Body (Decl: Iir)
+ is
+ Package_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ -- Set info field of package body declaration.
+ Package_Info := Get_Info (Get_Package (Decl));
+ Set_Info (Decl, Package_Info);
+
+ Current_Scope_Level := Package_Info.Frame_Scope_Level;
+
+ -- declarations
+ Annotate_Declaration_List (Package_Info, Get_Declaration_Chain (Decl));
+ end Annotate_Package_Body;
+
+ procedure Annotate_Component_Configuration
+ (Conf : Iir_Component_Configuration)
+ is
+ Block : constant Iir := Get_Block_Configuration (Conf);
+ begin
+ Annotate_Block_Configuration (Block);
+ end Annotate_Component_Configuration;
+
+ procedure Annotate_Block_Configuration (Block : Iir_Block_Configuration)
+ is
+ El : Iir;
+ begin
+ if Block = Null_Iir then
+ return;
+ end if;
+ Assert_No_Info (Block);
+
+ -- Declaration are use_clause only.
+ El := Get_Configuration_Item_Chain (Block);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Block_Configuration =>
+ Annotate_Block_Configuration (El);
+ when Iir_Kind_Component_Configuration =>
+ Annotate_Component_Configuration (El);
+ when others =>
+ Error_Kind ("annotate_block_configuration", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Annotate_Block_Configuration;
+
+ procedure Annotate_Configuration_Declaration
+ (Decl : Iir_Configuration_Declaration)
+ is
+ Config_Info: Sim_Info_Acc;
+ begin
+ Assert_No_Info (Decl);
+
+ Config_Info := new Sim_Info_Type'
+ (Kind => Kind_Block,
+ Inst_Slot => Invalid_Instance_Slot,
+ Frame_Scope_Level => Scope_Level_Global,
+ Nbr_Objects => 0,
+ Nbr_Instances => 0);
+
+ Current_Scope_Level := Scope_Level_Global;
+
+ Annotate_Declaration_List (Config_Info, Get_Declaration_Chain (Decl));
+ Annotate_Block_Configuration (Get_Block_Configuration (Decl));
+ end Annotate_Configuration_Declaration;
+
+ package Info_Node is new GNAT.Table
+ (Table_Component_Type => Sim_Info_Acc,
+ Table_Index_Type => Iir,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ procedure Annotate_Expand_Table
+ is
+ El: Iir;
+ begin
+ Info_Node.Increment_Last;
+ El := Info_Node.Last;
+ Info_Node.Set_Last (Get_Last_Node);
+ for I in El .. Info_Node.Last loop
+ Info_Node.Table (I) := null;
+ end loop;
+ end Annotate_Expand_Table;
+
+ -- Decorate the tree in order to be usable with the internal simulator.
+ procedure Annotate (Tree: Iir_Design_Unit)
+ is
+ El: Iir;
+ begin
+ -- Expand info table.
+ Annotate_Expand_Table;
+
+ El := Get_Library_Unit (Tree);
+ if Trace_Annotation then
+ Ada.Text_IO.Put_Line ("annotating " & Disp_Node (El));
+ end if;
+ case Get_Kind (El) is
+ when Iir_Kind_Entity_Declaration =>
+ Annotate_Entity (El);
+ when Iir_Kind_Architecture_Body =>
+ Annotate_Architecture (El);
+ when Iir_Kind_Package_Declaration =>
+ Annotate_Package (El);
+ declare
+ use Std_Package;
+ begin
+ if El = Standard_Package then
+ -- These types are not in std.standard!
+ Annotate_Type_Definition
+ (Get_Info (El), Convertible_Integer_Type_Definition);
+ Annotate_Type_Definition
+ (Get_Info (El), Convertible_Real_Type_Definition);
+ end if;
+ end;
+ when Iir_Kind_Package_Body =>
+ Annotate_Package_Body (El);
+ when Iir_Kind_Configuration_Declaration =>
+ Annotate_Configuration_Declaration (El);
+ when others =>
+ Error_Kind ("annotate2", El);
+ end case;
+ end Annotate;
+
+ -- Disp annotations for an iir node.
+ procedure Disp_Vhdl_Info (Node: Iir) is
+ use Ada.Text_IO;
+ Indent: Count;
+ Info: Sim_Info_Acc;
+ begin
+ Info := Get_Info (Node);
+ Indent := Col;
+ case Info.Kind is
+ when Kind_Block =>
+ Put_Line
+ ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects));
+
+ when Kind_Frame | Kind_Process =>
+ Put_Line ("-- scope level:" &
+ Scope_Level_Type'Image (Info.Frame_Scope_Level));
+ Set_Col (Indent);
+ Put_Line
+ ("-- nbr objects:" & Object_Slot_Type'Image (Info.Nbr_Objects));
+
+ when Kind_Object | Kind_Signal | Kind_File
+ | Kind_Terminal | Kind_Quantity =>
+ Put_Line ("-- slot:" & Object_Slot_Type'Image (Info.Slot)
+ & ", scope:"
+ & Scope_Level_Type'Image (Info.Scope_Level));
+ when Kind_Scalar_Type
+ | Kind_File_Type =>
+ null;
+ when Kind_Range =>
+ Put ("${");
+ Put (Object_Slot_Type'Image (Info.Slot));
+ Put ("}");
+ end case;
+ end Disp_Vhdl_Info;
+
+ procedure Disp_Info (Info : Sim_Info_Acc)
+ is
+ use Ada.Text_IO;
+ Indent: Count;
+ begin
+ Indent := Col + 2;
+ Set_Col (Indent);
+ if Info = null then
+ Put_Line ("*null*");
+ return;
+ end if;
+ case Info.Kind is
+ when Kind_Block | Kind_Frame | Kind_Process =>
+ Put_Line ("scope level:" &
+ Scope_Level_Type'Image (Info.Frame_Scope_Level));
+ Set_Col (Indent);
+ Put_Line ("inst_slot:"
+ & Instance_Slot_Type'Image (Info.Inst_Slot));
+ Set_Col (Indent);
+ Put_Line ("nbr objects:"
+ & Object_Slot_Type'Image (Info.Nbr_Objects));
+ Set_Col (Indent);
+ Put_Line ("nbr instance:"
+ & Instance_Slot_Type'Image (Info.Nbr_Instances));
+ when Kind_Object | Kind_Signal | Kind_File
+ | Kind_Terminal | Kind_Quantity =>
+ Put_Line ("slot:" & Object_Slot_Type'Image (Info.Slot)
+ & ", scope:"
+ & Scope_Level_Type'Image (Info.Scope_Level));
+ when Kind_Range =>
+ Put_Line ("range slot:" & Object_Slot_Type'Image (Info.Slot));
+ when Kind_Scalar_Type =>
+ Put_Line ("scalar type: "
+ & Iir_Value_Kind'Image (Info.Scalar_Mode));
+ when Kind_File_Type =>
+ Put ("file type: ");
+ if Info.File_Signature = null then
+ Put ("(no sig)");
+ else
+ Put (Info.File_Signature.all);
+ end if;
+ New_Line;
+ end case;
+ end Disp_Info;
+
+ procedure Disp_Tree_Info (Node: Iir) is
+ begin
+ Disp_Info (Get_Info (Node));
+ end Disp_Tree_Info;
+
+ procedure Set_Info (Target: Iir; Info: Sim_Info_Acc) is
+ begin
+ Info_Node.Table (Target) := Info;
+ end Set_Info;
+
+ function Get_Info (Target: Iir) return Sim_Info_Acc is
+ begin
+ return Info_Node.Table (Target);
+ end Get_Info;
+end Annotations;
diff --git a/src/simulate/annotations.ads b/src/simulate/annotations.ads
new file mode 100644
index 000000000..e9b48d005
--- /dev/null
+++ b/src/simulate/annotations.ads
@@ -0,0 +1,120 @@
+-- Annotations for interpreted simulation
+-- 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 Iirs; use Iirs;
+with Iir_Values; use Iir_Values;
+with Types; use Types;
+
+package Annotations is
+ Trace_Annotation : Boolean := False;
+
+ -- Decorate the tree in order to be usable with the internal simulator.
+ procedure Annotate (Tree: Iir_Design_Unit);
+
+ -- Disp annotations for an iir node.
+ procedure Disp_Vhdl_Info (Node: Iir);
+ procedure Disp_Tree_Info (Node: Iir);
+
+ -- Annotations are used to collect informations for elaboration and to
+ -- locate iir_value_literal for signals, variables or constants.
+
+ -- Scope corresponding to an object.
+ -- Scope_level_global is for objects that can be instancied only one
+ -- time, ie shared signals or constants declared in a package.
+ --
+ -- Scope_Level_Process is for objects declared in an entity, architecture,
+ -- process, bloc (but not generated bloc). These are static objects, that
+ -- can be instancied several times.
+ --
+ -- Scope_Level_First_Function and above are for dynamic objects declared
+ -- in a subprogram. The level is also the nest level.
+ --
+ -- Scope_Level_Component is set to a maximum, since there is at
+ -- most one scope after it (the next one is an entity).
+ type Scope_Level_Type is new Integer;
+ Scope_Level_Global: constant Scope_Level_Type := 0;
+ Scope_Level_Entity: constant Scope_Level_Type := 1;
+ Scope_Level_Component : constant Scope_Level_Type :=
+ Scope_Level_Type'Last - 1;
+
+ type Instance_Slot_Type is new Integer;
+ Invalid_Instance_Slot : constant Instance_Slot_Type := -1;
+
+ type Object_Slot_Type is new Integer;
+
+ -- The annotation depends on the kind of the node.
+ type Sim_Info_Kind is
+ (Kind_Block, Kind_Process, Kind_Frame,
+ Kind_Scalar_Type, Kind_File_Type,
+ Kind_Object, Kind_Signal, Kind_Range,
+ Kind_File,
+ Kind_Terminal, Kind_Quantity);
+
+ type Sim_Info_Type (Kind: Sim_Info_Kind);
+ type Sim_Info_Acc is access all Sim_Info_Type;
+
+ -- Annotation for an iir node in order to be able to simulate it.
+ type Sim_Info_Type (Kind: Sim_Info_Kind) is record
+ case Kind is
+ when Kind_Block
+ | Kind_Frame
+ | Kind_Process =>
+ -- Slot number.
+ Inst_Slot : Instance_Slot_Type;
+
+ -- scope level for this frame.
+ Frame_Scope_Level: Scope_Level_Type;
+
+ -- Number of objects/signals.
+ Nbr_Objects : Object_Slot_Type;
+
+ -- Number of children (blocks, generate, instantiation).
+ Nbr_Instances : Instance_Slot_Type;
+
+ when Kind_Object
+ | Kind_Signal
+ | Kind_Range
+ | Kind_File
+ | Kind_Terminal
+ | Kind_Quantity =>
+ -- block considered (hierarchy).
+ Scope_Level: Scope_Level_Type;
+
+ -- Variable index.
+ Slot: Object_Slot_Type;
+
+ when Kind_Scalar_Type =>
+ Scalar_Mode : Iir_Value_Kind;
+
+ when Kind_File_Type =>
+ File_Signature : String_Acc;
+ end case;
+ end record;
+
+ Nbr_Packages : Iir_Index32 := 0;
+
+ -- Get/Set annotation fied from/to an iir.
+ procedure Set_Info (Target: Iir; Info: Sim_Info_Acc);
+ pragma Inline (Set_Info);
+ function Get_Info (Target: Iir) return Sim_Info_Acc;
+ pragma Inline (Get_Info);
+
+ -- Expand the annotation table. This is automatically done by Annotate,
+ -- to be used only by debugger.
+ procedure Annotate_Expand_Table;
+end Annotations;
diff --git a/src/simulate/areapools.adb b/src/simulate/areapools.adb
new file mode 100644
index 000000000..341b14240
--- /dev/null
+++ b/src/simulate/areapools.adb
@@ -0,0 +1,147 @@
+-- Area based memory manager
+-- 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.Unchecked_Deallocation;
+
+package body Areapools is
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Chunk_Type, Chunk_Acc);
+
+ Free_Chunks : Chunk_Acc;
+
+ function Get_Chunk return Chunk_Acc is
+ Res : Chunk_Acc;
+ begin
+ if Free_Chunks /= null then
+ Res := Free_Chunks;
+ Free_Chunks := Res.Prev;
+ return Res;
+ else
+ return new Chunk_Type (Default_Chunk_Size - 1);
+ end if;
+ end Get_Chunk;
+
+ procedure Free_Chunk (Chunk : Chunk_Acc) is
+ begin
+ Chunk.Prev := Free_Chunks;
+ Free_Chunks := Chunk;
+ end Free_Chunk;
+
+ procedure Allocate (Pool : in out Areapool;
+ Res : out Address;
+ Size : Size_Type;
+ Align : Size_Type)
+ is
+ Align_M1 : constant Size_Type := Align - 1;
+
+ function Do_Align (X : Size_Type) return Size_Type is
+ begin
+ return (X + Align_M1) and not Align_M1;
+ end Do_Align;
+
+ Chunk : Chunk_Acc;
+ begin
+ -- Need to allocate a new chunk if there is no current chunk, or not
+ -- enough room in the current chunk.
+ if Pool.Last = null
+ or else Do_Align (Pool.Next_Use) + Size > Pool.Last.Last
+ then
+ if Size > Default_Chunk_Size then
+ Chunk := new Chunk_Type (Size - 1);
+ else
+ Chunk := Get_Chunk;
+ end if;
+ Chunk.Prev := Pool.Last;
+ Pool.Next_Use := 0;
+ if Pool.First = null then
+ Pool.First := Chunk;
+ end if;
+ Pool.Last := Chunk;
+ else
+ Chunk := Pool.Last;
+ Pool.Next_Use := Do_Align (Pool.Next_Use);
+ end if;
+ Res := Chunk.Data (Pool.Next_Use)'Address;
+ Pool.Next_Use := Pool.Next_Use + Size;
+ end Allocate;
+
+ procedure Mark (M : out Mark_Type; Pool : Areapool) is
+ begin
+ M := (Last => Pool.Last, Next_Use => Pool.Next_Use);
+ end Mark;
+
+ procedure Release (M : Mark_Type; Pool : in out Areapool)
+ is
+ Chunk : Chunk_Acc;
+ Prev : Chunk_Acc;
+ begin
+ Chunk := Pool.Last;
+ while Chunk /= M.Last loop
+ if Erase_When_Released then
+ Chunk.Data := (others => 16#DE#);
+ end if;
+
+ Prev := Chunk.Prev;
+ if Chunk.Last = Default_Chunk_Size - 1 then
+ Free_Chunk (Chunk);
+ else
+ Deallocate (Chunk);
+ end if;
+ Chunk := Prev;
+ end loop;
+
+ if Erase_When_Released
+ and then M.Last /= null
+ then
+ declare
+ Last : Size_Type;
+ begin
+ if Pool.Last = M.Last then
+ Last := Pool.Next_Use - 1;
+ else
+ Last := Chunk.Data'Last;
+ end if;
+ Chunk.Data (M.Next_Use .. Last) := (others => 16#DE#);
+ end;
+ end if;
+
+ Pool.Last := M.Last;
+ Pool.Next_Use := M.Next_Use;
+ end Release;
+
+ function Is_Empty (Pool : Areapool) return Boolean is
+ begin
+ return Pool.Last = null;
+ end Is_Empty;
+
+ function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T)
+ return System.Address
+ is
+ Res : Address;
+ begin
+ Allocate (Pool.all, Res, T'Size / Storage_Unit, T'Alignment);
+ declare
+ Addr1 : constant Address := Res;
+ Init : T := Val;
+ for Init'Address use Addr1;
+ begin
+ null;
+ end;
+ return Res;
+ end Alloc_On_Pool_Addr;
+end Areapools;
diff --git a/src/simulate/areapools.ads b/src/simulate/areapools.ads
new file mode 100644
index 000000000..186f29707
--- /dev/null
+++ b/src/simulate/areapools.ads
@@ -0,0 +1,87 @@
+-- Area based memory manager
+-- 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 System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package Areapools is
+ type Areapool is limited private;
+ type Mark_Type is private;
+
+ type Areapool_Acc is access all Areapool;
+
+ -- Modular type for the size. We don't use Storage_Offset in order to
+ -- make alignment computation efficient (knowing that alignment is a
+ -- power of two).
+ type Size_Type is mod System.Memory_Size;
+
+ -- Allocate SIZE bytes (aligned on ALIGN bytes) in memory pool POOL and
+ -- return the address in RES.
+ procedure Allocate (Pool : in out Areapool;
+ Res : out Address;
+ Size : Size_Type;
+ Align : Size_Type);
+
+ -- Return TRUE iff no memory is allocated in POOL.
+ function Is_Empty (Pool : Areapool) return Boolean;
+
+ -- Higher level abstraction for Allocate.
+ generic
+ type T is private;
+ function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T)
+ return System.Address;
+
+ -- Get a mark of POOL.
+ procedure Mark (M : out Mark_Type;
+ Pool : Areapool);
+
+ -- Release memory allocated in POOL after mark M.
+ procedure Release (M : Mark_Type;
+ Pool : in out Areapool);
+
+ Empty_Marker : constant Mark_Type;
+private
+ -- Minimal size of allocation.
+ Default_Chunk_Size : constant Size_Type := 16 * 1024;
+
+ type Chunk_Type;
+ type Chunk_Acc is access all Chunk_Type;
+
+ type Data_Array is array (Size_Type range <>) of Storage_Element;
+ for Data_Array'Alignment use Standard'Maximum_Alignment;
+
+ type Chunk_Type (Last : Size_Type) is record
+ Prev : Chunk_Acc;
+ Data : Data_Array (0 .. Last);
+ end record;
+ for Chunk_Type'Alignment use Standard'Maximum_Alignment;
+
+ type Areapool is limited record
+ First, Last : Chunk_Acc := null;
+ Next_Use : Size_Type;
+ end record;
+
+ type Mark_Type is record
+ Last : Chunk_Acc := null;
+ Next_Use : Size_Type;
+ end record;
+
+ Empty_Marker : constant Mark_Type := (Last => null, Next_Use => 0);
+
+ Erase_When_Released : constant Boolean := True;
+end Areapools;
diff --git a/src/simulate/debugger.adb b/src/simulate/debugger.adb
new file mode 100644
index 000000000..5a43533d6
--- /dev/null
+++ b/src/simulate/debugger.adb
@@ -0,0 +1,1845 @@
+-- Debugger for interpreter
+-- 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 System;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Table;
+with Types; use Types;
+with Iir_Values; use Iir_Values;
+with Name_Table;
+with Files_Map;
+with Parse;
+with Scanner;
+with Tokens;
+with Sem_Expr;
+with Sem_Scopes;
+with Std_Names;
+with Libraries;
+with Std_Package;
+with Annotations; use Annotations;
+with Iirs_Utils; use Iirs_Utils;
+with Errorout; use Errorout;
+with Disp_Vhdl;
+with Execution; use Execution;
+with Simulation; use Simulation;
+with Iirs_Walk; use Iirs_Walk;
+with Areapools; use Areapools;
+with Grt.Disp;
+with Grt.Readline;
+with Grt.Errors;
+with Grt.Disp_Signals;
+
+package body Debugger is
+ -- This exception can be raised by a debugger command to directly return
+ -- to the prompt.
+ Command_Error : exception;
+
+ Dbg_Top_Frame : Block_Instance_Acc;
+ Dbg_Cur_Frame : Block_Instance_Acc;
+
+ procedure Set_Cur_Frame (Frame : Block_Instance_Acc) is
+ begin
+ Dbg_Cur_Frame := Frame;
+ end Set_Cur_Frame;
+
+ procedure Set_Top_Frame (Frame : Block_Instance_Acc) is
+ begin
+ Dbg_Top_Frame := Frame;
+ Set_Cur_Frame (Frame);
+ end Set_Top_Frame;
+
+ type Breakpoint_Entry is record
+ Stmt : Iir;
+ end record;
+
+ package Breakpoints is new GNAT.Table
+ (Table_Index_Type => Natural,
+ Table_Component_Type => Breakpoint_Entry,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- Current execution state, or reason to stop execution (set by the
+ -- last debugger command).
+ type Exec_State_Type is
+ (-- Execution should continue until a breakpoint is reached or assertion
+ -- failure.
+ Exec_Run,
+
+ -- Execution will stop at the next statement.
+ Exec_Single_Step,
+
+ -- Execution will stop at the next statement in the same frame.
+ Exec_Next);
+
+ Exec_State : Exec_State_Type := Exec_Run;
+
+ Exec_Instance : Block_Instance_Acc;
+
+ -- Disp a message during execution.
+ procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is
+ begin
+ Disp_Iir_Location (Loc);
+ Put (Standard_Error, ' ');
+ Put_Line (Standard_Error, Msg);
+ Grt.Errors.Fatal_Error;
+ end Error_Msg_Exec;
+
+ procedure Warning_Msg_Exec (Msg: String; Loc: Iir) is
+ begin
+ Disp_Iir_Location (Loc);
+ Put (Standard_Error, "warning: ");
+ Put_Line (Standard_Error, Msg);
+ end Warning_Msg_Exec;
+
+ -- Disp a message for a constraint error.
+ procedure Error_Msg_Constraint (Expr: in Iir) is
+ begin
+ if Expr /= Null_Iir then
+ Disp_Iir_Location (Expr);
+ end if;
+ Put (Standard_Error, "constraint violation");
+ if Expr /= Null_Iir then
+ case Get_Kind (Expr) is
+ when Iir_Kind_Addition_Operator =>
+ Put_Line (Standard_Error, " in the ""+"" operation");
+ when Iir_Kind_Substraction_Operator =>
+ Put_Line (Standard_Error, " in the ""-"" operation");
+ when Iir_Kind_Integer_Literal =>
+ Put_Line (Standard_Error, ", literal out of range");
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration =>
+ Put_Line (Standard_Error, " for " & Disp_Node (Expr));
+ when others =>
+ New_Line (Standard_Error);
+ end case;
+ end if;
+ Grt.Errors.Fatal_Error;
+ end Error_Msg_Constraint;
+
+ function Get_Instance_Local_Name (Instance : Block_Instance_Acc;
+ Short : Boolean := False)
+ return String
+ is
+ Name : constant Iir := Instance.Label;
+ begin
+ if Name = Null_Iir then
+ return "<anon>";
+ end if;
+
+ case Get_Kind (Name) is
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kinds_Process_Statement =>
+ return Image_Identifier (Name);
+ when Iir_Kind_Iterator_Declaration =>
+ return Image_Identifier (Get_Parent (Name)) & '('
+ & Execute_Image_Attribute
+ (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name))
+ & ')';
+ when Iir_Kind_Architecture_Body =>
+ if Short then
+ return Image_Identifier (Get_Entity (Name));
+ else
+ return Image_Identifier (Get_Entity (Name))
+ & '(' & Image_Identifier (Name) & ')';
+ end if;
+ when others =>
+ Error_Kind ("disp_instance_local_name", Name);
+ end case;
+ end Get_Instance_Local_Name;
+
+ -- Disp the name of an instance, without newline.
+ procedure Disp_Instance_Name (Instance: Block_Instance_Acc;
+ Short : Boolean := False) is
+ begin
+ if Instance.Parent /= null then
+ Disp_Instance_Name (Instance.Parent);
+ Put ('.');
+ end if;
+ Put (Get_Instance_Local_Name (Instance, Short));
+ end Disp_Instance_Name;
+
+ function Get_Instance_Name (Instance: Block_Instance_Acc) return String
+ is
+ function Parent_Name return String is
+ begin
+ if Instance.Parent /= null then
+ return Get_Instance_Name (Instance.Parent) & '.';
+ else
+ return "";
+ end if;
+ end Parent_Name;
+ begin
+ return Parent_Name & Get_Instance_Local_Name (Instance);
+ end Get_Instance_Name;
+
+ procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is
+ begin
+ if Inst = null then
+ Put ("*null*");
+ New_Line;
+ return;
+ end if;
+ Put (Get_Instance_Local_Name (Inst));
+
+ Put (" ");
+ case Get_Kind (Inst.Label) is
+ when Iir_Kind_Block_Statement =>
+ Put ("[block]");
+ when Iir_Kind_Generate_Statement =>
+ Put ("[generate]");
+ when Iir_Kind_Iterator_Declaration =>
+ Put ("[iterator]");
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Put ("[component]");
+ when Iir_Kinds_Process_Statement =>
+ Put ("[process]");
+ when Iir_Kind_Architecture_Body =>
+ Put ("[entity]");
+ when others =>
+ Error_Kind ("disp_instances_tree1", Inst.Label);
+ end case;
+ New_Line;
+ end Disp_Instances_Tree_Name;
+
+ procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String)
+ is
+ Child : Block_Instance_Acc;
+ begin
+ Child := Inst.Children;
+ if Child = null then
+ return;
+ end if;
+
+ loop
+ if Child.Brother /= null then
+ Put (Pfx & "+-");
+ Disp_Instances_Tree_Name (Child);
+
+ Disp_Instances_Tree1 (Child, Pfx & "| ");
+ Child := Child.Brother;
+ else
+ Put (Pfx & "`-");
+ Disp_Instances_Tree_Name (Child);
+
+ Disp_Instances_Tree1 (Child, Pfx & " ");
+ exit;
+ end if;
+ end loop;
+ end Disp_Instances_Tree1;
+
+ procedure Disp_Instances_Tree is
+ begin
+ Disp_Instances_Tree_Name (Top_Instance);
+ Disp_Instances_Tree1 (Top_Instance, "");
+ end Disp_Instances_Tree;
+
+ -- Disp a block instance, in a human readable way.
+ -- Used to debug.
+ procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is
+ begin
+ Put_Line ("scope level:"
+ & Scope_Level_Type'Image (Instance.Scope_Level));
+ Put_Line ("Objects:");
+ for I in Instance.Objects'Range loop
+ Put (Object_Slot_Type'Image (I) & ": ");
+ Disp_Value_Tab (Instance.Objects (I), 3);
+ New_Line;
+ end loop;
+ end Disp_Block_Instance;
+
+ procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir);
+
+ procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc;
+ A_Type : Iir;
+ Dim : Natural)
+ is
+ begin
+ if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then
+ Put ("(");
+ for I in Value.Val_Array.V'Range loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type));
+ end loop;
+ Put (")");
+ else
+ Put ("(");
+ Disp_Signal_Array (Value, A_Type, Dim + 1);
+ Put (")");
+ end if;
+ end Disp_Signal_Array;
+
+ procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir)
+ is
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (A_Type));
+ Put ("(");
+ for I in Value.Val_Record.V'Range loop
+ El := Get_Nth_Element (List, Natural (I - 1));
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Put (Name_Table.Image (Get_Identifier (El)));
+ Put (" => ");
+ Disp_Signal (Value.Val_Record.V (I), Get_Type (El));
+ end loop;
+ Put (")");
+ end Disp_Signal_Record;
+
+ procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir) is
+ begin
+ if Value = null then
+ Put ("!NULL!");
+ return;
+ end if;
+ case Value.Kind is
+ when Iir_Value_I64
+ | Iir_Value_F64
+ | Iir_Value_E32
+ | Iir_Value_B1
+ | Iir_Value_Access =>
+ Disp_Iir_Value (Value, A_Type);
+ when Iir_Value_Array =>
+ Disp_Signal_Array (Value, A_Type, 1);
+ when Iir_Value_Record =>
+ Disp_Signal_Record (Value, A_Type);
+ when Iir_Value_Range =>
+ -- FIXME.
+ raise Internal_Error;
+ when Iir_Value_Signal =>
+ Grt.Disp_Signals.Disp_A_Signal (Value.Sig);
+ when Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Disp_Signal;
+
+ procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Decl);
+ begin
+ Put (" ");
+ Put (Name_Table.Image (Get_Identifier (Decl)));
+ Put (" = ");
+ Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl));
+ end Disp_Instance_Signal;
+
+ procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc;
+ Chain : Iir)
+ is
+ El : Iir;
+ begin
+ El := Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Signal_Interface_Declaration =>
+ Disp_Instance_Signal (Instance, El);
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Instance_Signals_Of_Chain;
+
+ procedure Disp_Instance_Signals (Instance: Block_Instance_Acc)
+ is
+ Blk : constant Iir := Instance.Label;
+ Child: Block_Instance_Acc;
+ begin
+ case Get_Kind (Blk) is
+ when Iir_Kind_Architecture_Body =>
+ declare
+ Ent : constant Iir := Get_Entity (Blk);
+ begin
+ Disp_Instance_Name (Instance);
+ Put_Line (" [architecture]:");
+
+ Disp_Instance_Signals_Of_Chain
+ (Instance, Get_Port_Chain (Ent));
+ Disp_Instance_Signals_Of_Chain
+ (Instance, Get_Declaration_Chain (Ent));
+ end;
+ when Iir_Kind_Block_Statement =>
+ Disp_Instance_Name (Instance);
+ Put_Line (" [block]:");
+
+ -- FIXME: ports.
+ Disp_Instance_Signals_Of_Chain
+ (Instance, Get_Declaration_Chain (Blk));
+ when Iir_Kind_Generate_Statement =>
+ Disp_Instance_Name (Instance);
+ Put_Line (" [generate]:");
+
+ Disp_Instance_Signals_Of_Chain
+ (Instance, Get_Declaration_Chain (Blk));
+ when Iir_Kind_Component_Instantiation_Statement =>
+ null;
+ when Iir_Kinds_Process_Statement =>
+ null;
+ when Iir_Kind_Iterator_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("disp_instance_signals", Instance.Label);
+ end case;
+
+ Child := Instance.Children;
+ while Child /= null loop
+ Disp_Instance_Signals (Child);
+ Child := Child.Brother;
+ end loop;
+ end Disp_Instance_Signals;
+
+ -- Disp all signals name and values.
+ procedure Disp_Signals_Value is
+ begin
+ if Disp_Time_Before_Values then
+ Grt.Disp.Disp_Now;
+ end if;
+ Disp_Instance_Signals (Top_Instance);
+ end Disp_Signals_Value;
+
+ procedure Disp_Objects_Value is
+ begin
+ null;
+-- -- Disp the results.
+-- for I in 0 .. Variables.Last loop
+-- Put (Get_String (Variables.Table (I).Name.all));
+-- Put (" = ");
+-- Put (Get_Str_Value
+-- (Get_Literal (variables.Table (I).Value.all),
+-- Get_Type (variables.Table (I).Value.all)));
+-- if I = variables.Last then
+-- Put_Line (";");
+-- else
+-- Put (", ");
+-- end if;
+-- end loop;
+ end Disp_Objects_Value;
+
+ procedure Disp_Label (Process : Iir)
+ is
+ Label : Name_Id;
+ begin
+ Label := Get_Label (Process);
+ if Label = Null_Identifier then
+ Put ("<unlabeled>");
+ else
+ Put (Name_Table.Image (Label));
+ end if;
+ end Disp_Label;
+
+ procedure Disp_Declaration_Objects
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir)
+ is
+ El : Iir;
+ begin
+ El := Decl_Chain;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ Put (Disp_Node (El));
+ Put (" = ");
+ Disp_Value_Tab (Instance.Objects (Get_Info (El).Slot), 3);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ declare
+ Sig : Iir_Value_Literal_Acc;
+ begin
+ Sig := Instance.Objects (Get_Info (El).Slot);
+ Put (Disp_Node (El));
+ Put (" = ");
+ Disp_Signal (Sig, Get_Type (El));
+ New_Line;
+ end;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ -- FIXME: disp ranges
+ null;
+ when Iir_Kind_Implicit_Function_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("disp_declaration_objects", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Declaration_Objects;
+
+ procedure Disp_Objects (Instance : Block_Instance_Acc)
+ is
+ Decl : constant Iir := Instance.Label;
+ begin
+ Disp_Instance_Name (Instance);
+ New_Line;
+ case Get_Kind (Decl) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ Disp_Declaration_Objects
+ (Instance, Get_Interface_Declaration_Chain (Decl));
+ Disp_Declaration_Objects
+ (Instance,
+ Get_Declaration_Chain (Get_Subprogram_Body (Decl)));
+ when Iir_Kind_Architecture_Body =>
+ declare
+ Entity : constant Iir_Entity_Declaration := Get_Entity (Decl);
+ begin
+ Disp_Declaration_Objects
+ (Instance, Get_Generic_Chain (Entity));
+ Disp_Declaration_Objects
+ (Instance, Get_Port_Chain (Entity));
+ Disp_Declaration_Objects
+ (Instance, Get_Declaration_Chain (Entity));
+ Disp_Declaration_Objects
+ (Instance, Get_Declaration_Chain (Decl));
+ -- FIXME: processes.
+ end;
+ when Iir_Kind_Component_Instantiation_Statement =>
+ null;
+ when others =>
+ Error_Kind ("disp_objects", Decl);
+ end case;
+ end Disp_Objects;
+ pragma Unreferenced (Disp_Objects);
+
+ procedure Disp_Process_Stats
+ is
+ Proc : Iir;
+ Stmt : Iir;
+ Nbr_User_Sensitized_Processes : Natural := 0;
+ Nbr_User_If_Sensitized_Processes : Natural := 0;
+ Nbr_Conc_Sensitized_Processes : Natural := 0;
+ Nbr_User_Non_Sensitized_Processes : Natural := 0;
+ Nbr_Conc_Non_Sensitized_Processes : Natural := 0;
+ begin
+ for I in Processes_Table.First .. Processes_Table.Last loop
+ Proc := Processes_Table.Table (I).Label;
+ case Get_Kind (Proc) is
+ when Iir_Kind_Sensitized_Process_Statement =>
+ if Get_Process_Origin (Proc) = Null_Iir then
+ Stmt := Get_Sequential_Statement_Chain (Proc);
+ if Stmt /= Null_Iir
+ and then Get_Kind (Stmt) = Iir_Kind_If_Statement
+ and then Get_Chain (Stmt) = Null_Iir
+ then
+ Nbr_User_If_Sensitized_Processes :=
+ Nbr_User_If_Sensitized_Processes + 1;
+ else
+ Nbr_User_Sensitized_Processes :=
+ Nbr_User_Sensitized_Processes + 1;
+ end if;
+ else
+ Nbr_Conc_Sensitized_Processes :=
+ Nbr_Conc_Sensitized_Processes + 1;
+ end if;
+ when Iir_Kind_Process_Statement =>
+ if Get_Process_Origin (Proc) = Null_Iir then
+ Nbr_User_Non_Sensitized_Processes :=
+ Nbr_User_Non_Sensitized_Processes + 1;
+ else
+ Nbr_Conc_Non_Sensitized_Processes :=
+ Nbr_Conc_Non_Sensitized_Processes + 1;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+
+ Put (Natural'Image (Nbr_User_If_Sensitized_Processes));
+ Put_Line (" user sensitized processes with only a if stmt");
+ Put (Natural'Image (Nbr_User_Sensitized_Processes));
+ Put_Line (" user sensitized processes (others)");
+ Put (Natural'Image (Nbr_User_Non_Sensitized_Processes));
+ Put_Line (" user non sensitized processes");
+ Put (Natural'Image (Nbr_Conc_Sensitized_Processes));
+ Put_Line (" sensitized concurrent statements");
+ Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes));
+ Put_Line (" non sensitized concurrent statements");
+ Put (Process_Index_Type'Image (Processes_Table.Last));
+ Put_Line (" processes (total)");
+ end Disp_Process_Stats;
+
+ procedure Disp_Signals_Stats
+ is
+ type Counters_Type is array (Signal_Type_Kind) of Natural;
+ Counters : Counters_Type := (others => 0);
+ Nbr_Signal_Elements : Natural := 0;
+ begin
+ for I in Signals_Table.First .. Signals_Table.Last loop
+ declare
+ Ent : Signal_Entry renames Signals_Table.Table (I);
+ begin
+ if Ent.Kind = User_Signal then
+ Nbr_Signal_Elements := Nbr_Signal_Elements +
+ Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig);
+ end if;
+ Counters (Ent.Kind) := Counters (Ent.Kind) + 1;
+ end;
+ end loop;
+ Put (Integer'Image (Counters (User_Signal)));
+ Put_Line (" declared user signals or ports");
+ Put (Integer'Image (Nbr_Signal_Elements));
+ Put_Line (" user signals sub-elements");
+ Put (Integer'Image (Counters (Implicit_Quiet)));
+ Put_Line (" 'quiet implicit signals");
+ Put (Integer'Image (Counters (Implicit_Stable)));
+ Put_Line (" 'stable implicit signals");
+ Put (Integer'Image (Counters (Implicit_Delayed)));
+ Put_Line (" 'delayed implicit signals");
+ Put (Integer'Image (Counters (Implicit_Transaction)));
+ Put_Line (" 'transaction implicit signals");
+ Put (Integer'Image (Counters (Guard_Signal)));
+ Put_Line (" guard signals");
+ end Disp_Signals_Stats;
+
+ procedure Disp_Design_Stats is
+ begin
+ Disp_Process_Stats;
+
+ New_Line;
+
+ Disp_Signals_Stats;
+
+ New_Line;
+
+ Put (Integer'Image (Connect_Table.Last));
+ Put_Line (" connections");
+ end Disp_Design_Stats;
+
+ procedure Disp_Design_Non_Sensitized
+ is
+ Instance : Block_Instance_Acc;
+ Proc : Iir;
+ begin
+ for I in Processes_Table.First .. Processes_Table.Last loop
+ Instance := Processes_Table.Table (I);
+ Proc := Processes_Table.Table (I).Label;
+ if Get_Kind (Proc) = Iir_Kind_Process_Statement then
+ Disp_Instance_Name (Instance);
+ New_Line;
+ Put_Line (" at " & Disp_Location (Proc));
+ end if;
+ end loop;
+ end Disp_Design_Non_Sensitized;
+
+ procedure Disp_Design_Connections is
+ begin
+ for I in Connect_Table.First .. Connect_Table.Last loop
+ declare
+ Conn : Connect_Entry renames Connect_Table.Table (I);
+ begin
+ Disp_Iir_Location (Conn.Assoc);
+ New_Line;
+ end;
+ end loop;
+ end Disp_Design_Connections;
+
+ function Walk_Files (Cb : Walk_Cb) return Walk_Status
+ is
+ Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain;
+ File : Iir_Design_File;
+ begin
+ while Lib /= Null_Iir loop
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ case Cb.all (File) is
+ when Walk_Continue =>
+ null;
+ when Walk_Up =>
+ exit;
+ when Walk_Abort =>
+ return Walk_Abort;
+ end case;
+ File := Get_Chain (File);
+ end loop;
+ Lib := Get_Chain (Lib);
+ end loop;
+ return Walk_Continue;
+ end Walk_Files;
+
+ Walk_Units_Cb : Walk_Cb;
+
+ function Cb_Walk_Units (Design_File : Iir) return Walk_Status
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is
+ when Walk_Continue =>
+ null;
+ when Walk_Abort =>
+ return Walk_Abort;
+ when Walk_Up =>
+ exit;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ return Walk_Continue;
+ end Cb_Walk_Units;
+
+ function Walk_Units (Cb : Walk_Cb) return Walk_Status is
+ begin
+ Walk_Units_Cb := Cb;
+ return Walk_Files (Cb_Walk_Units'Access);
+ end Walk_Units;
+
+ Walk_Declarations_Cb : Walk_Cb;
+
+ function Cb_Walk_Declarations (Unit : Iir) return Walk_Status
+ is
+ function Walk_Decl_Chain (Chain : Iir) return Walk_Status
+ is
+ Decl : Iir;
+ begin
+ Decl := Chain;
+ while Decl /= Null_Iir loop
+ case Walk_Declarations_Cb.all (Decl) is
+ when Walk_Abort =>
+ return Walk_Abort;
+ when Walk_Up =>
+ return Walk_Continue;
+ when Walk_Continue =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ return Walk_Continue;
+ end Walk_Decl_Chain;
+
+ function Walk_Conc_Chain (Chain : Iir) return Walk_Status
+ is
+ Stmt : Iir := Chain;
+ begin
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Process_Statement =>
+ if Walk_Decl_Chain (Get_Declaration_Chain (Stmt))
+ = Walk_Abort
+ then
+ return Walk_Abort;
+ end if;
+ when others =>
+ Error_Kind ("walk_conc_chain", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ return Walk_Continue;
+ end Walk_Conc_Chain;
+ begin
+ case Get_Kind (Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort
+ or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort
+ or else (Walk_Decl_Chain
+ (Get_Declaration_Chain (Unit)) = Walk_Abort)
+ or else (Walk_Conc_Chain
+ (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort)
+ then
+ return Walk_Abort;
+ end if;
+ when Iir_Kind_Architecture_Body =>
+ if (Walk_Decl_Chain
+ (Get_Declaration_Chain (Unit)) = Walk_Abort)
+ or else (Walk_Conc_Chain
+ (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort)
+ then
+ return Walk_Abort;
+ end if;
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body =>
+ if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort
+ then
+ return Walk_Abort;
+ end if;
+ when Iir_Kind_Configuration_Declaration =>
+ if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort
+ then
+ return Walk_Abort;
+ end if;
+ -- FIXME: block configuration ?
+ when others =>
+ Error_Kind ("Cb_Walk_Declarations", Unit);
+ end case;
+ return Walk_Continue;
+ end Cb_Walk_Declarations;
+
+ function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is
+ begin
+ Walk_Declarations_Cb := Cb;
+ return Walk_Units (Cb_Walk_Declarations'Access);
+ end Walk_Declarations;
+
+ function Is_Blank (C : Character) return Boolean is
+ begin
+ return C = ' ' or else C = ASCII.HT;
+ end Is_Blank;
+
+ function Skip_Blanks (S : String) return Positive
+ is
+ P : Positive := S'First;
+ begin
+ while P <= S'Last and then Is_Blank (S (P)) loop
+ P := P + 1;
+ end loop;
+ return P;
+ end Skip_Blanks;
+
+ -- Return the position of the last character of the word (the last
+ -- non-blank character).
+ function Get_Word (S : String) return Positive
+ is
+ P : Positive := S'First;
+ begin
+ while P <= S'Last and then not Is_Blank (S (P)) loop
+ P := P + 1;
+ end loop;
+ return P - 1;
+ end Get_Word;
+
+ procedure Disp_A_Frame (Instance: Block_Instance_Acc) is
+ begin
+ Put (Disp_Node (Instance.Label));
+ if Instance.Stmt /= Null_Iir then
+ Put (" at ");
+ Put (Get_Location_Str (Get_Location (Instance.Stmt)));
+ end if;
+ New_Line;
+ end Disp_A_Frame;
+
+ type Menu_Kind is (Menu_Command, Menu_Submenu);
+ type Menu_Entry (Kind : Menu_Kind);
+ type Menu_Entry_Acc is access all Menu_Entry;
+
+ type Cst_String_Acc is access constant String;
+
+ type Menu_Procedure is access procedure (Line : String);
+
+ type Menu_Entry (Kind : Menu_Kind) is record
+ Name : Cst_String_Acc;
+ Next : Menu_Entry_Acc;
+
+ case Kind is
+ when Menu_Command =>
+ Proc : Menu_Procedure;
+ when Menu_Submenu =>
+ First, Last : Menu_Entry_Acc := null;
+ end case;
+ end record;
+
+ -- Check there is a current process.
+ procedure Check_Current_Process is
+ begin
+ if Current_Process = null then
+ Put_Line ("no current process");
+ raise Command_Error;
+ end if;
+ end Check_Current_Process;
+
+ -- The status of the debugger. This status can be modified by a command
+ -- as a side effect to resume or quit the debugger.
+ type Command_Status_Type is (Status_Default, Status_Quit);
+ Command_Status : Command_Status_Type;
+
+ procedure Help_Proc (Line : String);
+
+ procedure Disp_Process_Loc (Proc : Process_State_Type) is
+ begin
+ Disp_Instance_Name (Proc.Top_Instance);
+ Put (" (" & Get_Location_Str (Get_Location (Proc.Proc)) & ")");
+ New_Line;
+ end Disp_Process_Loc;
+
+ -- Disp the list of processes (and its state)
+ procedure Ps_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Process : Iir;
+ begin
+ if Processes_State = null then
+ Put_Line ("no processes");
+ return;
+ end if;
+
+ for I in Processes_State'Range loop
+ Put (Process_Index_Type'Image (I) & ": ");
+ Process := Processes_State (I).Proc;
+ if Process /= Null_Iir then
+ Disp_Process_Loc (Processes_State (I));
+ Disp_A_Frame (Processes_State (I).Instance);
+ else
+ Put_Line ("not yet elaborated");
+ end if;
+ end loop;
+ end Ps_Proc;
+
+ procedure Up_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ begin
+ Check_Current_Process;
+ if Dbg_Cur_Frame.Parent = null then
+ Put_Line ("top of frames reached");
+ else
+ Set_Cur_Frame (Dbg_Cur_Frame.Parent);
+ end if;
+ end Up_Proc;
+
+ procedure Down_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ Inst : Block_Instance_Acc;
+ begin
+ Check_Current_Process;
+ if Dbg_Cur_Frame = Dbg_Top_Frame then
+ Put_Line ("bottom of frames reached");
+ else
+ Inst := Dbg_Top_Frame;
+ while Inst.Parent /= Dbg_Cur_Frame loop
+ Inst := Inst.Parent;
+ end loop;
+ Set_Cur_Frame (Inst);
+ end if;
+ end Down_Proc;
+
+ procedure Set_Breakpoint (Stmt : Iir) is
+ begin
+ Put_Line
+ ("set breakpoint at: " & Get_Location_Str (Get_Location (Stmt)));
+ Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt));
+ Flag_Need_Debug := True;
+ end Set_Breakpoint;
+
+ procedure Next_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ begin
+ Exec_State := Exec_Next;
+ Exec_Instance := Dbg_Top_Frame;
+ Flag_Need_Debug := True;
+ Command_Status := Status_Quit;
+ end Next_Proc;
+
+ procedure Step_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ begin
+ Exec_State := Exec_Single_Step;
+ Flag_Need_Debug := True;
+ Command_Status := Status_Quit;
+ end Step_Proc;
+
+ Break_Id : Name_Id;
+
+ function Cb_Set_Break (El : Iir) return Walk_Status is
+ begin
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if Get_Identifier (El) = Break_Id then
+ Set_Breakpoint
+ (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El)));
+ end if;
+ when others =>
+ null;
+ end case;
+ return Walk_Continue;
+ end Cb_Set_Break;
+
+ procedure Break_Proc (Line : String)
+ is
+ Status : Walk_Status;
+ P : Natural;
+ begin
+ P := Skip_Blanks (Line);
+ Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last));
+ Status := Walk_Declarations (Cb_Set_Break'Access);
+ pragma Assert (Status = Walk_Continue);
+ end Break_Proc;
+
+ procedure Where_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Frame : Block_Instance_Acc;
+ begin
+ Check_Current_Process;
+ Frame := Dbg_Top_Frame;
+ while Frame /= null loop
+ if Frame = Dbg_Cur_Frame then
+ Put ("* ");
+ else
+ Put (" ");
+ end if;
+ Disp_A_Frame (Frame);
+ Frame := Frame.Parent;
+ end loop;
+ end Where_Proc;
+
+ procedure Info_Tree_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ begin
+ if Top_Instance = null then
+ Put_Line ("design not yet fully elaborated");
+ else
+ Disp_Instances_Tree;
+ end if;
+ end Info_Tree_Proc;
+
+ procedure Info_Params_Proc (Line : String)
+ is
+ pragma Unreferenced (Line);
+ Decl : Iir;
+ Params : Iir;
+ begin
+ Check_Current_Process;
+ Decl := Dbg_Cur_Frame.Label;
+ if Decl = Null_Iir
+ or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration
+ then
+ Put_Line ("current frame is not a subprogram");
+ return;
+ end if;
+ Params := Get_Interface_Declaration_Chain (Decl);
+ Disp_Declaration_Objects (Dbg_Cur_Frame, Params);
+ end Info_Params_Proc;
+
+ procedure Info_Proc_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ begin
+ Check_Current_Process;
+ Disp_Process_Loc (Current_Process.all);
+ end Info_Proc_Proc;
+
+ function Cb_Disp_Subprograms (El : Iir) return Walk_Status is
+ begin
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Put_Line (Name_Table.Image (Get_Identifier (El)));
+ when others =>
+ null;
+ end case;
+ return Walk_Continue;
+ end Cb_Disp_Subprograms;
+
+ procedure Info_Subprograms_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Status : Walk_Status;
+ begin
+ Status := Walk_Declarations (Cb_Disp_Subprograms'Access);
+ pragma Assert (Status = Walk_Continue);
+ end Info_Subprograms_Proc;
+
+ function Cb_Disp_Units (El : Iir) return Walk_Status is
+ begin
+ case Get_Kind (El) is
+ when Iir_Kind_Package_Declaration =>
+ Put ("package ");
+ Put_Line (Name_Table.Image (Get_Identifier (El)));
+ when Iir_Kind_Entity_Declaration =>
+ Put ("entity ");
+ Put_Line (Name_Table.Image (Get_Identifier (El)));
+ when Iir_Kind_Architecture_Body =>
+ Put ("architecture ");
+ Put (Name_Table.Image (Get_Identifier (El)));
+ Put (" of ");
+ Put_Line (Name_Table.Image (Get_Identifier (Get_Entity (El))));
+ when Iir_Kind_Configuration_Declaration =>
+ Put ("configuration ");
+ Put_Line (Name_Table.Image (Get_Identifier (El)));
+ when Iir_Kind_Package_Body =>
+ null;
+ when others =>
+ Error_Kind ("cb_disp_units", El);
+ end case;
+ return Walk_Continue;
+ end Cb_Disp_Units;
+
+ procedure Info_Units_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Status : Walk_Status;
+ begin
+ Status := Walk_Units (Cb_Disp_Units'Access);
+ pragma Assert (Status = Walk_Continue);
+ end Info_Units_Proc;
+
+ function Cb_Disp_File (El : Iir) return Walk_Status is
+ begin
+ Put_Line (Name_Table.Image (Get_Design_File_Filename (El)));
+ return Walk_Continue;
+ end Cb_Disp_File;
+
+ procedure Info_Stats_Proc (Line : String) is
+ P : Natural := Line'First;
+ E : Natural;
+ begin
+ P := Skip_Blanks (Line (P .. Line'Last));
+ if P > Line'Last then
+ -- No parameters.
+ Disp_Design_Stats;
+ return;
+ end if;
+
+ E := Get_Word (Line (P .. Line'Last));
+ if Line (P .. E) = "global" then
+ Disp_Design_Stats;
+ elsif Line (P .. E) = "non-sensitized" then
+ Disp_Design_Non_Sensitized;
+ null;
+ elsif Line (P .. E) = "connections" then
+ Disp_Design_Connections;
+ -- TODO: nbr of conversions
+ else
+ Put_Line ("options are: global, non-sensitized, connections");
+ -- TODO: signals: nbr of scalars, nbr of non-user...
+ end if;
+ end Info_Stats_Proc;
+
+ procedure Info_Files_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Status : Walk_Status;
+ begin
+ Status := Walk_Files (Cb_Disp_File'Access);
+ pragma Assert (Status = Walk_Continue);
+ end Info_Files_Proc;
+
+ procedure Info_Libraries_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain;
+ begin
+ while Lib /= Null_Iir loop
+ Put_Line (Name_Table.Image (Get_Identifier (Lib)));
+ Lib := Get_Chain (Lib);
+ end loop;
+ end Info_Libraries_Proc;
+
+ procedure Disp_Declared_Signals_Chain
+ (Chain : Iir; Instance : Block_Instance_Acc)
+ is
+ pragma Unreferenced (Instance);
+ Decl : Iir;
+ begin
+ Decl := Chain;
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration =>
+ Put_Line (" " & Name_Table.Image (Get_Identifier (Decl)));
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Disp_Declared_Signals_Chain;
+
+ procedure Disp_Declared_Signals (Decl : Iir; Instance : Block_Instance_Acc)
+ is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ Disp_Declared_Signals (Get_Parent (Decl), Instance);
+ when Iir_Kind_Architecture_Body =>
+ Disp_Declared_Signals (Get_Entity (Decl), Instance);
+ when Iir_Kind_Entity_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("disp_declared_signals", Decl);
+ end case;
+
+ case Get_Kind (Decl) is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ -- No signal declaration in a process (FIXME: implicit signals)
+ null;
+ when Iir_Kind_Architecture_Body =>
+ Put_Line ("Signals of architecture "
+ & Name_Table.Image (Get_Identifier (Decl)) & ':');
+ Disp_Declared_Signals_Chain
+ (Get_Declaration_Chain (Decl), Instance);
+ when Iir_Kind_Entity_Declaration =>
+ Put_Line ("Ports of entity "
+ & Name_Table.Image (Get_Identifier (Decl)) & ':');
+ Disp_Declared_Signals_Chain
+ (Get_Port_Chain (Decl), Instance);
+ when others =>
+ Error_Kind ("disp_declared_signals (2)", Decl);
+ end case;
+ end Disp_Declared_Signals;
+
+ procedure Info_Signals_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ begin
+ Check_Current_Process;
+ Disp_Declared_Signals
+ (Current_Process.Proc, Current_Process.Top_Instance);
+ end Info_Signals_Proc;
+
+ type Handle_Scope_Type is access procedure (N : Iir);
+
+ procedure Foreach_Scopes (N : Iir; Handler : Handle_Scope_Type) is
+ begin
+ case Get_Kind (N) is
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Foreach_Scopes (Get_Parent (N), Handler);
+ Handler.all (N);
+ when Iir_Kind_Architecture_Body =>
+ Foreach_Scopes (Get_Entity (N), Handler);
+ Handler.all (N);
+
+ when Iir_Kind_Entity_Declaration =>
+ -- Top of scopes.
+ null;
+
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Foreach_Scopes (Get_Parent (N), Handler);
+ Handler.all (N);
+ when Iir_Kind_Package_Body =>
+ Handler.all (N);
+
+ when Iir_Kind_Variable_Assignment_Statement
+ | 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_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Case_Statement =>
+ Foreach_Scopes (Get_Parent (N), Handler);
+
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Foreach_Scopes (Get_Parent (N), Handler);
+ Handler.all (N);
+
+ when others =>
+ Error_Kind ("foreach_scopes", N);
+ end case;
+ end Foreach_Scopes;
+
+ procedure Add_Decls_For (N : Iir)
+ is
+ use Sem_Scopes;
+ begin
+ case Get_Kind (N) is
+ when Iir_Kind_Entity_Declaration =>
+ declare
+ Unit : constant Iir := Get_Design_Unit (N);
+ begin
+ Add_Context_Clauses (Unit);
+ -- Add_Name (Unit, Get_Identifier (N), False);
+ Add_Entity_Declarations (N);
+ end;
+ when Iir_Kind_Architecture_Body =>
+ Open_Declarative_Region;
+ Add_Context_Clauses (Get_Design_Unit (N));
+ Add_Declarations (Get_Declaration_Chain (N), False);
+ Add_Declarations_Of_Concurrent_Statement (N);
+ when Iir_Kind_Package_Body =>
+ declare
+ Package_Decl : constant Iir := Get_Package (N);
+ Package_Unit : constant Iir := Get_Design_Unit (Package_Decl);
+ begin
+ Add_Name (Package_Unit);
+ Add_Context_Clauses (Package_Unit);
+ Open_Declarative_Region;
+ Add_Declarations (Get_Declaration_Chain (Package_Decl), False);
+ Add_Declarations (Get_Declaration_Chain (N), False);
+ end;
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ declare
+ Spec : constant Iir := Get_Subprogram_Specification (N);
+ begin
+ Open_Declarative_Region;
+ Add_Declarations
+ (Get_Interface_Declaration_Chain (Spec), False);
+ Add_Declarations
+ (Get_Declaration_Chain (N), False);
+ end;
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Open_Declarative_Region;
+ Add_Declarations (Get_Declaration_Chain (N), False);
+ when Iir_Kind_For_Loop_Statement =>
+ Open_Declarative_Region;
+ Add_Name (Get_Parameter_Specification (N));
+ when Iir_Kind_Block_Statement =>
+ Open_Declarative_Region;
+ Add_Declarations (Get_Declaration_Chain (N), False);
+ Add_Declarations_Of_Concurrent_Statement (N);
+ when Iir_Kind_Generate_Statement =>
+ Open_Declarative_Region;
+ Add_Declarations (Get_Declaration_Chain (N), False);
+ Add_Declarations_Of_Concurrent_Statement (N);
+ when others =>
+ Error_Kind ("enter_scope(2)", N);
+ end case;
+ end Add_Decls_For;
+
+ procedure Enter_Scope (Node : Iir)
+ is
+ use Sem_Scopes;
+ begin
+ Push_Interpretations;
+ Open_Declarative_Region;
+
+ -- Add STD
+ Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False);
+ Use_All_Names (Std_Package.Standard_Package);
+
+ Foreach_Scopes (Node, Add_Decls_For'Access);
+ end Enter_Scope;
+
+ procedure Del_Decls_For (N : Iir)
+ is
+ use Sem_Scopes;
+ begin
+ case Get_Kind (N) is
+ when Iir_Kind_Entity_Declaration =>
+ null;
+ when Iir_Kind_Architecture_Body =>
+ Close_Declarative_Region;
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Close_Declarative_Region;
+ when others =>
+ Error_Kind ("Decl_Decls_For", N);
+ end case;
+ end Del_Decls_For;
+
+ procedure Leave_Scope (Node : Iir)
+ is
+ use Sem_Scopes;
+ begin
+ Foreach_Scopes (Node, Del_Decls_For'Access);
+
+ Close_Declarative_Region;
+ Pop_Interpretations;
+ end Leave_Scope;
+
+ Buffer_Index : Natural := 1;
+
+ procedure Print_Proc (Line : String)
+ is
+ use Tokens;
+ Index_Str : String := Natural'Image (Buffer_Index);
+ File : Source_File_Entry;
+ Expr : Iir;
+ Res : Iir_Value_Literal_Acc;
+ P : Natural;
+ Opt_Value : Boolean := False;
+ Marker : Mark_Type;
+ begin
+ -- Decode options: /v
+ P := Line'First;
+ loop
+ P := Skip_Blanks (Line (P .. Line'Last));
+ if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then
+ Opt_Value := True;
+ P := P + 2;
+ else
+ exit;
+ end if;
+ end loop;
+
+ Buffer_Index := Buffer_Index + 1;
+ Index_Str (Index_Str'First) := '*';
+ File := Files_Map.Create_Source_File_From_String
+ (Name_Table.Get_Identifier ("*debug" & Index_Str & '*'),
+ Line (P .. Line'Last));
+ Scanner.Set_File (File);
+ Scanner.Scan;
+ Expr := Parse.Parse_Expression;
+ if Scanner.Current_Token /= Tok_Eof then
+ Put_Line ("garbage at end of expression ignored");
+ end if;
+ Scanner.Close_File;
+ if Nbr_Errors /= 0 then
+ Put_Line ("error while parsing expression, evaluation aborted");
+ Nbr_Errors := 0;
+ return;
+ end if;
+
+ Enter_Scope (Dbg_Cur_Frame.Stmt);
+ Expr := Sem_Expr.Sem_Expression_Universal (Expr);
+ Leave_Scope (Dbg_Cur_Frame.Stmt);
+
+ if Expr = Null_Iir
+ or else Nbr_Errors /= 0
+ then
+ Put_Line ("error while analyzing expression, evaluation aborted");
+ Nbr_Errors := 0;
+ return;
+ end if;
+
+ Disp_Vhdl.Disp_Expression (Expr);
+ New_Line;
+
+ Annotate_Expand_Table;
+
+ Mark (Marker, Expr_Pool);
+
+ Res := Execute_Expression (Dbg_Cur_Frame, Expr);
+ if Opt_Value then
+ Disp_Value (Res);
+ else
+ Disp_Iir_Value (Res, Get_Type (Expr));
+ end if;
+ New_Line;
+
+ -- Free value
+ Release (Marker, Expr_Pool);
+ end Print_Proc;
+
+ procedure Quit_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ begin
+ Command_Status := Status_Quit;
+ raise Debugger_Quit;
+ end Quit_Proc;
+
+ procedure Cont_Proc (Line : String) is
+ pragma Unreferenced (Line);
+ begin
+ Command_Status := Status_Quit;
+
+ -- Set Flag_Need_Debug only if there is at least one enabled breakpoint.
+ Flag_Need_Debug := False;
+ for I in Breakpoints.First .. Breakpoints.Last loop
+ Flag_Need_Debug := True;
+ exit;
+ end loop;
+ end Cont_Proc;
+
+ Menu_Info_Stats : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("stats"),
+ Next => null,
+ Proc => Info_Stats_Proc'Access);
+
+ Menu_Info_Tree : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("tree"),
+ Next => Menu_Info_Stats'Access,
+ Proc => Info_Tree_Proc'Access);
+
+ Menu_Info_Params : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("param*eters"),
+ Next => Menu_Info_Tree'Access,
+ Proc => Info_Params_Proc'Access);
+
+ Menu_Info_Subprograms : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("subp*rograms"),
+ Next => Menu_Info_Params'Access,
+ Proc => Info_Subprograms_Proc'Access);
+
+ Menu_Info_Units : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("units"),
+ Next => Menu_Info_Subprograms'Access,
+ Proc => Info_Units_Proc'Access);
+
+ Menu_Info_Files : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("files"),
+ Next => Menu_Info_Units'Access,
+ Proc => Info_Files_Proc'Access);
+
+ Menu_Info_Libraries : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("lib*raries"),
+ Next => Menu_Info_Files'Access,
+ Proc => Info_Libraries_Proc'Access);
+
+ Menu_Info_Signals : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("sig*nals"),
+ Next => Menu_Info_Libraries'Access,
+ Proc => Info_Signals_Proc'Access);
+
+ Menu_Info_Proc : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("proc*esses"),
+ Next => Menu_Info_Signals'Access,
+ Proc => Info_Proc_Proc'Access);
+
+ Menu_Down : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("down"),
+ Next => null,
+ Proc => Down_Proc'Access);
+
+ Menu_Up : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("up"),
+ Next => Menu_Down'Access,
+ Proc => Up_Proc'Access);
+
+ Menu_Next : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("n*ext"),
+ Next => Menu_Up'Access,
+ Proc => Next_Proc'Access);
+
+ Menu_Step : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("s*tep"),
+ Next => Menu_Next'Access,
+ Proc => Step_Proc'Access);
+
+ Menu_Break : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("b*reak"),
+ Next => Menu_Step'Access,
+ Proc => Break_Proc'Access);
+
+ Menu_Where : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("where"),
+ Next => Menu_Break'Access,
+ Proc => Where_Proc'Access);
+
+ Menu_Ps : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("ps"),
+ Next => Menu_Where'Access,
+ Proc => Ps_Proc'Access);
+
+ Menu_Info : aliased Menu_Entry :=
+ (Kind => Menu_Submenu,
+ Name => new String'("i*nfo"),
+ Next => Menu_Ps'Access,
+ First | Last => Menu_Info_Proc'Access);
+
+ Menu_Print : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("pr*int"),
+ Next => Menu_Info'Access,
+ Proc => Print_Proc'Access);
+
+ Menu_Cont : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("c*ont"),
+ Next => Menu_Print'Access,
+ Proc => Cont_Proc'Access);
+
+ Menu_Quit : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("q*uit"),
+ Next => Menu_Cont'Access,
+ Proc => Quit_Proc'Access);
+
+ Menu_Help1 : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("help"),
+ Next => Menu_Quit'Access,
+ Proc => Help_Proc'Access);
+
+ Menu_Help2 : aliased Menu_Entry :=
+ (Kind => Menu_Command,
+ Name => new String'("?"),
+ Next => Menu_Help1'Access,
+ Proc => Help_Proc'Access);
+
+ Menu_Top : aliased Menu_Entry :=
+ (Kind => Menu_Submenu,
+ Name => null,
+ Next => null,
+ First | Last => Menu_Help2'Access);
+
+ function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String)
+ return Menu_Entry_Acc
+ is
+ function Is_Cmd (Cmd_Name : String; Str : String) return Boolean
+ is
+ -- Number of characters that were compared.
+ P : Natural;
+ begin
+ P := 0;
+ -- Prefix (before the '*').
+ loop
+ if P = Cmd_Name'Length then
+ -- Full match.
+ return P = Str'Length;
+ end if;
+ exit when Cmd_Name (Cmd_Name'First + P) = '*';
+ if P = Str'Length then
+ -- Command is too short
+ return False;
+ end if;
+ if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then
+ return False;
+ end if;
+ P := P + 1;
+ end loop;
+ -- Suffix (after the '*')
+ loop
+ if P = Str'Length then
+ return True;
+ end if;
+ if P + 1 = Cmd_Name'Length then
+ -- String is too long
+ return False;
+ end if;
+ if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then
+ return False;
+ end if;
+ P := P + 1;
+ end loop;
+ end Is_Cmd;
+ Ent : Menu_Entry_Acc;
+ begin
+ Ent := Menu.First;
+ while Ent /= null loop
+ if Is_Cmd (Ent.Name.all, Cmd) then
+ return Ent;
+ end if;
+ Ent := Ent.Next;
+ end loop;
+ return null;
+ end Find_Menu;
+
+ procedure Parse_Command (Line : String;
+ P : in out Natural;
+ Menu : out Menu_Entry_Acc)
+ is
+ E : Natural;
+ begin
+ P := Skip_Blanks (Line (P .. Line'Last));
+ if P > Line'Last then
+ return;
+ end if;
+ E := Get_Word (Line (P .. Line'Last));
+ Menu := Find_Menu (Menu, Line (P .. E));
+ if Menu = null then
+ Put_Line ("command '" & Line (P .. E) & "' not found");
+ end if;
+ P := E + 1;
+ end Parse_Command;
+
+ procedure Help_Proc (Line : String) is
+ P : Natural;
+ Root : Menu_Entry_Acc := Menu_Top'access;
+ begin
+ Put_Line ("This is the help command");
+ P := Line'First;
+ while P < Line'Last loop
+ Parse_Command (Line, P, Root);
+ if Root = null then
+ return;
+ elsif Root.Kind /= Menu_Submenu then
+ Put_Line ("Menu entry " & Root.Name.all & " is not a submenu");
+ return;
+ end if;
+ end loop;
+
+ Root := Root.First;
+ while Root /= null loop
+ Put (Root.Name.all);
+ if Root.Kind = Menu_Submenu then
+ Put (" (menu)");
+ end if;
+ New_Line;
+ Root := Root.Next;
+ end loop;
+ end Help_Proc;
+
+ procedure Disp_Source_Line (Loc : Location_Type)
+ is
+ use Files_Map;
+
+ File : Source_File_Entry;
+ Line_Pos : Source_Ptr;
+ Line : Natural;
+ Offset : Natural;
+ Buf : File_Buffer_Acc;
+ Next_Line_Pos : Source_Ptr;
+ begin
+ Location_To_Coord (Loc, File, Line_Pos, Line, Offset);
+ Buf := Get_File_Source (File);
+ Next_Line_Pos := Line_To_Position (File, Line + 1);
+ Put (String (Buf (Line_Pos .. Next_Line_Pos - 1)));
+ end Disp_Source_Line;
+
+ function Breakpoint_Hit return Natural
+ is
+ Stmt : constant Iir := Current_Process.Instance.Stmt;
+ begin
+ for I in Breakpoints.First .. Breakpoints.Last loop
+ if Stmt = Breakpoints.Table (I).Stmt then
+ return I;
+ end if;
+ end loop;
+ return 0;
+ end Breakpoint_Hit;
+
+ Prompt_Debug : constant String := "debug> " & ASCII.NUL;
+ Prompt_Crash : constant String := "crash> " & ASCII.NUL;
+ Prompt_Init : constant String := "init> " & ASCII.NUL;
+ Prompt_Elab : constant String := "elab> " & ASCII.NUL;
+
+ procedure Debug (Reason: Debug_Reason) is
+ use Grt.Readline;
+ Raw_Line : Char_Ptr;
+ Prompt : System.Address;
+ begin
+ -- Unless interractive, do not use the debugger.
+ if Reason /= Reason_Internal_Debug then
+ if not Flag_Interractive then
+ return;
+ end if;
+ end if;
+
+ Prompt := Prompt_Debug'Address;
+
+ case Reason is
+ when Reason_Start =>
+ Set_Top_Frame (null);
+ Prompt := Prompt_Init'Address;
+ when Reason_Elab =>
+ Set_Top_Frame (null);
+ Prompt := Prompt_Elab'Address;
+ when Reason_Internal_Debug =>
+ if Current_Process = null then
+ Set_Top_Frame (null);
+ else
+ Set_Top_Frame (Current_Process.Instance);
+ end if;
+ when Reason_Break =>
+ case Exec_State is
+ when Exec_Run =>
+ if Breakpoint_Hit /= 0 then
+ Put_Line ("breakpoint hit");
+ else
+ return;
+ end if;
+ when Exec_Single_Step =>
+ -- Default state.
+ Exec_State := Exec_Run;
+ when Exec_Next =>
+ if Current_Process.Instance /= Exec_Instance then
+ return;
+ end if;
+ -- Default state.
+ Exec_State := Exec_Run;
+ end case;
+ Set_Top_Frame (Current_Process.Instance);
+ declare
+ Stmt : constant Iir := Dbg_Cur_Frame.Stmt;
+ begin
+ Put ("stopped at: ");
+ Disp_Iir_Location (Stmt);
+ New_Line;
+ Disp_Source_Line (Get_Location (Stmt));
+ end;
+ when Reason_Assert =>
+ Set_Top_Frame (Current_Process.Instance);
+ Prompt := Prompt_Crash'Address;
+ Put_Line ("assertion failure, enterring in debugger");
+ when Reason_Error =>
+ Set_Top_Frame (Current_Process.Instance);
+ Prompt := Prompt_Crash'Address;
+ Put_Line ("error occurred, enterring in debugger");
+ end case;
+
+ Command_Status := Status_Default;
+
+ loop
+ loop
+ Raw_Line := Readline (Prompt);
+ -- Skip empty lines
+ exit when Raw_Line /= null and then Raw_Line (1) /= ASCII.NUL;
+ end loop;
+ declare
+ Line_Last : constant Natural := Strlen (Raw_Line);
+ Line : String renames Raw_Line (1 .. Line_Last);
+ P, E : Positive;
+ Cmd : Menu_Entry_Acc := Menu_Top'Access;
+ begin
+ -- Find command
+ P := 1;
+ loop
+ E := P;
+ Parse_Command (Line, E, Cmd);
+ exit when Cmd = null;
+ case Cmd.Kind is
+ when Menu_Submenu =>
+ if E > Line_Last then
+ Put_Line ("missing command for submenu "
+ & Line (P .. E - 1));
+ Cmd := null;
+ exit;
+ end if;
+ P := E;
+ when Menu_Command =>
+ exit;
+ end case;
+ end loop;
+
+ if Cmd /= null then
+ Cmd.Proc.all (Line (E .. Line_Last));
+
+ case Command_Status is
+ when Status_Default =>
+ null;
+ when Status_Quit =>
+ exit;
+ end case;
+ end if;
+ exception
+ when Command_Error =>
+ null;
+ end;
+ end loop;
+ -- Put ("resuming");
+ end Debug;
+
+ procedure Debug_Error is
+ begin
+ Debug (Reason_Error);
+ end Debug_Error;
+end Debugger;
diff --git a/src/simulate/debugger.ads b/src/simulate/debugger.ads
new file mode 100644
index 000000000..5e8c7ac67
--- /dev/null
+++ b/src/simulate/debugger.ads
@@ -0,0 +1,90 @@
+-- Debugger for interpreter
+-- 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 Elaboration; use Elaboration;
+with Iirs; use Iirs;
+
+package Debugger is
+ Flag_Need_Debug : Boolean := False;
+
+ -- Disp a message for a constraint error.
+ -- And raise the exception execution_constraint_error.
+ procedure Error_Msg_Constraint (Expr: Iir);
+ pragma No_Return (Error_Msg_Constraint);
+
+ -- Disp a message during execution.
+ procedure Error_Msg_Exec (Msg: String; Loc: Iir);
+ pragma No_Return (Error_Msg_Exec);
+
+ procedure Warning_Msg_Exec (Msg: String; Loc: Iir);
+
+ -- Disp a block instance, in a human readable way.
+ -- Used to debug.
+ procedure Disp_Block_Instance (Instance: Block_Instance_Acc);
+
+ -- Disp the instance tree.
+ procedure Disp_Instances_Tree;
+
+ -- Disp the name of an instance, without newline. The name of
+ -- architectures is displayed unless Short is True.
+ procedure Disp_Instance_Name (Instance: Block_Instance_Acc;
+ Short : Boolean := False);
+
+ -- Disp the resulting processes of elaboration.
+ -- procedure Disp_Processes;
+
+ -- Disp the label of PROCESS, or <unlabeled> if PROCESS has no label.
+ procedure Disp_Label (Process : Iir);
+
+ -- Disp all signals name and values.
+ procedure Disp_Signals_Value;
+
+ procedure Disp_Objects_Value;
+
+ -- Disp stats about the design (number of process, number of signals...)
+ procedure Disp_Design_Stats;
+
+ -- The reason why the debugger is invoked.
+ type Debug_Reason is
+ (-- Called from an external debugger while debugging ghdl.
+ Reason_Internal_Debug,
+
+ -- Interractive session, elaboration not done
+ Reason_Start,
+
+ -- At end of elaboration, for an interractive session
+ Reason_Elab,
+
+ -- Before execution of a statement.
+ Reason_Break,
+
+ -- Assertion failure
+ Reason_Assert,
+
+ -- Non recoverable error occurred (such as index error, overflow...)
+ Reason_Error
+ );
+
+ Debugger_Quit : exception;
+
+ -- Interractive debugger.
+ procedure Debug (Reason: Debug_Reason);
+
+ -- Call the debugger in case of error.
+ procedure Debug_Error;
+end Debugger;
diff --git a/src/simulate/elaboration.adb b/src/simulate/elaboration.adb
new file mode 100644
index 000000000..dd405ec18
--- /dev/null
+++ b/src/simulate/elaboration.adb
@@ -0,0 +1,2582 @@
+-- Elaboration
+-- 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 Errorout; use Errorout;
+with Execution; use Execution;
+with Simulation; use Simulation;
+with Iirs_Utils; use Iirs_Utils;
+with Libraries;
+with Name_Table;
+with File_Operation;
+with Debugger; use Debugger;
+with Iir_Chains; use Iir_Chains;
+with Sem_Names;
+with Grt.Types; use Grt.Types;
+with Simulation.AMS; use Simulation.AMS;
+with Areapools; use Areapools;
+with Grt.Errors;
+
+package body Elaboration is
+
+ procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit);
+
+ procedure Elaborate_Statement_Part
+ (Instance : Block_Instance_Acc; Stmt_Chain: Iir);
+ procedure Elaborate_Type_Definition
+ (Instance : Block_Instance_Acc; Def : Iir);
+ procedure Elaborate_Nature_Definition
+ (Instance : Block_Instance_Acc; Def : Iir);
+
+ function Elaborate_Default_Value
+ (Instance : Block_Instance_Acc; Decl : Iir)
+ return Iir_Value_Literal_Acc;
+
+ -- CONF is the block_configuration for components of ARCH.
+ function Elaborate_Architecture (Arch : Iir_Architecture_Body;
+ Conf : Iir_Block_Configuration;
+ Parent_Instance : Block_Instance_Acc;
+ Stmt : Iir;
+ Generic_Map : Iir;
+ Port_Map : Iir)
+ return Block_Instance_Acc;
+
+ -- Create a new signal, using DEFAULT as initial value.
+ -- Set its number.
+ procedure Elaborate_Signal (Block: Block_Instance_Acc;
+ Signal: Iir;
+ Default : Iir_Value_Literal_Acc)
+ is
+ function Create_Signal (Lit: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Lit.Kind is
+ when Iir_Value_Array =>
+ Res := Create_Array_Value (Lit.Val_Array.Len,
+ Lit.Bounds.Nbr_Dims);
+ Res.Bounds.D := Lit.Bounds.D;
+ Res := Unshare_Bounds (Res, Global_Pool'Access);
+
+ for I in Lit.Val_Array.V'Range loop
+ Res.Val_Array.V (I) := Create_Signal (Lit.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ Res := Create_Record_Value
+ (Lit.Val_Record.Len, Instance_Pool);
+ for I in Lit.Val_Record.V'Range loop
+ Res.Val_Record.V (I) := Create_Signal (Lit.Val_Record.V (I));
+ end loop;
+
+ when Iir_Value_I64
+ | Iir_Value_F64
+ | Iir_Value_B1
+ | Iir_Value_E32 =>
+ Res := Create_Signal_Value (null);
+
+ when Iir_Value_Signal
+ | Iir_Value_Range
+ | Iir_Value_File
+ | Iir_Value_Access
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Create_Signal;
+
+ Sig : Iir_Value_Literal_Acc;
+ Def : Iir_Value_Literal_Acc;
+ Slot : constant Object_Slot_Type := Get_Info (Signal).Slot;
+ begin
+ Sig := Create_Signal (Default);
+ Def := Unshare (Default, Global_Pool'Access);
+ Block.Objects (Slot) := Sig;
+ Block.Objects (Slot + 1) := Def;
+
+ Signals_Table.Append ((Kind => User_Signal,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Block,
+ Init => Def));
+ end Elaborate_Signal;
+
+ function Execute_Time_Attribute (Instance : Block_Instance_Acc; Attr : Iir)
+ return Ghdl_I64
+ is
+ Param : constant Iir := Get_Parameter (Attr);
+ Res : Ghdl_I64;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Param = Null_Iir then
+ Res := 0;
+ else
+ Val := Execute_Expression (Instance, Param);
+ Res := Val.I64;
+ end if;
+ return Res;
+ end Execute_Time_Attribute;
+
+ procedure Elaborate_Implicit_Signal
+ (Instance: Block_Instance_Acc; Signal: Iir; Kind : Signal_Type_Kind)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Signal);
+ Prefix : Iir_Value_Literal_Acc;
+ T : Ghdl_I64;
+ Sig : Iir_Value_Literal_Acc;
+ Init : Iir_Value_Literal_Acc;
+ begin
+ if Kind = Implicit_Transaction then
+ T := 0;
+ Init := Create_B1_Value (False);
+ else
+ T := Execute_Time_Attribute (Instance, Signal);
+ Init := Create_B1_Value (False);
+ end if;
+ Sig := Create_Signal_Value (null);
+ Instance.Objects (Info.Slot) := Sig;
+ Instance.Objects (Info.Slot + 1) := Unshare (Init, Global_Pool'Access);
+
+ Prefix := Execute_Name (Instance, Get_Prefix (Signal), True);
+ Prefix := Unshare_Bounds (Prefix, Global_Pool'Access);
+ case Kind is
+ when Implicit_Stable =>
+ Signals_Table.Append ((Kind => Implicit_Stable,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ when Implicit_Quiet =>
+ Signals_Table.Append ((Kind => Implicit_Quiet,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ when Implicit_Transaction =>
+ Signals_Table.Append ((Kind => Implicit_Transaction,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => 0,
+ Prefix => Prefix));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Elaborate_Implicit_Signal;
+
+ function Create_Delayed_Signal (Pfx : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Pfx.Kind is
+ when Iir_Value_Array =>
+ Res := Create_Array_Value (Pfx.Val_Array.Len,
+ Pfx.Bounds.Nbr_Dims,
+ Global_Pool'Access);
+ Res.Bounds.D := Pfx.Bounds.D;
+
+ for I in Pfx.Val_Array.V'Range loop
+ Res.Val_Array.V (I) := Create_Delayed_Signal
+ (Pfx.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ Res := Create_Record_Value (Pfx.Val_Record.Len,
+ Global_Pool'Access);
+ for I in Pfx.Val_Record.V'Range loop
+ Res.Val_Record.V (I) := Create_Delayed_Signal
+ (Pfx.Val_Record.V (I));
+ end loop;
+ when Iir_Value_Signal =>
+ Res := Create_Signal_Value (null);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Create_Delayed_Signal;
+
+ procedure Elaborate_Delayed_Signal
+ (Instance: Block_Instance_Acc; Signal: Iir)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Signal);
+ Prefix : Iir_Value_Literal_Acc;
+ Sig : Iir_Value_Literal_Acc;
+ Init : Iir_Value_Literal_Acc;
+ T : Ghdl_I64;
+ begin
+ Prefix := Execute_Name (Instance, Get_Prefix (Signal), True);
+ Prefix := Unshare_Bounds (Prefix, Global_Pool'Access);
+
+ T := Execute_Time_Attribute (Instance, Signal);
+
+ Sig := Create_Delayed_Signal (Prefix);
+ Instance.Objects (Info.Slot) := Sig;
+
+ Init := Execute_Signal_Init_Value (Instance, Get_Prefix (Signal));
+ Init := Unshare_Bounds (Init, Global_Pool'Access);
+ Instance.Objects (Info.Slot + 1) := Init;
+
+ Signals_Table.Append ((Kind => Implicit_Delayed,
+ Decl => Signal,
+ Sig => Sig,
+ Instance => Instance,
+ Time => T,
+ Prefix => Prefix));
+ end Elaborate_Delayed_Signal;
+
+ procedure Elaborate_Package (Decl: Iir)
+ is
+ Package_Info : constant Sim_Info_Acc := Get_Info (Decl);
+ Instance : Block_Instance_Acc;
+ begin
+ Instance := new Block_Instance_Type'
+ (Max_Objs => Package_Info.Nbr_Objects,
+ Scope_Level => Package_Info.Frame_Scope_Level,
+ Up_Block => null,
+ Label => Decl,
+ Stmt => Null_Iir,
+ Parent => null,
+ Children => null,
+ Brother => null,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ In_Wait_Flag => False,
+ Actuals_Ref => null,
+ Result => null);
+
+ Package_Instances (Package_Info.Inst_Slot) := Instance;
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl));
+ end if;
+
+ -- Elaborate objects declarations.
+ Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl));
+ end Elaborate_Package;
+
+ procedure Elaborate_Package_Body (Decl: Iir)
+ is
+ Package_Info : constant Sim_Info_Acc := Get_Info (Decl);
+ Instance : Block_Instance_Acc;
+ begin
+ Instance := Package_Instances
+ (Instance_Slot_Type (-Package_Info.Frame_Scope_Level));
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put_Line ("elaborating " & Disp_Node (Decl));
+ end if;
+
+ -- Elaborate objects declarations.
+ Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Decl));
+ end Elaborate_Package_Body;
+
+ -- Elaborate all packages which DESIGN_UNIT depends on.
+ -- The packages are elaborated only once. The body, if the package needs
+ -- one, can be loaded during the elaboration.
+ -- Recursive function.
+ -- FIXME: handle pathological cases of recursion.
+ -- Due to the rules of analysis, it is not possible to have a circulare
+ -- dependence.
+ procedure Elaborate_Dependence (Design_Unit: Iir_Design_Unit) is
+ Depend_List: Iir_Design_Unit_List;
+ Design: Iir;
+ Library_Unit: Iir;
+ begin
+ Depend_List := Get_Dependence_List (Design_Unit);
+
+ for I in Natural loop
+ Design := Get_Nth_Element (Depend_List, I);
+ exit when Design = Null_Iir;
+ if Get_Kind (Design) = Iir_Kind_Entity_Aspect_Entity then
+ -- During Sem, the architecture may be still unknown, and the
+ -- dependency is therefore the aspect.
+ Library_Unit := Get_Architecture (Design);
+ Design := Get_Design_Unit (Library_Unit);
+ else
+ Library_Unit := Get_Library_Unit (Design);
+ end if;
+ -- Elaborates only non-elaborated packages.
+ case Get_Kind (Library_Unit) is
+ when Iir_Kind_Package_Declaration =>
+ declare
+ Info : constant Sim_Info_Acc := Get_Info (Library_Unit);
+ Body_Design: Iir_Design_Unit;
+ begin
+ if Package_Instances (Info.Inst_Slot) = null then
+ -- Package not yet elaborated.
+
+ -- Load the body now, as it can add objects in the
+ -- package instance.
+ Body_Design := Libraries.Load_Secondary_Unit
+ (Design, Null_Identifier, Design_Unit);
+
+ -- First the packages on which DESIGN depends.
+ Elaborate_Dependence (Design);
+
+ -- Then the declaration.
+ Elaborate_Package (Library_Unit);
+
+ -- And then the body (if any).
+ if Body_Design = Null_Iir then
+ if Get_Need_Body (Library_Unit) then
+ Error_Msg_Elab
+ ("no package body for `" &
+ Image_Identifier (Library_Unit) & ''');
+ end if;
+ else
+ -- Note: the body can elaborate some packages.
+ Elaborate_Dependence (Body_Design);
+
+ Elaborate_Package_Body
+ (Get_Library_Unit (Body_Design));
+ end if;
+ end if;
+ end;
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Architecture_Body =>
+ Elaborate_Dependence (Design);
+ when others =>
+ Error_Kind ("elaborate_dependence", Library_Unit);
+ end case;
+ end loop;
+ end Elaborate_Dependence;
+
+ -- Create a block instance to instantiate OBJ (block, component,
+ -- architecture, generate) in FATHER. STMT is the statement/declaration
+ -- at the origin of the instantiation (it is generally the same as OBJ,
+ -- except for component where STMT is the component instantation
+ -- statement).
+ function Create_Block_Instance
+ (Father : Block_Instance_Acc;
+ Obj : Iir;
+ Stmt : Iir)
+ return Block_Instance_Acc
+ is
+ Obj_Info : constant Sim_Info_Acc := Get_Info (Obj);
+ Res : Block_Instance_Acc;
+ begin
+ Res := new Block_Instance_Type'
+ (Max_Objs => Obj_Info.Nbr_Objects,
+ Scope_Level => Obj_Info.Frame_Scope_Level,
+ Up_Block => Father,
+ Label => Stmt,
+ Stmt => Obj,
+ Parent => Father,
+ Children => null,
+ Brother => null,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ In_Wait_Flag => False,
+ Actuals_Ref => null,
+ Result => null);
+
+ if Father /= null then
+ Res.Brother := Father.Children;
+ Father.Children := Res;
+ end if;
+
+ return Res;
+ end Create_Block_Instance;
+
+ function Create_Protected_Object (Block: Block_Instance_Acc; Decl: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Bod : constant Iir := Get_Protected_Type_Body (Decl);
+ Inst : Block_Instance_Acc;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Protected_Table.Increment_Last;
+ Res := Create_Protected_Value (Protected_Table.Last);
+
+ Inst := Create_Subprogram_Instance (Block, Bod);
+ Protected_Table.Table (Res.Prot) := Inst;
+
+ -- Temporary put the instancce on the stack in case of function calls
+ -- during the elaboration of the protected object.
+ Current_Process.Instance := Inst;
+
+ Elaborate_Declarative_Part (Inst, Get_Declaration_Chain (Bod));
+
+ Current_Process.Instance := Block;
+
+ return Res;
+ end Create_Protected_Object;
+
+ -- Create an value_literal for DECL (defined in BLOCK) and set it with
+ -- its default values. Nodes are shared.
+ function Create_Value_For_Type
+ (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ if Default then
+ Bounds := Execute_Bounds (Block, Decl);
+ Res := Bounds.Left;
+ else
+ case Get_Info (Get_Base_Type (Decl)).Scalar_Mode is
+ when Iir_Value_B1 =>
+ Res := Create_B1_Value (False);
+ when Iir_Value_E32 =>
+ Res := Create_E32_Value (0);
+ when Iir_Value_I64 =>
+ Res := Create_I64_Value (0);
+ when Iir_Value_F64 =>
+ Res := Create_F64_Value (0.0);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ Res := Create_Array_Bounds_From_Type (Block, Decl, True);
+ declare
+ El : Iir_Value_Literal_Acc;
+ begin
+ if Res.Val_Array.Len > 0 then
+ El := Create_Value_For_Type
+ (Block, Get_Element_Subtype (Decl), Default);
+ Res.Val_Array.V (1) := El;
+ for I in 2 .. Res.Val_Array.Len loop
+ Res.Val_Array.V (I) := El;
+ end loop;
+ end if;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir_Element_Declaration;
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Decl));
+ begin
+ Res := Create_Record_Value
+ (Iir_Index32 (Get_Nbr_Elements (List)));
+
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Res.Val_Record.V (1 + Get_Element_Position (El)) :=
+ Create_Value_For_Type (Block, Get_Type (El), Default);
+ end loop;
+ end;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ return Create_Access_Value (null);
+ when Iir_Kind_Protected_Type_Declaration =>
+ return Create_Protected_Object (Block, Decl);
+ when others =>
+ Error_Kind ("create_value_for_type", Decl);
+ end case;
+ return Res;
+ end Create_Value_For_Type;
+
+ procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Slot : constant Object_Slot_Type := Get_Info (Decl).Slot;
+ begin
+ -- Check elaboration order.
+ -- Note: this is not done for package since objects from package are
+ -- commons (same scope), and package annotation order can be different
+ -- from package elaboration order (eg: body).
+ if Slot /= Instance.Elab_Objects + 1
+ or else Instance.Objects (Slot) /= null
+ then
+ Error_Msg_Elab ("bad elaboration order");
+ raise Internal_Error;
+ end if;
+ Instance.Elab_Objects := Slot;
+ end Create_Object;
+
+ procedure Destroy_Object (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Info : constant Sim_Info_Acc := Get_Info (Decl);
+ Slot : constant Object_Slot_Type := Info.Slot;
+ begin
+ if Slot /= Instance.Elab_Objects
+ or else Info.Scope_Level /= Instance.Scope_Level
+ then
+ Error_Msg_Elab ("bad destroy order");
+ raise Internal_Error;
+ end if;
+ -- Clear the slot (this is necessary for ranges).
+ Instance.Objects (Slot) := null;
+ Instance.Elab_Objects := Slot - 1;
+ end Destroy_Object;
+
+ procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Slot : constant Object_Slot_Type := Get_Info (Decl).Slot;
+ begin
+ if Slot /= Instance.Elab_Objects + 1
+ or else Instance.Objects (Slot) /= null
+ then
+ Error_Msg_Elab ("bad elaboration order");
+ raise Internal_Error;
+ end if;
+ -- One slot is reserved for default value
+ Instance.Elab_Objects := Slot + 1;
+ end Create_Signal;
+
+ function Create_Terminal_Object (Block: Block_Instance_Acc;
+ Decl : Iir;
+ Def: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ Res := Create_Terminal_Value
+ (Create_Scalar_Terminal (Decl, Block));
+ when others =>
+ Error_Kind ("create_terminal_object", Def);
+ end case;
+ return Res;
+ end Create_Terminal_Object;
+
+ procedure Create_Terminal (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Slot : constant Object_Slot_Type := Get_Info (Decl).Slot;
+ begin
+ if Slot + 1 = Instance.Elab_Objects then
+ -- Reference terminal of nature declaration may have already been
+ -- elaborated.
+ return;
+ end if;
+ if Slot /= Instance.Elab_Objects then
+ Error_Msg_Elab ("bad elaboration order");
+ raise Internal_Error;
+ end if;
+ Instance.Objects (Slot) :=
+ Create_Terminal_Object (Instance, Decl, Get_Nature (Decl));
+ Instance.Elab_Objects := Slot + 1;
+ end Create_Terminal;
+
+ function Create_Quantity_Object (Block: Block_Instance_Acc;
+ Decl : Iir;
+ Def: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Kind : Quantity_Kind;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ case Iir_Kinds_Quantity_Declaration (Get_Kind (Decl)) is
+ when Iir_Kind_Across_Quantity_Declaration =>
+ Kind := Quantity_Across;
+ when Iir_Kind_Through_Quantity_Declaration =>
+ Kind := Quantity_Through;
+ when Iir_Kind_Free_Quantity_Declaration =>
+ Kind := Quantity_Free;
+ end case;
+ Res := Create_Quantity_Value
+ (Create_Scalar_Quantity (Kind, Decl, Block));
+ when others =>
+ Error_Kind ("create_quantity_object", Def);
+ end case;
+ return Res;
+ end Create_Quantity_Object;
+
+ function Create_Quantity (Instance : Block_Instance_Acc; Decl : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Slot : constant Object_Slot_Type := Get_Info (Decl).Slot;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ if Slot /= Instance.Elab_Objects then
+ Error_Msg_Elab ("bad elaboration order");
+ raise Internal_Error;
+ end if;
+ Res := Create_Quantity_Object (Instance, Decl, Get_Type (Decl));
+ Instance.Objects (Slot) := Res;
+ Instance.Elab_Objects := Slot + 1;
+ return Res;
+ end Create_Quantity;
+
+ function Elaborate_Bound_Constraint
+ (Instance : Block_Instance_Acc; Bound: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Value : Iir_Value_Literal_Acc;
+ Ref : constant Iir := Get_Type (Bound);
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Value_For_Type (Instance, Ref, False);
+ Res := Unshare (Res, Instance_Pool);
+ Value := Execute_Expression (Instance, Bound);
+ Assign_Value_To_Object (Instance, Res, Ref, Value, Bound);
+ return Res;
+ end Elaborate_Bound_Constraint;
+
+ procedure Elaborate_Range_Expression
+ (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression)
+ is
+ Range_Info : constant Sim_Info_Acc := Get_Info (Rc);
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Range_Info.Scope_Level /= Instance.Scope_Level
+ or else Instance.Objects (Range_Info.Slot) /= null
+ then
+ -- A range expression may have already been created, for example
+ -- when severals objects are created with the same subtype:
+ -- variable v, v1 : bit_vector (x to y);
+ return;
+ end if;
+ if False
+ and then (Range_Info.Scope_Level /= Instance.Scope_Level
+ or else Range_Info.Slot < Instance.Elab_Objects)
+ then
+ -- FIXME: the test is wrong for packages.
+ -- The range was already elaborated.
+ -- ?? Is that possible
+ raise Internal_Error;
+ return;
+ end if;
+ Create_Object (Instance, Rc);
+ Val := Create_Range_Value
+ (Elaborate_Bound_Constraint (Instance, Get_Left_Limit (Rc)),
+ Elaborate_Bound_Constraint (Instance, Get_Right_Limit (Rc)),
+ Get_Direction (Rc));
+ Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool);
+ end Elaborate_Range_Expression;
+
+ procedure Elaborate_Range_Constraint
+ (Instance : Block_Instance_Acc; Rc: Iir)
+ is
+ begin
+ case Get_Kind (Rc) is
+ when Iir_Kind_Range_Expression =>
+ Elaborate_Range_Expression (Instance, Rc);
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ null;
+ when others =>
+ Error_Kind ("elaborate_range_constraint", Rc);
+ end case;
+ end Elaborate_Range_Constraint;
+
+ -- Create the bounds of a scalar type definition.
+ -- Elaborate_Range_Constraint cannot be used, as it checks bounds (and
+ -- here we create the bounds).
+ procedure Elaborate_Type_Range
+ (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression)
+ is
+ Range_Info : Sim_Info_Acc;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ Range_Info := Get_Info (Rc);
+ Create_Object (Instance, Rc);
+ Val := Create_Range_Value
+ (Execute_Expression (Instance, Get_Left_Limit (Rc)),
+ Execute_Expression (Instance, Get_Right_Limit (Rc)),
+ Get_Direction (Rc));
+ Instance.Objects (Range_Info.Slot) := Unshare (Val, Instance_Pool);
+ end Elaborate_Type_Range;
+
+ -- DECL is a subtype indication.
+ -- Elaborate DECL only if it is anonymous.
+ procedure Elaborate_Subtype_Indication_If_Anonymous
+ (Instance : Block_Instance_Acc; Decl : Iir) is
+ begin
+ if Is_Anonymous_Type_Definition (Decl) then
+ Elaborate_Subtype_Indication (Instance, Decl);
+ end if;
+ end Elaborate_Subtype_Indication_If_Anonymous;
+
+ -- LRM93 �12.3.1.3 Subtype Declarations
+ -- The elaboration of a subtype indication creates a subtype.
+ procedure Elaborate_Subtype_Indication
+ (Instance : Block_Instance_Acc; Ind : Iir)
+ is
+ begin
+ case Get_Kind (Ind) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Record_Type_Definition =>
+ Elaborate_Type_Definition (Instance, Ind);
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- LRM93 12.3.1.3
+ -- The elaboration of an index constraint consists of the
+ -- declaration of each of the discrete ranges in the index
+ -- constraint in some order that is not defined by the language.
+ declare
+ St_Indexes : constant Iir_List := Get_Index_Subtype_List (Ind);
+ St_El : Iir;
+ begin
+ for I in Natural loop
+ St_El := Get_Index_Type (St_Indexes, I);
+ exit when St_El = Null_Iir;
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, St_El);
+ end loop;
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Element_Subtype (Ind));
+ end;
+ when Iir_Kind_Record_Subtype_Definition =>
+ null;
+ when Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind));
+ when Iir_Kind_Physical_Subtype_Definition =>
+ Elaborate_Range_Constraint (Instance, Get_Range_Constraint (Ind));
+ when others =>
+ Error_Kind ("elaborate_subtype_indication", Ind);
+ end case;
+ end Elaborate_Subtype_Indication;
+
+ -- LRM93 �12.3.1.2 Type Declarations.
+ procedure Elaborate_Type_Definition
+ (Instance : Block_Instance_Acc; Def : Iir)
+ is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ -- Elaboration of an enumeration type definition has not effect
+ -- other than the creation of the corresponding type.
+ Elaborate_Type_Range (Instance, Get_Range_Constraint (Def));
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ null;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ -- Elaboration of an integer, floating point, or physical type
+ -- definition consists of the elaboration of the corresponding
+ -- range constraint.
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, Def);
+ -- Elaboration of a physical unit declaration has no effect other
+ -- than to create the unit defined by the unit declaration.
+ null;
+ when Iir_Kind_Array_Type_Definition =>
+ -- Elaboration of an unconstrained array type definition consists
+ -- of the elaboration of the element subtype indication of the
+ -- array type.
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Element_Subtype (Def));
+ when Iir_Kind_Access_Type_Definition =>
+ -- Elaboration of an access type definition consists of the
+ -- elaboration of the corresponding subtype indication.
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Designated_Type (Def));
+ when Iir_Kind_File_Type_Definition =>
+ -- GHDL: There is nothing about elaboration of a file type
+ -- definition. FIXME ??
+ null;
+ when Iir_Kind_Record_Type_Definition =>
+ -- Elaboration of a record type definition consists of the
+ -- elaboration of the equivalent single element declarations in
+ -- the given order.
+ declare
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ -- Elaboration of an element declaration consists of
+ -- elaboration of the element subtype indication.
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (El));
+ end loop;
+ end;
+ when Iir_Kind_Protected_Type_Declaration =>
+ Elaborate_Declarative_Part
+ (Instance, Get_Declaration_Chain (Def));
+
+ when Iir_Kind_Incomplete_Type_Definition =>
+ null;
+ when others =>
+ Error_Kind ("elaborate_type_definition", Def);
+ end case;
+ end Elaborate_Type_Definition;
+
+ -- LRM93 �12.3.1.2 Type Declarations.
+ procedure Elaborate_Type_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir_Type_Declaration)
+ is
+ Def : Iir;
+ Base_Type : Iir_Array_Type_Definition;
+ begin
+ -- Elaboration of a type declaration generally consists of the
+ -- elaboration of the definition of the type and the creation of that
+ -- type.
+ Def := Get_Type_Definition (Decl);
+ if Def = Null_Iir then
+ -- FIXME: can this happen ?
+ raise Program_Error;
+ end if;
+ if Get_Kind (Def) = Iir_Kind_Array_Subtype_Definition then
+ Base_Type := Get_Base_Type (Def);
+ -- For a constrained array type declaration, however,
+ -- elaboration consists of the elaboration of the equivalent
+ -- anonymous unconstrained array type [...]
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, Base_Type);
+ -- [...] followed by the elaboration of the named subtype
+ -- of that unconstrained type.
+ Elaborate_Subtype_Indication (Instance, Def);
+ else
+ Elaborate_Type_Definition (Instance, Def);
+ end if;
+ end Elaborate_Type_Declaration;
+
+ procedure Elaborate_Nature_Definition
+ (Instance : Block_Instance_Acc; Def : Iir)
+ is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ Elaborate_Subtype_Indication (Instance, Get_Across_Type (Def));
+ Elaborate_Subtype_Indication (Instance, Get_Through_Type (Def));
+ when others =>
+ Error_Kind ("elaborate_nature_definition", Def);
+ end case;
+ end Elaborate_Nature_Definition;
+
+ -- LRM93 �12.2.1 The Generic Clause
+ procedure Elaborate_Generic_Clause
+ (Instance : Block_Instance_Acc; Generic_Chain : Iir)
+ is
+ Decl : Iir_Constant_Interface_Declaration;
+ begin
+ -- Elaboration of a generic clause consists of the elaboration of each
+ -- of the equivalent single generic declarations contained in the
+ -- clause, in the order given.
+ Decl := Generic_Chain;
+ while Decl /= Null_Iir loop
+ -- The elaboration of a generic declaration consists of elaborating
+ -- the subtype indication and then creating a generic constant of
+ -- that subtype.
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl));
+ Create_Object (Instance, Decl);
+ -- The value of a generic constant is not defined until a subsequent
+ -- generic map aspect is evaluated, or in the absence of a generic
+ -- map aspect, until the default expression associated with the
+ -- generic constant is evaluated to determine the value of the
+ -- constant.
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Elaborate_Generic_Clause;
+
+ -- LRM93 12.2.3 The Port Clause
+ procedure Elaborate_Port_Clause
+ (Instance : Block_Instance_Acc; Port_Chain : Iir)
+ is
+ Decl : Iir_Signal_Interface_Declaration;
+ begin
+ Decl := Port_Chain;
+ while Decl /= Null_Iir loop
+ -- LRM93 �12.2.3
+ -- The elaboration of a port declaration consists of elaborating the
+ -- subtype indication and then creating a port of that subtype.
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, Get_Type (Decl));
+
+ -- Simply increase an index to check that the port was created.
+ Create_Signal (Instance, Decl);
+
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Elaborate_Port_Clause;
+
+ -- LRM93 �12.2.2 The generic Map Aspect
+ procedure Elaborate_Generic_Map_Aspect
+ (Target_Instance : Block_Instance_Acc;
+ Local_Instance : Block_Instance_Acc;
+ Map : Iir)
+ is
+ Assoc : Iir;
+ Inter : Iir_Constant_Interface_Declaration;
+ Value : Iir;
+ Val : Iir_Value_Literal_Acc;
+ Last_Individual : Iir_Value_Literal_Acc;
+ begin
+ -- Elaboration of a generic map aspect consists of elaborating the
+ -- generic association list.
+
+ -- Elaboration of a generic association list consists of the
+ -- elaboration of each generic association element in the
+ -- association list.
+ Assoc := Map;
+ while Assoc /= Null_Iir loop
+ -- Elaboration of a generic association element consists of the
+ -- elaboration of the formal part and the evaluation of the actual
+ -- part.
+ -- FIXME: elaboration of the formal part.
+ Inter := Get_Association_Interface (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ -- The generic association list contains an implicit
+ -- association element for each generic constant that is not
+ -- explicitly associated with an actual [GHDL: done trought
+ -- annotations] or that is associated with the reserved word
+ -- OPEN; the actual part of such an implicit association
+ -- element is the default expression appearing in the
+ -- declaration of that generic constant.
+ Value := Get_Default_Value (Inter);
+ if Value = Null_Iir then
+ Error_Msg_Exec ("no default value", Inter);
+ return;
+ end if;
+ Val := Execute_Expression (Target_Instance, Value);
+ when Iir_Kind_Association_Element_By_Expression =>
+ Value := Get_Actual (Assoc);
+ Val := Execute_Expression (Local_Instance, Value);
+ when Iir_Kind_Association_Element_By_Individual =>
+ Val := Create_Value_For_Type
+ (Local_Instance, Get_Actual_Type (Assoc), False);
+
+ Last_Individual := Unshare (Val, Instance_Pool);
+ Target_Instance.Objects (Get_Info (Inter).Slot) :=
+ Last_Individual;
+ goto Continue;
+ when others =>
+ Error_Kind ("elaborate_generic_map_aspect", Assoc);
+ end case;
+
+ if Get_Whole_Association_Flag (Assoc) then
+ -- It is an error if the value of the actual does not belong to
+ -- the subtype denoted by the subtype indication of the formal.
+ -- If the subtype denoted by the subtype indication of the
+ -- declaration of the formal is a constrained array subtype, then
+ -- an implicit subtype conversion is performed prior to this
+ -- check.
+ -- It is also an error if the type of the formal is an array type
+ -- and the value of each element of the actual does not belong to
+ -- the element subtype of the formal.
+ Implicit_Array_Conversion
+ (Target_Instance, Val, Get_Type (Inter), Inter);
+ Check_Constraints (Target_Instance, Val, Get_Type (Inter), Inter);
+
+ -- The generic constant or subelement or slice thereof designated
+ -- by the formal part is then initialized with the value
+ -- resulting from the evaluation of the corresponding actual part.
+ Target_Instance.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ else
+ declare
+ Targ : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Execute_Name_With_Base
+ (Target_Instance, Get_Formal (Assoc),
+ Last_Individual, Targ, Is_Sig);
+ Store (Targ, Val);
+ end;
+ end if;
+
+ <<Continue>> null;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Elaborate_Generic_Map_Aspect;
+
+ -- Return TRUE if EXPR is a signal name.
+ function Is_Signal (Expr : Iir) return Boolean
+ is
+ Obj : Iir;
+ begin
+ Obj := Sem_Names.Name_To_Object (Expr);
+ if Obj /= Null_Iir then
+ return Is_Signal_Object (Obj);
+ else
+ return False;
+ end if;
+ end Is_Signal;
+
+ -- LRM93 12.2.3 The Port Clause
+ procedure Elaborate_Port_Declaration
+ (Instance : Block_Instance_Acc;
+ Decl : Iir_Signal_Interface_Declaration;
+ Default_Value : Iir_Value_Literal_Acc)
+ is
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Default_Value = null then
+ Val := Elaborate_Default_Value (Instance, Decl);
+ else
+ Val := Default_Value;
+ end if;
+ Elaborate_Signal (Instance, Decl, Val);
+ end Elaborate_Port_Declaration;
+
+ procedure Elab_Connect
+ (Formal_Instance : Block_Instance_Acc;
+ Local_Instance : Block_Instance_Acc;
+ Actual_Expr : Iir_Value_Literal_Acc;
+ Assoc : Iir_Association_Element_By_Expression)
+ is
+ Inter : Iir;
+ Actual : Iir;
+ Local_Expr : Iir_Value_Literal_Acc;
+ Formal_Expr : Iir_Value_Literal_Acc;
+ begin
+ Inter := Get_Formal (Assoc);
+ Actual := Get_Actual (Assoc);
+ Formal_Expr := Execute_Name (Formal_Instance, Inter, True);
+ Formal_Expr := Unshare_Bounds (Formal_Expr, Global_Pool'Access);
+ if Actual_Expr = null then
+ Local_Expr := Execute_Name (Local_Instance, Actual, True);
+ Local_Expr := Unshare_Bounds (Local_Expr, Global_Pool'Access);
+ else
+ Local_Expr := Actual_Expr;
+ end if;
+
+ Connect_Table.Append ((Formal => Formal_Expr,
+ Formal_Instance => Formal_Instance,
+ Actual => Local_Expr,
+ Actual_Instance => Local_Instance,
+ Assoc => Assoc));
+ end Elab_Connect;
+
+ -- LRM93 12.2.3 The Port Clause
+ -- LRM93 �12.2.4 The Port Map Aspect
+ procedure Elaborate_Port_Map_Aspect
+ (Formal_Instance : Block_Instance_Acc;
+ Actual_Instance : Block_Instance_Acc;
+ Ports : Iir;
+ Map : Iir)
+ is
+ Assoc : Iir;
+ Inter : Iir_Signal_Interface_Declaration;
+ Actual_Expr : Iir_Value_Literal_Acc;
+ Init_Expr : Iir_Value_Literal_Acc;
+ Actual : Iir;
+ begin
+ if Ports = Null_Iir then
+ return;
+ end if;
+
+ -- Elaboration of a port map aspect consists of elaborating the port
+ -- association list.
+ if Map = Null_Iir then
+ -- No port association, elaborate the port clause.
+ -- Elaboration of a port clause consists of the elaboration of each
+ -- of the equivalent signal port declaration in the clause, in the
+ -- order given.
+ Inter := Ports;
+ while Inter /= Null_Iir loop
+ Elaborate_Port_Declaration (Formal_Instance, Inter, null);
+ Inter := Get_Chain (Inter);
+ end loop;
+ return;
+ end if;
+
+ Current_Component := Formal_Instance;
+
+ Assoc := Map;
+ while Assoc /= Null_Iir loop
+ -- Elaboration of a port association list consists of the elaboration
+ -- of each port association element in the association list whose
+ -- actual is not the reserved word OPEN.
+ Inter := Get_Association_Interface (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_In_Conversion (Assoc) = Null_Iir
+ and then Get_Out_Conversion (Assoc) = Null_Iir
+ then
+ Actual := Get_Actual (Assoc);
+ if Is_Signal (Actual) then
+ -- Association with a signal
+ Init_Expr := Execute_Signal_Init_Value
+ (Actual_Instance, Actual);
+ Implicit_Array_Conversion
+ (Formal_Instance, Init_Expr, Get_Type (Inter), Actual);
+ Init_Expr := Unshare_Bounds
+ (Init_Expr, Global_Pool'Access);
+ Actual_Expr := null;
+ else
+ -- Association with an expression
+ Init_Expr := Execute_Expression
+ (Actual_Instance, Actual);
+ Implicit_Array_Conversion
+ (Formal_Instance, Init_Expr,
+ Get_Type (Inter), Actual);
+ Init_Expr := Unshare (Init_Expr, Global_Pool'Access);
+ Actual_Expr := Init_Expr;
+ end if;
+ else
+ -- The actual doesn't define the constraints of the formal.
+ if Get_Whole_Association_Flag (Assoc) then
+ Init_Expr := Elaborate_Default_Value
+ (Formal_Instance, Inter);
+ Actual_Expr := null;
+ end if;
+ end if;
+
+ if Get_Whole_Association_Flag (Assoc)
+ and then Get_Collapse_Signal_Flag (Assoc)
+ then
+ declare
+ Slot : constant Object_Slot_Type :=
+ Get_Info (Inter).Slot;
+ Actual_Sig : Iir_Value_Literal_Acc;
+ begin
+ Actual_Sig :=
+ Execute_Name (Actual_Instance, Actual, True);
+ Implicit_Array_Conversion
+ (Formal_Instance, Actual_Sig,
+ Get_Type (Inter), Actual);
+ Formal_Instance.Objects (Slot) := Unshare_Bounds
+ (Actual_Sig, Global_Pool'Access);
+ Formal_Instance.Objects (Slot + 1) := Init_Expr;
+ end;
+ else
+ if Get_Whole_Association_Flag (Assoc) then
+ Elaborate_Signal (Formal_Instance, Inter, Init_Expr);
+ end if;
+
+ -- Elaboration of a port association element consists of the
+ -- elaboration of the formal part; the port or subelement
+ -- or slice thereof designated by the formal part is then
+ -- associated with the signal or expression designated
+ -- by the actual part.
+ Elab_Connect
+ (Formal_Instance, Actual_Instance, Actual_Expr, Assoc);
+ end if;
+
+ when Iir_Kind_Association_Element_Open =>
+ -- Note that an open cannot be associated with a formal that
+ -- is associated individually.
+ Elaborate_Port_Declaration (Formal_Instance, Inter, null);
+
+ when Iir_Kind_Association_Element_By_Individual =>
+ Init_Expr := Create_Value_For_Type
+ (Formal_Instance, Get_Actual_Type (Assoc), False);
+ Elaborate_Signal (Formal_Instance, Inter, Init_Expr);
+
+ when others =>
+ Error_Kind ("elaborate_port_map_aspect", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ Current_Component := null;
+ end Elaborate_Port_Map_Aspect;
+
+ -- LRM93 �12.2 Elaboration of a block header
+ -- Elaboration of a block header consists of the elaboration of the
+ -- generic clause, the generic map aspect, the port clause, and the port
+ -- map aspect, in that order.
+ procedure Elaborate_Block_Header
+ (Instance : Block_Instance_Acc; Header : Iir_Block_Header)
+ is
+ begin
+ Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Header));
+ Elaborate_Generic_Map_Aspect
+ (Instance, Instance, Get_Generic_Map_Aspect_Chain (Header));
+ Elaborate_Port_Clause (Instance, Get_Port_Chain (Header));
+ Elaborate_Port_Map_Aspect
+ (Instance, Instance,
+ Get_Port_Chain (Header), Get_Port_Map_Aspect_Chain (Header));
+ end Elaborate_Block_Header;
+
+ procedure Elaborate_Guard_Signal
+ (Instance : Block_Instance_Acc; Guard : Iir)
+ is
+ Sig : Iir_Value_Literal_Acc;
+ Info : constant Sim_Info_Acc := Get_Info (Guard);
+ begin
+ Create_Signal (Instance, Guard);
+
+ Sig := Create_Signal_Value (null);
+ Instance.Objects (Info.Slot) := Sig;
+ Instance.Objects (Info.Slot + 1) :=
+ Unshare (Create_B1_Value (False), Instance_Pool);
+
+ Signals_Table.Append ((Kind => Guard_Signal,
+ Decl => Guard,
+ Sig => Sig,
+ Instance => Instance));
+ end Elaborate_Guard_Signal;
+
+ -- LRM93 �12.4.1 Block statements.
+ procedure Elaborate_Block_Statement
+ (Instance : Block_Instance_Acc; Block : Iir_Block_Statement)
+ is
+ Header : Iir_Block_Header;
+ Ninstance : Block_Instance_Acc; -- FIXME
+ Guard : Iir;
+ begin
+ Ninstance := Create_Block_Instance (Instance, Block, Block);
+
+ Guard := Get_Guard_Decl (Block);
+ if Guard /= Null_Iir then
+ -- LRM93 12.6.4 (3)
+ -- The value of each implicit GUARD signal is set to the result of
+ -- evaluating the corresponding guard expression.
+ -- GHDL: done by grt when the guard signal is created.
+ Elaborate_Guard_Signal (Ninstance, Guard);
+ end if;
+
+ -- Elaboration of a block statement consists of the elaboration of the
+ -- block header, if present [...]
+ Header := Get_Block_Header (Block);
+ if Header /= Null_Iir then
+ Elaborate_Block_Header (Ninstance, Header);
+ end if;
+
+ -- [...] followed by the elaboration of the block declarative part [...]
+ Elaborate_Declarative_Part (Ninstance,
+ Get_Declaration_Chain (Block));
+ -- [...] followed by the elaboration of the block statement part.
+ Elaborate_Statement_Part
+ (Ninstance, Get_Concurrent_Statement_Chain (Block));
+ -- Elaboration of a block statement may occur under the control of a
+ -- configuration declaration.
+ -- In particular, a block configuration, wether implicit or explicit,
+ -- within a configuration declaration may supply a sequence of
+ -- additionnal implicit configuration specification to be applied
+ -- during the elaboration of the corresponding block statement.
+ -- If a block statement is being elaborated under the control of a
+ -- configuration declaration, then the sequence of implicit
+ -- configuration specifications supplied by the block configuration
+ -- is elaborated as part of the block declarative part, following all
+ -- other declarative items in that part.
+ -- The sequence of implicit configuration specifications supplied by a
+ -- block configuration, wether implicit or explicit, consists of each of
+ -- the configuration specifications implied by component configurations
+ -- occurring immediatly within the block configuration, and in the
+ -- order in which the component configurations themselves appear.
+ -- FIXME.
+ end Elaborate_Block_Statement;
+
+ function Create_Default_Association (Formal_Chain : Iir;
+ Local_Chain : Iir;
+ Node : Iir)
+ return Iir
+ is
+ Nbr_Formals : Natural;
+ begin
+ -- LRM93 5.2.2
+ -- The default binding indication includes a default generic map
+ -- aspect if the design entity implied by the entity aspect contains
+ -- formal generic.
+ --
+ -- LRM93 5.2.2
+ -- The default binding indication includes a default port map aspect if
+ -- the design entity implied by the entity aspect contains formal ports.
+ if Formal_Chain = Null_Iir then
+ if Local_Chain /= Null_Iir then
+ Error_Msg_Sem ("cannot create default map aspect", Node);
+ end if;
+ return Null_Iir;
+ end if;
+ Nbr_Formals := Get_Chain_Length (Formal_Chain);
+ declare
+ Assoc_List : Iir_Array (0 .. Nbr_Formals - 1) := (others => Null_Iir);
+ Assoc : Iir;
+ Local : Iir;
+ Formal : Iir;
+ Pos : Natural;
+ First, Last : Iir;
+ begin
+ -- LRM93 5.2.2
+ -- The default generic map aspect associates each local generic in
+ -- the corresponding component instantiation (if any) with a formal
+ -- of the same simple name.
+ Local := Local_Chain;
+ while Local /= Null_Iir loop
+ Formal := Formal_Chain;
+ Pos := 0;
+ while Formal /= Null_Iir loop
+ exit when Get_Identifier (Formal) = Get_Identifier (Local);
+ Formal := Get_Chain (Formal);
+ Pos := Pos + 1;
+ end loop;
+ if Formal = Null_Iir then
+ -- LRM93 5.2.2
+ -- It is an error if such a formal does not exist, or if
+ -- its mode and type are not appropriate for such an
+ -- association.
+ -- FIXME: mode/type check.
+ Error_Msg_Sem
+ ("cannot associate local " & Disp_Node (Local), Node);
+ exit;
+ end if;
+ if Assoc_List (Pos) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Assoc_List (Pos) := Local;
+
+ Local := Get_Chain (Local);
+ end loop;
+
+ Sub_Chain_Init (First, Last);
+ Formal := Formal_Chain;
+ for I in Assoc_List'Range loop
+ if Assoc_List (I) = Null_Iir then
+ -- LRM93 5.2.2
+ -- Any remaining unassociated formals are associated with the
+ -- actual designator any.
+ Assoc := Create_Iir (Iir_Kind_Association_Element_Open);
+ else
+ Assoc :=
+ Create_Iir (Iir_Kind_Association_Element_By_Expression);
+ Set_Actual (Assoc, Assoc_List (I));
+ end if;
+ Set_Whole_Association_Flag (Assoc, True);
+ Set_Formal (Assoc, Formal);
+ Sub_Chain_Append (First, Last, Assoc);
+
+ Formal := Get_Chain (Formal);
+ end loop;
+ return First;
+ end;
+ end Create_Default_Association;
+
+ -- LRM93 �12.4.3
+ function Is_Fully_Bound (Conf : Iir) return Boolean
+ is
+ Binding : Iir;
+ begin
+ if Conf = Null_Iir then
+ return False;
+ end if;
+ case Get_Kind (Conf) is
+ when Iir_Kind_Configuration_Specification
+ | Iir_Kind_Component_Configuration =>
+ Binding := Get_Binding_Indication (Conf);
+ if Binding = Null_Iir then
+ return False;
+ end if;
+ if Get_Kind (Get_Entity_Aspect (Binding))
+ = Iir_Kind_Entity_Aspect_Open
+ then
+ return False;
+ end if;
+ when others =>
+ null;
+ end case;
+ return True;
+ end Is_Fully_Bound;
+
+ procedure Elaborate_Component_Instantiation
+ (Instance : Block_Instance_Acc;
+ Stmt : Iir_Component_Instantiation_Statement)
+ is
+ Frame : Block_Instance_Acc;
+ begin
+ if Is_Component_Instantiation (Stmt) then
+ declare
+ Component : constant Iir :=
+ Get_Named_Entity (Get_Instantiated_Unit (Stmt));
+ begin
+ -- Elaboration of a component instantiation statement that
+ -- instanciates a component declaration has no effect unless the
+ -- component instance is either fully bound to a design entity
+ -- defined by an entity declaration and architecture body or is
+ -- bound to a configuration of such a design entity.
+ -- FIXME: in fact the component is created.
+
+ -- If a component instance is so bound, then elaboration of the
+ -- corresponding component instantiation statement consists of the
+ -- elaboration of the implied block statement representing the
+ -- component instance and [...]
+ Frame := Create_Block_Instance (Instance, Component, Stmt);
+
+ Elaborate_Generic_Clause (Frame, Get_Generic_Chain (Component));
+ Elaborate_Generic_Map_Aspect
+ (Frame, Instance, Get_Generic_Map_Aspect_Chain (Stmt));
+ Elaborate_Port_Clause (Frame, Get_Port_Chain (Component));
+ Elaborate_Port_Map_Aspect
+ (Frame, Instance,
+ Get_Port_Chain (Component), Get_Port_Map_Aspect_Chain (Stmt));
+ end;
+ else
+ -- Direct instantiation
+ declare
+ Aspect : constant Iir := Get_Instantiated_Unit (Stmt);
+ Arch : Iir;
+ Config : Iir;
+ begin
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Arch := Get_Architecture (Aspect);
+ if Arch = Null_Iir then
+ Arch := Libraries.Get_Latest_Architecture
+ (Get_Entity (Aspect));
+ end if;
+ Config := Get_Library_Unit
+ (Get_Default_Configuration_Declaration (Arch));
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Config := Get_Configuration (Aspect);
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (Config));
+ when Iir_Kind_Entity_Aspect_Open =>
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Config := Get_Block_Configuration (Config);
+
+ Frame := Elaborate_Architecture
+ (Arch, Config, Instance, Stmt,
+ Get_Generic_Map_Aspect_Chain (Stmt),
+ Get_Port_Map_Aspect_Chain (Stmt));
+ end;
+ end if;
+ end Elaborate_Component_Instantiation;
+
+ -- LRM93 12.4.2 Generate Statements
+ procedure Elaborate_Conditional_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Scheme : Iir;
+ Ninstance : Block_Instance_Acc;
+ Lit : Iir_Value_Literal_Acc;
+ begin
+ -- LRM93 12.4.2
+ -- For a generate statement with an if generation scheme, elaboration
+ -- consists of the evaluation of the boolean expression, followed by
+ -- the generation of exactly one block statement if the expression
+ -- evaluates to TRUE, and no block statement otherwise.
+ Scheme := Get_Generation_Scheme (Generate);
+ Lit := Execute_Expression (Instance, Scheme);
+ if Lit.B1 /= True then
+ return;
+ end if;
+
+ -- LRM93 12.4.2
+ -- If generated, the block statement has the following form:
+ -- 1. The block label is the same as the label of the generate
+ -- statement.
+ -- 2. The block declarative part consists of a copy of the declarative
+ -- items contained within the generate statement.
+ -- 3. The block statement part consists of a copy of the concurrent
+ -- statement contained within the generate statement.
+ Ninstance := Create_Block_Instance (Instance, Generate, Generate);
+ Elaborate_Declarative_Part (Ninstance, Get_Declaration_Chain (Generate));
+ Elaborate_Statement_Part
+ (Ninstance, Get_Concurrent_Statement_Chain (Generate));
+ end Elaborate_Conditional_Generate_Statement;
+
+ -- LRM93 12.4.2 Generate Statements
+ procedure Elaborate_Iterative_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Scheme : constant Iir_Iterator_Declaration :=
+ Get_Generation_Scheme (Generate);
+ Ninstance : Block_Instance_Acc;
+ Sub_Instance : Block_Instance_Acc;
+ Bound, Index : Iir_Value_Literal_Acc;
+ begin
+ -- LRM93 12.4.2
+ -- For a generate statement with a for generation scheme, elaboration
+ -- consists of the elaboration of the discrete range
+
+ Ninstance := Create_Block_Instance (Instance, Generate, Generate);
+ Elaborate_Declaration (Ninstance, Scheme);
+ Bound := Execute_Bounds (Ninstance, Get_Type (Scheme));
+
+ -- Index is the iterator value.
+ Index := Unshare (Ninstance.Objects (Get_Info (Scheme).Slot),
+ Current_Pool);
+
+ -- Initialize the iterator.
+ Store (Index, Bound.Left);
+
+ if not Is_In_Range (Index, Bound) then
+ -- Well, this instance should have never been built.
+ -- Should be destroyed ??
+ raise Internal_Error;
+ return;
+ end if;
+
+ loop
+ Sub_Instance := Create_Block_Instance (Ninstance, Generate, Scheme);
+
+ -- FIXME: this is needed to copy iterator type (if any). But this
+ -- elaborates the subtype several times (what about side effects).
+ Elaborate_Declaration (Sub_Instance, Scheme);
+
+ -- Store index.
+ Store (Sub_Instance.Objects (Get_Info (Scheme).Slot), Index);
+
+ Elaborate_Declarative_Part
+ (Sub_Instance, Get_Declaration_Chain (Generate));
+ Elaborate_Statement_Part
+ (Sub_Instance, Get_Concurrent_Statement_Chain (Generate));
+
+ Update_Loop_Index (Index, Bound);
+ exit when not Is_In_Range (Index, Bound);
+ end loop;
+ -- FIXME: destroy index ?
+ end Elaborate_Iterative_Generate_Statement;
+
+ procedure Elaborate_Generate_Statement
+ (Instance : Block_Instance_Acc; Generate : Iir_Generate_Statement)
+ is
+ Scheme : Iir;
+ begin
+ Scheme := Get_Generation_Scheme (Generate);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Elaborate_Iterative_Generate_Statement (Instance, Generate);
+ else
+ Elaborate_Conditional_Generate_Statement (Instance, Generate);
+ end if;
+ end Elaborate_Generate_Statement;
+
+ procedure Elaborate_Process_Statement
+ (Instance : Block_Instance_Acc; Stmt : Iir)
+ is
+ Proc_Instance : Block_Instance_Acc;
+ begin
+ Proc_Instance := Create_Block_Instance (Instance, Stmt, Stmt);
+
+ Processes_Table.Append (Proc_Instance);
+
+ -- Processes aren't elaborated here. They are elaborated
+ -- just before simulation.
+ end Elaborate_Process_Statement;
+
+ -- LRM93 �12.4 Elaboration of a Statement Part.
+ procedure Elaborate_Statement_Part
+ (Instance : Block_Instance_Acc; Stmt_Chain: Iir)
+ is
+ Stmt : Iir;
+ begin
+ -- Concurrent statements appearing in the statement part of a block
+ -- must be elaborated before execution begins.
+ -- Elaboration of the statement part of a block consists of the
+ -- elaboration of each concurrent statement in the order given.
+ Stmt := Stmt_Chain;
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Block_Statement =>
+ Elaborate_Block_Statement (Instance, Stmt);
+
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ Elaborate_Process_Statement (Instance, Stmt);
+
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Elaborate_Component_Instantiation (Instance, Stmt);
+
+ when Iir_Kind_Generate_Statement =>
+ Elaborate_Generate_Statement (Instance, Stmt);
+
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ Add_Characteristic_Expression
+ (Explicit,
+ Build (Op_Plus,
+ Instance, Get_Simultaneous_Right (Stmt),
+ Build (Op_Minus,
+ Instance, Get_Simultaneous_Left (Stmt))));
+
+ when others =>
+ Error_Kind ("elaborate_statement_part", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Elaborate_Statement_Part;
+
+ -- Compute the default value for declaration DECL, using either
+ -- DEFAULT_VALUE if not null, or the implicit default value for DECL.
+ -- DECL must have a type.
+ function Elaborate_Default_Value (Instance : Block_Instance_Acc; Decl : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Default_Value : constant Iir := Get_Default_Value (Decl);
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Default_Value /= Null_Iir then
+ Val := Execute_Expression_With_Type
+ (Instance, Default_Value, Get_Type (Decl));
+ else
+ Val := Create_Value_For_Type (Instance, Get_Type (Decl), True);
+ end if;
+ return Val;
+ end Elaborate_Default_Value;
+
+ -- LRM93 �12.3.1.1 Subprogram Declaration and Bodies
+ procedure Elaborate_Interface_List
+ (Instance : Block_Instance_Acc; Inter_Chain : Iir)
+ is
+ Inter : Iir;
+ begin
+ -- elaboration of the parameter interface list
+ -- this in turn involves the elaboration of the subtype indication of
+ -- each interface element to determine the subtype of each formal
+ -- parameter of the subprogram.
+ Inter := Inter_Chain;
+ while Inter /= Null_Iir loop
+ case Get_Kind (Inter) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Inter));
+ when others =>
+ Error_Kind ("elaborate_interface_list", Inter);
+ end case;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Elaborate_Interface_List;
+
+ -- LRM93 �12.3.1.1 Subprogram Declaration and Bodies
+ procedure Elaborate_Subprogram_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ begin
+ -- Elaboration of a subprogram declaration involves the elaboration
+ -- of the parameter interface list of the subprogram declaration; [...]
+ Elaborate_Interface_List
+ (Instance, Get_Interface_Declaration_Chain (Decl));
+
+ -- Elaboration of a subprogram body has no effect other than to
+ -- establish that the body can, from then on, be used for the
+ -- execution of calls of the subprogram.
+ -- FIXME
+ null;
+ end Elaborate_Subprogram_Declaration;
+
+ procedure Elaborate_Component_Configuration
+ (Stmt : Iir_Component_Instantiation_Statement;
+ Comp_Instance : Block_Instance_Acc;
+ Conf : Iir_Component_Configuration)
+ is
+ Component : constant Iir_Component_Declaration :=
+ Get_Named_Entity (Get_Instantiated_Unit (Stmt));
+ Entity : Iir_Entity_Declaration;
+ Arch_Name : Name_Id;
+ Arch_Design : Iir_Design_Unit;
+ Arch : Iir_Architecture_Body;
+ Arch_Frame : Block_Instance_Acc;
+ pragma Unreferenced (Arch_Frame);
+ Generic_Map_Aspect_Chain : Iir;
+ Port_Map_Aspect_Chain : Iir;
+ Binding : Iir_Binding_Indication;
+ Aspect : Iir;
+ Sub_Conf : Iir;
+ begin
+ if Trace_Elaboration then
+ Ada.Text_IO.Put ("configure component ");
+ Ada.Text_IO.Put (Name_Table.Image (Get_Label (Stmt)));
+ Ada.Text_IO.Put (": ");
+ Ada.Text_IO.Put_Line (Image_Identifier (Component));
+ end if;
+
+ -- Elaboration of a component instantiation statement that instanciates
+ -- a component declaration has no effect unless the component instance
+ -- is either fully bound to a design entity defined by an entity
+ -- declaration and architecture body or is bound to a configuration of
+ -- such a design entity.
+ if not Is_Fully_Bound (Conf) then
+ Warning_Msg (Disp_Node (Stmt) & " not bound");
+ return;
+ end if;
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put_Line
+ (" using " & Disp_Node (Conf) & " from " & Disp_Location (Conf));
+ end if;
+
+ -- If a component instance is so bound, then elaboration of the
+ -- corresponding component instantiation statement consists of the
+ -- elaboration of the implied block statement representing the
+ -- component instance and [...]
+ -- FIXME: extract frame.
+
+ -- and (within that block) the implied block statement representing the
+ -- design entity to which the component instance is so bound.
+ Arch := Null_Iir;
+ Arch_Name := Null_Identifier;
+ Binding := Get_Binding_Indication (Conf);
+ Aspect := Get_Entity_Aspect (Binding);
+
+ case Get_Kind (Conf) is
+ when Iir_Kind_Component_Configuration =>
+ Sub_Conf := Get_Block_Configuration (Conf);
+ when Iir_Kind_Configuration_Specification =>
+ Sub_Conf := Null_Iir;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Design_Unit =>
+ raise Internal_Error;
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Entity := Get_Entity (Aspect);
+ if Get_Architecture (Aspect) /= Null_Iir then
+ Arch_Name := Get_Identifier (Get_Architecture (Aspect));
+ end if;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ if Sub_Conf /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ declare
+ Conf : constant Iir := Get_Configuration (Aspect);
+ begin
+ Entity := Get_Entity (Conf);
+ Sub_Conf := Get_Block_Configuration (Conf);
+ Arch := Get_Block_Specification (Sub_Conf);
+ end;
+ when others =>
+ Error_Kind ("elaborate_component_declaration0", Aspect);
+ end case;
+
+ if Arch = Null_Iir then
+ if Arch_Name = Null_Identifier then
+ Arch := Libraries.Get_Latest_Architecture (Entity);
+ if Arch = Null_Iir then
+ Error_Msg_Elab ("no architecture analysed for "
+ & Disp_Node (Entity), Stmt);
+ end if;
+ Arch_Name := Get_Identifier (Arch);
+ end if;
+ Arch_Design := Libraries.Load_Secondary_Unit
+ (Get_Design_Unit (Entity), Arch_Name, Stmt);
+ if Arch_Design = Null_Iir then
+ Error_Msg_Elab ("no architecture `" & Name_Table.Image (Arch_Name)
+ & "' for " & Disp_Node (Entity), Stmt);
+ end if;
+ Arch := Get_Library_Unit (Arch_Design);
+ end if;
+
+ Generic_Map_Aspect_Chain := Get_Generic_Map_Aspect_Chain (Binding);
+ Port_Map_Aspect_Chain := Get_Port_Map_Aspect_Chain (Binding);
+
+ if Generic_Map_Aspect_Chain = Null_Iir then
+ -- LRM93 5.2.2
+ -- The default binding indication includes a default generic map
+ -- aspect if the design entity implied by the entity aspect contains
+ -- formal generic
+ -- GHDL: this condition is checked by create_default_association.
+ Generic_Map_Aspect_Chain :=
+ Create_Default_Association (Get_Generic_Chain (Entity),
+ Get_Generic_Chain (Component),
+ Stmt);
+ end if;
+
+ if Port_Map_Aspect_Chain = Null_Iir then
+ Port_Map_Aspect_Chain :=
+ Create_Default_Association (Get_Port_Chain (Entity),
+ Get_Port_Chain (Component),
+ Stmt);
+ end if;
+
+ if Sub_Conf = Null_Iir then
+ Sub_Conf := Get_Default_Configuration_Declaration (Arch);
+ Sub_Conf := Get_Block_Configuration (Get_Library_Unit (Sub_Conf));
+ end if;
+
+ -- FIXME: Use Sub_Conf instead of Arch for Stmt ? (But need to add
+ -- info for block configuration).
+ Arch_Frame := Elaborate_Architecture
+ (Arch, Sub_Conf, Comp_Instance, Arch,
+ Generic_Map_Aspect_Chain, Port_Map_Aspect_Chain);
+ end Elaborate_Component_Configuration;
+
+ procedure Elaborate_Block_Configuration
+ (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc);
+
+ procedure Apply_Block_Configuration_To_Iterative_Generate
+ (Stmt : Iir; Conf_Chain : Iir; Instance : Block_Instance_Acc)
+ is
+ Scheme : constant Iir := Get_Generation_Scheme (Stmt);
+ Bounds : constant Iir_Value_Literal_Acc :=
+ Execute_Bounds (Instance, Get_Type (Scheme));
+
+ Sub_Instances : Block_Instance_Acc_Array
+ (0 .. Instance_Slot_Type (Bounds.Length - 1));
+
+ type Sub_Conf_Type is array (0 .. Instance_Slot_Type (Bounds.Length - 1))
+ of Boolean;
+ Sub_Conf : Sub_Conf_Type := (others => False);
+
+ Child : Block_Instance_Acc;
+
+ Item : Iir;
+ Prev_Item : Iir;
+ Default_Item : Iir := Null_Iir;
+ Spec : Iir;
+ Expr : Iir_Value_Literal_Acc;
+ Ind : Instance_Slot_Type;
+ begin
+ -- Gather children
+ Child := Instance.Children;
+ for I in reverse Sub_Instances'Range loop
+ Sub_Instances (I) := Child;
+ Child := Child.Brother;
+ end loop;
+ if Child /= null then
+ raise Internal_Error;
+ end if;
+
+ -- Apply configuration items
+ Item := Conf_Chain;
+ while Item /= Null_Iir loop
+ Spec := Get_Block_Specification (Item);
+ if Get_Kind (Spec) = Iir_Kind_Simple_Name then
+ Spec := Get_Named_Entity (Spec);
+ end if;
+ Prev_Item := Get_Prev_Block_Configuration (Item);
+
+ case Get_Kind (Spec) is
+ when Iir_Kind_Slice_Name =>
+ Expr := Execute_Bounds (Instance, Get_Suffix (Spec));
+ Ind := Instance_Slot_Type
+ (Get_Index_Offset (Execute_Low_Limit (Expr), Bounds, Spec));
+ for I in 1 .. Instance_Slot_Type (Expr.Length) loop
+ Sub_Conf (Ind + I - 1) := True;
+ Elaborate_Block_Configuration
+ (Item, Sub_Instances (Ind + I - 1));
+ end loop;
+ when Iir_Kind_Indexed_Name =>
+ if Get_Index_List (Spec) = Iir_List_Others then
+ -- Must be the only default block configuration
+ pragma Assert (Default_Item = Null_Iir);
+ Default_Item := Item;
+ else
+ Expr := Execute_Expression
+ (Instance, Get_First_Element (Get_Index_List (Spec)));
+ Ind := Instance_Slot_Type
+ (Get_Index_Offset (Expr, Bounds, Spec));
+ Sub_Conf (Ind) := True;
+ Elaborate_Block_Configuration (Item, Sub_Instances (Ind));
+ end if;
+ when Iir_Kind_Generate_Statement =>
+ -- Must be the only block configuration
+ pragma Assert (Item = Conf_Chain);
+ pragma Assert (Prev_Item = Null_Iir);
+ for I in Sub_Instances'Range loop
+ Sub_Conf (I) := True;
+ Elaborate_Block_Configuration (Item, Sub_Instances (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Item := Prev_Item;
+ end loop;
+
+ if Default_Item /= Null_Iir then
+ for I in Sub_Instances'Range loop
+ if not Sub_Conf (I) then
+ Elaborate_Block_Configuration
+ (Default_Item, Sub_Instances (I));
+ end if;
+ end loop;
+ end if;
+ end Apply_Block_Configuration_To_Iterative_Generate;
+
+ procedure Elaborate_Block_Configuration
+ (Conf : Iir_Block_Configuration; Instance : Block_Instance_Acc)
+ is
+ Blk_Info : constant Sim_Info_Acc := Get_Info (Instance.Stmt);
+ Sub_Instances : Block_Instance_Acc_Array
+ (0 .. Blk_Info.Nbr_Instances - 1);
+ type Iir_Array is array (Instance_Slot_Type range <>) of Iir;
+ Sub_Conf : Iir_Array (0 .. Blk_Info.Nbr_Instances - 1) :=
+ (others => Null_Iir);
+
+ Item : Iir;
+ begin
+ pragma Assert (Conf /= Null_Iir);
+
+ -- Associate configuration items with subinstance. Gather items for
+ -- for-generate statements.
+ Item := Get_Configuration_Item_Chain (Conf);
+ while Item /= Null_Iir loop
+ case Get_Kind (Item) is
+ when Iir_Kind_Block_Configuration =>
+ declare
+ Spec : Iir;
+ Gen : Iir_Generate_Statement;
+ Info : Sim_Info_Acc;
+ begin
+ Spec := Get_Block_Specification (Item);
+ if Get_Kind (Spec) = Iir_Kind_Simple_Name then
+ Spec := Get_Named_Entity (Spec);
+ end if;
+ case Get_Kind (Spec) is
+ when Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Name =>
+ -- Block configuration for a generate statement.
+ Gen := Get_Named_Entity (Get_Prefix (Spec));
+ Info := Get_Info (Gen);
+ Set_Prev_Block_Configuration
+ (Item, Sub_Conf (Info.Inst_Slot));
+ Sub_Conf (Info.Inst_Slot) := Item;
+ when Iir_Kind_Generate_Statement =>
+ Info := Get_Info (Spec);
+ if Sub_Conf (Info.Inst_Slot) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Sub_Conf (Info.Inst_Slot) := Item;
+ when Iir_Kind_Block_Statement =>
+ -- Block configuration for a block statement.
+ Info := Get_Info (Spec);
+ if Sub_Conf (Info.Inst_Slot) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Sub_Conf (Info.Inst_Slot) := Item;
+ when others =>
+ Error_Kind ("elaborate_block_configuration1", Spec);
+ end case;
+ end;
+
+ when Iir_Kind_Component_Configuration =>
+ declare
+ List : constant Iir_List :=
+ Get_Instantiation_List (Item);
+ El : Iir;
+ Info : Sim_Info_Acc;
+ begin
+ if List = Iir_List_All or else List = Iir_List_Others then
+ raise Internal_Error;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Info := Get_Info (Get_Named_Entity (El));
+ if Sub_Conf (Info.Inst_Slot) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Sub_Conf (Info.Inst_Slot) := Item;
+ end loop;
+ end;
+
+ when others =>
+ Error_Kind ("elaborate_block_configuration", Item);
+ end case;
+ Item := Get_Chain (Item);
+ end loop;
+
+ -- Gather children.
+ declare
+ Child : Block_Instance_Acc;
+ begin
+ Child := Instance.Children;
+ while Child /= null loop
+ declare
+ Slot : constant Instance_Slot_Type :=
+ Get_Info (Child.Label).Inst_Slot;
+ begin
+ if Slot /= Invalid_Instance_Slot then
+ -- Processes have no slot.
+ if Sub_Instances (Slot) /= null then
+ raise Internal_Error;
+ end if;
+ Sub_Instances (Slot) := Child;
+ end if;
+ end;
+ Child := Child.Brother;
+ end loop;
+ end;
+
+ -- Configure sub instances.
+ declare
+ Stmt : Iir;
+ Info : Sim_Info_Acc;
+ Slot : Instance_Slot_Type;
+ begin
+ Stmt := Get_Concurrent_Statement_Chain (Instance.Stmt);
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Generate_Statement =>
+ Info := Get_Info (Stmt);
+ Slot := Info.Inst_Slot;
+ if Get_Kind (Get_Generation_Scheme (Stmt))
+ = Iir_Kind_Iterator_Declaration
+ then
+ -- Iterative generate: apply to all instances
+ Apply_Block_Configuration_To_Iterative_Generate
+ (Stmt, Sub_Conf (Slot), Sub_Instances (Slot));
+ else
+ -- Conditional generate: may not be instantiated
+ if Sub_Instances (Slot) /= null then
+ Elaborate_Block_Configuration
+ (Sub_Conf (Slot), Sub_Instances (Slot));
+ end if;
+ end if;
+ when Iir_Kind_Block_Statement =>
+ Info := Get_Info (Stmt);
+ Slot := Info.Inst_Slot;
+ Elaborate_Block_Configuration
+ (Sub_Conf (Slot), Sub_Instances (Slot));
+ when Iir_Kind_Component_Instantiation_Statement =>
+ if Is_Component_Instantiation (Stmt) then
+ Info := Get_Info (Stmt);
+ Slot := Info.Inst_Slot;
+ Elaborate_Component_Configuration
+ (Stmt, Sub_Instances (Slot), Sub_Conf (Slot));
+ else
+ -- Nothing to do for entity instantiation, will be
+ -- done during elaboration of statements.
+ null;
+ end if;
+ when others =>
+ null;
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end;
+ end Elaborate_Block_Configuration;
+
+ procedure Elaborate_Alias_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir_Object_Alias_Declaration)
+ is
+ Alias_Type : Iir;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ -- LRM93 12.3.1.5
+ -- Elaboration of an alias declaration consists of the elaboration
+ -- of the subtype indication to establish the subtype associated
+ -- with the alias, folloed by the creation of the alias as an
+ -- alternative name for the named entity.
+ -- The creation of an alias for an array object involves a check
+ -- that the subtype associated with the alias includes a matching
+ -- element for each element of the named object.
+ -- It is an error if this check fails.
+ Alias_Type := Get_Type (Decl);
+ Elaborate_Subtype_Indication_If_Anonymous (Instance, Alias_Type);
+ Create_Object (Instance, Decl);
+ Res := Execute_Name (Instance, Get_Name (Decl), True);
+ Implicit_Array_Conversion (Instance, Res, Alias_Type, Get_Name (Decl));
+ Instance.Objects (Get_Info (Decl).Slot) :=
+ Unshare_Bounds (Res, Instance_Pool);
+ end Elaborate_Alias_Declaration;
+
+ -- LRM93 �12.3.2.3 Disconnection Specifications
+ procedure Elaborate_Disconnection_Specification
+ (Instance : Block_Instance_Acc;
+ Decl : Iir_Disconnection_Specification)
+ is
+ Time_Val : Iir_Value_Literal_Acc;
+ Time : Iir_Value_Time;
+ List : Iir_List;
+ Sig : Iir;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ -- LRM93 �12.3.2.3
+ -- Elaboration of a disconnection specification proceeds as follows:
+ -- 2. The time expression is evaluated to determine the disconnection
+ -- time for drivers of the affected signals.
+ Time_Val := Execute_Expression (Instance, Get_Expression (Decl));
+ Time := Time_Val.I64;
+
+ -- LRM93 5.3
+ -- The time expression in a disconnection specification must be static
+ -- and must evaluate to a non-negative value.
+
+ if Time < 0 then
+ Error_Msg_Sem ("time must be non-negative", Decl);
+ end if;
+
+ -- LRM93 �12.3.2.3
+ -- 1. The guarded signal specification is elaborated in order to
+ -- identify the signals affected by the disconnection specification.
+ --
+ -- 3. The diconnection time is associated with each affected signal for
+ -- later use in constructing disconnection statements in the
+ -- equivalent processes for guarded assignments to the affected
+ -- signals.
+ List := Get_Signal_List (Decl);
+ case List is
+ when Iir_List_All
+ | Iir_List_Others =>
+ Error_Kind ("elaborate_disconnection_specification", Decl);
+ when others =>
+ for I in Natural loop
+ Sig := Get_Nth_Element (List, I);
+ exit when Sig = Null_Iir;
+ Val := Execute_Name (Instance, Sig, True);
+ Disconnection_Table.Append ((Sig => Val, Time => Time));
+ end loop;
+ end case;
+ end Elaborate_Disconnection_Specification;
+
+ procedure Elaborate_Branch_Quantity_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Terminal_Plus, Terminal_Minus : Iir;
+ Plus, Minus : Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Quantity (Instance, Decl);
+
+ Terminal_Plus := Get_Plus_Terminal (Decl);
+ Plus := Execute_Name (Instance, Terminal_Plus, True);
+ Terminal_Minus := Get_Minus_Terminal (Decl);
+ if Terminal_Minus = Null_Iir then
+ -- Get the reference of the nature
+ -- FIXME: select/index
+ Terminal_Minus := Get_Reference (Get_Nature (Terminal_Plus));
+ end if;
+ Minus := Execute_Name (Instance, Terminal_Minus, True);
+
+ case Iir_Kinds_Branch_Quantity_Declaration (Get_Kind (Decl)) is
+ when Iir_Kind_Across_Quantity_Declaration =>
+ -- Expr: q - P'ref + M'ref
+ Add_Characteristic_Expression
+ (Structural,
+ Build
+ (Op_Plus, Res.Quantity,
+ Build (Op_Minus,
+ Get_Terminal_Reference (Plus.Terminal),
+ Build (Op_Plus,
+ Get_Terminal_Reference (Minus.Terminal)))));
+ when Iir_Kind_Through_Quantity_Declaration =>
+ -- P'Contrib <- P'Contrib + q
+ -- M'Contrib <- M'Contrib - q
+ Append_Characteristic_Expression
+ (Plus.Terminal, Build (Op_Plus, Res.Quantity));
+ Append_Characteristic_Expression
+ (Minus.Terminal, Build (Op_Minus, Res.Quantity));
+ end case;
+ end Elaborate_Branch_Quantity_Declaration;
+
+ -- LRM93 �12.3.1 Elaboration of a declaration
+ procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Expr_Mark : Mark_Type;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+
+ -- Elaboration of a declaration has the effect of creating the declared
+ -- item. For each declaration, the language rules (in particular scope
+ -- and visibility rules) are such that it is either impossible or
+ -- illegal to use a given item before the elaboration of its
+ -- corresponding declaration.
+ -- Similarly, it is illegal to call a subprogram before its
+ -- corresponding body is elaborated.
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if not Is_Second_Subprogram_Specification (Decl) then
+ Elaborate_Subprogram_Declaration (Instance, Decl);
+ end if;
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Elaborate_Type_Definition (Instance, Get_Type_Definition (Decl));
+ when Iir_Kind_Type_Declaration =>
+ Elaborate_Type_Declaration (Instance, Decl);
+ when Iir_Kind_Subtype_Declaration =>
+ Elaborate_Subtype_Indication (Instance, Get_Type (Decl));
+ when Iir_Kind_Iterator_Declaration =>
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Decl));
+ Val := Create_Value_For_Type (Instance, Get_Type (Decl), True);
+ Create_Object (Instance, Decl);
+ Instance.Objects (Get_Info (Decl).Slot) :=
+ Unshare (Val, Instance_Pool);
+ when Iir_Kind_Signal_Declaration =>
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Decl));
+ Val := Elaborate_Default_Value (Instance, Decl);
+ Create_Signal (Instance, Decl);
+ Elaborate_Signal (Instance, Decl, Val);
+ when Iir_Kind_Variable_Declaration =>
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Decl));
+ Val := Elaborate_Default_Value (Instance, Decl);
+ Create_Object (Instance, Decl);
+ Instance.Objects (Get_Info (Decl).Slot) :=
+ Unshare (Val, Instance_Pool);
+ when Iir_Kind_Constant_Declaration =>
+ -- Elaboration of an object declaration that declares an object
+ -- other then a file object proceeds as follows:
+ -- 1. The subtype indication is first elaborated.
+ -- This establishes the subtype of the object.
+ if Get_Deferred_Declaration_Flag (Decl) then
+ Create_Object (Instance, Decl);
+ else
+ Elaborate_Subtype_Indication_If_Anonymous
+ (Instance, Get_Type (Decl));
+ Val := Elaborate_Default_Value (Instance, Decl);
+ if Get_Deferred_Declaration (Decl) = Null_Iir then
+ Create_Object (Instance, Decl);
+ end if;
+ Instance.Objects (Get_Info (Decl).Slot) :=
+ Unshare (Val, Instance_Pool);
+ end if;
+ when Iir_Kind_File_Declaration =>
+ -- LRM93 12.3.1.4
+ -- Elaboration of a file object declaration consists of the
+ -- elaboration of the subtype indication...
+ null; -- FIXME ??
+ -- ...followed by the creation of object.
+ Create_Object (Instance, Decl);
+ -- If the file object declaration contains file_open_information,
+ -- then the implicit call to FILE_OPEN is then executed.
+ Instance.Objects (Get_Info (Decl).Slot) := Unshare
+ (File_Operation.Elaborate_File_Declaration (Instance, Decl),
+ Instance_Pool);
+ when Iir_Kind_Object_Alias_Declaration =>
+ Elaborate_Alias_Declaration (Instance, Decl);
+ when Iir_Kind_Component_Declaration =>
+ -- LRM93 12.3.1.7
+ -- Elaboration of a component declaration has no effect other
+ -- than to create a template for instantiating component
+ -- instances.
+ null;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when Iir_Kind_Configuration_Specification =>
+ -- Elaboration of a configuration specification proceeds as
+ -- follows:
+ -- 1. The component specification is elaborated in order to
+ -- determine which component instances are affected by the
+ -- configuration specification.
+ -- GHDL: this is done during sem.
+
+ -- 2. The binding indication is elaborated to identify the design
+ -- entity to which the affected component instances will be
+ -- bound.
+ -- GHDL: this is already done during sem, according to rules
+ -- defined by section 5.3.1.1
+
+ -- 3. The binding information is associated with each affected
+ -- component instance label for later use in instantiating
+ -- those component instances.
+ -- GHDL: this is done during step 1.
+
+ -- As part of this elaboration process, a check is made that both
+ -- the entity declaration and the corresponding architecture body
+ -- implied by the binding indication exist whithin the specified
+ -- library.
+ -- It is an error if this check fails.
+ -- GHDL: this is already done during sem, according to rules
+ -- defined by section 5.3.1.1
+ null;
+
+ when Iir_Kind_Attribute_Declaration =>
+ -- LRM93 12.3.1.6
+ -- Elaboration of an attribute declaration has no effect other
+ -- than to create a template for defining attributes of items.
+ null;
+
+ when Iir_Kind_Attribute_Specification =>
+ -- LRM93 12.3.2.1
+ -- Elaboration of an attribute specification proceeds as follows:
+ -- 1. The entity specification is elaborated in order to
+ -- determine which items are affected by the attribute
+ -- specification.
+ -- GHDL: done by sem.
+
+ declare
+ Attr_Decl : constant Iir :=
+ Get_Named_Entity (Get_Attribute_Designator (Decl));
+ Attr_Type : constant Iir := Get_Type (Attr_Decl);
+ Value : Iir_Attribute_Value;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ Value := Get_Attribute_Value_Spec_Chain (Decl);
+ while Value /= Null_Iir loop
+ -- 2. The expression is evaluated to determine the value
+ -- of the attribute.
+ -- It is an error if the value of the expression does not
+ -- belong to the subtype of the attribute; if the
+ -- attribute is of an array type, then an implicit
+ -- subtype conversion is first performed on the value,
+ -- unless the attribute's subtype indication denotes an
+ -- unconstrained array type.
+ Val := Execute_Expression (Instance, Get_Expression (Decl));
+ Check_Constraints (Instance, Val, Attr_Type, Decl);
+
+ -- 3. A new instance of the designated attribute is created
+ -- and associated with each of the affected items.
+ --
+ -- 4. Each new attribute instance is assigned the value of
+ -- the expression.
+ Create_Object (Instance, Value);
+ Instance.Objects (Get_Info (Value).Slot) :=
+ Unshare (Val, Instance_Pool);
+
+ Value := Get_Spec_Chain (Value);
+ end loop;
+ end;
+
+ when Iir_Kind_Disconnection_Specification =>
+ Elaborate_Disconnection_Specification (Instance, Decl);
+
+ when Iir_Kind_Use_Clause =>
+ null;
+
+ when Iir_Kind_Delayed_Attribute =>
+ Elaborate_Delayed_Signal (Instance, Decl);
+ when Iir_Kind_Stable_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Stable);
+ when Iir_Kind_Quiet_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Quiet);
+ when Iir_Kind_Transaction_Attribute =>
+ Elaborate_Implicit_Signal (Instance, Decl, Implicit_Transaction);
+
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+
+ when Iir_Kind_Nature_Declaration =>
+ Elaborate_Nature_Definition (Instance, Get_Nature (Decl));
+ Create_Terminal (Instance, Get_Chain (Decl));
+
+ when Iir_Kind_Terminal_Declaration =>
+ Create_Terminal (Instance, Decl);
+
+ when Iir_Kinds_Branch_Quantity_Declaration =>
+ Elaborate_Branch_Quantity_Declaration (Instance, Decl);
+
+ when others =>
+ Error_Kind ("elaborate_declaration", Decl);
+ end case;
+
+ Release (Expr_Mark, Expr_Pool);
+ end Elaborate_Declaration;
+
+ procedure Destroy_Iterator_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir)
+ is
+ Obj_Type : constant Iir := Get_Type (Decl);
+ Constraint : Iir;
+ Cons_Info : Sim_Info_Acc;
+ begin
+ if Get_Kind (Decl) /= Iir_Kind_Iterator_Declaration then
+ raise Internal_Error;
+ end if;
+ Destroy_Object (Instance, Decl);
+
+ if Get_Kind (Obj_Type) = Iir_Kind_Range_Array_Attribute
+ or else not Is_Anonymous_Type_Definition (Obj_Type)
+ then
+ return;
+ end if;
+
+ Constraint := Get_Range_Constraint (Obj_Type);
+ if Get_Kind (Constraint) /= Iir_Kind_Range_Expression then
+ return;
+ end if;
+ Cons_Info := Get_Info (Constraint);
+ if Cons_Info.Scope_Level = Instance.Scope_Level
+ and then Cons_Info.Slot = Instance.Elab_Objects
+ then
+ Destroy_Object (Instance, Constraint);
+ end if;
+ end Destroy_Iterator_Declaration;
+
+ procedure Finalize_Declarative_Part
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir)
+ is
+ Decl : Iir;
+ Val : Iir_Value_Literal_Acc;
+ begin
+ Decl := Decl_Chain;
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_File_Declaration =>
+ -- LRM93 3.4.1
+ -- An implicit call to FILE_CLOSE exists in a subprogram body
+ -- for every file object declared in the corresponding
+ -- subprogram declarative part.
+ -- Each such call associates a unique file object with the
+ -- formal parameter F and is called whenever the corresponding
+ -- subprogram completes its execution.
+ Val := Instance.Objects (Get_Info (Decl).Slot);
+ if Get_Text_File_Flag (Get_Type (Decl)) then
+ File_Operation.File_Close_Text (Val, Null_Iir);
+ File_Operation.File_Destroy_Text (Val);
+ else
+ File_Operation.File_Close_Binary (Val, Null_Iir);
+ File_Operation.File_Destroy_Binary (Val);
+ end if;
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Finalize_Declarative_Part;
+
+ -- LRM93 �12.3 Elaboration of a Declarative Part
+ procedure Elaborate_Declarative_Part
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir)
+ is
+ Decl : Iir;
+ begin
+ -- The elaboration of a declarative part consists of the elaboration
+ -- of the declarative items, if any, in the order in which they are
+ -- given in the declarative part.
+ -- [Exception for 'foreign ]
+ Decl := Decl_Chain;
+ while Decl /= Null_Iir loop
+ -- In certain cases, the elaboration of a declarative item involves
+ -- the evaluation of expressions that appear within the declarative
+ -- item.
+ -- The value of any object denoted by a primary in such an expression
+ -- must be defined at the time the primary is read.
+ -- In addition, if a primary in such an expression is a function call
+ -- then the value of any object denoted or appearing as part of an
+ -- actual designator in the function call must be defined at the
+ -- time the expression is evaluated.
+ -- FIXME: check this.
+ Elaborate_Declaration (Instance, Decl);
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Elaborate_Declarative_Part;
+
+ function Elaborate_Architecture (Arch : Iir_Architecture_Body;
+ Conf : Iir_Block_Configuration;
+ Parent_Instance : Block_Instance_Acc;
+ Stmt : Iir;
+ Generic_Map : Iir;
+ Port_Map : Iir)
+ return Block_Instance_Acc
+ is
+ Entity : constant Iir_Entity_Declaration := Get_Entity (Arch);
+ Instance : Block_Instance_Acc;
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+
+ if Trace_Elaboration then
+ Ada.Text_IO.Put ("elaborating ");
+ Ada.Text_IO.Put (Image_Identifier (Arch));
+ Ada.Text_IO.Put (" of ");
+ Ada.Text_IO.Put_Line (Image_Identifier (Entity));
+ end if;
+
+ Instance := Create_Block_Instance (Parent_Instance, Arch, Stmt);
+ Instance.Up_Block := null; -- Packages_Instance;
+
+ -- LRM93 �12.1
+ -- Elaboration of a block statement involves first elaborating each not
+ -- yet elaborated package containing declarations referenced by the
+ -- block.
+ Elaborate_Dependence (Get_Design_Unit (Arch));
+
+ Elaborate_Generic_Clause (Instance, Get_Generic_Chain (Entity));
+ Elaborate_Generic_Map_Aspect (Instance, Parent_Instance, Generic_Map);
+ Elaborate_Port_Clause (Instance, Get_Port_Chain (Entity));
+ Elaborate_Port_Map_Aspect (Instance, Parent_Instance,
+ Get_Port_Chain (Entity), Port_Map);
+
+ Elaborate_Declarative_Part
+ (Instance, Get_Declaration_Chain (Entity));
+ Elaborate_Declarative_Part (Instance, Get_Declaration_Chain (Arch));
+ Elaborate_Statement_Part
+ (Instance, Get_Concurrent_Statement_Chain (Entity));
+ Elaborate_Statement_Part
+ (Instance, Get_Concurrent_Statement_Chain (Arch));
+
+ -- Configure the unit. This will create sub units.
+ Elaborate_Block_Configuration (Conf, Instance);
+
+ Release (Expr_Mark, Expr_Pool);
+
+ return Instance;
+ end Elaborate_Architecture;
+
+ -- Elaborate a design.
+ procedure Elaborate_Design (Design: Iir_Design_Unit)
+ is
+ Unit : constant Iir := Get_Library_Unit (Design);
+ Conf_Unit : Iir_Design_Unit;
+ Conf : Iir_Block_Configuration;
+ Arch_Unit : Iir_Design_Unit;
+ Arch : Iir_Architecture_Body;
+ Entity : Iir_Entity_Declaration;
+ Generic_Map : Iir;
+ Port_Map : Iir;
+ begin
+ Package_Instances :=
+ new Block_Instance_Acc_Array (1 .. Instance_Slot_Type (Nbr_Packages));
+
+ -- Use a 'fake' process to execute code during elaboration.
+ Current_Process := No_Process;
+
+ -- Find architecture and configuration for the top unit
+ case Get_Kind (Unit) is
+ when Iir_Kind_Architecture_Body =>
+ Arch := Unit;
+ Conf_Unit := Get_Default_Configuration_Declaration (Unit);
+ when Iir_Kind_Configuration_Declaration =>
+ Conf_Unit := Design;
+ Arch := Get_Block_Specification (Get_Block_Configuration (Unit));
+ Elaborate_Dependence (Design);
+ when others =>
+ Error_Kind ("elaborate_design", Unit);
+ end case;
+
+ Arch_Unit := Get_Design_Unit (Arch);
+ Entity := Get_Entity (Arch);
+
+ Elaborate_Dependence (Arch_Unit);
+
+ -- Sanity check: memory area for expressions must be empty.
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ -- Use default values for top entity generics and ports.
+ Generic_Map := Create_Default_Association
+ (Get_Generic_Chain (Entity), Null_Iir, Entity);
+ Port_Map := Create_Default_Association
+ (Get_Port_Chain (Entity), Null_Iir, Entity);
+
+ -- Elaborate from the top configuration.
+ Conf := Get_Block_Configuration (Get_Library_Unit (Conf_Unit));
+ Top_Instance := Elaborate_Architecture
+ (Arch, Conf, null, Arch, Generic_Map, Port_Map);
+
+ Current_Process := null;
+
+ -- Stop now in case of errors.
+ if Nbr_Errors /= 0 then
+ Grt.Errors.Fatal_Error;
+ end if;
+
+ -- Sanity check: memory area for expressions must be empty.
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+ end Elaborate_Design;
+
+end Elaboration;
diff --git a/src/simulate/elaboration.ads b/src/simulate/elaboration.ads
new file mode 100644
index 000000000..5a9ea8da2
--- /dev/null
+++ b/src/simulate/elaboration.ads
@@ -0,0 +1,209 @@
+-- Elaboration for interpretation
+-- 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.Unchecked_Deallocation;
+with GNAT.Table;
+with Iirs; use Iirs;
+with Iir_Values; use Iir_Values;
+with Grt.Types;
+with Annotations; use Annotations;
+with Areapools;
+
+-- This package elaborates design hierarchy.
+
+package Elaboration is
+ Trace_Elaboration : Boolean := False;
+ Trace_Drivers : Boolean := False;
+
+ -- A block instance with its architecture/entity declaration is an
+ -- instancied entity.
+ type Block_Instance_Type;
+ type Block_Instance_Acc is access Block_Instance_Type;
+
+ type Objects_Array is array (Object_Slot_Type range <>) of
+ Iir_Value_Literal_Acc;
+
+ -- A block instance with its architecture/entity declaration is an
+ -- instancied entity.
+
+ type Block_Instance_Type (Max_Objs : Object_Slot_Type) is record
+ -- Flag for wait statement: true if not yet executed.
+ In_Wait_Flag : Boolean;
+
+ -- Useful informations for a dynamic block (ie, a frame).
+ -- The scope level and an access to the block of upper scope level.
+ Scope_Level: Scope_Level_Type;
+ Up_Block: Block_Instance_Acc;
+
+ -- Block, architecture, package, process, component instantiation for
+ -- this instance.
+ Label : Iir;
+
+ -- For blocks: corresponding block (different from label for direct
+ -- component instantiation statement and generate iterator).
+ -- For packages: Null_Iir
+ -- For subprograms and processes: statement being executed.
+ Stmt : Iir;
+
+ -- Instanciation tree.
+ -- Parent is always set (but null for top-level block and packages)
+ Parent: Block_Instance_Acc;
+ -- Not null only for blocks and processes.
+ Children: Block_Instance_Acc;
+ Brother: Block_Instance_Acc;
+
+ -- Pool marker for the child (only for subprograms and processes).
+ Marker : Areapools.Mark_Type;
+
+ -- Reference to the actuals, for copy-out when returning from a
+ -- procedure.
+ Actuals_Ref : Value_Array_Acc;
+
+ -- Only for function frame; contains the result.
+ Result: Iir_Value_Literal_Acc;
+
+ -- Last object elaborated (or number of objects elaborated).
+ -- Note: this is generally the slot index of the next object to be
+ -- elaborated (this may be wrong for dynamic objects due to execution
+ -- branches).
+ Elab_Objects : Object_Slot_Type := 0;
+
+ -- Values of the objects in that frame.
+ Objects : Objects_Array (1 .. Max_Objs);
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Block_Instance_Type, Name => Block_Instance_Acc);
+
+ procedure Elaborate_Design (Design: Iir_Design_Unit);
+
+ procedure Elaborate_Declarative_Part
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir);
+
+ -- Reverse operation of Elaborate_Declarative_Part.
+ -- At least, finalize files.
+ procedure Finalize_Declarative_Part
+ (Instance : Block_Instance_Acc; Decl_Chain : Iir);
+
+ procedure Elaborate_Declaration (Instance : Block_Instance_Acc; Decl : Iir);
+
+ procedure Destroy_Iterator_Declaration
+ (Instance : Block_Instance_Acc; Decl : Iir);
+
+ -- Create a value for type DECL. Initialize it if DEFAULT is true.
+ function Create_Value_For_Type
+ (Block: Block_Instance_Acc; Decl: Iir; Default : Boolean)
+ return Iir_Value_Literal_Acc;
+
+ -- LRM93 �12.3.1.3 Subtype Declarations
+ -- The elaboration of a subtype indication creates a subtype.
+ -- Used for allocator.
+ procedure Elaborate_Subtype_Indication
+ (Instance : Block_Instance_Acc; Ind : Iir);
+
+ -- Create object DECL.
+ -- This does nothing except marking DECL as elaborated.
+ -- Used by simulation to dynamically create subprograms interfaces.
+ procedure Create_Object (Instance : Block_Instance_Acc; Decl : Iir);
+ procedure Create_Signal (Instance : Block_Instance_Acc; Decl : Iir);
+
+ Top_Instance: Block_Instance_Acc;
+
+ type Block_Instance_Acc_Array is array (Instance_Slot_Type range <>) of
+ Block_Instance_Acc;
+ type Block_Instance_Acc_Array_Acc is access Block_Instance_Acc_Array;
+
+ Package_Instances : Block_Instance_Acc_Array_Acc;
+
+ -- Disconnections. For each disconnection specification, the elaborator
+ -- adds an entry in the table.
+ type Disconnection_Entry is record
+ Sig : Iir_Value_Literal_Acc;
+ Time : Iir_Value_Time;
+ end record;
+
+ package Disconnection_Table is new GNAT.Table
+ (Table_Component_Type => Disconnection_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- Connections. For each associations (block/component/entry), the
+ -- elaborator adds an entry in that table.
+ type Connect_Entry is record
+ Formal : Iir_Value_Literal_Acc;
+ Formal_Instance : Block_Instance_Acc;
+ Actual : Iir_Value_Literal_Acc;
+ Actual_Instance : Block_Instance_Acc;
+ Assoc : Iir;
+ end record;
+
+ package Connect_Table is new GNAT.Table
+ (Table_Component_Type => Connect_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 32,
+ Table_Increment => 100);
+
+ -- Signals.
+ type Signal_Type_Kind is
+ (User_Signal,
+ Implicit_Quiet, Implicit_Stable, Implicit_Delayed,
+ Implicit_Transaction,
+ Guard_Signal);
+
+ type Signal_Entry (Kind : Signal_Type_Kind := User_Signal) is record
+ Decl : Iir;
+ Sig : Iir_Value_Literal_Acc;
+ Instance : Block_Instance_Acc;
+ case Kind is
+ when User_Signal =>
+ Init : Iir_Value_Literal_Acc;
+ when Implicit_Quiet | Implicit_Stable | Implicit_Delayed
+ | Implicit_Transaction =>
+ Time : Grt.Types.Ghdl_I64;
+ Prefix : Iir_Value_Literal_Acc;
+ when Guard_Signal =>
+ null;
+ end case;
+ end record;
+
+ package Signals_Table is new GNAT.Table
+ (Table_Component_Type => Signal_Entry,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ type Process_Index_Type is new Natural;
+
+ package Processes_Table is new GNAT.Table
+ (Table_Component_Type => Block_Instance_Acc,
+ Table_Index_Type => Process_Index_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ package Protected_Table is new GNAT.Table
+ (Table_Component_Type => Block_Instance_Acc,
+ Table_Index_Type => Protected_Index_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 2,
+ Table_Increment => 100);
+end Elaboration;
diff --git a/src/simulate/execution.adb b/src/simulate/execution.adb
new file mode 100644
index 000000000..ef4cccc46
--- /dev/null
+++ b/src/simulate/execution.adb
@@ -0,0 +1,4837 @@
+-- Interpreted simulation
+-- 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.Unchecked_Conversion;
+with Ada.Text_IO; use Ada.Text_IO;
+with System;
+with Grt.Types; use Grt.Types;
+with Errorout; use Errorout;
+with Std_Package;
+with Evaluation;
+with Iirs_Utils; use Iirs_Utils;
+with Annotations; use Annotations;
+with Name_Table;
+with File_Operation;
+with Debugger; use Debugger;
+with Std_Names;
+with Str_Table;
+with Files_Map;
+with Iir_Chains; use Iir_Chains;
+with Simulation; use Simulation;
+with Grt.Astdio;
+with Grt.Stdio;
+with Grt.Options;
+with Grt.Vstrings;
+with Grt_Interface;
+with Grt.Values;
+with Grt.Errors;
+with Grt.Std_Logic_1164;
+
+package body Execution is
+
+ function Execute_Function_Call
+ (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir)
+ return Iir_Value_Literal_Acc;
+
+ procedure Finish_Sequential_Statements
+ (Proc : Process_State_Acc; Complex_Stmt : Iir);
+ procedure Init_Sequential_Statements
+ (Proc : Process_State_Acc; Complex_Stmt : Iir);
+ procedure Update_Next_Statement (Proc : Process_State_Acc);
+
+ -- Display a message when an assertion has failed.
+ procedure Execute_Failed_Assertion (Report : String;
+ Severity : Natural;
+ Stmt: Iir);
+
+ function Get_Instance_By_Scope_Level
+ (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type)
+ return Block_Instance_Acc
+ is
+ Current: Block_Instance_Acc := Instance;
+ begin
+ while Current /= null loop
+ if Current.Scope_Level = Scope_Level then
+ return Current;
+ end if;
+ Current := Current.Up_Block;
+ end loop;
+ -- Global scope (packages)
+ if Scope_Level < Scope_Level_Global then
+ return Package_Instances (Instance_Slot_Type (-Scope_Level));
+ end if;
+ if Current_Component /= null
+ and then Current_Component.Scope_Level = Scope_Level
+ then
+ return Current_Component;
+ end if;
+ if Scope_Level = Scope_Level_Global then
+ return null;
+ end if;
+ raise Internal_Error;
+ end Get_Instance_By_Scope_Level;
+
+ function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir)
+ return Block_Instance_Acc
+ is
+ begin
+ return Get_Instance_By_Scope_Level (Instance,
+ Get_Info (Decl).Scope_Level);
+ end Get_Instance_For_Slot;
+
+ function Create_Bounds_From_Length (Block : Block_Instance_Acc;
+ Atype : Iir;
+ Len : Iir_Index32)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Index_Bounds : Iir_Value_Literal_Acc;
+ begin
+ Index_Bounds := Execute_Bounds (Block, Atype);
+
+ Res := Create_Range_Value (Left => Index_Bounds.Left,
+ Right => null,
+ Dir => Index_Bounds.Dir,
+ Length => Len);
+
+ if Len = 0 then
+ -- Special case.
+ Res.Right := Res.Left;
+ case Res.Left.Kind is
+ when Iir_Value_I64 =>
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ Res.Left := Create_I64_Value (Res.Right.I64 + 1);
+ when Iir_Downto =>
+ Res.Left := Create_I64_Value (Res.Right.I64 - 1);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ else
+ case Res.Left.Kind is
+ when Iir_Value_E32 =>
+ declare
+ R : Ghdl_E32;
+ begin
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ R := Res.Left.E32 + Ghdl_E32 (Len - 1);
+ when Iir_Downto =>
+ R := Res.Left.E32 - Ghdl_E32 (Len - 1);
+ end case;
+ Res.Right := Create_E32_Value (R);
+ end;
+ when Iir_Value_I64 =>
+ declare
+ R : Ghdl_I64;
+ begin
+ case Index_Bounds.Dir is
+ when Iir_To =>
+ R := Res.Left.I64 + Ghdl_I64 (Len - 1);
+ when Iir_Downto =>
+ R := Res.Left.I64 - Ghdl_I64 (Len - 1);
+ end case;
+ Res.Right := Create_I64_Value (R);
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ return Res;
+ end Create_Bounds_From_Length;
+
+ function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ if Bounds.Dir = Iir_To then
+ return Bounds.Right;
+ else
+ return Bounds.Left;
+ end if;
+ end Execute_High_Limit;
+
+ function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ if Bounds.Dir = Iir_To then
+ return Bounds.Left;
+ else
+ return Bounds.Right;
+ end if;
+ end Execute_Low_Limit;
+
+ function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Bounds.Left;
+ end Execute_Left_Limit;
+
+ function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Bounds.Right;
+ end Execute_Right_Limit;
+
+ function Execute_Length (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Create_I64_Value (Ghdl_I64 (Bounds.Length));
+ end Execute_Length;
+
+ function Create_Enum_Value (Pos : Natural; Etype : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Base_Type : constant Iir := Get_Base_Type (Etype);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ case Mode is
+ when Iir_Value_E32 =>
+ return Create_E32_Value (Ghdl_E32 (Pos));
+ when Iir_Value_B1 =>
+ return Create_B1_Value (Ghdl_B1'Val (Pos));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Create_Enum_Value;
+
+ function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Value (Str'Length, 1);
+ Res.Bounds.D (1) := Create_Range_Value
+ (Create_I64_Value (1),
+ Create_I64_Value (Str'Length),
+ Iir_To);
+ for I in Str'Range loop
+ Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) :=
+ Create_E32_Value (Character'Pos (Str (I)));
+ end loop;
+ return Res;
+ end String_To_Iir_Value;
+
+ function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc;
+ Expr_Type : Iir)
+ return String
+ is
+ begin
+ case Get_Kind (Expr_Type) is
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ declare
+ Str : String (1 .. 24);
+ Last : Natural;
+ begin
+ Grt.Vstrings.To_String (Str, Last, Val.F64);
+ return Str (Str'First .. Last);
+ end;
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ declare
+ Str : String (1 .. 21);
+ First : Natural;
+ begin
+ Grt.Vstrings.To_String (Str, First, Val.I64);
+ return Str (First .. Str'Last);
+ end;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ declare
+ Lits : constant Iir_List :=
+ Get_Enumeration_Literal_List (Expr_Type);
+ Pos : Natural;
+ begin
+ case Val.Kind is
+ when Iir_Value_B1 =>
+ Pos := Ghdl_B1'Pos (Val.B1);
+ when Iir_Value_E32 =>
+ Pos := Ghdl_E32'Pos (Val.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Name_Table.Image
+ (Get_Identifier (Get_Nth_Element (Lits, Pos)));
+ end;
+ when Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ declare
+ Str : String (1 .. 21);
+ First : Natural;
+ Id : constant Name_Id :=
+ Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type)));
+ begin
+ Grt.Vstrings.To_String (Str, First, Val.I64);
+ return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id);
+ end;
+ when others =>
+ Error_Kind ("execute_image_attribute", Expr_Type);
+ end case;
+ end Execute_Image_Attribute;
+
+ function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc;
+ Count : Ghdl_I64;
+ Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Func : constant Iir_Predefined_Shift_Functions :=
+ Get_Implicit_Definition (Get_Implementation (Expr));
+ Cnt : Iir_Index32;
+ Len : constant Iir_Index32 := Left.Bounds.D (1).Length;
+ Dir_Left : Boolean;
+ P : Iir_Index32;
+ Res : Iir_Value_Literal_Acc;
+ E : Iir_Value_Literal_Acc;
+ begin
+ -- 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 else Len = 0 then
+ return 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 := Iir_Index32 (-Count);
+ Dir_Left := not Dir_Left;
+ else
+ Cnt := Iir_Index32 (Count);
+ end if;
+
+ case Func is
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl =>
+ E := Create_Enum_Value
+ (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr))));
+ when Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra =>
+ if Dir_Left then
+ E := Left.Val_Array.V (Len);
+ else
+ E := Left.Val_Array.V (1);
+ 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 := Create_Array_Value (1);
+ Res.Bounds.D (1) := Left.Bounds.D (1);
+ Create_Array_Data (Res, Len);
+ P := 1;
+
+ 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
+ Res.Val_Array.V (P) := Left.Val_Array.V (I + 1);
+ P := P + 1;
+ end loop;
+ else
+ Cnt := Len;
+ end if;
+ for I in 0 .. Cnt - 1 loop
+ Res.Val_Array.V (P) := E;
+ P := P + 1;
+ end loop;
+ else
+ if Cnt > Len then
+ Cnt := Len;
+ end if;
+ for I in 0 .. Cnt - 1 loop
+ Res.Val_Array.V (P) := E;
+ P := P + 1;
+ end loop;
+ for I in Cnt .. Len - 1 loop
+ Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1);
+ P := P + 1;
+ end loop;
+ end if;
+ when Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ for I in 1 .. Len loop
+ Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1);
+ P := P + 1;
+ Cnt := Cnt + 1;
+ if Cnt = Len then
+ Cnt := 0;
+ end if;
+ end loop;
+ end case;
+ return Res;
+ end Execute_Shift_Operator;
+
+ Hex_Chars : constant array (Natural range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
+
+ function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc;
+ Log_Base : Natural)
+ return Iir_Value_Literal_Acc
+ is
+ Base : constant Natural := 2 ** Log_Base;
+ Blen : constant Natural := Natural (Val.Bounds.D (1).Length);
+ Str : String (1 .. (Blen + Log_Base - 1) / Log_Base);
+ Pos : Natural;
+ V : Natural;
+ N : Natural;
+ begin
+ V := 0;
+ N := 1;
+ Pos := Str'Last;
+ for I in reverse Val.Val_Array.V'Range loop
+ V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N;
+ N := N * 2;
+ if N = Base or else I = Val.Val_Array.V'First then
+ Str (Pos) := Hex_Chars (V);
+ Pos := Pos - 1;
+ N := 1;
+ V := 0;
+ end if;
+ end loop;
+ return String_To_Iir_Value (Str);
+ end Execute_Bit_Vector_To_String;
+
+ procedure Check_Std_Ulogic_Dc
+ (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic)
+ is
+ use Grt.Std_Logic_1164;
+ begin
+ if V = '-' then
+ Execute_Failed_Assertion
+ ("STD_LOGIC_1164: '-' operand for matching ordering operator",
+ 2, Loc);
+ end if;
+ end Check_Std_Ulogic_Dc;
+
+ -- EXPR is the expression whose implementation is an implicit function.
+ function Execute_Implicit_Function (Block : Block_Instance_Acc;
+ Expr: Iir;
+ Left_Param : Iir;
+ Right_Param : Iir;
+ Res_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ pragma Unsuppress (Overflow_Check);
+
+ Func : Iir_Predefined_Functions;
+
+ -- Rename definition for monadic operations.
+ Left, Right: Iir_Value_Literal_Acc;
+ Operand : Iir_Value_Literal_Acc renames Left;
+ Result: Iir_Value_Literal_Acc;
+
+ procedure Eval_Right is
+ begin
+ Right := Execute_Expression (Block, Right_Param);
+ end Eval_Right;
+
+ -- Eval right argument, check left and right have same length,
+ -- Create RESULT from left.
+ procedure Eval_Array is
+ begin
+ Eval_Right;
+ if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then
+ Error_Msg_Constraint (Expr);
+ end if;
+ -- Need to copy as the result is modified.
+ Result := Unshare (Left, Expr_Pool'Access);
+ end Eval_Array;
+
+ Imp : Iir;
+ begin
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) in Iir_Kinds_Denoting_Name then
+ Imp := Get_Named_Entity (Imp);
+ end if;
+ Func := Get_Implicit_Definition (Imp);
+
+ -- Eval left operand.
+ case Func is
+ when Iir_Predefined_Now_Function =>
+ Left := null;
+ when Iir_Predefined_Bit_Rising_Edge
+ | Iir_Predefined_Boolean_Rising_Edge
+ | Iir_Predefined_Bit_Falling_Edge
+ | Iir_Predefined_Boolean_Falling_Edge=>
+ Operand := Execute_Name (Block, Left_Param, True);
+ when others =>
+ Left := Execute_Expression (Block, Left_Param);
+ end case;
+ Right := null;
+
+ case Func is
+ when Iir_Predefined_Error =>
+ raise Internal_Error;
+
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Eval_Right;
+
+ declare
+ -- Array length of the result.
+ Len: Iir_Index32;
+
+ -- Index into the result.
+ Pos: Iir_Index32;
+ begin
+ -- Compute the length of the result.
+ case Func is
+ when Iir_Predefined_Array_Array_Concat =>
+ Len := Left.Val_Array.Len + Right.Val_Array.Len;
+ when Iir_Predefined_Element_Array_Concat =>
+ Len := 1 + Right.Val_Array.Len;
+ when Iir_Predefined_Array_Element_Concat =>
+ Len := Left.Val_Array.Len + 1;
+ when Iir_Predefined_Element_Element_Concat =>
+ Len := 1 + 1;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- LRM93 7.2.4
+ -- If both operands are null arrays, then the result of the
+ -- concatenation is the right operand.
+ if Len = 0 then
+ -- Note: this return is allowed since LEFT is free, and
+ -- RIGHT must not be free.
+ return Right;
+ end if;
+
+ -- Create the array result.
+ Result := Create_Array_Value (Len, 1);
+ Result.Bounds.D (1) := Create_Bounds_From_Length
+ (Block, Get_First_Element (Get_Index_Subtype_List (Res_Type)),
+ Len);
+
+ -- Fill the result: left.
+ case Func is
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Array_Element_Concat =>
+ for I in Left.Val_Array.V'Range loop
+ Result.Val_Array.V (I) := Left.Val_Array.V (I);
+ end loop;
+ Pos := Left.Val_Array.Len;
+ when Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Result.Val_Array.V (1) := Left;
+ Pos := 1;
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Note: here POS is equal to the position of the last element
+ -- filled, or 0 if no elements were filled.
+
+ -- Fill the result: right.
+ case Func is
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Element_Array_Concat =>
+ for I in Right.Val_Array.V'Range loop
+ Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I);
+ end loop;
+ when Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Result.Val_Array.V (Pos + 1) := Right;
+ when others =>
+ raise Program_Error;
+ end case;
+ end;
+
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Boolean_And =>
+ if Left.B1 = Lit_Enum_0.B1 then
+ -- Short circuit operator.
+ Result := Lit_Enum_0;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1);
+ end if;
+ when Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Boolean_Nand =>
+ if Left.B1 = Lit_Enum_0.B1 then
+ -- Short circuit operator.
+ Result := Lit_Enum_1;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1);
+ end if;
+ when Iir_Predefined_Bit_Or
+ | Iir_Predefined_Boolean_Or =>
+ if Left.B1 = Lit_Enum_1.B1 then
+ -- Short circuit operator.
+ Result := Lit_Enum_1;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1);
+ end if;
+ when Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_Nor =>
+ if Left.B1 = Lit_Enum_1.B1 then
+ -- Short circuit operator.
+ Result := Lit_Enum_0;
+ else
+ Eval_Right;
+ Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1);
+ end if;
+ when Iir_Predefined_Bit_Xor
+ | Iir_Predefined_Boolean_Xor =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.B1 /= Right.B1);
+ when Iir_Predefined_Bit_Xnor
+ | Iir_Predefined_Boolean_Xnor =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.B1 = Right.B1);
+ when Iir_Predefined_Bit_Not
+ | Iir_Predefined_Boolean_Not =>
+ Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1);
+
+ when Iir_Predefined_Bit_Condition =>
+ Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1);
+
+ 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 =>
+ Eval_Right;
+ Result := Execute_Shift_Operator (Left, Right.I64, Expr);
+
+ when Iir_Predefined_Enum_Equality
+ | Iir_Predefined_Integer_Equality
+ | Iir_Predefined_Array_Equality
+ | Iir_Predefined_Access_Equality
+ | Iir_Predefined_Physical_Equality
+ | Iir_Predefined_Floating_Equality
+ | Iir_Predefined_Record_Equality
+ | Iir_Predefined_Bit_Match_Equality
+ | Iir_Predefined_Bit_Array_Match_Equality =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Is_Equal (Left, Right));
+ when Iir_Predefined_Enum_Inequality
+ | Iir_Predefined_Integer_Inequality
+ | Iir_Predefined_Array_Inequality
+ | Iir_Predefined_Access_Inequality
+ | Iir_Predefined_Physical_Inequality
+ | Iir_Predefined_Floating_Inequality
+ | Iir_Predefined_Record_Inequality
+ | Iir_Predefined_Bit_Match_Inequality
+ | Iir_Predefined_Bit_Array_Match_Inequality =>
+ Eval_Right;
+ Result := Boolean_To_Lit (not Is_Equal (Left, Right));
+ when Iir_Predefined_Integer_Less
+ | Iir_Predefined_Physical_Less =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 < Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Greater
+ | Iir_Predefined_Physical_Greater =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 > Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Less_Equal
+ | Iir_Predefined_Physical_Less_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 <= Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Greater_Equal
+ | Iir_Predefined_Physical_Greater_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Boolean_To_Lit (Left.I64 >= Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Less =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ Result := Boolean_To_Lit (Left.B1 < Right.B1);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 < Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Greater =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ Result := Boolean_To_Lit (Left.B1 > Right.B1);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 > Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Less_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ Result := Boolean_To_Lit (Left.B1 <= Right.B1);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 <= Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_Greater_Equal =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ Result := Boolean_To_Lit (Left.B1 >= Right.B1);
+ when Iir_Value_E32 =>
+ Result := Boolean_To_Lit (Left.E32 >= Right.E32);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Enum_Minimum
+ | Iir_Predefined_Physical_Minimum =>
+ Eval_Right;
+ if Compare_Value (Left, Right) = Less then
+ Result := Left;
+ else
+ Result := Right;
+ end if;
+ when Iir_Predefined_Enum_Maximum
+ | Iir_Predefined_Physical_Maximum =>
+ Eval_Right;
+ if Compare_Value (Left, Right) = Less then
+ Result := Right;
+ else
+ Result := Left;
+ end if;
+
+ when Iir_Predefined_Integer_Plus
+ | Iir_Predefined_Physical_Plus =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (Left.I64 + Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Minus
+ | Iir_Predefined_Physical_Minus =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (Left.I64 - Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Mul =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (Left.I64 * Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Mod =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ if Right.I64 = 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Result := Create_I64_Value (Left.I64 mod Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Rem =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ if Right.I64 = 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Result := Create_I64_Value (Left.I64 rem Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Integer_Div =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ if Right.I64 = 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Result := Create_I64_Value (Left.I64 / Right.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Integer_Absolute
+ | Iir_Predefined_Physical_Absolute =>
+ case Operand.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (abs Operand.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Integer_Negation
+ | Iir_Predefined_Physical_Negation =>
+ case Operand.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (-Operand.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Integer_Identity
+ | Iir_Predefined_Physical_Identity =>
+ case Operand.Kind is
+ when Iir_Value_I64 =>
+ Result := Create_I64_Value (Operand.I64);
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Integer_Exp =>
+ Eval_Right;
+ case Left.Kind is
+ when Iir_Value_I64 =>
+ if Right.I64 < 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Result := Create_I64_Value (Left.I64 ** Natural (Right.I64));
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ when Iir_Predefined_Integer_Minimum =>
+ Eval_Right;
+ Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64));
+ when Iir_Predefined_Integer_Maximum =>
+ Eval_Right;
+ Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64));
+
+ when Iir_Predefined_Floating_Mul =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 * Right.F64);
+ when Iir_Predefined_Floating_Div =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 / Right.F64);
+ when Iir_Predefined_Floating_Minus =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 - Right.F64);
+ when Iir_Predefined_Floating_Plus =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 + Right.F64);
+ when Iir_Predefined_Floating_Exp =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 ** Integer (Right.I64));
+ when Iir_Predefined_Floating_Identity =>
+ Result := Create_F64_Value (Operand.F64);
+ when Iir_Predefined_Floating_Negation =>
+ Result := Create_F64_Value (-Operand.F64);
+ when Iir_Predefined_Floating_Absolute =>
+ Result := Create_F64_Value (abs (Operand.F64));
+ when Iir_Predefined_Floating_Less =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.F64 < Right.F64);
+ when Iir_Predefined_Floating_Less_Equal =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.F64 <= Right.F64);
+ when Iir_Predefined_Floating_Greater =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.F64 > Right.F64);
+ when Iir_Predefined_Floating_Greater_Equal =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Left.F64 >= Right.F64);
+
+ when Iir_Predefined_Floating_Minimum =>
+ Eval_Right;
+ Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64));
+ when Iir_Predefined_Floating_Maximum =>
+ Eval_Right;
+ Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64));
+
+ when Iir_Predefined_Integer_Physical_Mul =>
+ Eval_Right;
+ Result := Create_I64_Value (Left.I64 * Right.I64);
+ when Iir_Predefined_Physical_Integer_Mul =>
+ Eval_Right;
+ Result := Create_I64_Value (Left.I64 * Right.I64);
+ when Iir_Predefined_Physical_Physical_Div =>
+ Eval_Right;
+ Result := Create_I64_Value (Left.I64 / Right.I64);
+ when Iir_Predefined_Physical_Integer_Div =>
+ Eval_Right;
+ Result := Create_I64_Value (Left.I64 / Right.I64);
+ when Iir_Predefined_Real_Physical_Mul =>
+ Eval_Right;
+ Result := Create_I64_Value
+ (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64)));
+ when Iir_Predefined_Physical_Real_Mul =>
+ Eval_Right;
+ Result := Create_I64_Value
+ (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64));
+ when Iir_Predefined_Physical_Real_Div =>
+ Eval_Right;
+ Result := Create_I64_Value
+ (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64));
+
+ when Iir_Predefined_Universal_I_R_Mul =>
+ Eval_Right;
+ Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64);
+ when Iir_Predefined_Universal_R_I_Mul =>
+ Eval_Right;
+ Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64));
+
+ when Iir_Predefined_TF_Array_And =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Array_Nand =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1);
+ end loop;
+ when Iir_Predefined_TF_Array_Or =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Array_Nor =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1);
+ end loop;
+ when Iir_Predefined_TF_Array_Xor =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Array_Xnor =>
+ Eval_Array;
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1);
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_And =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 and Right.B1;
+ end loop;
+ when Iir_Predefined_TF_Element_Array_And =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 and Left.B1;
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_Or =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 or Right.B1;
+ end loop;
+ when Iir_Predefined_TF_Element_Array_Or =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 or Left.B1;
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_Xor =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 xor Right.B1;
+ end loop;
+ when Iir_Predefined_TF_Element_Array_Xor =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ Result.Val_Array.V (I).B1 xor Left.B1;
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_Nand =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 and Right.B1);
+ end loop;
+ when Iir_Predefined_TF_Element_Array_Nand =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 and Left.B1);
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_Nor =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 or Right.B1);
+ end loop;
+ when Iir_Predefined_TF_Element_Array_Nor =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 or Left.B1);
+ end loop;
+
+ when Iir_Predefined_TF_Array_Element_Xnor =>
+ Eval_Right;
+ Result := Unshare (Left, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 xor Right.B1);
+ end loop;
+ when Iir_Predefined_TF_Element_Array_Xnor =>
+ Eval_Right;
+ Result := Unshare (Right, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 :=
+ not (Result.Val_Array.V (I).B1 xor Left.B1);
+ end loop;
+
+ when Iir_Predefined_TF_Array_Not =>
+ -- Need to copy as the result is modified.
+ Result := Unshare (Operand, Expr_Pool'Access);
+ for I in Result.Val_Array.V'Range loop
+ Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1;
+ end loop;
+
+ when Iir_Predefined_TF_Reduction_And =>
+ Result := Create_B1_Value (True);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Reduction_Nand =>
+ Result := Create_B1_Value (True);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1;
+ end loop;
+ Result.B1 := not Result.B1;
+ when Iir_Predefined_TF_Reduction_Or =>
+ Result := Create_B1_Value (False);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Reduction_Nor =>
+ Result := Create_B1_Value (False);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1;
+ end loop;
+ Result.B1 := not Result.B1;
+ when Iir_Predefined_TF_Reduction_Xor =>
+ Result := Create_B1_Value (False);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1;
+ end loop;
+ when Iir_Predefined_TF_Reduction_Xnor =>
+ Result := Create_B1_Value (False);
+ for I in Operand.Val_Array.V'Range loop
+ Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1;
+ end loop;
+ Result.B1 := not Result.B1;
+
+ when Iir_Predefined_Bit_Rising_Edge
+ | Iir_Predefined_Boolean_Rising_Edge =>
+ return Boolean_To_Lit
+ (Execute_Event_Attribute (Operand)
+ and then Execute_Signal_Value (Operand).B1 = True);
+ when Iir_Predefined_Bit_Falling_Edge
+ | Iir_Predefined_Boolean_Falling_Edge =>
+ return Boolean_To_Lit
+ (Execute_Event_Attribute (Operand)
+ and then Execute_Signal_Value (Operand).B1 = False);
+
+ when Iir_Predefined_Array_Greater =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater);
+
+ when Iir_Predefined_Array_Greater_Equal =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal);
+
+ when Iir_Predefined_Array_Less =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less);
+
+ when Iir_Predefined_Array_Less_Equal =>
+ Eval_Right;
+ Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal);
+
+ when Iir_Predefined_Array_Minimum =>
+ Eval_Right;
+ if Compare_Value (Left, Right) = Less then
+ Result := Left;
+ else
+ Result := Right;
+ end if;
+ when Iir_Predefined_Array_Maximum =>
+ Eval_Right;
+ if Compare_Value (Left, Right) = Less then
+ Result := Right;
+ else
+ Result := Left;
+ end if;
+
+ when Iir_Predefined_Vector_Maximum =>
+ declare
+ El_St : constant Iir :=
+ Get_Return_Type (Get_Implementation (Expr));
+ V : Iir_Value_Literal_Acc;
+ begin
+ Result := Execute_Low_Limit (Execute_Bounds (Block, El_St));
+ for I in Left.Val_Array.V'Range loop
+ V := Left.Val_Array.V (I);
+ if Compare_Value (V, Result) = Greater then
+ Result := V;
+ end if;
+ end loop;
+ end;
+ when Iir_Predefined_Vector_Minimum =>
+ declare
+ El_St : constant Iir :=
+ Get_Return_Type (Get_Implementation (Expr));
+ V : Iir_Value_Literal_Acc;
+ begin
+ Result := Execute_High_Limit (Execute_Bounds (Block, El_St));
+ for I in Left.Val_Array.V'Range loop
+ V := Left.Val_Array.V (I);
+ if Compare_Value (V, Result) = Less then
+ Result := V;
+ end if;
+ end loop;
+ end;
+
+ when Iir_Predefined_Endfile =>
+ Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir));
+
+ when Iir_Predefined_Now_Function =>
+ Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time));
+
+ when Iir_Predefined_Integer_To_String
+ | Iir_Predefined_Floating_To_String
+ | Iir_Predefined_Physical_To_String =>
+ Result := String_To_Iir_Value
+ (Execute_Image_Attribute (Left, Get_Type (Left_Param)));
+
+ when Iir_Predefined_Enum_To_String =>
+ declare
+ use Name_Table;
+ Base_Type : constant Iir :=
+ Get_Base_Type (Get_Type (Left_Param));
+ Lits : constant Iir_List :=
+ Get_Enumeration_Literal_List (Base_Type);
+ Pos : constant Natural := Get_Enum_Pos (Left);
+ Id : Name_Id;
+ begin
+ if Base_Type = Std_Package.Character_Type_Definition then
+ Result := String_To_Iir_Value ((1 => Character'Val (Pos)));
+ else
+ Id := Get_Identifier (Get_Nth_Element (Lits, Pos));
+ if Is_Character (Id) then
+ Result := String_To_Iir_Value ((1 => Get_Character (Id)));
+ else
+ Result := String_To_Iir_Value (Image (Id));
+ end if;
+ end if;
+ end;
+
+ when Iir_Predefined_Array_Char_To_String =>
+ declare
+ Str : String (1 .. Natural (Left.Bounds.D (1).Length));
+ Lits : constant Iir_List :=
+ Get_Enumeration_Literal_List
+ (Get_Base_Type
+ (Get_Element_Subtype (Get_Type (Left_Param))));
+ Pos : Natural;
+ begin
+ for I in Left.Val_Array.V'Range loop
+ Pos := Get_Enum_Pos (Left.Val_Array.V (I));
+ Str (Positive (I)) := Name_Table.Get_Character
+ (Get_Identifier (Get_Nth_Element (Lits, Pos)));
+ end loop;
+ Result := String_To_Iir_Value (Str);
+ end;
+
+ when Iir_Predefined_Bit_Vector_To_Hstring =>
+ return Execute_Bit_Vector_To_String (Left, 4);
+
+ when Iir_Predefined_Bit_Vector_To_Ostring =>
+ return Execute_Bit_Vector_To_String (Left, 3);
+
+ when Iir_Predefined_Real_To_String_Digits =>
+ Eval_Right;
+ declare
+ Str : Grt.Vstrings.String_Real_Digits;
+ Last : Natural;
+ begin
+ Grt.Vstrings.To_String
+ (Str, Last, Left.F64, Ghdl_I32 (Right.I64));
+ Result := String_To_Iir_Value (Str (1 .. Last));
+ end;
+ when Iir_Predefined_Real_To_String_Format =>
+ Eval_Right;
+ declare
+ Format : String (1 .. Natural (Right.Val_Array.Len) + 1);
+ Str : Grt.Vstrings.String_Real_Format;
+ Last : Natural;
+ begin
+ for I in Right.Val_Array.V'Range loop
+ Format (Positive (I)) :=
+ Character'Val (Right.Val_Array.V (I).E32);
+ end loop;
+ Format (Format'Last) := ASCII.NUL;
+ Grt.Vstrings.To_String
+ (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address));
+ Result := String_To_Iir_Value (Str (1 .. Last));
+ end;
+ when Iir_Predefined_Time_To_String_Unit =>
+ Eval_Right;
+ declare
+ Str : Grt.Vstrings.String_Time_Unit;
+ First : Natural;
+ Unit : Iir;
+ begin
+ Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition);
+ while Unit /= Null_Iir loop
+ exit when Evaluation.Get_Physical_Value (Unit)
+ = Iir_Int64 (Right.I64);
+ Unit := Get_Chain (Unit);
+ end loop;
+ if Unit = Null_Iir then
+ Error_Msg_Exec
+ ("to_string for time called with wrong unit", Expr);
+ end if;
+ Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64);
+ Result := String_To_Iir_Value
+ (Str (First .. Str'Last) & ' '
+ & Name_Table.Image (Get_Identifier (Unit)));
+ end;
+
+ when Iir_Predefined_Std_Ulogic_Match_Equality =>
+ Eval_Right;
+ declare
+ use Grt.Std_Logic_1164;
+ begin
+ Result := Create_E32_Value
+ (Std_Ulogic'Pos
+ (Match_Eq_Table (Std_Ulogic'Val (Left.E32),
+ Std_Ulogic'Val (Right.E32))));
+ end;
+ when Iir_Predefined_Std_Ulogic_Match_Inequality =>
+ Eval_Right;
+ declare
+ use Grt.Std_Logic_1164;
+ begin
+ Result := Create_E32_Value
+ (Std_Ulogic'Pos
+ (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E32),
+ Std_Ulogic'Val (Right.E32)))));
+ end;
+ when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions =>
+ Eval_Right;
+ declare
+ use Grt.Std_Logic_1164;
+ L : constant Std_Ulogic := Std_Ulogic'Val (Left.E32);
+ R : constant Std_Ulogic := Std_Ulogic'Val (Right.E32);
+ Res : Std_Ulogic;
+ begin
+ Check_Std_Ulogic_Dc (Expr, L);
+ Check_Std_Ulogic_Dc (Expr, R);
+ case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func)
+ is
+ when Iir_Predefined_Std_Ulogic_Match_Less =>
+ Res := Match_Lt_Table (L, R);
+ when Iir_Predefined_Std_Ulogic_Match_Less_Equal =>
+ Res := Or_Table (Match_Lt_Table (L, R),
+ Match_Eq_Table (L, R));
+ when Iir_Predefined_Std_Ulogic_Match_Greater =>
+ Res := Not_Table (Or_Table (Match_Lt_Table (L, R),
+ Match_Eq_Table (L, R)));
+ when Iir_Predefined_Std_Ulogic_Match_Greater_Equal =>
+ Res := Not_Table (Match_Lt_Table (L, R));
+ end case;
+ Result := Create_E32_Value (Std_Ulogic'Pos (Res));
+ end;
+
+ when Iir_Predefined_Std_Ulogic_Array_Match_Equality
+ | Iir_Predefined_Std_Ulogic_Array_Match_Inequality =>
+ Eval_Right;
+ if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then
+ Error_Msg_Constraint (Expr);
+ end if;
+ declare
+ use Grt.Std_Logic_1164;
+ Res : Std_Ulogic := '1';
+ begin
+ Result := Create_E32_Value (Std_Ulogic'Pos ('1'));
+ for I in Left.Val_Array.V'Range loop
+ Res := And_Table
+ (Res,
+ Match_Eq_Table
+ (Std_Ulogic'Val (Left.Val_Array.V (I).E32),
+ Std_Ulogic'Val (Right.Val_Array.V (I).E32)));
+ end loop;
+ if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then
+ Res := Not_Table (Res);
+ end if;
+ Result := Create_E32_Value (Std_Ulogic'Pos (Res));
+ end;
+
+ when others =>
+ Error_Msg ("execute_implicit_function: unimplemented " &
+ Iir_Predefined_Functions'Image (Func));
+ raise Internal_Error;
+ end case;
+ return Result;
+ exception
+ when Constraint_Error =>
+ Error_Msg_Constraint (Expr);
+ end Execute_Implicit_Function;
+
+ procedure Execute_Implicit_Procedure
+ (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call)
+ is
+ Imp : constant Iir_Implicit_Procedure_Declaration :=
+ Get_Named_Entity (Get_Implementation (Stmt));
+ Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt);
+ Assoc: Iir;
+ Args: Iir_Value_Literal_Array (0 .. 3);
+ Inter_Chain : Iir;
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+ Assoc := Assoc_Chain;
+ for I in Iir_Index32 loop
+ exit when Assoc = Null_Iir;
+ Args (I) := Execute_Expression (Block, Get_Actual (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ Inter_Chain := Get_Interface_Declaration_Chain (Imp);
+ case Get_Implicit_Definition (Imp) is
+ when Iir_Predefined_Deallocate =>
+ if Args (0).Val_Access /= null then
+ Free_Heap_Value (Args (0));
+ Args (0).Val_Access := null;
+ end if;
+ when Iir_Predefined_File_Open =>
+ File_Operation.File_Open
+ (Args (0), Args (1), Args (2), Inter_Chain, Stmt);
+ when Iir_Predefined_File_Open_Status =>
+ File_Operation.File_Open_Status
+ (Args (0), Args (1), Args (2), Args (3),
+ Get_Chain (Inter_Chain), Stmt);
+ when Iir_Predefined_Write =>
+ if Get_Text_File_Flag (Get_Type (Inter_Chain)) then
+ File_Operation.Write_Text (Args (0), Args (1));
+ else
+ File_Operation.Write_Binary (Args (0), Args (1));
+ end if;
+ when Iir_Predefined_Read_Length =>
+ if Get_Text_File_Flag (Get_Type (Inter_Chain)) then
+ File_Operation.Read_Length_Text
+ (Args (0), Args (1), Args (2));
+ else
+ File_Operation.Read_Length_Binary
+ (Args (0), Args (1), Args (2));
+ end if;
+ when Iir_Predefined_Read =>
+ File_Operation.Read_Binary (Args (0), Args (1));
+ when Iir_Predefined_Flush =>
+ File_Operation.Flush (Args (0));
+ when Iir_Predefined_File_Close =>
+ if Get_Text_File_Flag (Get_Type (Inter_Chain)) then
+ File_Operation.File_Close_Text (Args (0), Stmt);
+ else
+ File_Operation.File_Close_Binary (Args (0), Stmt);
+ end if;
+ when others =>
+ Error_Kind ("execute_implicit_procedure",
+ Get_Implicit_Definition (Imp));
+ end case;
+ Release (Expr_Mark, Expr_Pool);
+ end Execute_Implicit_Procedure;
+
+ procedure Execute_Foreign_Procedure
+ (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call)
+ is
+ Imp : constant Iir_Implicit_Procedure_Declaration :=
+ Get_Implementation (Stmt);
+ Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt);
+ Assoc: Iir;
+ Args: Iir_Value_Literal_Array (0 .. 3) := (others => null);
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+ Assoc := Assoc_Chain;
+ for I in Args'Range loop
+ exit when Assoc = Null_Iir;
+ Args (I) := Execute_Expression (Block, Get_Actual (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ case Get_Identifier (Imp) is
+ when Std_Names.Name_Untruncated_Text_Read =>
+ File_Operation.Untruncated_Text_Read
+ (Args (0), Args (1), Args (2));
+ when Std_Names.Name_Control_Simulation =>
+ Put_Line (Standard_Error, "simulation finished");
+ raise Simulation_Finished;
+ when others =>
+ Error_Msg_Exec ("unsupported foreign procedure call", Stmt);
+ end case;
+ Release (Expr_Mark, Expr_Pool);
+ end Execute_Foreign_Procedure;
+
+ -- Compute the offset for INDEX into a range BOUNDS.
+ -- EXPR is only used in case of error.
+ function Get_Index_Offset
+ (Index: Iir_Value_Literal_Acc;
+ Bounds: Iir_Value_Literal_Acc;
+ Expr: Iir)
+ return Iir_Index32
+ is
+ Left_Pos, Right_Pos: Iir_Value_Literal_Acc;
+ begin
+ Left_Pos := Bounds.Left;
+ Right_Pos := Bounds.Right;
+ if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then
+ raise Internal_Error;
+ end if;
+ case Index.Kind is
+ when Iir_Value_B1 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.B1 >= Left_Pos.B1 and then
+ Index.B1 <= Right_Pos.B1
+ then
+ -- to
+ return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1);
+ end if;
+ when Iir_Downto =>
+ if Index.B1 <= Left_Pos.B1 and then
+ Index.B1 >= Right_Pos.B1
+ then
+ -- downto
+ return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1);
+ end if;
+ end case;
+ when Iir_Value_E32 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.E32 >= Left_Pos.E32 and then
+ Index.E32 <= Right_Pos.E32
+ then
+ -- to
+ return Iir_Index32 (Index.E32 - Left_Pos.E32);
+ end if;
+ when Iir_Downto =>
+ if Index.E32 <= Left_Pos.E32 and then
+ Index.E32 >= Right_Pos.E32
+ then
+ -- downto
+ return Iir_Index32 (Left_Pos.E32 - Index.E32);
+ end if;
+ end case;
+ when Iir_Value_I64 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ if Index.I64 >= Left_Pos.I64 and then
+ Index.I64 <= Right_Pos.I64
+ then
+ -- to
+ return Iir_Index32 (Index.I64 - Left_Pos.I64);
+ end if;
+ when Iir_Downto =>
+ if Index.I64 <= Left_Pos.I64 and then
+ Index.I64 >= Right_Pos.I64
+ then
+ -- downto
+ return Iir_Index32 (Left_Pos.I64 - Index.I64);
+ end if;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Error_Msg_Constraint (Expr);
+ return 0;
+ end Get_Index_Offset;
+
+ -- Create an iir_value_literal of kind iir_value_array and of life LIFE.
+ -- Allocate the array of bounds, and fill it from A_TYPE.
+ -- Allocate the array of values.
+ function Create_Array_Bounds_From_Type
+ (Block : Block_Instance_Acc;
+ A_Type : Iir;
+ Create_Val_Array : Boolean)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Index_List : Iir_List;
+ Len : Iir_Index32;
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ -- Only for constrained subtypes.
+ if Get_Kind (A_Type) = Iir_Kind_Array_Type_Definition then
+ raise Internal_Error;
+ end if;
+
+ Index_List := Get_Index_Subtype_List (A_Type);
+ Res := Create_Array_Value
+ (Iir_Index32 (Get_Nbr_Elements (Index_List)));
+ Len := 1;
+ for I in 1 .. Res.Bounds.Nbr_Dims loop
+ Bound := Execute_Bounds
+ (Block, Get_Nth_Element (Index_List, Natural (I - 1)));
+ Len := Len * Bound.Length;
+ Res.Bounds.D (I) := Bound;
+ end loop;
+ if Create_Val_Array then
+ Create_Array_Data (Res, Len);
+ end if;
+ return Res;
+ end Create_Array_Bounds_From_Type;
+
+ -- Return the steps (ie, offset in the array when index DIM is increased
+ -- by one) for array ARR and dimension DIM.
+ function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural)
+ return Iir_Index32
+ is
+ Bounds : Value_Bounds_Array_Acc renames Arr.Bounds;
+ Res : Iir_Index32;
+ begin
+ Res := 1;
+ for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop
+ Res := Res * Bounds.D (I).Length;
+ end loop;
+ return Res;
+ end Get_Step_For_Dim;
+
+ -- Create a literal for a string or a bit_string
+ function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Lit: Iir_Value_Literal_Acc;
+ Element_Mode : Iir_Value_Scalars;
+
+ procedure Create_Lit_El
+ (Index : Iir_Index32; Literal: Iir_Enumeration_Literal)
+ is
+ R : Iir_Value_Literal_Acc;
+ P : constant Iir_Int32 := Get_Enum_Pos (Literal);
+ begin
+ case Element_Mode is
+ when Iir_Value_B1 =>
+ R := Create_B1_Value (Ghdl_B1'Val (P));
+ when Iir_Value_E32 =>
+ R := Create_E32_Value (Ghdl_E32'Val (P));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Lit.Val_Array.V (Index) := R;
+ end Create_Lit_El;
+
+ El_Btype : constant Iir := Get_Base_Type (El_Type);
+ Literal_List: constant Iir_List :=
+ Get_Enumeration_Literal_List (El_Btype);
+ Len: Iir_Index32;
+ Str_As_Str: constant String := Iirs_Utils.Image_String_Lit (Str);
+ El : Iir;
+ begin
+ Element_Mode := Get_Info (El_Btype).Scalar_Mode;
+
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Len := Iir_Index32 (Str_As_Str'Length);
+ Lit := Create_Array_Value (Len, 1);
+
+ for I in Lit.Val_Array.V'Range loop
+ -- FIXME: use literal from type ??
+ El := Find_Name_In_List
+ (Literal_List,
+ Name_Table.Get_Identifier (Str_As_Str (Natural (I))));
+ if El = Null_Iir then
+ -- FIXME: could free what was already built.
+ return null;
+ end if;
+ Create_Lit_El (I, El);
+ end loop;
+
+ when Iir_Kind_Bit_String_Literal =>
+ declare
+ Lit_0, Lit_1 : Iir;
+ Buf : String_Fat_Acc;
+ Len1 : Int32;
+ begin
+ Lit_0 := Get_Bit_String_0 (Str);
+ Lit_1 := Get_Bit_String_1 (Str);
+ Buf := Str_Table.Get_String_Fat_Acc (Get_String_Id (Str));
+ Len1 := Get_String_Length (Str);
+ Lit := Create_Array_Value (Iir_Index32 (Len1), 1);
+
+ if Lit_0 = Null_Iir or Lit_1 = Null_Iir then
+ raise Internal_Error;
+ end if;
+ for I in 1 .. Len1 loop
+ case Buf (I) is
+ when '0' =>
+ Create_Lit_El (Iir_Index32 (I), Lit_0);
+ when '1' =>
+ Create_Lit_El (Iir_Index32 (I), Lit_1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ return Lit;
+ end String_To_Enumeration_Array_1;
+
+ -- Create a literal for a string or a bit_string
+ function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ Array_Type: constant Iir := Get_Type (Str);
+ Index_Types : constant Iir_List := Get_Index_Subtype_List (Array_Type);
+ begin
+ if Get_Nbr_Elements (Index_Types) /= 1 then
+ raise Internal_Error; -- array must be unidimensional
+ end if;
+
+ Res := String_To_Enumeration_Array_1
+ (Str, Get_Element_Subtype (Array_Type));
+
+ -- When created from static evaluation, a string may still have an
+ -- unconstrained type.
+ if Get_Constraint_State (Array_Type) /= Fully_Constrained then
+ Res.Bounds.D (1) :=
+ Create_Range_Value (Create_I64_Value (1),
+ Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)),
+ Iir_To,
+ Res.Val_Array.Len);
+ else
+ Res.Bounds.D (1) :=
+ Execute_Bounds (Block, Get_First_Element (Index_Types));
+ end if;
+
+ -- The range may not be statically constant.
+ if Res.Bounds.D (1).Length /= Res.Val_Array.Len then
+ Error_Msg_Constraint (Str);
+ end if;
+
+ return Res;
+ end String_To_Enumeration_Array;
+
+ -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP.
+ -- Use expressions from (BLOCK, AGGREGATE) to fill the elements.
+ -- EL_TYPE is the type of the array element.
+ procedure Fill_Array_Aggregate_1
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc;
+ Orig : Iir_Index32;
+ Step : Iir_Index32;
+ Dim : Iir_Index32;
+ Nbr_Dim : Iir_Index32;
+ El_Type : Iir)
+ is
+ Value : Iir;
+ Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim);
+
+ procedure Set_Elem (Pos : Iir_Index32)
+ is
+ Val : Iir_Value_Literal_Acc;
+ begin
+ if Dim = Nbr_Dim then
+ -- VALUE is an expression (which may be an aggregate, but not
+ -- a sub-aggregate.
+ Val := Execute_Expression_With_Type (Block, Value, El_Type);
+ -- LRM93 7.3.2.2
+ -- For a multi-dimensional aggregate of dimension n, a check
+ -- is made that all (n-1)-dimensional subaggregates have the
+ -- same bounds.
+ -- GHDL: I have added an implicit array conversion, however
+ -- it may be useful to allow cases like this:
+ -- type str_array is array (natural range <>)
+ -- of string (10 downto 1);
+ -- constant floats : str_array :=
+ -- ( "00000000.0", HT & "+1.5ABCDE");
+ -- The subtype of the first sub-aggregate (0.0) is
+ -- determinated by the context, according to rule 9 and 4
+ -- of LRM93 7.3.2.2 and therefore is string (10 downto 1),
+ -- while the subtype of the second sub-aggregate (HT & ...)
+ -- is determinated by rules 1 and 2 of LRM 7.2.4, and is
+ -- string (1 to 10).
+ -- Unless an implicit conversion is used, according to the
+ -- LRM, this should fail, but it makes no sens.
+ --
+ -- FIXME: Add a warning, a flag ?
+ --Implicit_Array_Conversion (Block, Val, El_Type, Value);
+ --Check_Constraints (Block, Val, El_Type, Value);
+ Res.Val_Array.V (1 + Orig + Pos * Step) := Val;
+ else
+ case Get_Kind (Value) is
+ when Iir_Kind_Aggregate =>
+ -- VALUE is a sub-aggregate.
+ Fill_Array_Aggregate_1 (Block, Value, Res,
+ Orig + Pos * Step,
+ Step / Res.Bounds.D (Dim + 1).Length,
+ Dim + 1, Nbr_Dim, El_Type);
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ pragma Assert (Dim + 1 = Nbr_Dim);
+ Val := String_To_Enumeration_Array_1 (Value, El_Type);
+ if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then
+ Error_Msg_Constraint (Value);
+ end if;
+ for I in Val.Val_Array.V'Range loop
+ Res.Val_Array.V (Orig + Pos * Step + I) :=
+ Val.Val_Array.V (I);
+ end loop;
+ when others =>
+ Error_Kind ("fill_array_aggregate_1", Value);
+ end case;
+ end if;
+ end Set_Elem;
+
+ procedure Set_Elem_By_Expr (Expr : Iir)
+ is
+ Expr_Pos: Iir_Value_Literal_Acc;
+ begin
+ Expr_Pos := Execute_Expression (Block, Expr);
+ Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr));
+ end Set_Elem_By_Expr;
+
+ procedure Set_Elem_By_Range (Expr : Iir)
+ is
+ A_Range : Iir_Value_Literal_Acc;
+ High, Low : Iir_Value_Literal_Acc;
+ begin
+ A_Range := Execute_Bounds (Block, Expr);
+ if Is_Nul_Range (A_Range) then
+ return;
+ end if;
+ if A_Range.Dir = Iir_To then
+ High := A_Range.Right;
+ Low := A_Range.Left;
+ else
+ High := A_Range.Left;
+ Low := A_Range.Right;
+ end if;
+
+ -- Locally modified (incremented)
+ Low := Unshare (Low, Expr_Pool'Access);
+
+ loop
+ Set_Elem (Get_Index_Offset (Low, Bound, Expr));
+ exit when Is_Equal (Low, High);
+ Increment (Low);
+ end loop;
+ end Set_Elem_By_Range;
+
+ Length : constant Iir_Index32 := Bound.Length;
+ Assoc : Iir;
+ Pos : Iir_Index32;
+ begin
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 0;
+ while Assoc /= Null_Iir loop
+ Value := Get_Associated_Expr (Assoc);
+ loop
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ if Pos >= Length then
+ Error_Msg_Constraint (Assoc);
+ end if;
+ Set_Elem (Pos);
+ Pos := Pos + 1;
+ when Iir_Kind_Choice_By_Expression =>
+ Set_Elem_By_Expr (Get_Choice_Expression (Assoc));
+ when Iir_Kind_Choice_By_Range =>
+ Set_Elem_By_Range (Get_Choice_Range (Assoc));
+ when Iir_Kind_Choice_By_Others =>
+ for J in 1 .. Length loop
+ if Res.Val_Array.V (Orig + J * Step) = null then
+ Set_Elem (J - 1);
+ end if;
+ end loop;
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ exit when not Get_Same_Alternative_Flag (Assoc);
+ end loop;
+ end loop;
+
+ -- Check each elements have been set.
+ -- FIXME: check directly with type.
+ for J in 1 .. Length loop
+ if Res.Val_Array.V (Orig + J * Step) = null then
+ Error_Msg_Constraint (Aggregate);
+ end if;
+ end loop;
+ end Fill_Array_Aggregate_1;
+
+ -- Use expressions from (BLOCK, AGGREGATE) to fill RES.
+ procedure Fill_Array_Aggregate
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc)
+ is
+ Aggr_Type : constant Iir := Get_Type (Aggregate);
+ El_Type : constant Iir := Get_Element_Subtype (Aggr_Type);
+ Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type);
+ Nbr_Dim : constant Iir_Index32 :=
+ Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Step : Iir_Index32;
+ begin
+ Step := Get_Step_For_Dim (Res, 1);
+ Fill_Array_Aggregate_1
+ (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type);
+ end Fill_Array_Aggregate;
+
+ function Execute_Record_Aggregate (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type));
+
+ Res: Iir_Value_Literal_Acc;
+ Expr : Iir;
+
+ procedure Set_Expr (Pos : Iir_Index32) is
+ El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1));
+ begin
+ Res.Val_Record.V (Pos) :=
+ Execute_Expression_With_Type (Block, Expr, Get_Type (El));
+ end Set_Expr;
+
+ Pos : Iir_Index32;
+ Assoc: Iir;
+ N_Expr : Iir;
+ begin
+ Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List)));
+
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 1;
+ loop
+ N_Expr := Get_Associated_Expr (Assoc);
+ if N_Expr /= Null_Iir then
+ Expr := N_Expr;
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ Set_Expr (Pos);
+ Pos := Pos + 1;
+ when Iir_Kind_Choice_By_Name =>
+ Set_Expr (1 + Get_Element_Position (Get_Choice_Name (Assoc)));
+ when Iir_Kind_Choice_By_Others =>
+ for I in Res.Val_Record.V'Range loop
+ if Res.Val_Record.V (I) = null then
+ Set_Expr (I);
+ end if;
+ end loop;
+ when others =>
+ Error_Kind ("execute_record_aggregate", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ end loop;
+ return Res;
+ end Execute_Record_Aggregate;
+
+ function Execute_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Aggregate_Type) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Bounds_From_Type
+ (Block, Aggregate_Type, True);
+ Fill_Array_Aggregate (Block, Aggregate, Res);
+ return Res;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Execute_Record_Aggregate
+ (Block, Aggregate, Aggregate_Type);
+ when others =>
+ Error_Kind ("execute_aggregate", Aggregate_Type);
+ end case;
+ end Execute_Aggregate;
+
+ function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ List : constant Iir_List := Get_Simple_Aggregate_List (Aggr);
+ begin
+ Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True);
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1)));
+ end loop;
+ return Res;
+ end Execute_Simple_Aggregate;
+
+ -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP.
+ -- Use expressions from (BLOCK, AGGREGATE) to fill the elements.
+ -- EL_TYPE is the type of the array element.
+ procedure Execute_Name_Array_Aggregate
+ (Block : Block_Instance_Acc;
+ Aggregate : Iir;
+ Res : Iir_Value_Literal_Acc;
+ Orig : Iir_Index32;
+ Step : Iir_Index32;
+ Dim : Iir_Index32;
+ Nbr_Dim : Iir_Index32;
+ El_Type : Iir)
+ is
+ Value : Iir;
+ Bound : Iir_Value_Literal_Acc;
+
+ procedure Set_Elem (Pos : Iir_Index32)
+ is
+ Val : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ if Dim = Nbr_Dim then
+ -- VALUE is an expression (which may be an aggregate, but not
+ -- a sub-aggregate.
+ Execute_Name_With_Base (Block, Value, null, Val, Is_Sig);
+ Res.Val_Array.V (1 + Orig + Pos * Step) := Val;
+ else
+ -- VALUE is a sub-aggregate.
+ Execute_Name_Array_Aggregate
+ (Block, Value, Res,
+ Orig + Pos * Step,
+ Step / Res.Bounds.D (Dim + 1).Length,
+ Dim + 1, Nbr_Dim, El_Type);
+ end if;
+ end Set_Elem;
+
+ Assoc : Iir;
+ Pos : Iir_Index32;
+ begin
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Bound := Res.Bounds.D (Dim);
+ Pos := 0;
+ while Assoc /= Null_Iir loop
+ Value := Get_Associated_Expr (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ declare
+ Expr_Pos: Iir_Value_Literal_Acc;
+ Val : constant Iir := Get_Expression (Assoc);
+ begin
+ Expr_Pos := Execute_Expression (Block, Val);
+ Pos := Get_Index_Offset (Expr_Pos, Bound, Val);
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Set_Elem (Pos);
+ Pos := Pos + 1;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Execute_Name_Array_Aggregate;
+
+ function Execute_Record_Name_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type));
+ Res: Iir_Value_Literal_Acc;
+ Expr : Iir;
+ Pos : Iir_Index32;
+ El_Pos : Iir_Index32;
+ Is_Sig : Boolean;
+ Assoc: Iir;
+ begin
+ Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List)));
+ Assoc := Get_Association_Choices_Chain (Aggregate);
+ Pos := 0;
+ loop
+ Expr := Get_Associated_Expr (Assoc);
+ if Expr = Null_Iir then
+ -- List of choices is not allowed.
+ raise Internal_Error;
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ El_Pos := Pos;
+ Pos := Pos + 1;
+ when Iir_Kind_Choice_By_Name =>
+ El_Pos := Get_Element_Position (Get_Name (Assoc));
+ when Iir_Kind_Choice_By_Others =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("execute_record_name_aggregate", Assoc);
+ end case;
+ Execute_Name_With_Base
+ (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig);
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ end loop;
+ return Res;
+ end Execute_Record_Name_Aggregate;
+
+ function Execute_Name_Aggregate
+ (Block: Block_Instance_Acc;
+ Aggregate: Iir;
+ Aggregate_Type: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Aggregate_Type) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type);
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (Aggregate_Type);
+ Nbr_Dim : constant Iir_Index32 :=
+ Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Step : Iir_Index32;
+ begin
+ Res := Create_Array_Bounds_From_Type
+ (Block, Aggregate_Type, True);
+ Step := Get_Step_For_Dim (Res, 1);
+ Execute_Name_Array_Aggregate
+ (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type);
+ return Res;
+ end;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Execute_Record_Name_Aggregate
+ (Block, Aggregate, Aggregate_Type);
+ when others =>
+ Error_Kind ("execute_name_aggregate", Aggregate_Type);
+ end case;
+ end Execute_Name_Aggregate;
+
+ -- Return the indexes range of dimension DIM for type or object PREFIX.
+ -- DIM starts at 1.
+ function Execute_Indexes
+ (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ declare
+ Index : Iir;
+ begin
+ Index := Get_Nth_Element
+ (Get_Index_Subtype_List (Get_Type (Prefix)),
+ Natural (Dim - 1));
+ return Execute_Bounds (Block, Index);
+ end;
+ when Iir_Kinds_Denoting_Name =>
+ return Execute_Indexes (Block, Get_Named_Entity (Prefix), Dim);
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ Error_Kind ("execute_indexes", Prefix);
+ when others =>
+ declare
+ Orig : Iir_Value_Literal_Acc;
+ begin
+ Orig := Execute_Name (Block, Prefix, True);
+ return Orig.Bounds.D (Iir_Index32 (Dim));
+ end;
+ end case;
+ end Execute_Indexes;
+
+ function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Range_Expression =>
+ declare
+ Info : constant Sim_Info_Acc := Get_Info (Prefix);
+ begin
+ if Info = null then
+ Bound := Create_Range_Value
+ (Execute_Expression (Block, Get_Left_Limit (Prefix)),
+ Execute_Expression (Block, Get_Right_Limit (Prefix)),
+ Get_Direction (Prefix));
+ elsif Info.Kind = Kind_Object then
+ Bound := Get_Instance_For_Slot
+ (Block, Prefix).Objects (Info.Slot);
+ else
+ raise Internal_Error;
+ end if;
+ end;
+
+ when Iir_Kind_Subtype_Declaration =>
+ return Execute_Bounds (Block, Get_Type (Prefix));
+
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ -- FIXME: move this block before and avoid recursion.
+ return Execute_Bounds (Block, Get_Range_Constraint (Prefix));
+
+ when Iir_Kind_Range_Array_Attribute =>
+ declare
+ Prefix_Val : Iir_Value_Literal_Acc;
+ Dim : Iir_Int64;
+ begin
+ Dim := Get_Value (Get_Parameter (Prefix));
+ Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim);
+ Bound := Prefix_Val;
+ end;
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ declare
+ Dim : Iir_Int64;
+ begin
+ Dim := Get_Value (Get_Parameter (Prefix));
+ Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim);
+ case Bound.Dir is
+ when Iir_To =>
+ Bound := Create_Range_Value
+ (Bound.Right, Bound.Left, Iir_Downto, Bound.Length);
+ when Iir_Downto =>
+ Bound := Create_Range_Value
+ (Bound.Right, Bound.Left, Iir_To, Bound.Length);
+ end case;
+ end;
+
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Integer_Type_Definition =>
+ return Execute_Bounds
+ (Block,
+ Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix))));
+
+ when Iir_Kinds_Denoting_Name =>
+ return Execute_Bounds (Block, Get_Named_Entity (Prefix));
+
+ when others =>
+ -- Error_Kind ("execute_bounds", Get_Kind (Prefix));
+ declare
+ Prefix_Val: Iir_Value_Literal_Acc;
+ begin
+ Prefix_Val := Execute_Expression (Block, Prefix);
+ Bound := Prefix_Val.Bounds.D (1);
+ end;
+ end case;
+ if not Bound.Dir'Valid then
+ raise Internal_Error;
+ end if;
+ return Bound;
+ end Execute_Bounds;
+
+ -- Perform type conversion as desribed in LRM93 7.3.5
+ function Execute_Type_Conversion (Block: Block_Instance_Acc;
+ Conv : Iir_Type_Conversion;
+ Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Target_Type : constant Iir := Get_Type (Conv);
+ Res: Iir_Value_Literal_Acc;
+ begin
+ Res := Val;
+ case Get_Kind (Target_Type) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ case Res.Kind is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_F64 =>
+ if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or
+ Res.F64 < Ghdl_F64 (Iir_Int64'First)
+ then
+ Error_Msg_Constraint (Conv);
+ end if;
+ Res := Create_I64_Value (Ghdl_I64 (Res.F64));
+ when Iir_Value_B1
+ | Iir_Value_E32
+ | Iir_Value_Range
+ | Iir_Value_Array
+ | Iir_Value_Signal
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These values are not of abstract numeric type.
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ case Res.Kind is
+ when Iir_Value_F64 =>
+ null;
+ when Iir_Value_I64 =>
+ Res := Create_F64_Value (Ghdl_F64 (Res.I64));
+ when Iir_Value_B1
+ | Iir_Value_E32
+ | Iir_Value_Range
+ | Iir_Value_Array
+ | Iir_Value_Signal
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These values are not of abstract numeric type.
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ -- must be same type.
+ null;
+ when Iir_Kind_Array_Type_Definition =>
+ -- LRM93 7.3.5
+ -- if the type mark denotes an unconstrained array type and the
+ -- operand is not a null array, then for each index position, the
+ -- bounds of the result are obtained by converting the bounds of
+ -- the operand to the corresponding index type of the target type.
+ -- FIXME: what is bound conversion ??
+ null;
+ when Iir_Kind_Array_Subtype_Definition =>
+ -- LRM93 7.3.5
+ -- If the type mark denotes a constrained array subtype, then the
+ -- bounds of the result are those imposed by the type mark.
+ Implicit_Array_Conversion (Block, Res, Target_Type, Conv);
+ when others =>
+ Error_Kind ("execute_type_conversion", Target_Type);
+ end case;
+ Check_Constraints (Block, Res, Target_Type, Conv);
+ return Res;
+ end Execute_Type_Conversion;
+
+ -- Decrement VAL.
+ -- May raise a constraint error using EXPR.
+ function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Val.Kind is
+ when Iir_Value_B1 =>
+ if Val.B1 = False then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_B1_Value (False);
+ when Iir_Value_E32 =>
+ if Val.E32 = 0 then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_E32_Value (Val.E32 - 1);
+ when Iir_Value_I64 =>
+ if Val.I64 = Ghdl_I64'First then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_I64_Value (Val.I64 - 1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Execute_Dec;
+
+ -- Increment VAL.
+ -- May raise a constraint error using EXPR.
+ function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Val.Kind is
+ when Iir_Value_B1 =>
+ if Val.B1 = True then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_B1_Value (True);
+ when Iir_Value_E32 =>
+ if Val.E32 = Ghdl_E32'Last then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_E32_Value (Val.E32 + 1);
+ when Iir_Value_I64 =>
+ if Val.I64 = Ghdl_I64'Last then
+ Error_Msg_Constraint (Expr);
+ end if;
+ Res := Create_I64_Value (Val.I64 + 1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Execute_Inc;
+
+ function Execute_Expression_With_Type
+ (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Expr_Type : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ and then not Is_Fully_Constrained_Type (Get_Type (Expr))
+ then
+ return Execute_Aggregate (Block, Expr, Expr_Type);
+ else
+ Res := Execute_Expression (Block, Expr);
+ Implicit_Array_Conversion (Block, Res, Expr_Type, Expr);
+ Check_Constraints (Block, Res, Expr_Type, Expr);
+ return Res;
+ end if;
+ end Execute_Expression_With_Type;
+
+ function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Base : constant Iir := Get_Object_Prefix (Expr);
+ Info : constant Sim_Info_Acc := Get_Info (Base);
+ Bblk : Block_Instance_Acc;
+ Base_Val : Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Bblk := Get_Instance_By_Scope_Level (Block, Info.Scope_Level);
+ Base_Val := Bblk.Objects (Info.Slot + 1);
+ Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig);
+ pragma Assert (Is_Sig);
+ return Res;
+ end Execute_Signal_Init_Value;
+
+ procedure Execute_Name_With_Base (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Base : Iir_Value_Literal_Acc;
+ Res : out Iir_Value_Literal_Acc;
+ Is_Sig : out Boolean)
+ is
+ Slot_Block: Block_Instance_Acc;
+ begin
+ -- Default value
+ Is_Sig := False;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ Is_Sig := True;
+ if Base /= null then
+ Res := Base;
+ else
+ Slot_Block := Get_Instance_For_Slot (Block, Expr);
+ Res := Slot_Block.Objects (Get_Info (Expr).Slot);
+ end if;
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ pragma Assert (Base = null);
+ -- FIXME: add a flag ?
+ case Get_Kind (Get_Object_Prefix (Expr)) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ Is_Sig := True;
+ when others =>
+ Is_Sig := False;
+ end case;
+ Slot_Block := Get_Instance_For_Slot (Block, Expr);
+ Res := Slot_Block.Objects (Get_Info (Expr).Slot);
+
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kinds_Quantity_Declaration =>
+ if Base /= null then
+ Res := Base;
+ else
+ declare
+ Info : constant Sim_Info_Acc := Get_Info (Expr);
+ begin
+ Slot_Block :=
+ Get_Instance_By_Scope_Level (Block, Info.Scope_Level);
+ Res := Slot_Block.Objects (Info.Slot);
+ end;
+ end if;
+
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Prefix: Iir;
+ Index_List: Iir_List;
+ Index: Iir;
+ Nbr_Dimensions: Iir_Index32;
+ Value: Iir_Value_Literal_Acc;
+ Pfx: Iir_Value_Literal_Acc;
+ Pos, Off : Iir_Index32;
+ begin
+ Prefix := Get_Prefix (Expr);
+ Index_List := Get_Index_List (Expr);
+ Nbr_Dimensions := Iir_Index32 (Get_Nbr_Elements (Index_List));
+ Execute_Name_With_Base (Block, Prefix, Base, Pfx, Is_Sig);
+ for I in 1 .. Nbr_Dimensions loop
+ Index := Get_Nth_Element (Index_List, Natural (I - 1));
+ Value := Execute_Expression (Block, Index);
+ Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr);
+ if I = 1 then
+ Pos := Off;
+ else
+ Pos := Pos * Pfx.Bounds.D (I).Length + Off;
+ end if;
+ end loop;
+ Res := Pfx.Val_Array.V (1 + Pos);
+ -- FIXME: free PFX.
+ end;
+
+ when Iir_Kind_Slice_Name =>
+ declare
+ Prefix: Iir;
+ Prefix_Array: Iir_Value_Literal_Acc;
+
+ Srange : Iir_Value_Literal_Acc;
+ Index_Order : Order;
+ -- Lower and upper bounds of the slice.
+ Low, High: Iir_Index32;
+ begin
+ Srange := Execute_Bounds (Block, Get_Suffix (Expr));
+
+ Prefix := Get_Prefix (Expr);
+
+ Execute_Name_With_Base
+ (Block, Prefix, Base, Prefix_Array, Is_Sig);
+ if Prefix_Array = null then
+ raise Internal_Error;
+ end if;
+
+ -- LRM93 6.5
+ -- It is an error if the direction of the discrete range is not
+ -- the same as that of the index range of the array denoted by
+ -- the prefix of the slice name.
+ if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then
+ Error_Msg_Exec ("slice direction mismatch", Expr);
+ end if;
+
+ -- LRM93 6.5
+ -- It is an error if either of the bounds of the
+ -- discrete range does not belong to the index range of the
+ -- prefixing array, unless the slice is a null slice.
+ Index_Order := Compare_Value (Srange.Left, Srange.Right);
+ if (Srange.Dir = Iir_To and Index_Order = Greater)
+ or (Srange.Dir = Iir_Downto and Index_Order = Less)
+ then
+ -- Null slice.
+ Low := 1;
+ High := 0;
+ else
+ Low := Get_Index_Offset
+ (Srange.Left, Prefix_Array.Bounds.D (1), Expr);
+ High := Get_Index_Offset
+ (Srange.Right, Prefix_Array.Bounds.D (1), Expr);
+ end if;
+ Res := Create_Array_Value (High - Low + 1, 1);
+ Res.Bounds.D (1) := Srange;
+ for I in Low .. High loop
+ Res.Val_Array.V (1 + I - Low) :=
+ Prefix_Array.Val_Array.V (1 + I);
+ end loop;
+ end;
+
+ when Iir_Kind_Selected_Element =>
+ declare
+ Prefix: Iir_Value_Literal_Acc;
+ Pos: Iir_Index32;
+ begin
+ Execute_Name_With_Base
+ (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig);
+ Pos := Get_Element_Position (Get_Selected_Element (Expr));
+ Res := Prefix.Val_Record.V (Pos + 1);
+ end;
+
+ when Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ declare
+ Prefix: Iir_Value_Literal_Acc;
+ begin
+ Prefix := Execute_Name (Block, Get_Prefix (Expr));
+ Res := Prefix.Val_Access;
+ if Res = null then
+ Error_Msg_Exec ("deferencing null access", Expr);
+ end if;
+ end;
+
+ when Iir_Kinds_Denoting_Name
+ | Iir_Kind_Attribute_Name =>
+ Execute_Name_With_Base
+ (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig);
+
+ when Iir_Kind_Function_Call =>
+ -- A prefix can be an expression
+ if Base /= null then
+ raise Internal_Error;
+ end if;
+ Res := Execute_Expression (Block, Expr);
+
+ when Iir_Kind_Aggregate =>
+ Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr));
+ -- FIXME: is_sig ?
+
+ when others =>
+ Error_Kind ("execute_name_with_base", Expr);
+ end case;
+ end Execute_Name_With_Base;
+
+ function Execute_Name (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Ref : Boolean := False)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig);
+ if not Is_Sig or else Ref then
+ return Res;
+ else
+ return Execute_Signal_Value (Res);
+ end if;
+ end Execute_Name;
+
+ function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Val : Iir_Value_Literal_Acc;
+ Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr));
+ begin
+ Val := Execute_Expression (Block, Get_Parameter (Expr));
+ return String_To_Iir_Value
+ (Execute_Image_Attribute (Val, Attr_Type));
+ end Execute_Image_Attribute;
+
+ function Execute_Value_Attribute (Block: Block_Instance_Acc;
+ Str_Val : Iir_Value_Literal_Acc;
+ Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ use Grt_Interface;
+ use Name_Table;
+ pragma Unreferenced (Block);
+
+ Expr_Type : constant Iir := Get_Type (Expr);
+ Res : Iir_Value_Literal_Acc;
+
+ Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val);
+ Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length);
+ Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address),
+ To_Std_String_Boundp (Str_Bnd'Address));
+ begin
+ Set_Std_String_From_Iir_Value (Str, Str_Val);
+ case Get_Kind (Expr_Type) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Res := Create_I64_Value
+ (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access));
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Floating_Subtype_Definition =>
+ Res := Create_F64_Value
+ (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access));
+ when Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ declare
+ Is_Real : Boolean;
+ Lit_Pos : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+ Unit_Pos : Ghdl_Index_Type;
+ Unit_Len : Ghdl_Index_Type;
+ Mult : Ghdl_I64;
+ Unit : Iir;
+ Unit_Id : Name_Id;
+ begin
+ Grt.Values.Ghdl_Value_Physical_Split
+ (Str'Unrestricted_Access,
+ Is_Real, Lit_Pos, Lit_End, Unit_Pos);
+
+ -- Find unit.
+ Unit_Len := 0;
+ Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based
+ for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop
+ exit when Grt.Values.Is_Whitespace (Str_Str (I));
+ Unit_Len := Unit_Len + 1;
+ Str_Str (I) := Grt.Values.To_LC (Str_Str (I));
+ end loop;
+
+ Unit := Get_Primary_Unit (Expr_Type);
+ while Unit /= Null_Iir loop
+ Unit_Id := Get_Identifier (Unit);
+ exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len)
+ and then Image (Unit_Id) =
+ String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1));
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ if Unit = Null_Iir then
+ Error_Msg_Exec ("incorrect unit name", Expr);
+ end if;
+ Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit_Value (Unit)));
+
+ Str_Bnd.Dim_1.Length := Lit_End;
+ if Is_Real then
+ Res := Create_I64_Value
+ (Ghdl_I64
+ (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)
+ * Ghdl_F64 (Mult)));
+ else
+ Res := Create_I64_Value
+ (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)
+ * Mult);
+ end if;
+ end;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ declare
+ Lit_Start : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+ Enums : constant Iir_List :=
+ Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type));
+ Enum : Iir;
+ Enum_Id : Name_Id;
+ begin
+ -- Remove leading and trailing blanks
+ for I in Str_Str'Range loop
+ if not Grt.Values.Is_Whitespace (Str_Str (I)) then
+ Lit_Start := I;
+ exit;
+ end if;
+ end loop;
+ for I in reverse Lit_Start .. Str_Str'Last loop
+ if not Grt.Values.Is_Whitespace (Str_Str (I)) then
+ Lit_End := I;
+ exit;
+ end if;
+ end loop;
+
+ -- Convert to lower case.
+ for I in Lit_Start .. Lit_End loop
+ Str_Str (I) := Grt.Values.To_LC (Str_Str (I));
+ end loop;
+
+ for I in Natural loop
+ Enum := Get_Nth_Element (Enums, I);
+ if Enum = Null_Iir then
+ Error_Msg_Exec ("incorrect unit name", Expr);
+ end if;
+ Enum_Id := Get_Identifier (Enum);
+ exit when (Get_Name_Length (Enum_Id) =
+ Natural (Lit_End - Lit_Start + 1))
+ and then (Image (Enum_Id) =
+ String (Str_Str (Lit_Start .. Lit_End)));
+ end loop;
+
+ return Create_Enum_Value
+ (Natural (Get_Enum_Pos (Enum)), Expr_Type);
+ end;
+ when others =>
+ Error_Kind ("value_attribute", Expr_Type);
+ end case;
+ return Res;
+ end Execute_Value_Attribute;
+
+ function Execute_Path_Instance_Name_Attribute
+ (Block : Block_Instance_Acc; Attr : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ use Evaluation;
+ use Grt.Vstrings;
+ use Name_Table;
+
+ Name : constant Path_Instance_Name_Type :=
+ Get_Path_Instance_Name_Suffix (Attr);
+ Instance : Block_Instance_Acc;
+ Rstr : Rstring;
+ Is_Instance : constant Boolean :=
+ Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute;
+ begin
+ if Name.Path_Instance = Null_Iir then
+ return String_To_Iir_Value (Name.Suffix);
+ end if;
+
+ Instance := Get_Instance_By_Scope_Level
+ (Block, Get_Info (Name.Path_Instance).Frame_Scope_Level);
+
+ loop
+ case Get_Kind (Instance.Label) is
+ when Iir_Kind_Entity_Declaration =>
+ if Instance.Parent = null then
+ Prepend (Rstr, Image (Get_Identifier (Instance.Label)));
+ exit;
+ end if;
+ when Iir_Kind_Architecture_Body =>
+ if Is_Instance then
+ Prepend (Rstr, ')');
+ Prepend (Rstr, Image (Get_Identifier (Instance.Label)));
+ Prepend (Rstr, '(');
+ end if;
+
+ if Is_Instance or else Instance.Parent = null then
+ Prepend
+ (Rstr,
+ Image (Get_Identifier (Get_Entity (Instance.Label))));
+ end if;
+ if Instance.Parent = null then
+ Prepend (Rstr, ':');
+ exit;
+ else
+ Instance := Instance.Parent;
+ end if;
+ when Iir_Kind_Block_Statement =>
+ Prepend (Rstr, Image (Get_Label (Instance.Label)));
+ Prepend (Rstr, ':');
+ Instance := Instance.Parent;
+ when Iir_Kind_Iterator_Declaration =>
+ declare
+ Val : Iir_Value_Literal_Acc;
+ begin
+ Val := Execute_Name (Instance, Instance.Label);
+ Prepend (Rstr, ')');
+ Prepend (Rstr, Execute_Image_Attribute
+ (Val, Get_Type (Instance.Label)));
+ Prepend (Rstr, '(');
+ end;
+ Instance := Instance.Parent;
+ when Iir_Kind_Generate_Statement =>
+ Prepend (Rstr, Image (Get_Label (Instance.Label)));
+ Prepend (Rstr, ':');
+ Instance := Instance.Parent;
+ when Iir_Kind_Component_Instantiation_Statement =>
+ if Is_Instance then
+ Prepend (Rstr, '@');
+ end if;
+ Prepend (Rstr, Image (Get_Label (Instance.Label)));
+ Prepend (Rstr, ':');
+ Instance := Instance.Parent;
+ when others =>
+ Error_Kind ("Execute_Path_Instance_Name_Attribute",
+ Instance.Label);
+ end case;
+ end loop;
+ declare
+ Str1 : String (1 .. Length (Rstr));
+ Len1 : Natural;
+ begin
+ Copy (Rstr, Str1, Len1);
+ Free (Rstr);
+ return String_To_Iir_Value (Str1 & ':' & Name.Suffix);
+ end;
+ end Execute_Path_Instance_Name_Attribute;
+
+ -- For 'Last_Event and 'Last_Active: convert the absolute last time to
+ -- a relative delay.
+ function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is
+ A : Ghdl_I64;
+ begin
+ if T = -Ghdl_I64'Last then
+ A := Ghdl_I64'Last;
+ else
+ A := Ghdl_I64 (Grt.Types.Current_Time) - T;
+ end if;
+ return Create_I64_Value (A);
+ end To_Relative_Time;
+
+ -- Evaluate an expression.
+ function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Object_Alias_Declaration =>
+ Res := Execute_Name (Block, Expr);
+ return Res;
+
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Interface_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ return Execute_Name (Block, Expr);
+
+ when Iir_Kinds_Denoting_Name
+ | Iir_Kind_Attribute_Name =>
+ return Execute_Expression (Block, Get_Named_Entity (Expr));
+
+ when Iir_Kind_Aggregate =>
+ return Execute_Aggregate (Block, Expr, Get_Type (Expr));
+ when Iir_Kind_Simple_Aggregate =>
+ return Execute_Simple_Aggregate (Block, Expr);
+
+ when Iir_Kinds_Dyadic_Operator
+ | Iir_Kinds_Monadic_Operator =>
+ declare
+ Imp : Iir;
+ begin
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) = Iir_Kind_Function_Declaration then
+ return Execute_Function_Call (Block, Expr, Imp);
+ else
+ if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then
+ Res := Execute_Implicit_Function
+ (Block, Expr, Get_Left (Expr), Get_Right (Expr),
+ Get_Type (Expr));
+ else
+ Res := Execute_Implicit_Function
+ (Block, Expr, Get_Operand (Expr), Null_Iir,
+ Get_Type (Expr));
+ end if;
+ return Res;
+ end if;
+ end;
+
+ when Iir_Kind_Function_Call =>
+ declare
+ Imp : constant Iir :=
+ Get_Named_Entity (Get_Implementation (Expr));
+ Assoc : Iir;
+ Args : Iir_Array (0 .. 1);
+ begin
+ if Get_Kind (Imp) = Iir_Kind_Function_Declaration then
+ return Execute_Function_Call (Block, Expr, Imp);
+ else
+ Assoc := Get_Parameter_Association_Chain (Expr);
+ if Assoc /= Null_Iir then
+ Args (0) := Get_Actual (Assoc);
+ Assoc := Get_Chain (Assoc);
+ else
+ Args (0) := Null_Iir;
+ end if;
+ if Assoc /= Null_Iir then
+ Args (1) := Get_Actual (Assoc);
+ else
+ Args (1) := Null_Iir;
+ end if;
+ return Execute_Implicit_Function
+ (Block, Expr, Args (0), Args (1), Get_Type (Expr));
+ end if;
+ end;
+
+ when Iir_Kind_Integer_Literal =>
+ declare
+ Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr));
+ Lit : constant Iir_Int64 := Get_Value (Expr);
+ begin
+ case Get_Info (Lit_Type).Scalar_Mode is
+ when Iir_Value_I64 =>
+ return Create_I64_Value (Ghdl_I64 (Lit));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when Iir_Kind_Floating_Point_Literal =>
+ return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr)));
+
+ when Iir_Kind_Enumeration_Literal =>
+ declare
+ Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr));
+ Lit : constant Iir_Int32 := Get_Enum_Pos (Expr);
+ begin
+ case Get_Info (Lit_Type).Scalar_Mode is
+ when Iir_Value_B1 =>
+ return Create_B1_Value (Ghdl_B1'Val (Lit));
+ when Iir_Value_E32 =>
+ return Create_E32_Value (Ghdl_E32 (Lit));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Unit_Declaration =>
+ return Create_I64_Value
+ (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr)));
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return String_To_Enumeration_Array (Block, Expr);
+
+ when Iir_Kind_Null_Literal =>
+ return Null_Lit;
+
+ when Iir_Kind_Overflow_Literal =>
+ Error_Msg_Constraint (Expr);
+ return null;
+
+ when Iir_Kind_Parenthesis_Expression =>
+ return Execute_Expression (Block, Get_Expression (Expr));
+
+ when Iir_Kind_Type_Conversion =>
+ return Execute_Type_Conversion
+ (Block, Expr,
+ Execute_Expression (Block, Get_Expression (Expr)));
+
+ when Iir_Kind_Qualified_Expression =>
+ Res := Execute_Expression_With_Type
+ (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr)));
+ return Res;
+
+ when Iir_Kind_Allocator_By_Expression =>
+ Res := Execute_Expression (Block, Get_Expression (Expr));
+ Res := Unshare_Heap (Res);
+ return Create_Access_Value (Res);
+
+ when Iir_Kind_Allocator_By_Subtype =>
+ Res := Create_Value_For_Type
+ (Block,
+ Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)),
+ True);
+ Res := Unshare_Heap (Res);
+ return Create_Access_Value (Res);
+
+ when Iir_Kind_Left_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Left_Limit (Res);
+
+ when Iir_Kind_Right_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Right_Limit (Res);
+
+ when Iir_Kind_High_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_High_Limit (Res);
+
+ when Iir_Kind_Low_Type_Attribute =>
+ Res := Execute_Bounds (Block, Get_Prefix (Expr));
+ return Execute_Low_Limit (Res);
+
+ when Iir_Kind_High_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_High_Limit (Res);
+
+ when Iir_Kind_Low_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Low_Limit (Res);
+
+ when Iir_Kind_Left_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Left_Limit (Res);
+
+ when Iir_Kind_Right_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Right_Limit (Res);
+
+ when Iir_Kind_Length_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Execute_Length (Res);
+
+ when Iir_Kind_Ascending_Array_Attribute =>
+ Res := Execute_Indexes
+ (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr)));
+ return Boolean_To_Lit (Res.Dir = Iir_To);
+
+ when Iir_Kind_Event_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Event_Attribute (Res));
+
+ when Iir_Kind_Active_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Active_Attribute (Res));
+
+ when Iir_Kind_Driving_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Boolean_To_Lit (Execute_Driving_Attribute (Res));
+
+ when Iir_Kind_Last_Value_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Execute_Last_Value_Attribute (Res);
+
+ when Iir_Kind_Driving_Value_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return Execute_Driving_Value_Attribute (Res);
+
+ when Iir_Kind_Last_Event_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return To_Relative_Time (Execute_Last_Event_Attribute (Res));
+
+ when Iir_Kind_Last_Active_Attribute =>
+ Res := Execute_Name (Block, Get_Prefix (Expr), True);
+ return To_Relative_Time (Execute_Last_Active_Attribute (Res));
+
+ when Iir_Kind_Val_Attribute =>
+ declare
+ Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr));
+ Base_Type : constant Iir := Get_Base_Type (Prefix_Type);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ case Mode is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_E32 =>
+ Res := Create_E32_Value (Ghdl_E32 (Res.I64));
+ when Iir_Value_B1 =>
+ Res := Create_B1_Value (Ghdl_B1'Val (Res.I64));
+ when others =>
+ Error_Kind ("execute_expression(val attribute)",
+ Prefix_Type);
+ end case;
+ Check_Constraints (Block, Res, Prefix_Type, Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Pos_Attribute =>
+ declare
+ N_Res: Iir_Value_Literal_Acc;
+ Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr));
+ Base_Type : constant Iir := Get_Base_Type (Prefix_Type);
+ Mode : constant Iir_Value_Kind :=
+ Get_Info (Base_Type).Scalar_Mode;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ case Mode is
+ when Iir_Value_I64 =>
+ null;
+ when Iir_Value_B1 =>
+ N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1));
+ Res := N_Res;
+ when Iir_Value_E32 =>
+ N_Res := Create_I64_Value (Ghdl_I64 (Res.E32));
+ Res := N_Res;
+ when others =>
+ Error_Kind ("execute_expression(pos attribute)",
+ Base_Type);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Succ_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Res := Execute_Inc (Res, Expr);
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+
+ when Iir_Kind_Pred_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Res := Execute_Dec (Res, Expr);
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+
+ when Iir_Kind_Leftof_Attribute =>
+ declare
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Bound := Execute_Bounds
+ (Block, Get_Type (Get_Prefix (Expr)));
+ case Bound.Dir is
+ when Iir_To =>
+ Res := Execute_Dec (Res, Expr);
+ when Iir_Downto =>
+ Res := Execute_Inc (Res, Expr);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Rightof_Attribute =>
+ declare
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ Bound := Execute_Bounds
+ (Block, Get_Type (Get_Prefix (Expr)));
+ case Bound.Dir is
+ when Iir_Downto =>
+ Res := Execute_Dec (Res, Expr);
+ when Iir_To =>
+ Res := Execute_Inc (Res, Expr);
+ end case;
+ Check_Constraints (Block, Res, Get_Type (Expr), Expr);
+ return Res;
+ end;
+
+ when Iir_Kind_Image_Attribute =>
+ return Execute_Image_Attribute (Block, Expr);
+
+ when Iir_Kind_Value_Attribute =>
+ Res := Execute_Expression (Block, Get_Parameter (Expr));
+ return Execute_Value_Attribute (Block, Res, Expr);
+
+ when Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ return Execute_Path_Instance_Name_Attribute (Block, Expr);
+
+ when others =>
+ Error_Kind ("execute_expression", Expr);
+ end case;
+ end Execute_Expression;
+
+ procedure Execute_Dyadic_Association
+ (Out_Block: Block_Instance_Acc;
+ In_Block: Block_Instance_Acc;
+ Expr : Iir;
+ Inter_Chain: Iir)
+ is
+ Inter: Iir;
+ Val: Iir_Value_Literal_Acc;
+ begin
+ Inter := Inter_Chain;
+ for I in 0 .. 1 loop
+ if I = 0 then
+ Val := Execute_Expression (Out_Block, Get_Left (Expr));
+ else
+ Val := Execute_Expression (Out_Block, Get_Right (Expr));
+ end if;
+ Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr);
+ Check_Constraints (In_Block, Val, Get_Type (Inter), Expr);
+
+ Elaboration.Create_Object (In_Block, Inter);
+ In_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Execute_Dyadic_Association;
+
+ procedure Execute_Monadic_Association
+ (Out_Block: Block_Instance_Acc;
+ In_Block: Block_Instance_Acc;
+ Expr : Iir;
+ Inter: Iir)
+ is
+ Val: Iir_Value_Literal_Acc;
+ begin
+ Val := Execute_Expression (Out_Block, Get_Operand (Expr));
+ Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr);
+ Check_Constraints (In_Block, Val, Get_Type (Inter), Expr);
+
+ Elaboration.Create_Object (In_Block, Inter);
+ In_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ end Execute_Monadic_Association;
+
+ -- Create a block instance for subprogram IMP.
+ function Create_Subprogram_Instance (Instance : Block_Instance_Acc;
+ Imp : Iir)
+ return Block_Instance_Acc
+ is
+ Func_Info : constant Sim_Info_Acc := Get_Info (Imp);
+
+ subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects);
+ function To_Block_Instance_Acc is new
+ Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc);
+ function Alloc_Block_Instance is new
+ Alloc_On_Pool_Addr (Block_Type);
+
+ Up_Block: Block_Instance_Acc;
+ Res : Block_Instance_Acc;
+ begin
+ Up_Block := Get_Instance_By_Scope_Level
+ (Instance, Func_Info.Frame_Scope_Level - 1);
+
+ Res := To_Block_Instance_Acc
+ (Alloc_Block_Instance
+ (Instance_Pool,
+ Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects,
+ Scope_Level => Func_Info.Frame_Scope_Level,
+ Up_Block => Up_Block,
+ Label => Imp,
+ Stmt => Null_Iir,
+ Parent => Instance,
+ Children => null,
+ Brother => null,
+ Marker => Empty_Marker,
+ Objects => (others => null),
+ Elab_Objects => 0,
+ In_Wait_Flag => False,
+ Actuals_Ref => null,
+ Result => null)));
+ return Res;
+ end Create_Subprogram_Instance;
+
+ -- Destroy a dynamic block_instance.
+ procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc)
+ is
+ Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label);
+ begin
+ Finalize_Declarative_Part
+ (Instance, Get_Declaration_Chain (Subprg_Body));
+ end Execute_Subprogram_Call_Final;
+
+ function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Subprg_Body : constant Iir := Get_Subprogram_Body (Func);
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Current_Process.Instance := Instance;
+
+ Elaborate_Declarative_Part
+ (Instance, Get_Declaration_Chain (Subprg_Body));
+
+ -- execute statements
+ Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body);
+ Execute_Sequential_Statements (Current_Process);
+ pragma Assert (Current_Process.Instance = Instance);
+
+ if Instance.Result = null then
+ Error_Msg_Exec
+ ("function scope exited without a return statement", Func);
+ end if;
+
+ -- Free variables, slots...
+ -- Need to copy the return value, because it can contains values from
+ -- arguments.
+ Res := Instance.Result;
+
+ Current_Process.Instance := Instance.Parent;
+ Execute_Subprogram_Call_Final (Instance);
+
+ return Res;
+ end Execute_Function_Body;
+
+ function Execute_Assoc_Function_Conversion
+ (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Inter : Iir;
+ Instance : Block_Instance_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Instance_Pool.all);
+
+ -- Create an instance for this function.
+ Instance := Create_Subprogram_Instance (Block, Func);
+
+ Inter := Get_Interface_Declaration_Chain (Func);
+ Elaboration.Create_Object (Instance, Inter);
+ -- FIXME: implicit conversion
+ Instance.Objects (Get_Info (Inter).Slot) := Val;
+
+ Res := Execute_Function_Body (Instance, Func);
+ Res := Unshare (Res, Expr_Pool'Access);
+ Release (Marker, Instance_Pool.all);
+ return Res;
+ end Execute_Assoc_Function_Conversion;
+
+ function Execute_Assoc_Conversion
+ (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Ent : Iir;
+ begin
+ case Get_Kind (Conv) is
+ when Iir_Kind_Function_Call =>
+ -- FIXME: shouldn't CONV always be a denoting_name ?
+ return Execute_Assoc_Function_Conversion
+ (Block, Get_Named_Entity (Get_Implementation (Conv)), Val);
+ when Iir_Kind_Type_Conversion =>
+ -- FIXME: shouldn't CONV always be a denoting_name ?
+ return Execute_Type_Conversion (Block, Conv, Val);
+ when Iir_Kinds_Denoting_Name =>
+ Ent := Get_Named_Entity (Conv);
+ if Get_Kind (Ent) = Iir_Kind_Function_Declaration then
+ return Execute_Assoc_Function_Conversion (Block, Ent, Val);
+ elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then
+ return Execute_Type_Conversion (Block, Ent, Val);
+ else
+ Error_Kind ("execute_assoc_conversion(1)", Ent);
+ end if;
+ when others =>
+ Error_Kind ("execute_assoc_conversion(2)", Conv);
+ end case;
+ end Execute_Assoc_Conversion;
+
+ -- Establish correspondance for association list ASSOC_LIST from block
+ -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK.
+ procedure Execute_Association
+ (Out_Block: Block_Instance_Acc;
+ Subprg_Block: Block_Instance_Acc;
+ Assoc_Chain: Iir)
+ is
+ Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain);
+ Assoc: Iir;
+ Actual : Iir;
+ Inter: Iir;
+ Formal : Iir;
+ Conv : Iir;
+ Val: Iir_Value_Literal_Acc;
+ Assoc_Idx : Iir_Index32;
+ Last_Individual : Iir_Value_Literal_Acc;
+ Mode : Iir_Mode;
+ Marker : Mark_Type;
+ begin
+ Subprg_Block.Actuals_Ref := null;
+ Mark (Marker, Expr_Pool);
+
+ Assoc := Assoc_Chain;
+ Assoc_Idx := 1;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ Inter := Get_Association_Interface (Assoc);
+
+ -- Extract the actual value.
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ -- Not allowed in individual association.
+ pragma Assert (Formal = Inter);
+ pragma Assert (Get_Whole_Association_Flag (Assoc));
+ Actual := Get_Default_Value (Inter);
+ when Iir_Kind_Association_Element_By_Expression =>
+ Actual := Get_Actual (Assoc);
+ when Iir_Kind_Association_Element_By_Individual =>
+ -- FIXME: signals ?
+ pragma Assert
+ (Get_Kind (Inter) /= Iir_Kind_Signal_Interface_Declaration);
+ Last_Individual := Create_Value_For_Type
+ (Out_Block, Get_Actual_Type (Assoc), False);
+ Last_Individual := Unshare (Last_Individual, Instance_Pool);
+
+ Elaboration.Create_Object (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual;
+ goto Continue;
+ when others =>
+ Error_Kind ("execute_association(1)", Assoc);
+ end case;
+
+ -- Compute actual value.
+ case Get_Kind (Inter) is
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ Val := Execute_Expression (Out_Block, Actual);
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Val := Execute_Name (Out_Block, Actual, True);
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+ when Iir_Kind_Variable_Interface_Declaration =>
+ Mode := Get_Mode (Inter);
+ if Mode = Iir_In_Mode then
+ -- FIXME: Ref ?
+ Val := Execute_Expression (Out_Block, Actual);
+ else
+ Val := Execute_Name (Out_Block, Actual, False);
+ end if;
+
+ -- FIXME: by value for scalars ?
+
+ -- Keep ref for back-copy
+ if Mode /= Iir_In_Mode then
+ if Subprg_Block.Actuals_Ref = null then
+ declare
+ subtype Actuals_Ref_Type is
+ Value_Array (Iir_Index32 (Nbr_Assoc));
+ function To_Value_Array_Acc is new
+ Ada.Unchecked_Conversion (System.Address,
+ Value_Array_Acc);
+ function Alloc_Actuals_Ref is new
+ Alloc_On_Pool_Addr (Actuals_Ref_Type);
+
+ begin
+ Subprg_Block.Actuals_Ref := To_Value_Array_Acc
+ (Alloc_Actuals_Ref
+ (Instance_Pool,
+ Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc),
+ V => (others => null))));
+ end;
+ end if;
+ Subprg_Block.Actuals_Ref.V (Assoc_Idx) :=
+ Unshare_Bounds (Val, Instance_Pool);
+ end if;
+
+ if Mode = Iir_Out_Mode then
+ if Get_Out_Conversion (Assoc) /= Null_Iir then
+ -- For an OUT variable using an out conversion, don't
+ -- associate with the actual, create a temporary value.
+ Val := Create_Value_For_Type
+ (Out_Block, Get_Type (Formal), True);
+ elsif Get_Kind (Get_Type (Formal)) in
+ Iir_Kinds_Scalar_Type_Definition
+ then
+ -- These are passed by value. Must be reset.
+ Val := Create_Value_For_Type
+ (Out_Block, Get_Type (Formal), True);
+ end if;
+ else
+ if Get_Kind (Assoc) =
+ Iir_Kind_Association_Element_By_Expression
+ then
+ Conv := Get_In_Conversion (Assoc);
+ if Conv /= Null_Iir then
+ Val := Execute_Assoc_Conversion
+ (Subprg_Block, Conv, Val);
+ end if;
+ end if;
+
+ -- FIXME: check constraints ?
+ end if;
+
+ Implicit_Array_Conversion
+ (Subprg_Block, Val, Get_Type (Formal), Assoc);
+
+ when others =>
+ Error_Kind ("execute_association(2)", Inter);
+ end case;
+
+ if Get_Whole_Association_Flag (Assoc) then
+ case Get_Kind (Inter) is
+ when Iir_Kind_Constant_Interface_Declaration
+ | Iir_Kind_Variable_Interface_Declaration
+ | Iir_Kind_File_Interface_Declaration =>
+ -- FIXME: Arguments are passed by copy.
+ Elaboration.Create_Object (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare (Val, Instance_Pool);
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Elaboration.Create_Signal (Subprg_Block, Inter);
+ Subprg_Block.Objects (Get_Info (Inter).Slot) :=
+ Unshare_Bounds (Val, Instance_Pool);
+ when others =>
+ Error_Kind ("execute_association", Inter);
+ end case;
+ else
+ declare
+ Targ : Iir_Value_Literal_Acc;
+ Is_Sig : Boolean;
+ begin
+ Execute_Name_With_Base
+ (Subprg_Block, Formal, Last_Individual, Targ, Is_Sig);
+ Store (Targ, Val);
+ end;
+ end if;
+
+ << Continue >> null;
+ Assoc := Get_Chain (Assoc);
+ Assoc_Idx := Assoc_Idx + 1;
+ end loop;
+
+ Release (Marker, Expr_Pool);
+ end Execute_Association;
+
+ procedure Execute_Back_Association (Instance : Block_Instance_Acc)
+ is
+ Proc : Iir;
+ Assoc: Iir;
+ Inter: Iir;
+ Formal : Iir;
+ Assoc_Idx : Iir_Index32;
+ begin
+ Proc := Get_Procedure_Call (Instance.Parent.Stmt);
+ Assoc := Get_Parameter_Association_Chain (Proc);
+ Assoc_Idx := 1;
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then
+ Formal := Get_Formal (Assoc);
+ Inter := Get_Association_Interface (Assoc);
+ case Get_Kind (Inter) is
+ when Iir_Kind_Variable_Interface_Declaration =>
+ if Get_Mode (Inter) /= Iir_In_Mode
+ and then Get_Kind (Get_Type (Inter)) /=
+ Iir_Kind_File_Type_Definition
+ then
+ -- For out/inout variable interface, the value must
+ -- be copied (FIXME: unless when passed by reference ?).
+ declare
+ Targ : constant Iir_Value_Literal_Acc :=
+ Instance.Actuals_Ref.V (Assoc_Idx);
+ Base : constant Iir_Value_Literal_Acc :=
+ Instance.Objects (Get_Info (Inter).Slot);
+ Val : Iir_Value_Literal_Acc;
+ Conv : Iir;
+ Is_Sig : Boolean;
+ Expr_Mark : Mark_Type;
+ begin
+ Mark (Expr_Mark, Expr_Pool);
+
+ -- Extract for individual association.
+ Execute_Name_With_Base
+ (Instance, Formal, Base, Val, Is_Sig);
+ Conv := Get_Out_Conversion (Assoc);
+ if Conv /= Null_Iir then
+ Val := Execute_Assoc_Conversion
+ (Instance, Conv, Val);
+ -- FIXME: free val ?
+ end if;
+ Store (Targ, Val);
+
+ Release (Expr_Mark, Expr_Pool);
+ end;
+ end if;
+ when Iir_Kind_File_Interface_Declaration =>
+ null;
+ when Iir_Kind_Signal_Interface_Declaration
+ | Iir_Kind_Constant_Interface_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("execute_back_association", Inter);
+ end case;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ Assoc_Idx := Assoc_Idx + 1;
+ end loop;
+ end Execute_Back_Association;
+
+ -- When a subprogram of a protected type is called, a link to the object
+ -- must be passed. This procedure modifies the up_link of SUBPRG_BLOCK to
+ -- point to the block of the object (extracted from CALL and BLOCK).
+ -- This change doesn't modify the parent (so that the activation chain is
+ -- not changed).
+ procedure Adjust_Up_Link_For_Protected_Object
+ (Block: Block_Instance_Acc; Call: Iir; Subprg_Block : Block_Instance_Acc)
+ is
+ Meth_Obj : constant Iir := Get_Method_Object (Call);
+ Obj : Iir_Value_Literal_Acc;
+ Obj_Block : Block_Instance_Acc;
+ begin
+ if Meth_Obj /= Null_Iir then
+ Obj := Execute_Name (Block, Meth_Obj, True);
+ Obj_Block := Protected_Table.Table (Obj.Prot);
+ Subprg_Block.Up_Block := Obj_Block;
+ end if;
+ end Adjust_Up_Link_For_Protected_Object;
+
+ function Execute_Foreign_Function_Call
+ (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ pragma Unreferenced (Block);
+ begin
+ case Get_Identifier (Imp) is
+ when Std_Names.Name_Get_Resolution_Limit =>
+ return Create_I64_Value
+ (Ghdl_I64
+ (Evaluation.Get_Physical_Value (Std_Package.Time_Base)));
+ when others =>
+ Error_Msg_Exec ("unsupported foreign function call", Expr);
+ end case;
+ return null;
+ end Execute_Foreign_Function_Call;
+
+ -- BLOCK is the block instance in which the function call appears.
+ function Execute_Function_Call
+ (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir)
+ return Iir_Value_Literal_Acc
+ is
+ Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp);
+ Subprg_Block: Block_Instance_Acc;
+ Assoc_Chain: Iir;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Mark (Block.Marker, Instance_Pool.all);
+
+ Subprg_Block := Create_Subprogram_Instance (Block, Imp);
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Function_Call =>
+ Adjust_Up_Link_For_Protected_Object (Block, Expr, Subprg_Block);
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ Execute_Association (Block, Subprg_Block, Assoc_Chain);
+ -- No out/inout interface for functions.
+ pragma Assert (Subprg_Block.Actuals_Ref = null);
+ when Iir_Kinds_Dyadic_Operator =>
+ Execute_Dyadic_Association
+ (Block, Subprg_Block, Expr, Inter_Chain);
+ when Iir_Kinds_Monadic_Operator =>
+ Execute_Monadic_Association
+ (Block, Subprg_Block, Expr, Inter_Chain);
+ when others =>
+ Error_Kind ("execute_subprogram_call_init", Expr);
+ end case;
+
+ if Get_Foreign_Flag (Imp) then
+ Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp);
+ else
+ Res := Execute_Function_Body (Subprg_Block, Imp);
+ end if;
+
+ -- Unfortunately, we don't know where the result has been allocated,
+ -- so copy it before releasing the instance pool.
+ Res := Unshare (Res, Expr_Pool'Access);
+
+ Release (Block.Marker, Instance_Pool.all);
+
+ return Res;
+ end Execute_Function_Call;
+
+ -- Slide an array VALUE using bounds from REF_VALUE. Do not modify
+ -- VALUE if not an array.
+ procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc;
+ Ref_Value : Iir_Value_Literal_Acc;
+ Expr : Iir)
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ if Value.Kind /= Iir_Value_Array then
+ return;
+ end if;
+ Res := Create_Array_Value (Value.Bounds.Nbr_Dims);
+ Res.Val_Array := Value.Val_Array;
+ for I in Value.Bounds.D'Range loop
+ if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ Res.Bounds.D (I) := Ref_Value.Bounds.D (I);
+ end loop;
+ Value := Res;
+ end Implicit_Array_Conversion;
+
+ procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc;
+ Value : in out Iir_Value_Literal_Acc;
+ Ref_Type : Iir;
+ Expr : Iir)
+ is
+ Ref_Value : Iir_Value_Literal_Acc;
+ begin
+ -- Do array conversion only if REF_TYPE is a constrained array type
+ -- definition.
+ if Value.Kind /= Iir_Value_Array then
+ return;
+ end if;
+ if Get_Constraint_State (Ref_Type) /= Fully_Constrained then
+ return;
+ end if;
+ Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True);
+ for I in Value.Bounds.D'Range loop
+ if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ end loop;
+ Ref_Value.Val_Array.V := Value.Val_Array.V;
+ Value := Ref_Value;
+ end Implicit_Array_Conversion;
+
+ procedure Check_Array_Constraints
+ (Instance: Block_Instance_Acc;
+ Value: Iir_Value_Literal_Acc;
+ Def: Iir;
+ Expr: Iir)
+ is
+ Index_List: Iir_List;
+ Element_Subtype: Iir;
+ New_Bounds : Iir_Value_Literal_Acc;
+ begin
+ -- Nothing to check for unconstrained arrays.
+ if not Get_Index_Constraint_Flag (Def) then
+ return;
+ end if;
+
+ Index_List := Get_Index_Subtype_List (Def);
+ for I in Value.Bounds.D'Range loop
+ New_Bounds := Execute_Bounds
+ (Instance, Get_Nth_Element (Index_List, Natural (I - 1)));
+ if not Is_Equal (Value.Bounds.D (I), New_Bounds) then
+ Error_Msg_Constraint (Expr);
+ return;
+ end if;
+ end loop;
+
+ if Boolean'(False) then
+ Index_List := Get_Index_List (Def);
+ Element_Subtype := Get_Element_Subtype (Def);
+ for I in Value.Val_Array.V'Range loop
+ Check_Constraints
+ (Instance, Value.Val_Array.V (I), Element_Subtype, Expr);
+ end loop;
+ end if;
+ end Check_Array_Constraints;
+
+ -- Check DEST and SRC are array compatible.
+ procedure Check_Array_Match
+ (Instance: Block_Instance_Acc;
+ Dest: Iir_Value_Literal_Acc;
+ Src : Iir_Value_Literal_Acc;
+ Expr: Iir)
+ is
+ pragma Unreferenced (Instance);
+ begin
+ for I in Dest.Bounds.D'Range loop
+ if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then
+ Error_Msg_Constraint (Expr);
+ exit;
+ end if;
+ end loop;
+ end Check_Array_Match;
+ pragma Unreferenced (Check_Array_Match);
+
+ procedure Check_Constraints
+ (Instance: Block_Instance_Acc;
+ Value: Iir_Value_Literal_Acc;
+ Def: Iir;
+ Expr: Iir)
+ is
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ High, Low: Iir_Value_Literal_Acc;
+ Bound : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ Bound := Execute_Bounds (Instance, Def);
+ if Bound.Dir = Iir_To then
+ High := Bound.Right;
+ Low := Bound.Left;
+ else
+ High := Bound.Left;
+ Low := Bound.Right;
+ end if;
+ case Get_Info (Base_Type).Scalar_Mode is
+ when Iir_Value_I64 =>
+ if Value.I64 in Low.I64 .. High.I64 then
+ return;
+ end if;
+ when Iir_Value_E32 =>
+ if Value.E32 in Low.E32 .. High.E32 then
+ return;
+ end if;
+ when Iir_Value_F64 =>
+ if Value.F64 in Low.F64 .. High.F64 then
+ return;
+ end if;
+ when Iir_Value_B1 =>
+ if Value.B1 in Low.B1 .. High.B1 then
+ return;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ Check_Array_Constraints (Instance, Value, Def, Expr);
+ return;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El: Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Check_Constraints
+ (Instance,
+ Value.Val_Record.V (Get_Element_Position (El) + 1),
+ Get_Type (El),
+ Expr);
+ end loop;
+ end;
+ return;
+ when Iir_Kind_Integer_Type_Definition =>
+ return;
+ when Iir_Kind_Floating_Type_Definition =>
+ return;
+ when Iir_Kind_Physical_Type_Definition =>
+ return;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ return;
+ when Iir_Kind_File_Type_Definition =>
+ return;
+ when others =>
+ Error_Kind ("check_constraints", Def);
+ end case;
+ Error_Msg_Constraint (Expr);
+ end Check_Constraints;
+
+ function Execute_Resolution_Function
+ (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Inter : Iir;
+ Instance : Block_Instance_Acc;
+ begin
+ -- Create a frame for this function.
+ Instance := Create_Subprogram_Instance (Block, Imp);
+
+ Inter := Get_Interface_Declaration_Chain (Imp);
+ Elaboration.Create_Object (Instance, Inter);
+ Instance.Objects (Get_Info (Inter).Slot) := Arr;
+
+ return Execute_Function_Body (Instance, Imp);
+ end Execute_Resolution_Function;
+
+ procedure Execute_Signal_Assignment
+ (Instance: Block_Instance_Acc;
+ Stmt: Iir_Signal_Assignment_Statement)
+ is
+ Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt);
+ Nbr_We : constant Natural := Get_Chain_Length (Wf);
+
+ Transactions : Transaction_Type (Nbr_We);
+
+ We: Iir_Waveform_Element;
+ Res: Iir_Value_Literal_Acc;
+ Rdest: Iir_Value_Literal_Acc;
+ Targ_Type : Iir;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+
+ Rdest := Execute_Name (Instance, Get_Target (Stmt), True);
+ Targ_Type := Get_Type (Get_Target (Stmt));
+
+ -- Disconnection statement.
+ if Wf = Null_Iir then
+ Disconnect_Signal (Rdest);
+ Release (Marker, Expr_Pool);
+ return;
+ end if;
+
+ Transactions.Stmt := Stmt;
+
+ -- LRM93 8.4.1
+ -- Evaluation of a waveform consists of the evaluation of each waveform
+ -- elements in the waveform.
+ We := Wf;
+ for I in Transactions.Els'Range loop
+ declare
+ Trans : Transaction_El_Type renames Transactions.Els (I);
+ begin
+ if Get_Time (We) /= Null_Iir then
+ Res := Execute_Expression (Instance, Get_Time (We));
+ -- LRM93 8.4.1
+ -- It is an error if the time expression in a waveform element
+ -- evaluates to a negative value.
+ if Res.I64 < 0 then
+ Error_Msg_Exec ("time value is negative", Get_Time (We));
+ end if;
+ Trans.After := Std_Time (Res.I64);
+ else
+ -- LRM93 8.4.1
+ -- If the after clause of a waveform element is not present,
+ -- then an implicit "after 0 ns" is assumed.
+ Trans.After := 0;
+ end if;
+
+ -- LRM93 8.4.1
+ -- It is an error if the sequence of new transactions is not in
+ -- ascending order with respect to time.
+ if I > 1
+ and then Trans.After <= Transactions.Els (I - 1).After
+ then
+ Error_Msg_Exec
+ ("sequence not in ascending order with respect to time", We);
+ end if;
+
+ if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then
+ -- null transaction.
+ Trans.Value := null;
+ else
+ -- LRM93 8.4.1
+ -- For the first form of waveform element, the value component
+ -- of the transaction is determined by the value expression in
+ -- the waveform element.
+ Trans.Value := Execute_Expression_With_Type
+ (Instance, Get_We_Value (We), Targ_Type);
+ end if;
+ end;
+ We := Get_Chain (We);
+ end loop;
+ pragma Assert (We = Null_Iir);
+
+ case Get_Delay_Mechanism (Stmt) is
+ when Iir_Transport_Delay =>
+ Transactions.Reject := 0;
+ when Iir_Inertial_Delay =>
+ -- LRM93 8.4
+ -- or, in the case that a pulse rejection limit is specified,
+ -- a pulse whose duration is shorter than that limit will not
+ -- be transmitted.
+ -- Every inertially delayed signal assignment has a pulse
+ -- rejection limit.
+ if Get_Reject_Time_Expression (Stmt) /= Null_Iir then
+ -- LRM93 8.4
+ -- If the delay mechanism specifies inertial delay, and if the
+ -- reserved word reject followed by a time expression is
+ -- present, then the time expression specifies the pulse
+ -- rejection limit.
+ Res := Execute_Expression
+ (Instance, Get_Reject_Time_Expression (Stmt));
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any
+ -- inertially delayed signal assignement statement is either
+ -- negative ...
+ if Res.I64 < 0 then
+ Error_Msg_Exec ("reject time negative", Stmt);
+ end if;
+ -- LRM93 8.4
+ -- ... or greather than the time expression associated with
+ -- the first waveform element.
+ Transactions.Reject := Std_Time (Res.I64);
+ if Transactions.Reject > Transactions.Els (1).After then
+ Error_Msg_Exec
+ ("reject time greather than time expression", Stmt);
+ end if;
+ else
+ -- LRM93 8.4
+ -- In all other cases, the pulse rejection limit is the time
+ -- expression associated ith the first waveform element.
+ Transactions.Reject := Transactions.Els (1).After;
+ end if;
+ end case;
+
+ -- FIXME: slice Transactions to remove transactions after end of time.
+ Assign_Value_To_Signal (Instance, Rdest, Transactions);
+
+ Release (Marker, Expr_Pool);
+ end Execute_Signal_Assignment;
+
+ procedure Assign_Simple_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Dest: Iir_Value_Literal_Acc;
+ Dest_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ begin
+ if Dest.Kind /= Value.Kind then
+ raise Internal_Error; -- literal kind mismatch.
+ end if;
+
+ Check_Constraints (Instance, Value, Dest_Type, Stmt);
+
+ Store (Dest, Value);
+ end Assign_Simple_Value_To_Object;
+
+ procedure Assign_Array_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Depth: Natural;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ Element_Type: Iir;
+ begin
+ if Target.Val_Array.Len /= Value.Val_Array.Len then
+ -- Dimension mismatch.
+ raise Program_Error;
+ end if;
+ if Depth = Get_Nbr_Elements (Get_Index_List (Target_Type)) then
+ Element_Type := Get_Element_Subtype (Target_Type);
+ for I in Target.Val_Array.V'Range loop
+ Assign_Value_To_Object (Instance,
+ Target.Val_Array.V (I),
+ Element_Type,
+ Value.Val_Array.V (I),
+ Stmt);
+ end loop;
+ else
+ for I in Target.Val_Array.V'Range loop
+ Assign_Array_Value_To_Object (Instance,
+ Target.Val_Array.V (I),
+ Target_Type,
+ Depth + 1,
+ Value.Val_Array.V (I),
+ Stmt);
+ end loop;
+ end if;
+ end Assign_Array_Value_To_Object;
+
+ procedure Assign_Record_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ Element_Type: Iir;
+ List : Iir_List;
+ Element: Iir_Element_Declaration;
+ Pos : Iir_Index32;
+ begin
+ if Target.Val_Record.Len /= Value.Val_Record.Len then
+ -- Dimension mismatch.
+ raise Program_Error;
+ end if;
+ List := Get_Elements_Declaration_List (Target_Type);
+ for I in Natural loop
+ Element := Get_Nth_Element (List, I);
+ exit when Element = Null_Iir;
+ Element_Type := Get_Type (Element);
+ Pos := Get_Element_Position (Element);
+ Assign_Value_To_Object (Instance,
+ Target.Val_Record.V (1 + Pos),
+ Element_Type,
+ Value.Val_Record.V (1 + Pos),
+ Stmt);
+ end loop;
+ end Assign_Record_Value_To_Object;
+
+ procedure Assign_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir)
+ is
+ begin
+ case Target.Kind is
+ when Iir_Value_Array =>
+ Assign_Array_Value_To_Object
+ (Instance, Target, Target_Type, 1, Value, Stmt);
+ when Iir_Value_Record =>
+ Assign_Record_Value_To_Object
+ (Instance, Target, Target_Type, Value, Stmt);
+ when Iir_Value_Scalars
+ | Iir_Value_Access =>
+ Assign_Simple_Value_To_Object
+ (Instance, Target, Target_Type, Value, Stmt);
+ when Iir_Value_File
+ | Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Range
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Assign_Value_To_Object;
+
+ -- Display a message when an assertion has failed.
+ -- REPORT is the value (string) to display, or null to use default message.
+ -- SEVERITY is the severity or null to use default (error).
+ -- STMT is used to display location.
+ procedure Execute_Failed_Assertion (Report : String;
+ Severity : Natural;
+ Stmt: Iir) is
+ begin
+ -- LRM93 8.2
+ -- The error message consists of at least:
+
+ -- 4: name of the design unit containing the assertion.
+ Disp_Iir_Location (Stmt);
+
+ -- 1: an indication that this message is from an assertion.
+ Put (Standard_Error, "(assertion ");
+
+ -- 2: the value of the severity level.
+ case Severity is
+ when 0 =>
+ Put (Standard_Error, "note");
+ when 1 =>
+ Put (Standard_Error, "warning");
+ when 2 =>
+ Put (Standard_Error, "error");
+ when 3 =>
+ Put (Standard_Error, "failure");
+ when others =>
+ Error_Internal (Null_Iir, "execute_failed_assertion");
+ end case;
+ if Disp_Time_Before_Values then
+ Put (Standard_Error, " at ");
+ Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time);
+ end if;
+ Put (Standard_Error, "): ");
+
+ -- 3: the value of the message string.
+ Put_Line (Standard_Error, Report);
+
+ -- Stop execution if the severity is too high.
+ if Severity >= Grt.Options.Severity_Level then
+ Debug (Reason_Assert);
+ Grt.Errors.Fatal_Error;
+ end if;
+ end Execute_Failed_Assertion;
+
+ procedure Execute_Failed_Assertion (Report : Iir_Value_Literal_Acc;
+ Severity : Natural;
+ Stmt: Iir) is
+ begin
+ if Report /= null then
+ declare
+ Msg : String (1 .. Natural (Report.Val_Array.Len));
+ begin
+ for I in Report.Val_Array.V'Range loop
+ Msg (Positive (I)) :=
+ Character'Val (Report.Val_Array.V (I).E32);
+ end loop;
+ Execute_Failed_Assertion (Msg, Severity, Stmt);
+ end;
+ else
+ -- The default value for the message string is:
+ -- "Assertion violation.".
+ -- Does the message string include quotes ?
+ Execute_Failed_Assertion ("Assertion violation.", Severity, Stmt);
+ end if;
+ end Execute_Failed_Assertion;
+
+ procedure Execute_Report_Statement
+ (Instance: Block_Instance_Acc; Stmt: Iir; Default_Severity : Natural)
+ is
+ Expr: Iir;
+ Report, Severity_Lit: Iir_Value_Literal_Acc;
+ Severity : Natural;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+ Expr := Get_Report_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Report := Execute_Expression (Instance, Expr);
+ else
+ Report := null;
+ end if;
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Severity_Lit := Execute_Expression (Instance, Expr);
+ Severity := Natural'Val (Severity_Lit.E32);
+ else
+ Severity := Default_Severity;
+ end if;
+ Execute_Failed_Assertion (Report, Severity, Stmt);
+ Release (Marker, Expr_Pool);
+ end Execute_Report_Statement;
+
+ function Is_In_Choice
+ (Instance: Block_Instance_Acc;
+ Choice: Iir;
+ Expr: Iir_Value_Literal_Acc)
+ return Boolean
+ is
+ Res : Boolean;
+ begin
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ return True;
+ when Iir_Kind_Choice_By_Expression =>
+ declare
+ Expr1: Iir_Value_Literal_Acc;
+ begin
+ Expr1 := Execute_Expression
+ (Instance, Get_Choice_Expression (Choice));
+ Res := Is_Equal (Expr, Expr1);
+ return Res;
+ end;
+ when Iir_Kind_Choice_By_Range =>
+ declare
+ A_Range : Iir_Value_Literal_Acc;
+ begin
+ A_Range := Execute_Bounds
+ (Instance, Get_Choice_Range (Choice));
+ Res := Is_In_Range (Expr, A_Range);
+ end;
+ return Res;
+ when others =>
+ Error_Kind ("is_in_choice", Choice);
+ end case;
+ end Is_In_Choice;
+
+ -- Return TRUE iff VAL is in the range defined by BOUNDS.
+ function Is_In_Range (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc)
+ return Boolean
+ is
+ Max, Min : Iir_Value_Literal_Acc;
+ begin
+ case Bounds.Dir is
+ when Iir_To =>
+ Min := Bounds.Left;
+ Max := Bounds.Right;
+ when Iir_Downto =>
+ Min := Bounds.Right;
+ Max := Bounds.Left;
+ end case;
+
+ case Val.Kind is
+ when Iir_Value_E32 =>
+ return Val.E32 >= Min.E32 and Val.E32 <= Max.E32;
+ when Iir_Value_B1 =>
+ return Val.B1 >= Min.B1 and Val.B1 <= Max.B1;
+ when Iir_Value_I64 =>
+ return Val.I64 >= Min.I64 and Val.I64 <= Max.I64;
+ when others =>
+ raise Internal_Error;
+ return False;
+ end case;
+ end Is_In_Range;
+
+ -- Increment or decrement VAL according to BOUNDS.DIR.
+ -- FIXME: use increment ?
+ procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc)
+ is
+ begin
+ case Val.Kind is
+ when Iir_Value_E32 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.E32 := Val.E32 + 1;
+ when Iir_Downto =>
+ Val.E32 := Val.E32 - 1;
+ end case;
+ when Iir_Value_B1 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.B1 := True;
+ when Iir_Downto =>
+ Val.B1 := False;
+ end case;
+ when Iir_Value_I64 =>
+ case Bounds.Dir is
+ when Iir_To =>
+ Val.I64 := Val.I64 + 1;
+ when Iir_Downto =>
+ Val.I64 := Val.I64 - 1;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Update_Loop_Index;
+
+ procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc;
+ Stmt : Iir)
+ is
+ begin
+ Destroy_Iterator_Declaration
+ (Instance, Get_Parameter_Specification (Stmt));
+ end Finalize_For_Loop_Statement;
+
+ procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc;
+ Stmt : Iir)
+ is
+ begin
+ if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then
+ Finalize_For_Loop_Statement (Instance, Stmt);
+ end if;
+ end Finalize_Loop_Statement;
+
+ procedure Execute_For_Loop_Statement (Proc : Process_State_Acc)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir_For_Loop_Statement := Instance.Stmt;
+ Iterator : constant Iir := Get_Parameter_Specification (Stmt);
+ Bounds : Iir_Value_Literal_Acc;
+ Index : Iir_Value_Literal_Acc;
+ Stmt_Chain : Iir;
+ Is_Nul : Boolean;
+ Marker : Mark_Type;
+ begin
+ -- Elaborate the iterator (and its type).
+ Elaborate_Declaration (Instance, Iterator);
+
+ -- Extract bounds.
+ Mark (Marker, Expr_Pool);
+ Bounds := Execute_Bounds (Instance, Get_Type (Iterator));
+ Index := Instance.Objects (Get_Info (Iterator).Slot);
+ Store (Index, Bounds.Left);
+ Is_Nul := Is_Nul_Range (Bounds);
+ Release (Marker, Expr_Pool);
+
+ if Is_Nul then
+ -- Loop is complete.
+ Finalize_For_Loop_Statement (Instance, Stmt);
+ Update_Next_Statement (Proc);
+ else
+ Stmt_Chain := Get_Sequential_Statement_Chain (Stmt);
+ if Stmt_Chain = Null_Iir then
+ -- Nothing to do for an empty loop.
+ Finalize_For_Loop_Statement (Instance, Stmt);
+ Update_Next_Statement (Proc);
+ else
+ Instance.Stmt := Stmt_Chain;
+ end if;
+ end if;
+ end Execute_For_Loop_Statement;
+
+ -- This function is called when there is no more statements to execute
+ -- in the statement list of a for_loop. Returns FALSE in case of end of
+ -- loop.
+ function Finish_For_Loop_Statement (Instance : Block_Instance_Acc)
+ return Boolean
+ is
+ Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt);
+ Bounds : Iir_Value_Literal_Acc;
+ Index : Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ -- FIXME: avoid allocation.
+ Mark (Marker, Expr_Pool);
+ Bounds := Execute_Bounds (Instance, Get_Type (Iterator));
+ Index := Instance.Objects (Get_Info (Iterator).Slot);
+
+ if Is_Equal (Index, Bounds.Right) then
+ -- Loop is complete.
+ Release (Marker, Expr_Pool);
+ Finalize_For_Loop_Statement (Instance, Instance.Stmt);
+ return False;
+ else
+ -- Update the loop index.
+ Update_Loop_Index (Index, Bounds);
+
+ Release (Marker, Expr_Pool);
+
+ -- start the loop again.
+ Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt);
+ return True;
+ end if;
+ end Finish_For_Loop_Statement;
+
+ -- Evaluate boolean condition COND. If COND is Null_Iir, returns true.
+ function Execute_Condition (Instance : Block_Instance_Acc;
+ Cond : Iir) return Boolean
+ is
+ V : Iir_Value_Literal_Acc;
+ Res : Boolean;
+ Marker : Mark_Type;
+ begin
+ if Cond = Null_Iir then
+ return True;
+ end if;
+
+ Mark (Marker, Expr_Pool);
+ V := Execute_Expression (Instance, Cond);
+ Res := V.B1 = True;
+ Release (Marker, Expr_Pool);
+ return Res;
+ end Execute_Condition;
+
+ -- Start a while loop statement, or return FALSE if the loop is not
+ -- executed.
+ procedure Execute_While_Loop_Statement (Proc : Process_State_Acc)
+ is
+ Instance: constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Stmt;
+ Cond : Boolean;
+ begin
+ Cond := Execute_Condition (Instance, Get_Condition (Stmt));
+ if Cond then
+ Init_Sequential_Statements (Proc, Stmt);
+ else
+ Update_Next_Statement (Proc);
+ end if;
+ end Execute_While_Loop_Statement;
+
+ -- This function is called when there is no more statements to execute
+ -- in the statement list of a while loop. Returns FALSE iff loop is
+ -- completed.
+ function Finish_While_Loop_Statement (Instance : Block_Instance_Acc)
+ return Boolean
+ is
+ Cond : Boolean;
+ begin
+ Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt));
+
+ if Cond then
+ -- start the loop again.
+ Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt);
+ return True;
+ else
+ -- Loop is complete.
+ return False;
+ end if;
+ end Finish_While_Loop_Statement;
+
+ -- Return TRUE if the loop must be executed again
+ function Finish_Loop_Statement (Instance : Block_Instance_Acc;
+ Stmt : Iir) return Boolean is
+ begin
+ Instance.Stmt := Stmt;
+ case Get_Kind (Stmt) is
+ when Iir_Kind_While_Loop_Statement =>
+ return Finish_While_Loop_Statement (Instance);
+ when Iir_Kind_For_Loop_Statement =>
+ return Finish_For_Loop_Statement (Instance);
+ when others =>
+ Error_Kind ("finish_loop_statement", Stmt);
+ end case;
+ end Finish_Loop_Statement;
+
+ -- Return FALSE if the next statement should be executed (possibly
+ -- updated).
+ procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc;
+ Is_Exit : Boolean)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Stmt;
+ Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt));
+ Cond : Boolean;
+ Parent : Iir;
+ begin
+ Cond := Execute_Condition (Instance, Get_Condition (Stmt));
+ if not Cond then
+ Update_Next_Statement (Proc);
+ return;
+ end if;
+
+ Parent := Stmt;
+ loop
+ Parent := Get_Parent (Parent);
+ case Get_Kind (Parent) is
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement =>
+ if Label = Null_Iir or else Label = Parent then
+ -- Target is this statement.
+ if Is_Exit then
+ Finalize_Loop_Statement (Instance, Parent);
+ Instance.Stmt := Parent;
+ Update_Next_Statement (Proc);
+ elsif not Finish_Loop_Statement (Instance, Parent) then
+ Update_Next_Statement (Proc);
+ else
+ Init_Sequential_Statements (Proc, Parent);
+ end if;
+ return;
+ else
+ Finalize_Loop_Statement (Instance, Parent);
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Execute_Exit_Next_Statement;
+
+ procedure Execute_Case_Statement (Proc : Process_State_Acc)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Stmt;
+ Value: Iir_Value_Literal_Acc;
+ Assoc: Iir;
+ Stmt_Chain : Iir;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+
+ Value := Execute_Expression (Instance, Get_Expression (Stmt));
+ Assoc := Get_Case_Statement_Alternative_Chain (Stmt);
+
+ while Assoc /= Null_Iir loop
+ if not Get_Same_Alternative_Flag (Assoc) then
+ Stmt_Chain := Get_Associated_Chain (Assoc);
+ end if;
+
+ if Is_In_Choice (Instance, Assoc, Value) then
+ if Stmt_Chain = Null_Iir then
+ Update_Next_Statement (Proc);
+ else
+ Instance.Stmt := Stmt_Chain;
+ end if;
+ Release (Marker, Expr_Pool);
+ return;
+ end if;
+
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ -- FIXME: infinite loop???
+ Error_Msg_Exec ("no choice for expression", Stmt);
+ raise Internal_Error;
+ end Execute_Case_Statement;
+
+ procedure Execute_Call_Statement (Proc : Process_State_Acc)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Stmt;
+ Call : constant Iir := Get_Procedure_Call (Stmt);
+ Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call));
+ Subprg_Instance : Block_Instance_Acc;
+ Assoc_Chain: Iir;
+ Subprg_Body : Iir;
+ begin
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration then
+ Execute_Implicit_Procedure (Instance, Call);
+ Update_Next_Statement (Proc);
+ elsif Get_Foreign_Flag (Imp) then
+ Execute_Foreign_Procedure (Instance, Call);
+ Update_Next_Statement (Proc);
+ else
+ Mark (Instance.Marker, Instance_Pool.all);
+ Subprg_Instance := Create_Subprogram_Instance (Instance, Imp);
+ Adjust_Up_Link_For_Protected_Object
+ (Instance, Call, Subprg_Instance);
+ Assoc_Chain := Get_Parameter_Association_Chain (Call);
+ Execute_Association (Instance, Subprg_Instance, Assoc_Chain);
+
+ Current_Process.Instance := Subprg_Instance;
+ Subprg_Body := Get_Subprogram_Body (Imp);
+ Elaborate_Declarative_Part
+ (Subprg_Instance, Get_Declaration_Chain (Subprg_Body));
+
+ Init_Sequential_Statements (Proc, Subprg_Body);
+ end if;
+ end Execute_Call_Statement;
+
+ procedure Finish_Procedure_Frame (Proc : Process_State_Acc)
+ is
+ Old_Instance : constant Block_Instance_Acc := Proc.Instance;
+ begin
+ Execute_Back_Association (Old_Instance);
+ Proc.Instance := Old_Instance.Parent;
+ Execute_Subprogram_Call_Final (Old_Instance);
+ Release (Proc.Instance.Marker, Instance_Pool.all);
+ end Finish_Procedure_Frame;
+
+ procedure Execute_If_Statement
+ (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement)
+ is
+ Clause: Iir;
+ Cond: Boolean;
+ begin
+ Clause := Stmt;
+ loop
+ Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause));
+ if Cond then
+ Init_Sequential_Statements (Proc, Clause);
+ return;
+ end if;
+ Clause := Get_Else_Clause (Clause);
+ exit when Clause = Null_Iir;
+ end loop;
+ Update_Next_Statement (Proc);
+ end Execute_If_Statement;
+
+ procedure Execute_Variable_Assignment
+ (Proc : Process_State_Acc; Stmt : Iir)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Target : constant Iir := Get_Target (Stmt);
+ Target_Type : constant Iir := Get_Type (Target);
+ Expr : constant Iir := Get_Expression (Stmt);
+ Expr_Type : constant Iir := Get_Type (Expr);
+ Target_Val: Iir_Value_Literal_Acc;
+ Res : Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ Mark (Marker, Expr_Pool);
+ Target_Val := Execute_Expression (Instance, Target);
+
+ -- If the type of the target is not static and the value is
+ -- an aggregate, then the aggregate may be contrained by the
+ -- target.
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ and then Get_Type_Staticness (Expr_Type) < Locally
+ and then Get_Kind (Expr_Type)
+ in Iir_Kinds_Array_Type_Definition
+ then
+ Res := Copy_Array_Bound (Target_Val);
+ Fill_Array_Aggregate (Instance, Expr, Res);
+ else
+ Res := Execute_Expression (Instance, Expr);
+ end if;
+ if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then
+ -- Note: target_type may be dynamic (slice case), so
+ -- check_constraints is not called.
+ Implicit_Array_Conversion (Res, Target_Val, Stmt);
+ else
+ Check_Constraints (Instance, Res, Target_Type, Stmt);
+ end if;
+
+ -- Note: we need to unshare before copying to avoid
+ -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)).
+ -- FIXME: improve that handling (detect overlaps before).
+ Store (Target_Val, Unshare (Res, Expr_Pool'Access));
+
+ Release (Marker, Expr_Pool);
+ end Execute_Variable_Assignment;
+
+ function Execute_Return_Statement (Proc : Process_State_Acc)
+ return Boolean
+ is
+ Res : Iir_Value_Literal_Acc;
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : constant Iir := Instance.Stmt;
+ Expr : constant Iir := Get_Expression (Stmt);
+ begin
+ if Expr /= Null_Iir then
+ Res := Execute_Expression (Instance, Expr);
+ Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt);
+ Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt);
+ Instance.Result := Res;
+ end if;
+
+ case Get_Kind (Instance.Label) is
+ when Iir_Kind_Procedure_Declaration =>
+ Finish_Procedure_Frame (Proc);
+ Update_Next_Statement (Proc);
+ return False;
+ when Iir_Kind_Function_Declaration =>
+ return True;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Return_Statement;
+
+ procedure Finish_Sequential_Statements
+ (Proc : Process_State_Acc; Complex_Stmt : Iir)
+ is
+ Instance : Block_Instance_Acc := Proc.Instance;
+ Stmt : Iir;
+ begin
+ Stmt := Complex_Stmt;
+ loop
+ Instance.Stmt := Stmt;
+ case Get_Kind (Stmt) is
+ when Iir_Kind_For_Loop_Statement =>
+ if Finish_For_Loop_Statement (Instance) then
+ return;
+ end if;
+ when Iir_Kind_While_Loop_Statement =>
+ if Finish_While_Loop_Statement (Instance) then
+ return;
+ end if;
+ when Iir_Kind_Case_Statement
+ | Iir_Kind_If_Statement =>
+ null;
+ when Iir_Kind_Sensitized_Process_Statement =>
+ Instance.Stmt := Null_Iir;
+ return;
+ when Iir_Kind_Process_Statement =>
+ -- Start again.
+ Instance.Stmt := Get_Sequential_Statement_Chain (Stmt);
+ return;
+ when Iir_Kind_Procedure_Body =>
+ Finish_Procedure_Frame (Proc);
+ Instance := Proc.Instance;
+ when Iir_Kind_Function_Body =>
+ Error_Msg_Exec ("missing return statement in function", Stmt);
+ when others =>
+ Error_Kind ("execute_next_statement", Stmt);
+ end case;
+ Stmt := Get_Chain (Instance.Stmt);
+ if Stmt /= Null_Iir then
+ Instance.Stmt := Stmt;
+ return;
+ end if;
+ Stmt := Get_Parent (Instance.Stmt);
+ end loop;
+ end Finish_Sequential_Statements;
+
+ procedure Init_Sequential_Statements
+ (Proc : Process_State_Acc; Complex_Stmt : Iir)
+ is
+ Stmt : Iir;
+ begin
+ Stmt := Get_Sequential_Statement_Chain (Complex_Stmt);
+ if Stmt /= Null_Iir then
+ Proc.Instance.Stmt := Stmt;
+ else
+ Finish_Sequential_Statements (Proc, Complex_Stmt);
+ end if;
+ end Init_Sequential_Statements;
+
+ procedure Update_Next_Statement (Proc : Process_State_Acc)
+ is
+ Instance : constant Block_Instance_Acc := Proc.Instance;
+ Stmt : Iir;
+ begin
+ Stmt := Get_Chain (Instance.Stmt);
+ if Stmt /= Null_Iir then
+ Instance.Stmt := Stmt;
+ return;
+ end if;
+ Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt));
+ end Update_Next_Statement;
+
+ procedure Execute_Sequential_Statements (Proc : Process_State_Acc)
+ is
+ Instance : Block_Instance_Acc;
+ Stmt: Iir;
+ begin
+ loop
+ Instance := Proc.Instance;
+ Stmt := Instance.Stmt;
+
+ -- End of process or subprogram.
+ exit when Stmt = Null_Iir;
+
+ if Trace_Statements then
+ declare
+ Name : Name_Id;
+ Line : Natural;
+ Col : Natural;
+ begin
+ Files_Map.Location_To_Position
+ (Get_Location (Stmt), Name, Line, Col);
+ Put_Line ("Execute statement at "
+ & Name_Table.Image (Name)
+ & Natural'Image (Line));
+ end;
+ end if;
+
+ if Flag_Need_Debug then
+ Debug (Reason_Break);
+ end if;
+
+ -- execute statement STMT.
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Null_Statement =>
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_If_Statement =>
+ Execute_If_Statement (Proc, Stmt);
+
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Execute_Signal_Assignment (Instance, Stmt);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Assertion_Statement =>
+ declare
+ Res : Boolean;
+ begin
+ Res := Execute_Condition
+ (Instance, Get_Assertion_Condition (Stmt));
+ if not Res then
+ Execute_Report_Statement (Instance, Stmt, 2);
+ end if;
+ end;
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Report_Statement =>
+ Execute_Report_Statement (Instance, Stmt, 0);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Execute_Variable_Assignment (Proc, Stmt);
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Return_Statement =>
+ if Execute_Return_Statement (Proc) then
+ return;
+ end if;
+
+ when Iir_Kind_For_Loop_Statement =>
+ Execute_For_Loop_Statement (Proc);
+
+ when Iir_Kind_While_Loop_Statement =>
+ Execute_While_Loop_Statement (Proc);
+
+ when Iir_Kind_Case_Statement =>
+ Execute_Case_Statement (Proc);
+
+ when Iir_Kind_Wait_Statement =>
+ if Execute_Wait_Statement (Instance, Stmt) then
+ return;
+ end if;
+ Update_Next_Statement (Proc);
+
+ when Iir_Kind_Procedure_Call_Statement =>
+ Execute_Call_Statement (Proc);
+
+ when Iir_Kind_Exit_Statement =>
+ Execute_Exit_Next_Statement (Proc, True);
+ when Iir_Kind_Next_Statement =>
+ Execute_Exit_Next_Statement (Proc, False);
+
+ when others =>
+ Error_Kind ("execute_sequential_statements", Stmt);
+ end case;
+ end loop;
+ end Execute_Sequential_Statements;
+end Execution;
diff --git a/src/simulate/execution.ads b/src/simulate/execution.ads
new file mode 100644
index 000000000..faed1111d
--- /dev/null
+++ b/src/simulate/execution.ads
@@ -0,0 +1,185 @@
+-- Interpreted simulation
+-- 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 Iir_Values; use Iir_Values;
+with Elaboration; use Elaboration;
+with Areapools; use Areapools;
+
+package Execution is
+ Trace_Statements : Boolean := False;
+
+ -- If true, disp current time in assert message.
+ Disp_Time_Before_Values: Boolean := False;
+
+ Current_Component : Block_Instance_Acc := null;
+
+ -- State associed with each process.
+ type Process_State_Type is record
+ -- The process instance.
+ Top_Instance: Block_Instance_Acc := null;
+ Proc: Iir := Null_Iir;
+
+ -- Memory pool to allocate objects from.
+ Pool : aliased Areapool;
+
+ -- The stack of the process.
+ Instance : Block_Instance_Acc := null;
+ end record;
+ type Process_State_Acc is access all Process_State_Type;
+
+ Simulation_Finished : exception;
+
+ -- Current process being executed. This is only for the debugger.
+ Current_Process : Process_State_Acc;
+
+ -- Pseudo process used for resolution functions, ...
+ No_Process : Process_State_Acc := new Process_State_Type;
+ -- Execute a list of sequential statements.
+ -- Return when there is no more statements to execute.
+ procedure Execute_Sequential_Statements (Proc : Process_State_Acc);
+
+ -- Evaluate an expression.
+ function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir)
+ return Iir_Value_Literal_Acc;
+
+ -- Evaluate boolean condition COND. If COND is Null_Iir, returns true.
+ function Execute_Condition (Instance : Block_Instance_Acc;
+ Cond : Iir) return Boolean;
+
+ -- Execute a name. Return the value if Ref is False, or the reference
+ -- (for a signal, a quantity or a terminal) if Ref is True.
+ function Execute_Name (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Ref : Boolean := False)
+ return Iir_Value_Literal_Acc;
+
+ procedure Execute_Name_With_Base (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Base : Iir_Value_Literal_Acc;
+ Res : out Iir_Value_Literal_Acc;
+ Is_Sig : out Boolean);
+
+ -- Return the initial value (default value) of signal name EXPR. To be
+ -- used only during (non-dynamic) elaboration.
+ function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir)
+ return Iir_Value_Literal_Acc;
+
+ function Execute_Expression_With_Type
+ (Block: Block_Instance_Acc;
+ Expr: Iir;
+ Expr_Type : Iir)
+ return Iir_Value_Literal_Acc;
+
+ function Execute_Resolution_Function
+ (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ function Execute_Assoc_Conversion
+ (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Sub function common for left/right/length/low/high attributes.
+ -- Return bounds of PREFIX.
+ function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir)
+ return Iir_Value_Literal_Acc;
+
+ -- Compute the offset for INDEX into a range BOUNDS.
+ -- EXPR is only used in case of error.
+ function Get_Index_Offset
+ (Index: Iir_Value_Literal_Acc;
+ Bounds: Iir_Value_Literal_Acc;
+ Expr: Iir)
+ return Iir_Index32;
+
+ function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir)
+ return Block_Instance_Acc;
+
+ -- Store VALUE to TARGET.
+ -- Note: VALUE is not freed.
+ procedure Assign_Value_To_Object
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Target_Type: Iir;
+ Value: Iir_Value_Literal_Acc;
+ Stmt: Iir);
+
+ -- Check VALUE follows the constraints of DEF.
+ -- INSTANCE,DEF is the definition of a subtype.
+ -- EXPR is just used in case of error to display the location
+ -- If there is no location, EXPR can be null.
+ -- Implicitly convert VALUE (array cases).
+ -- Return in case of success.
+ -- Raise errorout.execution_constraint_error in case of failure.
+ procedure Check_Constraints
+ (Instance: Block_Instance_Acc;
+ Value: Iir_Value_Literal_Acc;
+ Def: Iir; Expr: Iir);
+
+ -- If VALUE is not an array, then this is a no-op.
+ -- If VALUE is an array, then bounds are checked and converted. INSTANCE
+ -- is the instance corresponding to REF_TYPE.
+ -- EXPR is used in case of error.
+ procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc;
+ Ref_Value : Iir_Value_Literal_Acc;
+ Expr : Iir);
+ procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc;
+ Value : in out Iir_Value_Literal_Acc;
+ Ref_Type : Iir;
+ Expr : Iir);
+
+ -- Create an iir_value_literal of kind iir_value_array and of life LIFE.
+ -- Allocate the array of bounds, and fill it from A_TYPE.
+ -- Allocate the array of values.
+ function Create_Array_Bounds_From_Type
+ (Block : Block_Instance_Acc;
+ A_Type : Iir;
+ Create_Val_Array : Boolean)
+ return Iir_Value_Literal_Acc;
+
+ -- Create a range from LEN for scalar type ATYPE.
+ function Create_Bounds_From_Length (Block : Block_Instance_Acc;
+ Atype : Iir;
+ Len : Iir_Index32)
+ return Iir_Value_Literal_Acc;
+
+ -- Return TRUE iff VAL is in the range defined by BOUNDS.
+ function Is_In_Range (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc)
+ return Boolean;
+
+ -- Increment or decrement VAL according to BOUNDS.DIR.
+ procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc;
+ Bounds : Iir_Value_Literal_Acc);
+
+ -- Create a block instance for subprogram IMP.
+ function Create_Subprogram_Instance (Instance : Block_Instance_Acc;
+ Imp : Iir)
+ return Block_Instance_Acc;
+
+ function Execute_Function_Body (Instance : Block_Instance_Acc; Func : Iir)
+ return Iir_Value_Literal_Acc;
+
+ function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc;
+ Expr_Type : Iir)
+ return String;
+end Execution;
diff --git a/src/simulate/file_operation.adb b/src/simulate/file_operation.adb
new file mode 100644
index 000000000..33700fd6c
--- /dev/null
+++ b/src/simulate/file_operation.adb
@@ -0,0 +1,341 @@
+-- File operations for interpreter
+-- 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 Annotations; use Annotations;
+with Execution; use Execution;
+with Debugger; use Debugger;
+with Grt.Types; use Grt.Types;
+with Grt_Interface; use Grt_Interface;
+
+package body File_Operation is
+ -- Open a file.
+ -- See LRM93 3.4.1 for definition of arguments.
+ -- IS_TEXT is true if the file format is text.
+ -- The purpose of the IS_TEXT is to allow a text implementation of file
+ -- type TEXT, defined in std.textio.
+ procedure File_Open (Status : out Ghdl_I32;
+ File : Iir_Value_Literal_Acc;
+ External_Name : Iir_Value_Literal_Acc;
+ Mode : Ghdl_I32;
+ Is_Text : Boolean;
+ Return_Status : Boolean)
+ is
+ Name_Len : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (External_Name.Bounds.D (1).Length);
+ Name_Str : aliased Std_String_Uncons (1 .. Name_Len);
+ Name_Bnd : aliased Std_String_Bound := Build_Bound (External_Name);
+ Name : aliased Std_String := (To_Std_String_Basep (Name_Str'Address),
+ To_Std_String_Boundp (Name_Bnd'Address));
+ begin
+ -- Convert the string to an Ada string.
+ for I in External_Name.Val_Array.V'Range loop
+ Name_Str (Name_Str'First + Ghdl_Index_Type (I - 1)) :=
+ Character'Val (External_Name.Val_Array.V (I).E32);
+ end loop;
+
+ if Is_Text then
+ if Return_Status then
+ Status := Ghdl_Text_File_Open_Status
+ (File.File, Mode, Name'Unrestricted_Access);
+ else
+ Ghdl_Text_File_Open (File.File, Mode, Name'Unrestricted_Access);
+ Status := Open_Ok;
+ end if;
+ else
+ if Return_Status then
+ Status := Ghdl_File_Open_Status
+ (File.File, Mode, Name'Unrestricted_Access);
+ else
+ Ghdl_File_Open (File.File, Mode, Name'Unrestricted_Access);
+ Status := Open_Ok;
+ end if;
+ end if;
+ end File_Open;
+
+ -- Open a file.
+ procedure File_Open (File : Iir_Value_Literal_Acc;
+ Name : Iir_Value_Literal_Acc;
+ Mode : Iir_Value_Literal_Acc;
+ File_Decl : Iir;
+ Stmt : Iir)
+ is
+ pragma Unreferenced (Stmt);
+ Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl));
+ File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32);
+ Status : Ghdl_I32;
+ begin
+ File_Open (Status, File, Name, File_Mode, Is_Text, False);
+ if Status /= Open_Ok then
+ raise Program_Error;
+ end if;
+ end File_Open;
+
+ procedure File_Open_Status (Status : Iir_Value_Literal_Acc;
+ File : Iir_Value_Literal_Acc;
+ Name : Iir_Value_Literal_Acc;
+ Mode : Iir_Value_Literal_Acc;
+ File_Decl : Iir;
+ Stmt : Iir)
+ is
+ pragma Unreferenced (Stmt);
+ Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (File_Decl));
+ File_Mode : constant Ghdl_I32 := Ghdl_I32 (Mode.E32);
+ R_Status : Ghdl_I32;
+ begin
+ File_Open (R_Status, File, Name, File_Mode, Is_Text, True);
+ Status.E32 := Ghdl_E32 (R_Status);
+ end File_Open_Status;
+
+ function Elaborate_File_Declaration
+ (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration)
+ return Iir_Value_Literal_Acc
+ is
+ Def : constant Iir := Get_Type (Decl);
+ External_Name : Iir;
+ File_Name: Iir_Value_Literal_Acc;
+ Is_Text : constant Boolean := Get_Text_File_Flag (Def);
+ File_Mode : Ghdl_I32;
+ Res : Iir_Value_Literal_Acc;
+ Status : Ghdl_I32;
+ Mode : Iir_Value_Literal_Acc;
+ begin
+ if Is_Text then
+ Res := Create_File_Value (Ghdl_Text_File_Elaborate);
+ else
+ declare
+ Sig : constant String_Acc := Get_Info (Def).File_Signature;
+ Cstr : Ghdl_C_String;
+ begin
+ if Sig = null then
+ Cstr := null;
+ else
+ Cstr := To_Ghdl_C_String (Sig.all'Address);
+ end if;
+ Res := Create_File_Value (Ghdl_File_Elaborate (Cstr));
+ end;
+ end if;
+
+ External_Name := Get_File_Logical_Name (Decl);
+
+ -- LRM93 4.3.1.4
+ -- If file open information is not included in a given file declaration,
+ -- then the file declared by the declaration is not opened when the file
+ -- declaration is elaborated.
+ if External_Name = Null_Iir then
+ return Res;
+ end if;
+
+ File_Name := Execute_Expression (Instance, External_Name);
+ if Get_File_Open_Kind (Decl) /= Null_Iir then
+ Mode := Execute_Expression (Instance, Get_File_Open_Kind (Decl));
+ File_Mode := Ghdl_I32 (Mode.E32);
+ else
+ case Get_Mode (Decl) is
+ when Iir_In_Mode =>
+ File_Mode := Read_Mode;
+ when Iir_Out_Mode =>
+ File_Mode := Write_Mode;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ File_Open (Status, Res, File_Name, File_Mode, Is_Text, False);
+ return Res;
+ end Elaborate_File_Declaration;
+
+ procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir) is
+ pragma Unreferenced (Stmt);
+ begin
+ Ghdl_Text_File_Close (File.File);
+ end File_Close_Text;
+
+ procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir) is
+ pragma Unreferenced (Stmt);
+ begin
+ Ghdl_File_Close (File.File);
+ end File_Close_Binary;
+
+ procedure File_Destroy_Text (File : Iir_Value_Literal_Acc) is
+ begin
+ Ghdl_Text_File_Finalize (File.File);
+ end File_Destroy_Text;
+
+ procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc) is
+ begin
+ Ghdl_File_Finalize (File.File);
+ end File_Destroy_Binary;
+
+
+ procedure Write_Binary (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc) is
+ begin
+ case Value.Kind is
+ when Iir_Value_B1 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1);
+ when Iir_Value_I64 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8);
+ when Iir_Value_E32 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4);
+ when Iir_Value_F64 =>
+ Ghdl_Write_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8);
+ when Iir_Value_Array =>
+ for I in Value.Bounds.D'Range loop
+ Ghdl_Write_Scalar
+ (File.File, Ghdl_Ptr (Value.Bounds.D (I).Length'Address), 4);
+ end loop;
+ for I in Value.Val_Array.V'Range loop
+ Write_Binary (File, Value.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Value.Val_Record.V'Range loop
+ Write_Binary (File, Value.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Write_Binary;
+
+ procedure Write_Text (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc)
+ is
+ Val_Len : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (Value.Bounds.D (1).Length);
+ Val_Str : aliased Std_String_Uncons (1 .. Val_Len);
+ Val_Bnd : aliased Std_String_Bound := Build_Bound (Value);
+ Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address),
+ To_Std_String_Boundp (Val_Bnd'Address));
+ begin
+ -- Convert the string to an Ada string.
+ for I in Value.Val_Array.V'Range loop
+ Val_Str (Val_Str'First + Ghdl_Index_Type (I - 1)) :=
+ Character'Val (Value.Val_Array.V (I).E32);
+ end loop;
+
+ Ghdl_Text_Write (File.File, Val'Unrestricted_Access);
+ end Write_Text;
+
+ function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir)
+ return Boolean
+ is
+ pragma Unreferenced (Stmt);
+ begin
+ return Grt.Files.Ghdl_File_Endfile (File.File);
+ end Endfile;
+
+ procedure Read_Length_Text (File : Iir_Value_Literal_Acc;
+ Value : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc)
+ is
+ Val_Len : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (Value.Bounds.D (1).Length);
+ Val_Str : aliased Std_String_Uncons (1 .. Val_Len);
+ Val_Bnd : aliased Std_String_Bound := Build_Bound (Value);
+ Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address),
+ To_Std_String_Boundp (Val_Bnd'Address));
+ Len : Std_Integer;
+ begin
+ Len := Ghdl_Text_Read_Length (File.File, Val'Unrestricted_Access);
+ for I in 1 .. Len loop
+ Value.Val_Array.V (Iir_Index32 (I)).E32 :=
+ Character'Pos (Val_Str (Ghdl_Index_Type (I)));
+ end loop;
+ Length.I64 := Ghdl_I64 (Len);
+ end Read_Length_Text;
+
+ procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc;
+ Str : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc)
+ is
+ Res : Ghdl_Untruncated_Text_Read_Result;
+ Val_Len : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (Str.Bounds.D (1).Length);
+ Val_Str : aliased Std_String_Uncons (1 .. Val_Len);
+ Val_Bnd : aliased Std_String_Bound := Build_Bound (Str);
+ Val : aliased Std_String := (To_Std_String_Basep (Val_Str'Address),
+ To_Std_String_Boundp (Val_Bnd'Address));
+ begin
+ Ghdl_Untruncated_Text_Read
+ (Res'Unrestricted_Access, File.File, Val'Unrestricted_Access);
+ for I in 1 .. Res.Len loop
+ Str.Val_Array.V (Iir_Index32 (I)).E32 :=
+ Character'Pos (Val_Str (Ghdl_Index_Type (I)));
+ end loop;
+ Length.I64 := Ghdl_I64 (Res.Len);
+ end Untruncated_Text_Read;
+
+ procedure Read_Binary (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc)
+ is
+ begin
+ case Value.Kind is
+ when Iir_Value_B1 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.B1'Address), 1);
+ when Iir_Value_I64 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.I64'Address), 8);
+ when Iir_Value_E32 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.E32'Address), 4);
+ when Iir_Value_F64 =>
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Value.F64'Address), 8);
+ when Iir_Value_Array =>
+ for I in Value.Bounds.D'Range loop
+ declare
+ Len : Iir_Index32;
+ begin
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4);
+ if Len /= Value.Bounds.D (I).Length then
+ Error_Msg_Constraint (Null_Iir); -- FIXME: loc
+ end if;
+ end;
+ end loop;
+ for I in Value.Val_Array.V'Range loop
+ Read_Binary (File, Value.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Value.Val_Record.V'Range loop
+ Read_Binary (File, Value.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Read_Binary;
+
+ procedure Read_Length_Binary (File : Iir_Value_Literal_Acc;
+ Value : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc)
+ is
+ Len : Iir_Index32;
+ begin
+ Ghdl_Read_Scalar (File.File, Ghdl_Ptr (Len'Address), 4);
+ for I in 1 .. Len loop
+ if I <= Value.Bounds.D (1).Length then
+ Read_Binary (File, Value.Val_Array.V (I));
+ else
+ -- FIXME: for empty arrays ??
+ -- Lose_Binary (File, Value.Val_Array (0));
+ raise Internal_Error;
+ end if;
+ end loop;
+ Length.I64 := Ghdl_I64 (Len);
+ end Read_Length_Binary;
+
+ procedure Flush (File : Iir_Value_Literal_Acc) is
+ begin
+ Ghdl_File_Flush (File.File);
+ end Flush;
+end File_Operation;
diff --git a/src/simulate/file_operation.ads b/src/simulate/file_operation.ads
new file mode 100644
index 000000000..b66a06756
--- /dev/null
+++ b/src/simulate/file_operation.ads
@@ -0,0 +1,81 @@
+-- File operations for interpreter
+-- 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 Iirs; use Iirs;
+with Iir_Values; use Iir_Values;
+with Elaboration; use Elaboration;
+with Grt.Files; use Grt.Files;
+
+package File_Operation is
+ Null_File : constant Natural := 0;
+
+ -- Open a file.
+ procedure File_Open (File : Iir_Value_Literal_Acc;
+ Name : Iir_Value_Literal_Acc;
+ Mode : Iir_Value_Literal_Acc;
+ File_Decl : Iir;
+ Stmt : Iir);
+
+ procedure File_Open_Status (Status : Iir_Value_Literal_Acc;
+ File : Iir_Value_Literal_Acc;
+ Name : Iir_Value_Literal_Acc;
+ Mode : Iir_Value_Literal_Acc;
+ File_Decl : Iir;
+ Stmt : Iir);
+
+ -- Close a file.
+ -- If the file was not open, this has no effects.
+ procedure File_Close_Text (File : Iir_Value_Literal_Acc; Stmt : Iir);
+ procedure File_Close_Binary (File : Iir_Value_Literal_Acc; Stmt : Iir);
+
+ procedure File_Destroy_Text (File : Iir_Value_Literal_Acc);
+ procedure File_Destroy_Binary (File : Iir_Value_Literal_Acc);
+
+ -- Elaborate a file_declaration.
+ function Elaborate_File_Declaration
+ (Instance: Block_Instance_Acc; Decl: Iir_File_Declaration)
+ return Iir_Value_Literal_Acc;
+
+ -- Write VALUE to FILE.
+ -- STMT is the statement, to display error.
+ procedure Write_Text (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc);
+ procedure Write_Binary (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc);
+
+ procedure Read_Binary (File: Iir_Value_Literal_Acc;
+ Value: Iir_Value_Literal_Acc);
+
+ procedure Read_Length_Text (File : Iir_Value_Literal_Acc;
+ Value : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc);
+
+ procedure Read_Length_Binary (File : Iir_Value_Literal_Acc;
+ Value : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc);
+
+ procedure Untruncated_Text_Read (File : Iir_Value_Literal_Acc;
+ Str : Iir_Value_Literal_Acc;
+ Length : Iir_Value_Literal_Acc);
+
+ procedure Flush (File : Iir_Value_Literal_Acc);
+
+ -- Test end of FILE is reached.
+ function Endfile (File : Iir_Value_Literal_Acc; Stmt : Iir)
+ return Boolean;
+end File_Operation;
diff --git a/src/simulate/grt_interface.adb b/src/simulate/grt_interface.adb
new file mode 100644
index 000000000..c4eab58c4
--- /dev/null
+++ b/src/simulate/grt_interface.adb
@@ -0,0 +1,44 @@
+-- Interpreted simulation
+-- 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 Iirs; use Iirs;
+with Types; use Types;
+
+package body Grt_Interface is
+ To_Dir : constant array (Iir_Direction) of Ghdl_Dir_Type :=
+ (Iir_To => Dir_To, Iir_Downto => Dir_Downto);
+
+ function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound
+ is
+ Rng : constant Iir_Value_Literal_Acc := Arr.Bounds.D (1);
+ begin
+ return (Dim_1 => (Left => Std_Integer (Rng.Left.I64),
+ Right => Std_Integer (Rng.Right.I64),
+ Dir => To_Dir (Rng.Dir),
+ Length => Ghdl_Index_Type (Rng.Length)));
+ end Build_Bound;
+
+ procedure Set_Std_String_From_Iir_Value (Str : Std_String;
+ Val : Iir_Value_Literal_Acc) is
+ begin
+ for I in Val.Val_Array.V'Range loop
+ Str.Base (Ghdl_Index_Type (I - 1)) :=
+ Character'Val (Val.Val_Array.V (I).E32);
+ end loop;
+ end Set_Std_String_From_Iir_Value;
+end Grt_Interface;
diff --git a/src/simulate/grt_interface.ads b/src/simulate/grt_interface.ads
new file mode 100644
index 000000000..05f7abb69
--- /dev/null
+++ b/src/simulate/grt_interface.ads
@@ -0,0 +1,27 @@
+-- Interpreted simulation
+-- 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 Grt.Types; use Grt.Types;
+with Iir_Values; use Iir_Values;
+
+package Grt_Interface is
+ procedure Set_Std_String_From_Iir_Value (Str : Std_String;
+ Val : Iir_Value_Literal_Acc);
+
+ function Build_Bound (Arr : Iir_Value_Literal_Acc) return Std_String_Bound;
+end Grt_Interface;
diff --git a/src/simulate/iir_values.adb b/src/simulate/iir_values.adb
new file mode 100644
index 000000000..d80f3bf0a
--- /dev/null
+++ b/src/simulate/iir_values.adb
@@ -0,0 +1,1066 @@
+-- Naive values for interpreted simulation
+-- 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 System;
+with Ada.Unchecked_Conversion;
+with GNAT.Debug_Utilities;
+with Name_Table;
+with Debugger; use Debugger;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Iir_Values is
+
+ -- Functions for iir_value_literal
+ function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is
+ begin
+ if Left.Kind /= Right.Kind then
+ raise Internal_Error;
+ end if;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ return Left.B1 = Right.B1;
+ when Iir_Value_E32 =>
+ return Left.E32 = Right.E32;
+ when Iir_Value_I64 =>
+ return Left.I64 = Right.I64;
+ when Iir_Value_F64 =>
+ return Left.F64 = Right.F64;
+ when Iir_Value_Access =>
+ return Left.Val_Access = Right.Val_Access;
+ when Iir_Value_File =>
+ raise Internal_Error;
+ when Iir_Value_Array =>
+ if Left.Bounds.Nbr_Dims /= Right.Bounds.Nbr_Dims then
+ raise Internal_Error;
+ end if;
+ for I in Left.Bounds.D'Range loop
+ if Left.Bounds.D (I).Length /= Right.Bounds.D (I).Length then
+ return False;
+ end if;
+ end loop;
+ for I in Left.Val_Array.V'Range loop
+ if not Is_Equal (Left.Val_Array.V (I),
+ Right.Val_Array.V (I)) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ when Iir_Value_Record =>
+ if Left.Val_Record.Len /= Right.Val_Record.Len then
+ raise Constraint_Error;
+ end if;
+ for I in Left.Val_Record.V'Range loop
+ if not Is_Equal (Left.Val_Record.V (I),
+ Right.Val_Record.V (I)) then
+ return False;
+ end if;
+ end loop;
+ return True;
+ when Iir_Value_Range =>
+ if Left.Dir /= Right.Dir then
+ return False;
+ end if;
+ if not Is_Equal (Left.Left, Right.Left) then
+ return False;
+ end if;
+ if not Is_Equal (Left.Right, Right.Right) then
+ return False;
+ end if;
+ return True;
+ when Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Is_Equal;
+
+ function Compare_Value (Left, Right : Iir_Value_Literal_Acc)
+ return Order is
+ begin
+ if Left.Kind /= Right.Kind then
+ raise Constraint_Error;
+ end if;
+ case Left.Kind is
+ when Iir_Value_B1 =>
+ if Left.B1 < Right.B1 then
+ return Less;
+ elsif Left.B1 = Right.B1 then
+ return Equal;
+ else
+ return Greater;
+ end if;
+ when Iir_Value_E32 =>
+ if Left.E32 < Right.E32 then
+ return Less;
+ elsif Left.E32 = Right.E32 then
+ return Equal;
+ else
+ return Greater;
+ end if;
+ when Iir_Value_I64 =>
+ if Left.I64 < Right.I64 then
+ return Less;
+ elsif Left.I64 = Right.I64 then
+ return Equal;
+ else
+ return Greater;
+ end if;
+ when Iir_Value_F64 =>
+ if Left.F64 < Right.F64 then
+ return Less;
+ elsif Left.F64 = Right.F64 then
+ return Equal;
+ elsif Left.F64 > Right.F64 then
+ return Greater;
+ else
+ raise Constraint_Error;
+ end if;
+ when Iir_Value_Array =>
+ -- LRM93 �7.2.2
+ -- For discrete array types, the relation < (less than) is defined
+ -- such as the left operand is less than the right operand if
+ -- and only if:
+ -- * the left operand is a null array and the right operand is
+ -- a non-null array; otherwise
+ -- * both operands are non-null arrays, and one of the following
+ -- conditions is satisfied:
+ -- - the leftmost element of the left operand is less than
+ -- that of the right; or
+ -- - the leftmost element of the left operand is equal to
+ -- that of the right, and the tail of the left operand is
+ -- less than that of the right (the tail consists of the
+ -- remaining elements to the rights of the leftmost element
+ -- and can be null)
+ -- The relation <= (less than or equal) for discrete array types
+ -- is defined to be the inclusive disjunction of the results of
+ -- the < and = operators for the same two operands.
+ -- The relation > (greater than) and >= (greater than of equal)
+ -- are defined to be the complements of the <= and < operators
+ -- respectively for the same two operands.
+ if Left.Bounds.Nbr_Dims /= 1 or Right.Bounds.Nbr_Dims /= 1 then
+ raise Internal_Error;
+ end if;
+ for I in 1 .. Iir_Index32'Min (Left.Bounds.D (1).Length,
+ Right.Bounds.D (1).Length)
+ loop
+ case Compare_Value (Left.Val_Array.V (I),
+ Right.Val_Array.V (I)) is
+ when Less =>
+ return Less;
+ when Greater =>
+ return Greater;
+ when Equal =>
+ null;
+ end case;
+ end loop;
+ if Left.Bounds.D (1).Length < Right.Bounds.D (1).Length then
+ return Less;
+ elsif Left.Bounds.D (1).Length = Right.Bounds.D (1).Length then
+ return Equal;
+ else
+ return Greater;
+ end if;
+ when Iir_Value_Signal
+ | Iir_Value_Access
+ | Iir_Value_Range
+ | Iir_Value_Record
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Compare_Value;
+
+ function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean
+ is
+ Cmp : Order;
+ begin
+ Cmp := Compare_Value (Arange.Left, Arange.Right);
+ case Arange.Dir is
+ when Iir_To =>
+ return Cmp = Greater;
+ when Iir_Downto =>
+ return Cmp = Less;
+ end case;
+ end Is_Nul_Range;
+
+ procedure Increment (Val : Iir_Value_Literal_Acc) is
+ begin
+ case Val.Kind is
+ when Iir_Value_B1 =>
+ if Val.B1 = False then
+ Val.B1 := True;
+ else
+ raise Constraint_Error;
+ end if;
+ when Iir_Value_E32 =>
+ Val.E32 := Val.E32 + 1;
+ when Iir_Value_I64 =>
+ Val.I64 := Val.I64 + 1;
+ when Iir_Value_F64
+ | Iir_Value_Array
+ | Iir_Value_Record
+ | Iir_Value_Range
+ | Iir_Value_File
+ | Iir_Value_Access
+ | Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Increment;
+
+ procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc)
+ is
+ begin
+ if Dest.Kind /= Src.Kind then
+ raise Constraint_Error;
+ end if;
+ case Dest.Kind is
+ when Iir_Value_Array =>
+ if Dest.Val_Array.Len /= Src.Val_Array.Len then
+ raise Constraint_Error;
+ end if;
+ for I in Dest.Val_Array.V'Range loop
+ Store (Dest.Val_Array.V (I), Src.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ if Dest.Val_Record.Len /= Src.Val_Record.Len then
+ raise Constraint_Error;
+ end if;
+ for I in Dest.Val_Record.V'Range loop
+ Store (Dest.Val_Record.V (I), Src.Val_Record.V (I));
+ end loop;
+ when Iir_Value_B1 =>
+ Dest.B1 := Src.B1;
+ when Iir_Value_E32 =>
+ Dest.E32 := Src.E32;
+ when Iir_Value_I64 =>
+ Dest.I64 := Src.I64;
+ when Iir_Value_F64 =>
+ Dest.F64 := Src.F64;
+ when Iir_Value_Access =>
+ Dest.Val_Access := Src.Val_Access;
+ when Iir_Value_File =>
+ Dest.File := Src.File;
+ when Iir_Value_Protected =>
+ Dest.Prot := Src.Prot;
+ when Iir_Value_Signal
+ | Iir_Value_Range
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Store;
+
+ procedure Check_Bounds (Dest : Iir_Value_Literal_Acc;
+ Src : Iir_Value_Literal_Acc;
+ Loc : Iir)
+ is
+ begin
+ case Dest.Kind is
+ when Iir_Value_Array =>
+ if Src.Kind /= Iir_Value_Array then
+ raise Internal_Error;
+ end if;
+ if Dest.Val_Array.Len /= Src.Val_Array.Len then
+ Error_Msg_Constraint (Loc);
+ end if;
+ if Dest.Val_Array.Len /= 0 then
+ Check_Bounds (Dest.Val_Array.V (1), Src.Val_Array.V (1), Loc);
+ end if;
+ when Iir_Value_Record =>
+ if Src.Kind /= Iir_Value_Record then
+ raise Internal_Error;
+ end if;
+ if Dest.Val_Record.Len /= Src.Val_Record.Len then
+ raise Internal_Error;
+ end if;
+ for I in Dest.Val_Record.V'Range loop
+ Check_Bounds (Dest.Val_Record.V (I), Src.Val_Record.V (I), Loc);
+ end loop;
+ when Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ if Src.Kind /= Dest.Kind then
+ raise Internal_Error;
+ end if;
+ when Iir_Value_B1
+ | Iir_Value_E32
+ | Iir_Value_I64
+ | Iir_Value_F64
+ | Iir_Value_Signal =>
+ return;
+ end case;
+ end Check_Bounds;
+
+ function To_Iir_Value_Literal_Acc is new Ada.Unchecked_Conversion
+ (System.Address, Iir_Value_Literal_Acc);
+ function To_Value_Array_Acc is new Ada.Unchecked_Conversion
+ (System.Address, Value_Array_Acc);
+ function To_Value_Bounds_Array_Acc is new Ada.Unchecked_Conversion
+ (System.Address, Value_Bounds_Array_Acc);
+
+ function Create_Signal_Value (Sig : Ghdl_Signal_Ptr)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Signal_Value is Iir_Value_Literal (Iir_Value_Signal);
+ function Alloc is new Alloc_On_Pool_Addr (Signal_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Global_Pool'Access,
+ (Kind => Iir_Value_Signal, Sig => Sig)));
+ end Create_Signal_Value;
+
+ function Create_Terminal_Value (Terminal : Terminal_Index_Type)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Terminal_Value is Iir_Value_Literal (Iir_Value_Terminal);
+ function Alloc is new Alloc_On_Pool_Addr (Terminal_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Global_Pool'Access,
+ (Kind => Iir_Value_Terminal, Terminal => Terminal)));
+ end Create_Terminal_Value;
+
+ function Create_Quantity_Value (Quantity : Quantity_Index_Type)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Quantity_Value is Iir_Value_Literal (Iir_Value_Quantity);
+ function Alloc is new Alloc_On_Pool_Addr (Quantity_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Global_Pool'Access,
+ (Kind => Iir_Value_Quantity, Quantity => Quantity)));
+ end Create_Quantity_Value;
+
+ function Create_Protected_Value (Prot : Protected_Index_Type)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Protected_Value is Iir_Value_Literal (Iir_Value_Protected);
+ function Alloc is new Alloc_On_Pool_Addr (Protected_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Global_Pool'Access,
+ (Kind => Iir_Value_Protected, Prot => Prot)));
+ end Create_Protected_Value;
+
+ function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc
+ is
+ subtype B1_Value is Iir_Value_Literal (Iir_Value_B1);
+ function Alloc is new Alloc_On_Pool_Addr (B1_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val)));
+ end Create_B1_Value;
+
+ function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc
+ is
+ subtype E32_Value is Iir_Value_Literal (Iir_Value_E32);
+ function Alloc is new Alloc_On_Pool_Addr (E32_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool, (Kind => Iir_Value_E32, E32 => Val)));
+ end Create_E32_Value;
+
+ function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc
+ is
+ subtype I64_Value is Iir_Value_Literal (Iir_Value_I64);
+ function Alloc is new Alloc_On_Pool_Addr (I64_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool, (Kind => Iir_Value_I64, I64 => Val)));
+ end Create_I64_Value;
+
+ function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc
+ is
+ subtype F64_Value is Iir_Value_Literal (Iir_Value_F64);
+ function Alloc is new Alloc_On_Pool_Addr (F64_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool, (Kind => Iir_Value_F64, F64 => Val)));
+ end Create_F64_Value;
+
+ function Create_Access_Value (Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Access_Value is Iir_Value_Literal (Iir_Value_Access);
+ function Alloc is new Alloc_On_Pool_Addr (Access_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool,
+ (Kind => Iir_Value_Access, Val_Access => Val)));
+ end Create_Access_Value;
+
+ function Create_Range_Value
+ (Left, Right : Iir_Value_Literal_Acc;
+ Dir : Iir_Direction;
+ Length : Iir_Index32)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Range_Value is Iir_Value_Literal (Iir_Value_Range);
+ function Alloc is new Alloc_On_Pool_Addr (Range_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool,
+ (Kind => Iir_Value_Range,
+ Left => Left,
+ Right => Right,
+ Dir => Dir,
+ Length => Length)));
+ end Create_Range_Value;
+
+ function Create_File_Value (Val : Grt.Files.Ghdl_File_Index)
+ return Iir_Value_Literal_Acc
+ is
+ subtype File_Value is Iir_Value_Literal (Iir_Value_File);
+ function Alloc is new Alloc_On_Pool_Addr (File_Value);
+ begin
+ return To_Iir_Value_Literal_Acc
+ (Alloc (Current_Pool,
+ (Kind => Iir_Value_File, File => Val)));
+ end Create_File_Value;
+
+ -- Create a range_value of life LIFE.
+ function Create_Range_Value
+ (Left, Right : Iir_Value_Literal_Acc;
+ Dir : Iir_Direction)
+ return Iir_Value_Literal_Acc
+ is
+ Low, High : Iir_Value_Literal_Acc;
+ Len : Iir_Index32;
+ begin
+ case Dir is
+ when Iir_To =>
+ Low := Left;
+ High := Right;
+ when Iir_Downto =>
+ Low := Right;
+ High := Left;
+ end case;
+
+ case (Low.Kind) is
+ when Iir_Value_B1 =>
+ if High.B1 >= Low.B1 then
+ Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1;
+ else
+ Len := 0;
+ end if;
+ when Iir_Value_E32 =>
+ if High.E32 >= Low.E32 then
+ Len := Iir_Index32 (High.E32 - Low.E32 + 1);
+ else
+ Len := 0;
+ end if;
+ when Iir_Value_I64 =>
+ declare
+ L : Ghdl_I64;
+ begin
+ if High.I64 = Ghdl_I64'Last and Low.I64 = Ghdl_I64'First
+ then
+ -- Prevent overflow
+ Len := Iir_Index32'Last;
+ else
+ L := High.I64 - Low.I64;
+ if L >= Ghdl_I64 (Iir_Index32'Last) then
+ -- Prevent overflow
+ Len := Iir_Index32'Last;
+ else
+ L := L + 1;
+ if L < 0 then
+ -- null range.
+ Len := 0;
+ else
+ Len := Iir_Index32 (L);
+ end if;
+ end if;
+ end if;
+ end;
+ when Iir_Value_F64 =>
+ Len := 0;
+ when Iir_Value_Array
+ | Iir_Value_Record
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Signal
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ return Create_Range_Value (Left, Right, Dir, Len);
+ end Create_Range_Value;
+
+ -- Return an array of length LENGTH.
+ function Create_Array_Value (Dim : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Array_Value is Iir_Value_Literal (Iir_Value_Array);
+ function Alloc_Array is new Alloc_On_Pool_Addr (Array_Value);
+ subtype Dim_Type is Value_Bounds_Array (Dim);
+ function Alloc_Bounds is new Alloc_On_Pool_Addr (Dim_Type);
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := To_Iir_Value_Literal_Acc
+ (Alloc_Array (Pool,
+ (Kind => Iir_Value_Array,
+ Bounds => null, Val_Array => null)));
+
+ Res.Bounds := To_Value_Bounds_Array_Acc
+ (Alloc_Bounds (Pool, Dim_Type'(Nbr_Dims => Dim,
+ D => (others => null))));
+
+ return Res;
+ end Create_Array_Value;
+
+ procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc;
+ Len : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool)
+ is
+ use System;
+ subtype Data_Type is Value_Array (Len);
+ Res : Address;
+ begin
+ -- Manually allocate the array to handle large arrays without
+ -- creating a large temporary value.
+ Allocate
+ (Pool.all, Res, Data_Type'Size / Storage_Unit, Data_Type'Alignment);
+
+ declare
+ -- Discard the warnings for no pragma Import as we really want
+ -- to use the default initialization.
+ pragma Warnings (Off);
+ Addr1 : constant Address := Res;
+ Init : Data_Type;
+ for Init'Address use Addr1;
+ pragma Warnings (On);
+ begin
+ null;
+ end;
+
+ Arr.Val_Array := To_Value_Array_Acc (Res);
+ end Create_Array_Data;
+
+ function Create_Array_Value (Length: Iir_Index32;
+ Dim : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Value (Dim, Pool);
+ Create_Array_Data (Res, Length, Pool);
+ return Res;
+ end Create_Array_Value;
+
+ function Create_Record_Value
+ (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc
+ is
+ subtype Record_Value is Iir_Value_Literal (Iir_Value_Record);
+ function Alloc_Record is new Alloc_On_Pool_Addr (Record_Value);
+ subtype Data_Type is Value_Array (Nbr);
+ function Alloc_Data is new Alloc_On_Pool_Addr (Data_Type);
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := To_Iir_Value_Literal_Acc
+ (Alloc_Record (Pool, (Kind => Iir_Value_Record, Val_Record => null)));
+
+ Res.Val_Record := To_Value_Array_Acc
+ (Alloc_Data (Pool, Data_Type'(Len => Nbr, V => (others => null))));
+
+ return Res;
+ end Create_Record_Value;
+
+ -- Create a copy of SRC with a specified life.
+ function Copy (Src: in Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ begin
+ case Src.Kind is
+ when Iir_Value_E32 =>
+ return Create_E32_Value (Src.E32);
+ when Iir_Value_I64 =>
+ return Create_I64_Value (Src.I64);
+ when Iir_Value_F64 =>
+ return Create_F64_Value (Src.F64);
+ when Iir_Value_B1 =>
+ return Create_B1_Value (Src.B1);
+ when Iir_Value_Access =>
+ return Create_Access_Value (Src.Val_Access);
+ when Iir_Value_Array =>
+ Res := Copy_Array_Bound (Src);
+ for I in Src.Val_Array.V'Range loop
+ Res.Val_Array.V (I) := Copy (Src.Val_Array.V (I));
+ end loop;
+ return Res;
+
+ when Iir_Value_Range =>
+ return Create_Range_Value
+ (Left => Copy (Src.Left),
+ Right => Copy (Src.Right),
+ Dir => Src.Dir,
+ Length => Src.Length);
+
+ when Iir_Value_Record =>
+ Res := Copy_Record (Src);
+ for I in Src.Val_Record.V'Range loop
+ Res.Val_Record.V (I) := Copy (Src.Val_Record.V (I));
+ end loop;
+ return Res;
+
+ when Iir_Value_File =>
+ return Create_File_Value (Src.File);
+ when Iir_Value_Protected =>
+ return Create_Protected_Value (Src.Prot);
+
+ when Iir_Value_Signal
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Copy;
+
+ function Copy_Array_Bound (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims);
+ for I in Res.Bounds.D'Range loop
+ Res.Bounds.D (I) := Copy (Src.Bounds.D (I));
+ end loop;
+ return Res;
+ end Copy_Array_Bound;
+
+ function Copy_Record (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Create_Record_Value (Src.Val_Record.Len);
+ end Copy_Record;
+
+ function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Prev_Pool : constant Areapool_Acc := Current_Pool;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Current_Pool := Pool;
+ Res := Copy (Src);
+ Current_Pool := Prev_Pool;
+ return Res;
+ end Unshare;
+
+ function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ if Src.Kind /= Iir_Value_Array then
+ return Src;
+ end if;
+ declare
+ Prev_Pool : constant Areapool_Acc := Current_Pool;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Current_Pool := Pool;
+ Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims);
+ for I in Src.Bounds.D'Range loop
+ Res.Bounds.D (I) := Copy (Src.Bounds.D (I));
+ end loop;
+ Res.Val_Array.V := Src.Val_Array.V;
+ Current_Pool := Prev_Pool;
+ return Res;
+ end;
+ end Unshare_Bounds;
+
+ Heap_Pool : aliased Areapool;
+
+ function Unshare_Heap (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ -- FIXME: this is never free.
+ return Unshare (Src, Heap_Pool'Access);
+ end Unshare_Heap;
+
+ procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc) is
+ begin
+ null;
+ end Free_Heap_Value;
+
+ function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural is
+ begin
+ case Val.Kind is
+ when Iir_Value_Scalars
+ | Iir_Value_Access
+ | Iir_Value_Signal =>
+ return 1;
+ when Iir_Value_Record =>
+ declare
+ Total : Natural := 0;
+ begin
+ for I in Val.Val_Record.V'Range loop
+ Total := Total + Get_Nbr_Of_Scalars (Val.Val_Record.V (I));
+ end loop;
+ return Total;
+ end;
+ when Iir_Value_Array =>
+ if Val.Val_Array.Len = 0 then
+ -- Nul array
+ return 0;
+ else
+ -- At least one element.
+ return Natural (Val.Val_Array.Len)
+ * Get_Nbr_Of_Scalars (Val.Val_Array.V (1));
+ end if;
+ when Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Protected
+ | Iir_Value_Terminal
+ | Iir_Value_Quantity =>
+ raise Internal_Error;
+ end case;
+ end Get_Nbr_Of_Scalars;
+
+ function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is
+ begin
+ case Val.Kind is
+ when Iir_Value_E32 =>
+ return Ghdl_E32'Pos (Val.E32);
+ when Iir_Value_B1 =>
+ return Ghdl_B1'Pos (Val.B1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Enum_Pos;
+
+ procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc;
+ Tab: Ada.Text_IO.Count)
+ is
+ use Ada.Text_IO;
+ use GNAT.Debug_Utilities;
+ begin
+ Set_Col (Tab);
+ if Value = null then
+ Put_Line ("*NULL*");
+ return;
+ end if;
+
+ if Boolean'(True) then
+ Put (Image (Value.all'Address) & ' ');
+ end if;
+
+ case Value.Kind is
+ when Iir_Value_B1 =>
+ Put_Line ("b1:" & Ghdl_B1'Image (Value.B1));
+ when Iir_Value_E32 =>
+ Put_Line ("e32:" & Ghdl_E32'Image (Value.E32));
+ when Iir_Value_I64 =>
+ Put_Line ("i64:" & Ghdl_I64'Image (Value.I64));
+ when Iir_Value_F64 =>
+ Put_Line ("F64:" & Ghdl_F64'Image (Value.F64));
+ when Iir_Value_Access =>
+ -- FIXME.
+ if Value.Val_Access = null then
+ Put_Line ("access: null");
+ else
+ Put ("access: ");
+ Put_Line (Image (Value.Val_Access.all'Address));
+ end if;
+ when Iir_Value_Array =>
+ if Value.Val_Array = null then
+ Put_Line ("array, without elements");
+ return;
+ else
+ Put_Line ("array, length: "
+ & Iir_Index32'Image (Value.Val_Array.Len));
+ declare
+ Ntab: constant Count := Tab + Indentation;
+ begin
+ Set_Col (Ntab);
+ if Value.Bounds /= null then
+ Put_Line ("bounds 1 .."
+ & Iir_Index32'Image (Value.Bounds.Nbr_Dims)
+ & ':');
+ for I in Value.Bounds.D'Range loop
+ Disp_Value_Tab (Value.Bounds.D (I), Ntab);
+ end loop;
+ else
+ Put_Line ("bounds = null");
+ end if;
+ Set_Col (Ntab);
+ Put_Line ("values 1 .."
+ & Iir_Index32'Image (Value.Val_Array.Len)
+ & ':');
+ for I in Value.Val_Array.V'Range loop
+ Disp_Value_Tab (Value.Val_Array.V (I), Ntab);
+ end loop;
+ end;
+ end if;
+
+ when Iir_Value_Range =>
+ Put_Line ("range:");
+ Set_Col (Tab);
+ Put (" direction: ");
+ Put (Iir_Direction'Image (Value.Dir));
+ Put (", length:");
+ Put_Line (Iir_Index32'Image (Value.Length));
+ if Value.Left /= null then
+ Set_Col (Tab);
+ Put (" left bound: ");
+ Disp_Value_Tab (Value.Left, Col);
+ end if;
+ if Value.Right /= null then
+ Set_Col (Tab);
+ Put (" right bound: ");
+ Disp_Value_Tab (Value.Right, Col);
+ end if;
+
+ when Iir_Value_Record =>
+ Put_Line ("record:");
+ for I in Value.Val_Record.V'Range loop
+ Disp_Value_Tab (Value.Val_Record.V (I), Tab + Indentation);
+ end loop;
+ when Iir_Value_Signal =>
+ Put ("signal: ");
+ if Value.Sig = null then
+ Put_Line ("(not created)");
+ else
+ Put_Line (Image (Value.Sig.all'Address));
+ end if;
+
+ when Iir_Value_File =>
+ Put_Line ("file:" & Grt.Files.Ghdl_File_Index'Image (Value.File));
+ when Iir_Value_Protected =>
+ Put_Line ("protected");
+ when Iir_Value_Quantity =>
+ Put_Line ("quantity");
+ when Iir_Value_Terminal =>
+ Put_Line ("terminal");
+ end case;
+ end Disp_Value_Tab;
+
+ procedure Disp_Value (Value: Iir_Value_Literal_Acc) is
+ begin
+ Disp_Value_Tab (Value, 1);
+ end Disp_Value;
+
+ -- Return TRUE if VALUE has an indirect value.
+ function Is_Indirect (Value : Iir_Value_Literal_Acc) return Boolean is
+ begin
+ case Value.Kind is
+ when Iir_Value_Scalars
+ | Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ return False;
+ when Iir_Value_Range =>
+ return Is_Indirect (Value.Left)
+ or else Is_Indirect (Value.Right);
+ when Iir_Value_Array =>
+ for I in Value.Val_Array.V'Range loop
+ if Is_Indirect (Value.Val_Array.V (I)) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ when Iir_Value_Record =>
+ for I in Value.Val_Record.V'Range loop
+ if Is_Indirect (Value.Val_Record.V (I)) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ when Iir_Value_Signal =>
+ return True;
+ end case;
+ end Is_Indirect;
+
+ procedure Disp_Iir_Value_Array (Value: Iir_Value_Literal_Acc;
+ A_Type: Iir;
+ Dim: Iir_Index32;
+ Off : in out Iir_Index32)
+ is
+ use Ada.Text_IO;
+ type Last_Enum_Type is (None, Char, Identifier);
+ Last_Enum: Last_Enum_Type;
+ El_Type: Iir;
+ Enum_List: Iir_List;
+ El_Id : Name_Id;
+ El_Pos : Natural;
+ begin
+ if Dim = Value.Bounds.Nbr_Dims then
+ -- Last dimension
+ El_Type := Get_Base_Type (Get_Element_Subtype (A_Type));
+
+ -- Pretty print vectors of enumerated types
+ if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition
+ and then not Is_Indirect (Value)
+ then
+ Last_Enum := None;
+ Enum_List := Get_Enumeration_Literal_List (El_Type);
+ for I in 1 .. Value.Bounds.D (Dim).Length loop
+ El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off));
+ Off := Off + 1;
+ El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos));
+ if Name_Table.Is_Character (El_Id) then
+ case Last_Enum is
+ when None =>
+ Put ("""");
+ when Identifier =>
+ Put (" & """);
+ when Char =>
+ null;
+ end case;
+ Put (Name_Table.Get_Character (El_Id));
+ Last_Enum := Char;
+ else
+ case Last_Enum is
+ when None =>
+ null;
+ when Identifier =>
+ Put (" & ");
+ when Char =>
+ Put (""" & ");
+ end case;
+ Put (Name_Table.Image (El_Id));
+ Last_Enum := Identifier;
+ end if;
+ end loop;
+ case Last_Enum is
+ when None =>
+ Put ("""");
+ when Identifier =>
+ null;
+ when Char =>
+ Put ("""");
+ end case;
+ else
+ Put ("(");
+ for I in 1 .. Value.Bounds.D (Dim).Length loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Iir_Value (Value.Val_Array.V (Off), El_Type);
+ Off := Off + 1;
+ end loop;
+ Put (")");
+ end if;
+ else
+ Put ("(");
+ for I in 1 .. Value.Bounds.D (Dim).Length loop
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off);
+ end loop;
+ Put (")");
+ end if;
+ end Disp_Iir_Value_Array;
+
+ procedure Disp_Iir_Value_Record
+ (Value: Iir_Value_Literal_Acc; A_Type: Iir)
+ is
+ use Ada.Text_IO;
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Get_Base_Type (A_Type));
+ Put ("(");
+ for I in Value.Val_Record.V'Range loop
+ El := Get_Nth_Element (List, Natural (I - 1));
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Put (Name_Table.Image (Get_Identifier (El)));
+ Put (" => ");
+ Disp_Iir_Value (Value.Val_Record.V (I), Get_Type (El));
+ end loop;
+ Put (")");
+ end Disp_Iir_Value_Record;
+
+ procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir) is
+ use Ada.Text_IO;
+ begin
+ if Value = null then
+ Put ("!NULL!");
+ return;
+ end if;
+ case Value.Kind is
+ when Iir_Value_I64 =>
+ Put (Ghdl_I64'Image (Value.I64));
+ when Iir_Value_F64 =>
+ Put (Ghdl_F64'Image (Value.F64));
+ when Iir_Value_E32
+ | Iir_Value_B1 =>
+ declare
+ Bt : constant Iir := Get_Base_Type (A_Type);
+ Id : Name_Id;
+ Pos : Integer;
+ begin
+ if Value.Kind = Iir_Value_E32 then
+ Pos := Ghdl_E32'Pos (Value.E32);
+ else
+ Pos := Ghdl_B1'Pos (Value.B1);
+ end if;
+ Id := Get_Identifier
+ (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos));
+ Put (Name_Table.Image (Id));
+ end;
+ when Iir_Value_Access =>
+ if Value.Val_Access = null then
+ Put ("null");
+ else
+ -- FIXME.
+ Put ("*acc*");
+ end if;
+ when Iir_Value_Array =>
+ declare
+ Off : Iir_Index32;
+ begin
+ Off := 1;
+ Disp_Iir_Value_Array (Value, A_Type, 1, Off);
+ pragma Assert (Off = Value.Val_Array.Len + 1);
+ end;
+ when Iir_Value_File =>
+ raise Internal_Error;
+ when Iir_Value_Record =>
+ Disp_Iir_Value_Record (Value, A_Type);
+ when Iir_Value_Range =>
+ -- FIXME.
+ raise Internal_Error;
+ when Iir_Value_Quantity =>
+ Put ("[quantity]");
+ when Iir_Value_Terminal =>
+ Put ("[terminal]");
+ when Iir_Value_Signal =>
+ Put ("[signal]");
+ when Iir_Value_Protected =>
+ Put ("[protected]");
+ end case;
+ end Disp_Iir_Value;
+end Iir_Values;
diff --git a/src/simulate/iir_values.ads b/src/simulate/iir_values.ads
new file mode 100644
index 000000000..699ab883a
--- /dev/null
+++ b/src/simulate/iir_values.ads
@@ -0,0 +1,355 @@
+-- Naive values for interpreted simulation
+-- 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 Iirs; use Iirs;
+with Grt.Types; use Grt.Types;
+with Grt.Signals; use Grt.Signals;
+with Grt.Files;
+with Areapools; use Areapools;
+-- with System.Debug_Pools;
+
+package Iir_Values is
+ -- During simulation, all values are contained into objects of type
+ -- iir_value_literal. The annotation pass creates such objects for every
+ -- literal of units. The elaboration pass creates such objects for
+ -- signals, variables, contants...
+ -- The simulator uses iir_value_literal for intermediate results, for
+ -- computed values...
+
+ -- There is several kinds of iir_value_literal, mainly depending on the
+ -- type of the value:
+ --
+ -- iir_value_e32:
+ -- the value is an enumeration literal. The enum field contains the
+ -- position of the literal (same as 'pos).
+ --
+ -- iir_value_i64:
+ -- the value is an integer.
+ --
+ -- iir_value_f64:
+ -- the value is a floating point.
+ --
+ -- iir_value_range:
+ -- Boundaries and direction.
+ --
+ -- iir_value_array:
+ -- All the values are contained in the array Val_Array.
+ -- Boundaries of the array are contained in the array BOUNDS, one element
+ -- per dimension, from 1 to number of dimensions.
+ --
+ -- iir_value_signal:
+ -- Special case: the iir_value_literal designates a signal.
+ --
+ -- iir_value_record
+ -- For records.
+ --
+ -- iir_value_access
+ -- for accesses.
+ --
+ -- iir_value_file
+ -- for files.
+
+ -- Memory management:
+ -- The values are always allocated on areapool, which uses a mark/release
+ -- management. A release operation frees all the memory of the areapool
+ -- allocated since the mark. This memory management is very efficient.
+ --
+ -- There is one areapool per processes; there is one mark per instances.
+ -- Objects (variables, signals, constants, iterators, ...) are allocated
+ -- on the per-process pool. When an activation frame is created (due
+ -- to a call to a subprogram), a mark is saved. When the activation frame
+ -- is removed (due to a return from subprogram), the memory is released to
+ -- the mark. That's simple.
+ --
+ -- Objects for the process is allocated in that areapool, but never
+ -- released (could be if the process is waiting forever if the user don't
+ -- need to inspect values).
+ --
+ -- Signals and constants for blocks/entity/architecture are allocated on
+ -- a global pool.
+ --
+ -- In fact this is not so simple because of functions: they return a
+ -- value. The current solution is to compute every expressions on a
+ -- expression pool (only one is needed as the computation cannot be
+ -- suspended), use the result (copy in case of assignment or return), and
+ -- release that pool.
+ --
+ -- It is highly recommended to share values as much as possible for
+ -- expressions (for example, alias the values of 'others =>'). Do not
+ -- share values for names, but be sure to keep the original nodes.
+ -- ??? In fact sharing is required to pass actual by references.
+ -- When an object is created, be sure to unshare the values. This is
+ -- usually achieved by Copy.
+ --
+ -- Finally, a pool is also needed during elaboration (as elaboration is
+ -- not done within the context of a process).
+
+ type Iir_Value_Kind is
+ (Iir_Value_B1, Iir_Value_E32,
+ Iir_Value_I64, Iir_Value_F64,
+ Iir_Value_Access,
+ Iir_Value_File,
+ Iir_Value_Range,
+ Iir_Value_Array, Iir_Value_Record,
+ Iir_Value_Protected,
+ Iir_Value_Signal,
+ Iir_Value_Terminal,
+ Iir_Value_Quantity);
+
+ type Protected_Index_Type is new Natural;
+
+ type Quantity_Index_Type is new Natural;
+ type Terminal_Index_Type is new Natural;
+
+ -- Scalar values. Only these ones can be signals.
+ subtype Iir_Value_Scalars is
+ Iir_Value_Kind range Iir_Value_B1 .. Iir_Value_F64;
+
+ type Iir_Value_Literal (Kind: Iir_Value_Kind);
+
+ type Iir_Value_Literal_Acc is access Iir_Value_Literal;
+
+ -- Must start at 0.
+ -- Thus, length of the array is val_array'last - 1.
+ type Iir_Value_Literal_Array is array (Iir_Index32 range <>) of
+ Iir_Value_Literal_Acc;
+
+ type Iir_Value_Literal_Array_Acc is access Iir_Value_Literal_Array;
+
+ type Value_Bounds_Array (Nbr_Dims : Iir_Index32) is record
+ D : Iir_Value_Literal_Array (1 .. Nbr_Dims);
+ end record;
+
+ type Value_Bounds_Array_Acc is access Value_Bounds_Array;
+
+ type Value_Array (Len : Iir_Index32) is record
+ V : Iir_Value_Literal_Array (1 .. Len);
+ end record;
+
+ type Value_Array_Acc is access Value_Array;
+
+ type Iir_Value_Literal (Kind: Iir_Value_Kind) is record
+ case Kind is
+ when Iir_Value_B1 =>
+ B1 : Ghdl_B1;
+ when Iir_Value_E32 =>
+ E32 : Ghdl_E32;
+ when Iir_Value_I64 =>
+ I64 : Ghdl_I64;
+ when Iir_Value_F64 =>
+ F64 : Ghdl_F64;
+ when Iir_Value_Access =>
+ Val_Access: Iir_Value_Literal_Acc;
+ when Iir_Value_File =>
+ File: Grt.Files.Ghdl_File_Index;
+ when Iir_Value_Array =>
+ Val_Array: Value_Array_Acc; -- range 1 .. N
+ Bounds : Value_Bounds_Array_Acc; -- range 1 .. Dim
+ when Iir_Value_Record =>
+ Val_Record: Value_Array_Acc; -- range 1 .. N
+ when Iir_Value_Signal =>
+ Sig : Ghdl_Signal_Ptr;
+ when Iir_Value_Protected =>
+ Prot : Protected_Index_Type;
+ when Iir_Value_Quantity =>
+ Quantity : Quantity_Index_Type;
+ when Iir_Value_Terminal =>
+ Terminal : Terminal_Index_Type;
+ when Iir_Value_Range =>
+ Dir: Iir_Direction;
+ Length : Iir_Index32;
+ Left: Iir_Value_Literal_Acc;
+ Right: Iir_Value_Literal_Acc;
+ end case;
+ end record;
+
+ -- What is chosen for time.
+ -- Currently only int32 is available, but time should use an int64.
+ subtype Iir_Value_Time is Ghdl_I64;
+
+ Global_Pool : aliased Areapool;
+ Expr_Pool : aliased Areapool;
+
+ -- Areapool used by Create_*_Value
+ Current_Pool : Areapool_Acc := Expr_Pool'Access;
+
+ -- Pool for objects allocated in the current instance.
+ Instance_Pool : Areapool_Acc;
+
+ function Create_Signal_Value (Sig : Ghdl_Signal_Ptr)
+ return Iir_Value_Literal_Acc;
+
+ function Create_Terminal_Value (Terminal : Terminal_Index_Type)
+ return Iir_Value_Literal_Acc;
+
+ function Create_Quantity_Value (Quantity : Quantity_Index_Type)
+ return Iir_Value_Literal_Acc;
+
+ function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc;
+
+ function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc;
+
+ -- Return an iir_value_literal_acc (iir_value_int64).
+ function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc;
+
+ -- Return an iir_value_literal_acc (iir_value_fp64)
+ function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc;
+
+ function Create_Access_Value (Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ function Create_File_Value (Val : Grt.Files.Ghdl_File_Index)
+ return Iir_Value_Literal_Acc;
+
+ function Create_Protected_Value (Prot : Protected_Index_Type)
+ return Iir_Value_Literal_Acc;
+
+ -- Return an iir_value_literal (iir_value_record) of NBR elements.
+ function Create_Record_Value
+ (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc;
+
+ -- Allocate array and the dimension vector (but bounds and values aren't
+ -- allocated).
+ function Create_Array_Value (Dim : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc;
+
+ -- Allocate the Val_Array vector.
+ procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc;
+ Len : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool);
+
+ -- Return an array of length LENGTH and DIM bounds.
+ -- If DIM is 0, then the bounds array is not allocated.
+ function Create_Array_Value (Length: Iir_Index32;
+ Dim : Iir_Index32;
+ Pool : Areapool_Acc := Current_Pool)
+ return Iir_Value_Literal_Acc;
+
+ -- Create a range_value of life LIFE.
+ function Create_Range_Value
+ (Left, Right : Iir_Value_Literal_Acc;
+ Dir : Iir_Direction;
+ Length : Iir_Index32)
+ return Iir_Value_Literal_Acc;
+
+ -- Create a range_value (compute the length)
+ function Create_Range_Value
+ (Left, Right : Iir_Value_Literal_Acc;
+ Dir : Iir_Direction)
+ return Iir_Value_Literal_Acc;
+
+ -- Return true if the value of LEFT and RIGHT are equal.
+ -- Return false if they are not equal.
+ -- Raise constraint_error if the types differes.
+ -- Value or sub-value must not be indirect.
+ function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean;
+
+ -- Return TRUE iif ARANGE is a nul range.
+ function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean;
+
+ -- Get order of LEFT with RIGHT.
+ -- Must be discrete kind (enum, int, fp, physical) or array (uni dim).
+ type Order is (Less, Equal, Greater);
+ function Compare_Value (Left, Right : Iir_Value_Literal_Acc)
+ return Order;
+
+ -- Check that SRC has the same structure as DEST. Report an error at
+ -- LOC if not.
+ procedure Check_Bounds (Dest : Iir_Value_Literal_Acc;
+ Src : Iir_Value_Literal_Acc;
+ Loc : Iir);
+
+ -- Store (by copy) SRC into DEST.
+ -- The type must be equal (otherwise constraint_error is raised).
+ -- Life of DEST must be Target, otherwise program_error is raised.
+ -- Value or sub-value must not be indirect.
+ procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc);
+
+ -- Create a copy of SRC allocated in POOL.
+ function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- If SRC is an array, just copy the bounds in POOL and return it.
+ -- Otherwise return SRC. Values are always kept, so that this could
+ -- be used by alias declarations.
+ function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Create a copy of SRC on the heap.
+ function Unshare_Heap (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Deallocate value accessed by ACC.
+ procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc);
+
+ -- Increment.
+ -- VAL must be of kind integer or enumeration.
+ -- VAL must be of life temporary.
+ procedure Increment (Val : Iir_Value_Literal_Acc);
+
+ -- Copy BOUNDS of SRC with a specified life.
+ -- Note: val_array is allocated but not filled.
+ function Copy_Array_Bound (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Copy the bounds (well the array containing the values) of SRC.
+ -- Val_record is allocated but not filled.
+ function Copy_Record (Src : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Return the number of scalars elements in VALS.
+ function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural;
+
+ -- Return the position of an enumerated type value.
+ function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural;
+
+ -- Well known values.
+ -- Boolean_to_lit can be used to convert a boolean value from Ada to a
+ -- boolean value for vhdl.
+ type Lit_Enum_Type is array (Boolean) of Iir_Value_Literal_Acc;
+ Lit_Enum_0 : constant Iir_Value_Literal_Acc :=
+ new Iir_Value_Literal'(Kind => Iir_Value_B1,
+ B1 => False);
+ Lit_Enum_1 : constant Iir_Value_Literal_Acc :=
+ new Iir_Value_Literal'(Kind => Iir_Value_B1,
+ B1 => True);
+ Boolean_To_Lit: constant Lit_Enum_Type :=
+ (False => Lit_Enum_0, True => Lit_Enum_1);
+ Lit_Boolean_False: Iir_Value_Literal_Acc
+ renames Boolean_To_Lit (False);
+ Lit_Boolean_True: Iir_Value_Literal_Acc
+ renames Boolean_To_Lit (True);
+
+ -- Literal NULL.
+ Null_Lit: constant Iir_Value_Literal_Acc :=
+ new Iir_Value_Literal'(Kind => Iir_Value_Access,
+ Val_Access => null);
+
+ -- Disp a value_literal in raw form.
+ procedure Disp_Value (Value: Iir_Value_Literal_Acc);
+ procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc;
+ Tab: Ada.Text_IO.Count);
+
+ -- Disp a value_literal in readable form.
+ procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir);
+end Iir_Values;
+
diff --git a/src/simulate/sim_be.adb b/src/simulate/sim_be.adb
new file mode 100644
index 000000000..49a146879
--- /dev/null
+++ b/src/simulate/sim_be.adb
@@ -0,0 +1,117 @@
+-- Interpreter back-end
+-- 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 Sem;
+with Canon;
+with Annotations;
+with Disp_Tree;
+with Errorout; use Errorout;
+with Flags;
+with Disp_Vhdl;
+with Post_Sems;
+
+package body Sim_Be is
+ procedure Finish_Compilation (Unit: Iir_Design_Unit; Main: Boolean := False)
+ is
+ use Ada.Text_IO;
+ Lib_Unit : Iir;
+ begin
+ Lib_Unit := Get_Library_Unit (Unit);
+ -- Semantic analysis.
+ if Flags.Verbose then
+ Put_Line ("semantize " & Disp_Node (Lib_Unit));
+ end if;
+ Sem.Semantic (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Sem then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Sem then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ -- Post checks
+ ----------------
+
+ Post_Sems.Post_Sem_Checks (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+
+ -- Canonicalisation.
+ ------------------
+ if Flags.Verbose then
+ Put_Line ("canonicalize " & Disp_Node (Lib_Unit));
+ end if;
+
+ Canon.Canonicalize (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ if Flags.Flag_Elaborate then
+ if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then
+ declare
+ Config : Iir_Design_Unit;
+ begin
+ Config := Canon.Create_Default_Configuration_Declaration
+ (Lib_Unit);
+ Set_Default_Configuration_Declaration (Lib_Unit, Config);
+ if (Main or Flags.Dump_All) and then Flags.Dump_Canon then
+ Disp_Tree.Disp_Tree (Config);
+ end if;
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Config);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Annotation.
+ -------------
+ if Flags.Verbose then
+ Put_Line ("annotate " & Disp_Node (Lib_Unit));
+ end if;
+
+ Annotations.Annotate (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Annotate then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+ if (Main or Flags.Dump_All) and then Flags.Dump_Annotate then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+ end Finish_Compilation;
+end Sim_Be;
diff --git a/src/simulate/sim_be.ads b/src/simulate/sim_be.ads
new file mode 100644
index 000000000..9256c4b68
--- /dev/null
+++ b/src/simulate/sim_be.ads
@@ -0,0 +1,25 @@
+-- Interpreter back-end
+-- 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 Iirs; use Iirs;
+
+package Sim_Be is
+ procedure Finish_Compilation
+ (Unit: Iir_Design_Unit; Main: Boolean := False);
+end Sim_Be;
+
diff --git a/src/simulate/simulation-ams-debugger.adb b/src/simulate/simulation-ams-debugger.adb
new file mode 100644
index 000000000..9cdbc75b2
--- /dev/null
+++ b/src/simulate/simulation-ams-debugger.adb
@@ -0,0 +1,87 @@
+-- Interpreter AMS simulation
+-- 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 Debugger; use Debugger;
+with Iirs_Utils; use Iirs_Utils;
+with Ada.Text_IO; use Ada.Text_IO;
+with Disp_Vhdl;
+
+package body Simulation.AMS.Debugger is
+ procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type)
+ is
+ Obj : Scalar_Quantity renames Scalar_Quantities.Table (Quantity);
+ begin
+ Disp_Instance_Name (Obj.Instance, True);
+ Put ('.');
+ Put (Image_Identifier (Obj.Decl));
+ if Obj.Kind = Quantity_Reference then
+ Put ("'Ref");
+ end if;
+ end Disp_Quantity_Name;
+
+ procedure Disp_Term (Term : Ams_Term_Acc) is
+ begin
+ case Term.Sign is
+ when Op_Plus =>
+ Put (" + ");
+ when Op_Minus =>
+ Put (" - ");
+ end case;
+
+ case Term.Op is
+ when Op_Quantity =>
+ Disp_Quantity_Name (Term.Quantity);
+ when Op_Vhdl_Expr =>
+ Disp_Vhdl.Disp_Expression (Term.Vhdl_Expr);
+ end case;
+ end Disp_Term;
+
+ procedure Disp_Characteristic_Expression
+ (Ce : Characteristic_Expressions_Index)
+ is
+ Obj : Characteristic_Expr renames
+ Characteristic_Expressions.Table (Ce);
+ Expr : Ams_Term_Acc := Obj.Expr;
+ begin
+ case Obj.Kind is
+ when Explicit =>
+ Put ("Explic:");
+ when Contribution =>
+ Put ("Contri:");
+ when Structural =>
+ Put ("Struct:");
+ end case;
+
+ while Expr /= null loop
+ Disp_Term (Expr);
+ Expr := Expr.Next;
+ end loop;
+ New_Line;
+ end Disp_Characteristic_Expression;
+
+ procedure Disp_Characteristic_Expressions is
+ begin
+ Put_Line ("Characteristic expressions:");
+ for I in Characteristic_Expressions.First
+ .. Characteristic_Expressions.Last
+ loop
+ Disp_Characteristic_Expression (I);
+ end loop;
+ end Disp_Characteristic_Expressions;
+end Simulation.AMS.Debugger;
+
diff --git a/src/simulate/simulation-ams-debugger.ads b/src/simulate/simulation-ams-debugger.ads
new file mode 100644
index 000000000..0cfcdedc7
--- /dev/null
+++ b/src/simulate/simulation-ams-debugger.ads
@@ -0,0 +1,27 @@
+-- Interpreter AMS simulation
+-- 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 Simulation.AMS.Debugger is
+ procedure Disp_Quantity_Name (Quantity : Quantity_Index_Type);
+
+ procedure Disp_Characteristic_Expression
+ (Ce : Characteristic_Expressions_Index);
+
+ procedure Disp_Characteristic_Expressions;
+end Simulation.AMS.Debugger;
+
diff --git a/src/simulate/simulation-ams.adb b/src/simulate/simulation-ams.adb
new file mode 100644
index 000000000..31dd43e0e
--- /dev/null
+++ b/src/simulate/simulation-ams.adb
@@ -0,0 +1,201 @@
+-- Interpreter AMS simulation
+-- 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 Errorout; use Errorout;
+
+package body Simulation.AMS is
+ function Create_Characteristic_Expression
+ (Kind : Characteristic_Expr_Kind)
+ return Characteristic_Expressions_Index
+ is
+ begin
+ case Kind is
+ when Contribution =>
+ Characteristic_Expressions.Append
+ ((Kind => Contribution,
+ Expr => null,
+ Tolerance => 0,
+ Dependencies => null));
+ when others =>
+ raise Program_Error;
+ end case;
+ return Characteristic_Expressions.Last;
+ end Create_Characteristic_Expression;
+
+ function Create_Scalar_Quantity (Kind : Quantity_Kind;
+ Decl : Iir;
+ Instance : Block_Instance_Acc)
+ return Quantity_Index_Type
+ is
+ begin
+ case Kind is
+ when Quantity_Reference =>
+ Scalar_Quantities.Append
+ ((Kind => Quantity_Reference,
+ Value => 0.0,
+ Decl => Decl,
+ Instance => Instance,
+ Contribution =>
+ Create_Characteristic_Expression (Contribution)));
+ when Quantity_Across =>
+ Scalar_Quantities.Append
+ ((Kind => Quantity_Across,
+ Value => 0.0,
+ Decl => Decl,
+ Instance => Instance));
+ when Quantity_Through =>
+ Scalar_Quantities.Append
+ ((Kind => Quantity_Through,
+ Value => 0.0,
+ Decl => Decl,
+ Instance => Instance));
+ when others =>
+ raise Program_Error;
+ end case;
+ return Scalar_Quantities.Last;
+ end Create_Scalar_Quantity;
+
+ function Create_Scalar_Terminal (Decl : Iir;
+ Instance : Block_Instance_Acc)
+ return Terminal_Index_Type
+ is
+ begin
+ -- Simply create the reference quantity for a terminal
+ return Terminal_Index_Type
+ (Create_Scalar_Quantity (Quantity_Reference, Decl, Instance));
+ end Create_Scalar_Terminal;
+
+ function Get_Terminal_Reference (Terminal : Terminal_Index_Type)
+ return Quantity_Index_Type is
+ begin
+ return Quantity_Index_Type (Terminal);
+ end Get_Terminal_Reference;
+
+ procedure Add_Characteristic_Expression
+ (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc)
+ is
+ begin
+ Characteristic_Expressions.Append
+ ((Kind => Kind,
+ Expr => Expr,
+ Tolerance => Default_Tolerance_Index,
+ Dependencies => null));
+ end Add_Characteristic_Expression;
+
+ procedure Compute_Dependencies (Idx : Characteristic_Expressions_Index)
+ is
+ package Quantity_Table is new GNAT.Table
+ (Table_Component_Type => Quantity_Index_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ El : Characteristic_Expr renames Characteristic_Expressions.Table (Idx);
+ Res : Quantity_Dependency_Acc := null;
+
+ procedure Add_Dependency (Block : Block_Instance_Acc; N : Iir)
+ is
+ Q : Iir_Value_Literal_Acc;
+ begin
+ case Get_Kind (N) is
+ when Iir_Kinds_Branch_Quantity_Declaration =>
+ Q := Execute_Name (Block, N, True);
+ Quantity_Table.Append (Q.Quantity);
+ when Iir_Kind_Simple_Name =>
+ Add_Dependency (Block, Get_Named_Entity (N));
+ when Iir_Kinds_Dyadic_Operator =>
+ Add_Dependency (Block, Get_Left (N));
+ Add_Dependency (Block, Get_Right (N));
+ when Iir_Kinds_Literal =>
+ null;
+ when others =>
+ Error_Kind ("compute_dependencies", N);
+ end case;
+ end Add_Dependency;
+
+ Term : Ams_Term_Acc := El.Expr;
+ begin
+ pragma Assert (El.Dependencies = null);
+
+ while Term /= null loop
+ case Term.Op is
+ when Op_Quantity =>
+ Quantity_Table.Append (Term.Quantity);
+ when Op_Vhdl_Expr =>
+ Add_Dependency (Term.Vhdl_Instance, Term.Vhdl_Expr);
+ end case;
+ Term := Term.Next;
+ end loop;
+ Res := new Quantity_Dependency_Type (Nbr => Quantity_Table.Last);
+ for I in Quantity_Table.First .. Quantity_Table.Last loop
+ Res.Quantities (I) := Quantity_Table.Table (I);
+ end loop;
+ Quantity_Table.Free;
+ El.Dependencies := Res;
+ end Compute_Dependencies;
+
+ function Build (Op : Ams_Sign;
+ Val : Quantity_Index_Type;
+ Right : Ams_Term_Acc := null)
+ return Ams_Term_Acc
+ is
+ begin
+ return new Ams_Term'(Op => Op_Quantity,
+ Sign => Op,
+ Next => Right,
+ Quantity => Val);
+ end Build;
+
+ function Build (Op : Ams_Sign;
+ Instance : Block_Instance_Acc;
+ Expr : Iir;
+ Right : Ams_Term_Acc := null)
+ return Ams_Term_Acc
+ is
+ begin
+ return new Ams_Term'
+ (Op => Op_Vhdl_Expr,
+ Sign => Op,
+ Vhdl_Expr => Expr,
+ Vhdl_Instance => Instance,
+ Next => Right);
+ end Build;
+
+ procedure Append_Characteristic_Expression
+ (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc)
+ is
+ Ref : constant Quantity_Index_Type := Get_Terminal_Reference (Terminal);
+ Ce : constant Characteristic_Expressions_Index :=
+ Scalar_Quantities.Table (Ref).Contribution;
+ begin
+ pragma Assert (Expr.Next = null);
+ Expr.Next := Characteristic_Expressions.Table (Ce).Expr;
+ Characteristic_Expressions.Table (Ce).Expr := Expr;
+ end Append_Characteristic_Expression;
+
+ procedure Create_Tables is
+ begin
+ for I in Characteristic_Expressions.First
+ .. Characteristic_Expressions.Last
+ loop
+ Compute_Dependencies (I);
+ end loop;
+ end Create_Tables;
+end Simulation.AMS;
+
diff --git a/src/simulate/simulation-ams.ads b/src/simulate/simulation-ams.ads
new file mode 100644
index 000000000..8ca513652
--- /dev/null
+++ b/src/simulate/simulation-ams.ads
@@ -0,0 +1,165 @@
+-- Interpreter AMS simulation
+-- 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 GNAT.Table;
+
+package Simulation.AMS is
+ -- AMS expressions
+ --
+ -- At many places during elaboration, the LRM defines characteristic
+ -- expressions that aren't present in source code:
+ -- * contribution expression (12.3.1.4)
+ -- * characteristic expression for an across quantity declaration
+ -- (12.3.1.4)
+ -- * characteristic expression for simple simultaneous statement (the
+ -- expression is in the source in that case) (15.1)
+ --
+ -- They are represented using a list of Ams_Expression elements. The value
+ -- is the sum of each element, using the + or - sign.
+
+ type Ams_Sign is (Op_Plus, Op_Minus);
+ -- Sign for the operand
+
+ type Ams_Operand is (Op_Quantity, Op_Vhdl_Expr);
+ -- The operand is one of:
+ -- Op_Quantity: a quantity
+ -- Op_Vhdl_Expr: an expression from the design. This expression may contain
+ -- quantities
+
+ type Ams_Term (<>) is private;
+ type Ams_Term_Acc is access Ams_Term;
+ -- A term of a characteristic expression
+
+ type Characteristic_Expr_Kind is
+ (Explicit,
+ Contribution,
+ Structural);
+
+ type Tolerance_Index_Type is new Natural;
+ Default_Tolerance_Index : constant Tolerance_Index_Type := 0;
+ -- Tolerance
+
+ type Characteristic_Expressions_Index is new Natural;
+
+ type Quantity_Kind is
+ (Quantity_Reference,
+ -- The potential of a terminal. This is an across quantity between the
+ -- terminal and the reference terminal of the nature.
+
+ Quantity_Across,
+ Quantity_Through,
+ Quantity_Free
+ -- Explicitly declared quantities
+ );
+
+ function Create_Scalar_Quantity (Kind : Quantity_Kind;
+ Decl : Iir;
+ Instance : Block_Instance_Acc)
+ return Quantity_Index_Type;
+ -- Create a new scalar quantity
+
+ function Create_Scalar_Terminal (Decl : Iir;
+ Instance : Block_Instance_Acc)
+ return Terminal_Index_Type;
+ -- Create a new scalar terminal
+
+ function Get_Terminal_Reference (Terminal : Terminal_Index_Type)
+ return Quantity_Index_Type;
+ -- Get the reference quantity of a terminal
+
+ procedure Add_Characteristic_Expression
+ (Kind : Characteristic_Expr_Kind; Expr : Ams_Term_Acc);
+ -- Add a new characteristic expression
+
+ function Build (Op : Ams_Sign;
+ Val : Quantity_Index_Type;
+ Right : Ams_Term_Acc := null)
+ return Ams_Term_Acc;
+ function Build (Op : Ams_Sign;
+ Instance : Block_Instance_Acc;
+ Expr : Iir;
+ Right : Ams_Term_Acc := null)
+ return Ams_Term_Acc;
+ -- Build a term of a characteristic expression
+
+ procedure Append_Characteristic_Expression
+ (Terminal : Terminal_Index_Type; Expr : Ams_Term_Acc);
+ -- Append an expression to the contribution of a terminal
+
+ procedure Create_Tables;
+private
+ type Quantity_Index_Array is array (Positive range <>)
+ of Quantity_Index_Type;
+
+ type Quantity_Dependency_Type (Nbr : Natural);
+ type Quantity_Dependency_Acc is access Quantity_Dependency_Type;
+
+ type Quantity_Dependency_Type (Nbr : Natural) is record
+ Quantities : Quantity_Index_Array (1 .. Nbr);
+ end record;
+
+ type Ams_Term (Op : Ams_Operand) is record
+ Sign : Ams_Sign;
+ Next : Ams_Term_Acc;
+
+ case Op is
+ when Op_Quantity =>
+ Quantity : Quantity_Index_Type;
+ when Op_Vhdl_Expr =>
+ Vhdl_Expr : Iir;
+ Vhdl_Instance : Block_Instance_Acc;
+ end case;
+ end record;
+
+ type Characteristic_Expr is record
+ Kind : Characteristic_Expr_Kind;
+ Expr : Ams_Term_Acc;
+ Tolerance : Tolerance_Index_Type;
+ Dependencies : Quantity_Dependency_Acc;
+ end record;
+
+ package Characteristic_Expressions is new Gnat.Table
+ (Table_Index_Type => Characteristic_Expressions_Index,
+ Table_Component_Type => Characteristic_Expr,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ type Scalar_Quantity (Kind : Quantity_Kind := Quantity_Reference) is record
+ Value : Ghdl_F64;
+ -- The value of the quantity
+
+ Decl : Iir;
+ Instance : Block_Instance_Acc;
+ -- Declaration for the quantity
+
+ case Kind is
+ when Quantity_Reference =>
+ Contribution : Characteristic_Expressions_Index;
+ when others =>
+ null;
+ end case;
+ end record;
+
+ package Scalar_Quantities is new Gnat.Table
+ (Table_Index_Type => Quantity_Index_Type,
+ Table_Component_Type => Scalar_Quantity,
+ Table_Low_Bound => 1,
+ Table_Initial => 128,
+ Table_Increment => 100);
+end Simulation.AMS;
diff --git a/src/simulate/simulation.adb b/src/simulate/simulation.adb
new file mode 100644
index 000000000..3f3f8715b
--- /dev/null
+++ b/src/simulate/simulation.adb
@@ -0,0 +1,1669 @@
+-- Interpreted simulation
+-- 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.Unchecked_Conversion;
+with Ada.Text_IO; use Ada.Text_IO;
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+with Trans_Analyzes;
+with Types; use Types;
+with Debugger; use Debugger;
+with Simulation.AMS.Debugger;
+with Areapools; use Areapools;
+with Grt.Stacks;
+with Grt.Signals;
+with Grt.Processes;
+with Grt.Main;
+with Grt.Errors;
+with Grt.Rtis;
+
+package body Simulation is
+
+ function Value_To_Iir_Value (Mode : Mode_Type; Val : Value_Union)
+ return Iir_Value_Literal_Acc is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ return Create_B1_Value (Val.B1);
+ when Mode_E32 =>
+ return Create_E32_Value (Val.E32);
+ when Mode_I64 =>
+ return Create_I64_Value (Val.I64);
+ when Mode_F64 =>
+ return Create_F64_Value (Val.F64);
+ when others =>
+ raise Internal_Error; -- FIXME
+ end case;
+ end Value_To_Iir_Value;
+
+ procedure Iir_Value_To_Value (Src : Iir_Value_Literal_Acc;
+ Dst : out Value_Union) is
+ begin
+ case Src.Kind is
+ when Iir_Value_B1 =>
+ Dst.B1 := Src.B1;
+ when Iir_Value_E32 =>
+ Dst.E32 := Src.E32;
+ when Iir_Value_I64 =>
+ Dst.I64 := Src.I64;
+ when Iir_Value_F64 =>
+ Dst.F64 := Src.F64;
+ when others =>
+ raise Internal_Error; -- FIXME
+ end case;
+ end Iir_Value_To_Value;
+
+ type Read_Signal_Flag_Enum is
+ (Read_Signal_Event,
+ Read_Signal_Active,
+ -- In order to reuse the same code (that returns immediately if the
+ -- attribute is true), we use not driving.
+ Read_Signal_Not_Driving);
+
+ function Read_Signal_Flag (Lit: Iir_Value_Literal_Acc;
+ Kind : Read_Signal_Flag_Enum)
+ return Boolean
+ is
+ begin
+ case Lit.Kind is
+ when Iir_Value_Array =>
+ for I in Lit.Val_Array.V'Range loop
+ if Read_Signal_Flag (Lit.Val_Array.V (I), Kind) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ when Iir_Value_Record =>
+ for I in Lit.Val_Record.V'Range loop
+ if Read_Signal_Flag (Lit.Val_Record.V (I), Kind) then
+ return True;
+ end if;
+ end loop;
+ return False;
+ when Iir_Value_Signal =>
+ case Kind is
+ when Read_Signal_Event =>
+ return Lit.Sig.Event;
+ when Read_Signal_Active =>
+ return Lit.Sig.Active;
+ when Read_Signal_Not_Driving =>
+ if Grt.Signals.Ghdl_Signal_Driving (Lit.Sig) = True then
+ return False;
+ else
+ return True;
+ end if;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Read_Signal_Flag;
+
+ function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean is
+ begin
+ return Read_Signal_Flag (Lit, Read_Signal_Event);
+ end Execute_Event_Attribute;
+
+ function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean is
+ begin
+ return Read_Signal_Flag (Lit, Read_Signal_Active);
+ end Execute_Active_Attribute;
+
+ function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean is
+ begin
+ return not Read_Signal_Flag (Lit, Read_Signal_Not_Driving);
+ end Execute_Driving_Attribute;
+
+ type Read_Signal_Value_Enum is
+ (Read_Signal_Last_Value,
+
+ -- For conversion functions.
+ Read_Signal_Driving_Value,
+ Read_Signal_Effective_Value,
+
+ -- 'Driving_Value
+ Read_Signal_Driver_Value);
+
+ function Execute_Read_Signal_Value (Sig: Iir_Value_Literal_Acc;
+ Attr : Read_Signal_Value_Enum)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ begin
+ case Sig.Kind is
+ when Iir_Value_Array =>
+ Res := Copy_Array_Bound (Sig);
+ for I in Sig.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Execute_Read_Signal_Value (Sig.Val_Array.V (I), Attr);
+ end loop;
+ return Res;
+ when Iir_Value_Record =>
+ Res := Create_Record_Value (Sig.Val_Record.Len);
+ for I in Sig.Val_Record.V'Range loop
+ Res.Val_Record.V (I) :=
+ Execute_Read_Signal_Value (Sig.Val_Record.V (I), Attr);
+ end loop;
+ return Res;
+ when Iir_Value_Signal =>
+ case Attr is
+ when Read_Signal_Last_Value =>
+ return Value_To_Iir_Value
+ (Sig.Sig.Mode, Sig.Sig.Last_Value);
+ when Read_Signal_Driver_Value =>
+ case Sig.Sig.Mode is
+ when Mode_F64 =>
+ return Create_F64_Value
+ (Grt.Signals.Ghdl_Signal_Driving_Value_F64
+ (Sig.Sig));
+ when Mode_I64 =>
+ return Create_I64_Value
+ (Grt.Signals.Ghdl_Signal_Driving_Value_I64
+ (Sig.Sig));
+ when Mode_E32 =>
+ return Create_E32_Value
+ (Grt.Signals.Ghdl_Signal_Driving_Value_E32
+ (Sig.Sig));
+ when Mode_B1 =>
+ return Create_B1_Value
+ (Grt.Signals.Ghdl_Signal_Driving_Value_B1
+ (Sig.Sig));
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Read_Signal_Effective_Value =>
+ return Value_To_Iir_Value
+ (Sig.Sig.Mode, Sig.Sig.Value);
+ when Read_Signal_Driving_Value =>
+ return Value_To_Iir_Value
+ (Sig.Sig.Mode, Sig.Sig.Driving_Value);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Read_Signal_Value;
+
+ type Write_Signal_Enum is
+ (Write_Signal_Driving_Value,
+ Write_Signal_Effective_Value);
+
+ procedure Execute_Write_Signal (Sig: Iir_Value_Literal_Acc;
+ Val : Iir_Value_Literal_Acc;
+ Attr : Write_Signal_Enum) is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Array =>
+ pragma Assert (Val.Kind = Iir_Value_Array);
+ pragma Assert (Sig.Val_Array.Len = Val.Val_Array.Len);
+ for I in Sig.Val_Array.V'Range loop
+ Execute_Write_Signal
+ (Sig.Val_Array.V (I), Val.Val_Array.V (I), Attr);
+ end loop;
+ when Iir_Value_Record =>
+ pragma Assert (Val.Kind = Iir_Value_Record);
+ pragma Assert (Sig.Val_Record.Len = Val.Val_Record.Len);
+ for I in Sig.Val_Record.V'Range loop
+ Execute_Write_Signal
+ (Sig.Val_Record.V (I), Val.Val_Record.V (I), Attr);
+ end loop;
+ when Iir_Value_Signal =>
+ pragma Assert (Val.Kind in Iir_Value_Scalars);
+ case Attr is
+ when Write_Signal_Driving_Value =>
+ Iir_Value_To_Value (Val, Sig.Sig.Driving_Value);
+ when Write_Signal_Effective_Value =>
+ Iir_Value_To_Value (Val, Sig.Sig.Value);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Write_Signal;
+
+ function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Execute_Read_Signal_Value (Indirect, Read_Signal_Last_Value);
+ end Execute_Last_Value_Attribute;
+
+ function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ return Execute_Read_Signal_Value (Indirect, Read_Signal_Driver_Value);
+ end Execute_Driving_Value_Attribute;
+
+ type Signal_Read_Last_Type is
+ (Read_Last_Event,
+ Read_Last_Active);
+
+ -- Return the Last_Event absolute time.
+ function Execute_Read_Signal_Last (Indirect: Iir_Value_Literal_Acc;
+ Kind : Signal_Read_Last_Type)
+ return Ghdl_I64
+ is
+ Res: Ghdl_I64;
+ begin
+ case Indirect.Kind is
+ when Iir_Value_Array =>
+ Res := Ghdl_I64'First;
+ for I in Indirect.Val_Array.V'Range loop
+ Res := Ghdl_I64'Max
+ (Res, Execute_Read_Signal_Last (Indirect.Val_Array.V (I),
+ Kind));
+ end loop;
+ return Res;
+ when Iir_Value_Signal =>
+ case Kind is
+ when Read_Last_Event =>
+ return Ghdl_I64 (Indirect.Sig.Last_Event);
+ when Read_Last_Active =>
+ return Ghdl_I64 (Indirect.Sig.Last_Active);
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Read_Signal_Last;
+
+ function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Ghdl_I64 is
+ begin
+ return Execute_Read_Signal_Last (Indirect, Read_Last_Event);
+ end Execute_Last_Event_Attribute;
+
+ function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Ghdl_I64 is
+ begin
+ return Execute_Read_Signal_Last (Indirect, Read_Last_Active);
+ end Execute_Last_Active_Attribute;
+
+ function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ Res: Iir_Value_Literal_Acc;
+ begin
+ case Indirect.Kind is
+ when Iir_Value_Array =>
+ Res := Copy_Array_Bound (Indirect);
+ for I in Indirect.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Execute_Signal_Value (Indirect.Val_Array.V (I));
+ end loop;
+ return Res;
+ when Iir_Value_Record =>
+ Res := Create_Record_Value (Indirect.Val_Record.Len);
+ for I in Indirect.Val_Record.V'Range loop
+ Res.Val_Record.V (I) :=
+ Execute_Signal_Value (Indirect.Val_Record.V (I));
+ end loop;
+ return Res;
+ when Iir_Value_Signal =>
+ return Value_To_Iir_Value (Indirect.Sig.Mode, Indirect.Sig.Value);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Execute_Signal_Value;
+
+ procedure Assign_Value_To_Array_Signal
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Transactions: Transaction_Type)
+ is
+ Sub_Trans : Transaction_Type (Transactions.Len);
+ begin
+ Sub_Trans.Stmt := Transactions.Stmt;
+ Sub_Trans.Reject := Transactions.Reject;
+
+ for J in Target.Val_Array.V'Range loop
+ for K in Transactions.Els'Range loop
+ declare
+ T : Transaction_El_Type renames Transactions.Els (K);
+ S : Transaction_El_Type renames Sub_Trans.Els (K);
+ begin
+ S.After := T.After;
+
+ if T.Value = null then
+ S.Value := null;
+ else
+ S.Value := T.Value.Val_Array.V (J);
+ end if;
+ end;
+ end loop;
+
+ Assign_Value_To_Signal
+ (Instance, Target.Val_Array.V (J), Sub_Trans);
+ end loop;
+ end Assign_Value_To_Array_Signal;
+
+ procedure Assign_Value_To_Record_Signal
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Transactions: Transaction_Type)
+ is
+ Sub_Trans : Transaction_Type (Transactions.Len);
+ begin
+ Sub_Trans.Stmt := Transactions.Stmt;
+ Sub_Trans.Reject := Transactions.Reject;
+
+ for J in Target.Val_Record.V'Range loop
+ for K in Transactions.Els'Range loop
+ declare
+ T : Transaction_El_Type renames Transactions.Els (K);
+ S : Transaction_El_Type renames Sub_Trans.Els (K);
+ begin
+ S.After := T.After;
+
+ if T.Value = null then
+ S.Value := null;
+ else
+ S.Value := T.Value.Val_Record.V (J);
+ end if;
+ end;
+ end loop;
+
+ Assign_Value_To_Signal
+ (Instance, Target.Val_Record.V (J), Sub_Trans);
+ end loop;
+ end Assign_Value_To_Record_Signal;
+
+ procedure Assign_Value_To_Scalar_Signal
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Transactions: Transaction_Type)
+ is
+ pragma Unreferenced (Instance);
+ use Grt.Signals;
+ begin
+ declare
+ El : Transaction_El_Type renames Transactions.Els (1);
+ begin
+ if El.Value = null then
+ Ghdl_Signal_Start_Assign_Null
+ (Target.Sig, Transactions.Reject, El.After);
+ if Transactions.Els'Last /= 1 then
+ raise Internal_Error;
+ end if;
+ return;
+ end if;
+
+ -- FIXME: null transaction, check constraints.
+ case Iir_Value_Scalars (El.Value.Kind) is
+ when Iir_Value_B1 =>
+ Ghdl_Signal_Start_Assign_B1
+ (Target.Sig, Transactions.Reject, El.Value.B1, El.After);
+ when Iir_Value_E32 =>
+ Ghdl_Signal_Start_Assign_E32
+ (Target.Sig, Transactions.Reject, El.Value.E32, El.After);
+ when Iir_Value_I64 =>
+ Ghdl_Signal_Start_Assign_I64
+ (Target.Sig, Transactions.Reject, El.Value.I64, El.After);
+ when Iir_Value_F64 =>
+ Ghdl_Signal_Start_Assign_F64
+ (Target.Sig, Transactions.Reject, El.Value.F64, El.After);
+ end case;
+ end;
+
+ for I in 2 .. Transactions.Els'Last loop
+ declare
+ El : Transaction_El_Type renames Transactions.Els (I);
+ begin
+ case Iir_Value_Scalars (El.Value.Kind) is
+ when Iir_Value_B1 =>
+ Ghdl_Signal_Next_Assign_B1
+ (Target.Sig, El.Value.B1, El.After);
+ when Iir_Value_E32 =>
+ Ghdl_Signal_Next_Assign_E32
+ (Target.Sig, El.Value.E32, El.After);
+ when Iir_Value_I64 =>
+ Ghdl_Signal_Next_Assign_I64
+ (Target.Sig, El.Value.I64, El.After);
+ when Iir_Value_F64 =>
+ Ghdl_Signal_Next_Assign_F64
+ (Target.Sig, El.Value.F64, El.After);
+ end case;
+ end;
+ end loop;
+ end Assign_Value_To_Scalar_Signal;
+
+ procedure Assign_Value_To_Signal
+ (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Transaction: Transaction_Type)
+ is
+ begin
+ case Target.Kind is
+ when Iir_Value_Array =>
+ Assign_Value_To_Array_Signal
+ (Instance, Target, Transaction);
+ when Iir_Value_Record =>
+ Assign_Value_To_Record_Signal
+ (Instance, Target, Transaction);
+ when Iir_Value_Signal =>
+ Assign_Value_To_Scalar_Signal
+ (Instance, Target, Transaction);
+ when Iir_Value_Scalars
+ | Iir_Value_Range
+ | Iir_Value_File
+ | Iir_Value_Access
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Assign_Value_To_Signal;
+
+ procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc) is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Array =>
+ for I in Sig.Val_Array.V'Range loop
+ Disconnect_Signal (Sig.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Sig.Val_Array.V'Range loop
+ Disconnect_Signal (Sig.Val_Record.V (I));
+ end loop;
+ when Iir_Value_Signal =>
+ Grt.Signals.Ghdl_Signal_Disconnect (Sig.Sig);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Disconnect_Signal;
+
+ -- Call Ghdl_Process_Wait_Add_Sensitivity for each scalar subelement of
+ -- SIG.
+ procedure Wait_Add_Sensitivity (Sig: Iir_Value_Literal_Acc)
+ is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Signal =>
+ Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity (Sig.Sig);
+ when Iir_Value_Array =>
+ for I in Sig.Val_Array.V'Range loop
+ Wait_Add_Sensitivity (Sig.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Sig.Val_Record.V'Range loop
+ Wait_Add_Sensitivity (Sig.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Wait_Add_Sensitivity;
+
+ -- Return true if the process should be suspended.
+ function Execute_Wait_Statement (Instance : Block_Instance_Acc;
+ Stmt: Iir_Wait_Statement)
+ return Boolean
+ is
+ Expr: Iir;
+ El : Iir;
+ List: Iir_List;
+ Res: Iir_Value_Literal_Acc;
+ Status : Boolean;
+ Marker : Mark_Type;
+ begin
+ if not Instance.In_Wait_Flag then
+ Mark (Marker, Expr_Pool);
+
+ -- LRM93 8.1
+ -- The execution of a wait statement causes the time expression to
+ -- be evaluated to determine the timeout interval.
+ Expr := Get_Timeout_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Res := Execute_Expression (Instance, Expr);
+ Grt.Processes.Ghdl_Process_Wait_Set_Timeout (Std_Time (Res.I64));
+ end if;
+
+ -- LRM93 8.1
+ -- The suspended process may also resume as a result of an event
+ -- occuring on any signal in the sensitivity set of the wait
+ -- statement.
+ List := Get_Sensitivity_List (Stmt);
+ if List /= Null_Iir_List then
+ for J in Natural loop
+ El := Get_Nth_Element (List, J);
+ exit when El = Null_Iir;
+ Wait_Add_Sensitivity (Execute_Name (Instance, El, True));
+ end loop;
+ end if;
+
+ -- LRM93 8.1
+ -- It also causes the execution of the corresponding process
+ -- statement to be suspended.
+ Grt.Processes.Ghdl_Process_Wait_Wait;
+ Instance.In_Wait_Flag := True;
+ Release (Marker, Expr_Pool);
+ return True;
+ else
+ -- LRM93 8.1
+ -- The suspended process will resume, at the latest, immediately
+ -- after the timeout interval has expired.
+ if not Grt.Processes.Ghdl_Process_Wait_Has_Timeout then
+ -- Compute the condition clause only if the timeout has not
+ -- expired.
+
+ -- LRM93 8.1
+ -- If such an event occurs, the condition in the condition clause
+ -- is evaluated.
+ --
+ -- if no condition clause appears, the condition clause until true
+ -- is assumed.
+ Status :=
+ Execute_Condition (Instance, Get_Condition_Clause (Stmt));
+ if not Status then
+ -- LRM93 8.1
+ -- If the value of the condition is FALSE, the process will
+ -- re-suspend.
+ -- Such re-suspension does not involve the recalculation of
+ -- the timeout interval.
+ Grt.Processes.Ghdl_Process_Wait_Wait;
+ return True;
+ end if;
+ end if;
+
+ -- LRM93 8.1
+ -- If the value of the condition is TRUE, the process will resume.
+ -- next statement.
+ Grt.Processes.Ghdl_Process_Wait_Close;
+
+ Instance.In_Wait_Flag := False;
+ return False;
+ end if;
+ end Execute_Wait_Statement;
+
+ function To_Instance_Acc is new Ada.Unchecked_Conversion
+ (System.Address, Grt.Stacks.Instance_Acc);
+
+ procedure Process_Executer (Self : Grt.Stacks.Instance_Acc);
+ pragma Convention (C, Process_Executer);
+
+ procedure Process_Executer (Self : Grt.Stacks.Instance_Acc)
+ is
+ function To_Process_State_Acc is new Ada.Unchecked_Conversion
+ (Grt.Stacks.Instance_Acc, Process_State_Acc);
+
+ Process : Process_State_Acc renames
+ To_Process_State_Acc (Self);
+ begin
+ -- For debugger
+ Current_Process := Process;
+
+ Instance_Pool := Process.Pool'Access;
+
+ if Trace_Simulation then
+ Put (" run process: ");
+ Disp_Instance_Name (Process.Top_Instance);
+ Put_Line (" (" & Disp_Location (Process.Proc) & ")");
+ end if;
+
+ Execute_Sequential_Statements (Process);
+
+ -- Sanity checks.
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ case Get_Kind (Process.Proc) is
+ when Iir_Kind_Sensitized_Process_Statement =>
+ if Process.Instance.In_Wait_Flag then
+ raise Internal_Error;
+ end if;
+ if Process.Instance.Stmt = Null_Iir then
+ Process.Instance.Stmt :=
+ Get_Sequential_Statement_Chain (Process.Proc);
+ end if;
+ when Iir_Kind_Process_Statement =>
+ if not Process.Instance.In_Wait_Flag then
+ raise Internal_Error;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Instance_Pool := null;
+ Current_Process := null;
+ end Process_Executer;
+
+ type Resolver_Read_Mode is (Read_Port, Read_Driver);
+
+ function Resolver_Read_Value (Sig : Iir_Value_Literal_Acc;
+ Mode : Resolver_Read_Mode;
+ Index : Ghdl_Index_Type)
+ return Iir_Value_Literal_Acc
+ is
+ use Grt.Signals;
+ Val : Ghdl_Value_Ptr;
+ Res : Iir_Value_Literal_Acc;
+ begin
+ case Sig.Kind is
+ when Iir_Value_Array =>
+ Res := Copy_Array_Bound (Sig);
+ for I in Sig.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Resolver_Read_Value (Sig.Val_Array.V (I), Mode, Index);
+ end loop;
+ when Iir_Value_Record =>
+ Res := Create_Record_Value (Sig.Val_Record.Len);
+ for I in Sig.Val_Record.V'Range loop
+ Res.Val_Record.V (I) :=
+ Resolver_Read_Value (Sig.Val_Record.V (I), Mode, Index);
+ end loop;
+ when Iir_Value_Signal =>
+ case Mode is
+ when Read_Port =>
+ Val := Ghdl_Signal_Read_Port (Sig.Sig, Index);
+ when Read_Driver =>
+ Val := Ghdl_Signal_Read_Driver (Sig.Sig, Index);
+ end case;
+ Res := Value_To_Iir_Value (Sig.Sig.Mode, Val.all);
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Resolver_Read_Value;
+
+ procedure Resolution_Proc (Instance_Addr : System.Address;
+ Val : System.Address;
+ Bool_Vec : System.Address;
+ Vec_Len : Ghdl_Index_Type;
+ Nbr_Drv : Ghdl_Index_Type;
+ Nbr_Ports : Ghdl_Index_Type)
+ is
+ pragma Unreferenced (Val);
+
+ Instance : Resolv_Instance_Type;
+ pragma Import (Ada, Instance);
+ for Instance'Address use Instance_Addr;
+
+ type Bool_Array is array (1 .. Nbr_Drv) of Boolean;
+ Vec : Bool_Array;
+ pragma Import (Ada, Vec);
+ for Vec'Address use Bool_Vec;
+ Off : Iir_Index32;
+
+ Arr : Iir_Value_Literal_Acc;
+ Arr_Type : constant Iir :=
+ Get_Type (Get_Interface_Declaration_Chain (Instance.Func));
+
+ Res : Iir_Value_Literal_Acc;
+
+ Len : constant Iir_Index32 := Iir_Index32 (Vec_Len + Nbr_Ports);
+ Instance_Mark, Expr_Mark : Mark_Type;
+ begin
+ pragma Assert (Instance_Pool = null);
+ Instance_Pool := Global_Pool'Access;
+ Mark (Instance_Mark, Instance_Pool.all);
+ Mark (Expr_Mark, Expr_Pool);
+ Current_Process := No_Process;
+
+ Arr := Create_Array_Value (Len, 1);
+ Arr.Bounds.D (1) := Create_Bounds_From_Length
+ (Instance.Block,
+ Get_First_Element (Get_Index_Subtype_List (Arr_Type)),
+ Len);
+
+ -- First ports
+ for I in 1 .. Nbr_Ports loop
+ Arr.Val_Array.V (Iir_Index32 (I)) := Resolver_Read_Value
+ (Instance.Sig, Read_Port, I - 1);
+ end loop;
+
+ -- Then drivers.
+ Off := Iir_Index32 (Nbr_Ports) + 1;
+ for I in 1 .. Nbr_Drv loop
+ if Vec (I) then
+ Arr.Val_Array.V (Off) := Resolver_Read_Value
+ (Instance.Sig, Read_Driver, I - 1);
+ Off := Off + 1;
+ end if;
+ end loop;
+
+ -- Call resolution function.
+ Res := Execute_Resolution_Function (Instance.Block, Instance.Func, Arr);
+
+ -- Set driving value.
+ Execute_Write_Signal (Instance.Sig, Res, Write_Signal_Driving_Value);
+
+ Release (Instance_Mark, Instance_Pool.all);
+ Release (Expr_Mark, Expr_Pool);
+ Instance_Pool := null;
+ end Resolution_Proc;
+
+ type Convert_Mode is (Convert_In, Convert_Out);
+
+ type Convert_Instance_Type is record
+ Mode : Convert_Mode;
+ Instance : Block_Instance_Acc;
+ Func : Iir;
+ Src : Iir_Value_Literal_Acc;
+ Dst : Iir_Value_Literal_Acc;
+ end record;
+
+ type Convert_Instance_Acc is access Convert_Instance_Type;
+
+ procedure Conversion_Proc (Data : System.Address) is
+ Conv : Convert_Instance_Type;
+ pragma Import (Ada, Conv);
+ for Conv'Address use Data;
+
+ Src : Iir_Value_Literal_Acc;
+ Dst : Iir_Value_Literal_Acc;
+
+ Expr_Mark : Mark_Type;
+ begin
+ pragma Assert (Instance_Pool = null);
+ Instance_Pool := Global_Pool'Access;
+ Mark (Expr_Mark, Expr_Pool);
+ Current_Process := No_Process;
+
+ case Conv.Mode is
+ when Convert_In =>
+ Src := Execute_Read_Signal_Value
+ (Conv.Src, Read_Signal_Effective_Value);
+ when Convert_Out =>
+ Src := Execute_Read_Signal_Value
+ (Conv.Src, Read_Signal_Driving_Value);
+ end case;
+
+ Dst := Execute_Assoc_Conversion (Conv.Instance, Conv.Func, Src);
+
+ Check_Bounds (Conv.Dst, Dst, Conv.Func);
+
+ case Conv.Mode is
+ when Convert_In =>
+ Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Effective_Value);
+ when Convert_Out =>
+ Execute_Write_Signal (Conv.Dst, Dst, Write_Signal_Driving_Value);
+ end case;
+
+ Release (Expr_Mark, Expr_Pool);
+ Instance_Pool := null;
+ end Conversion_Proc;
+
+ function Guard_Func (Data : System.Address) return Ghdl_B1
+ is
+ Guard : Guard_Instance_Type;
+ pragma Import (Ada, Guard);
+ for Guard'Address use Data;
+
+ Val : Boolean;
+
+ Prev_Instance_Pool : Areapool_Acc;
+ begin
+ pragma Assert (Instance_Pool = null
+ or else Instance_Pool = Global_Pool'Access);
+ Prev_Instance_Pool := Instance_Pool;
+
+ Instance_Pool := Global_Pool'Access;
+ Current_Process := No_Process;
+
+ Val := Execute_Condition
+ (Guard.Instance, Get_Guard_Expression (Guard.Guard));
+
+ Instance_Pool := Prev_Instance_Pool;
+
+ return Ghdl_B1'Val (Boolean'Pos (Val));
+ end Guard_Func;
+
+ -- Add a driver for signal designed by VAL (via index field) for instance
+ -- INSTANCE of process PROC.
+ -- FIXME: default value.
+ procedure Add_Source
+ (Instance: Block_Instance_Acc; Val: Iir_Value_Literal_Acc; Proc: Iir)
+ is
+ begin
+ case Val.Kind is
+ when Iir_Value_Signal =>
+ if Proc = Null_Iir then
+ -- Can this happen ?
+ raise Internal_Error;
+ end if;
+ Grt.Signals.Ghdl_Process_Add_Driver (Val.Sig);
+ when Iir_Value_Array =>
+ for I in Val.Val_Array.V'Range loop
+ Add_Source (Instance, Val.Val_Array.V (I), Proc);
+ end loop;
+ when Iir_Value_Record =>
+ for I in Val.Val_Record.V'Range loop
+ Add_Source (Instance, Val.Val_Record.V (I), Proc);
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Add_Source;
+
+ -- Add drivers for process PROC.
+ -- Note: this is done recursively on the callees of PROC.
+ procedure Elaborate_Drivers (Instance: Block_Instance_Acc; Proc: Iir)
+ is
+ Driver_List: Iir_List;
+ El: Iir;
+ Val: Iir_Value_Literal_Acc;
+ Marker : Mark_Type;
+ begin
+ if Trace_Drivers then
+ Ada.Text_IO.Put ("Drivers for ");
+ Disp_Instance_Name (Instance);
+ Ada.Text_IO.Put_Line (": " & Disp_Node (Proc));
+ end if;
+
+ Driver_List := Trans_Analyzes.Extract_Drivers (Proc);
+
+ -- Some processes have no driver list (assertion).
+ if Driver_List = Null_Iir_List then
+ return;
+ end if;
+
+ for I in Natural loop
+ El := Get_Nth_Element (Driver_List, I);
+ exit when El = Null_Iir;
+ if Trace_Drivers then
+ Put_Line (' ' & Disp_Node (El));
+ end if;
+
+ Mark (Marker, Expr_Pool);
+ Val := Execute_Name (Instance, El, True);
+ Add_Source (Instance, Val, Proc);
+ Release (Marker, Expr_Pool);
+ end loop;
+ end Elaborate_Drivers;
+
+ -- Call Ghdl_Process_Add_Sensitivity for each scalar subelement of
+ -- SIG.
+ procedure Process_Add_Sensitivity (Sig: Iir_Value_Literal_Acc) is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Signal =>
+ Grt.Processes.Ghdl_Process_Add_Sensitivity (Sig.Sig);
+ when Iir_Value_Array =>
+ for I in Sig.Val_Array.V'Range loop
+ Process_Add_Sensitivity (Sig.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Sig.Val_Record.V'Range loop
+ Process_Add_Sensitivity (Sig.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Process_Add_Sensitivity;
+
+ procedure Create_Processes
+ is
+ use Grt.Processes;
+ El : Iir;
+ Instance : Block_Instance_Acc;
+ Instance_Grt : Grt.Stacks.Instance_Acc;
+ begin
+ Processes_State := new Process_State_Array (1 .. Processes_Table.Last);
+
+ for I in Processes_Table.First .. Processes_Table.Last loop
+ Instance := Processes_Table.Table (I);
+ El := Instance.Label;
+
+ Instance_Pool := Processes_State (I).Pool'Access;
+ Instance.Stmt := Get_Sequential_Statement_Chain (El);
+
+ Processes_State (I).Top_Instance := Instance;
+ Processes_State (I).Proc := El;
+ Processes_State (I).Instance := Instance;
+
+ Current_Process := Processes_State (I)'Access;
+ Instance_Grt := To_Instance_Acc (Processes_State (I)'Address);
+ case Get_Kind (El) is
+ when Iir_Kind_Sensitized_Process_Statement =>
+ if Get_Postponed_Flag (El) then
+ Ghdl_Postponed_Sensitized_Process_Register
+ (Instance_Grt,
+ Process_Executer'Access,
+ null, System.Null_Address);
+ else
+ Ghdl_Sensitized_Process_Register
+ (Instance_Grt,
+ Process_Executer'Access,
+ null, System.Null_Address);
+ end if;
+
+ -- Register sensitivity.
+ declare
+ Sig_List : Iir_List;
+ Sig : Iir;
+ Marker : Mark_Type;
+ begin
+ Sig_List := Get_Sensitivity_List (El);
+ for J in Natural loop
+ Sig := Get_Nth_Element (Sig_List, J);
+ exit when Sig = Null_Iir;
+ Mark (Marker, Expr_Pool);
+ Process_Add_Sensitivity
+ (Execute_Name (Instance, Sig, True));
+ Release (Marker, Expr_Pool);
+ end loop;
+ end;
+
+ when Iir_Kind_Process_Statement =>
+ if Get_Postponed_Flag (El) then
+ Ghdl_Postponed_Process_Register
+ (Instance_Grt,
+ Process_Executer'Access,
+ null, System.Null_Address);
+ else
+ Ghdl_Process_Register
+ (Instance_Grt,
+ Process_Executer'Access,
+ null, System.Null_Address);
+ end if;
+
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- LRM93 �12.4.4 Other Concurrent Statements
+ -- All other concurrent statements are either process
+ -- statements or are statements for which there is an
+ -- equivalent process statement.
+ -- Elaboration of a process statement proceeds as follows:
+ -- 1. The process declarative part is elaborated.
+ Elaborate_Declarative_Part
+ (Instance, Get_Declaration_Chain (El));
+
+ -- 2. The drivers required by the process statement
+ -- are created.
+ -- 3. The initial transaction defined by the default value
+ -- associated with each scalar signal driven by the
+ -- process statement is inserted into the corresponding
+ -- driver.
+ -- FIXME: do it for drivers in called subprograms too.
+ Elaborate_Drivers (Instance, El);
+
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ -- Elaboration of all concurrent signal assignment
+ -- statements and concurrent assertion statements consists
+ -- of the construction of the equivalent process statement
+ -- followed by the elaboration of the equivalent process
+ -- statement.
+ -- [GHDL: this is done by canonicalize. ]
+
+ -- FIXME: check passive statements,
+ -- check no wait statement in sensitized processes.
+
+ Instance_Pool := null;
+ end loop;
+
+ if Trace_Simulation then
+ Disp_Signals_Value;
+ end if;
+ end Create_Processes;
+
+ -- Configuration for the whole design
+ Top_Config : Iir_Design_Unit;
+
+ -- Elaborate the design
+ procedure Ghdl_Elaborate;
+ pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ procedure Set_Disconnection (Val : Iir_Value_Literal_Acc;
+ Time : Iir_Value_Time)
+ is
+ begin
+ case Val.Kind is
+ when Iir_Value_Signal =>
+ Grt.Signals.Ghdl_Signal_Set_Disconnect (Val.Sig, Std_Time (Time));
+ when Iir_Value_Record =>
+ for I in Val.Val_Record.V'Range loop
+ Set_Disconnection (Val.Val_Record.V (I), Time);
+ end loop;
+ when Iir_Value_Array =>
+ for I in Val.Val_Array.V'Range loop
+ Set_Disconnection (Val.Val_Array.V (I), Time);
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Disconnection;
+
+ procedure Create_Disconnections is
+ begin
+ for I in Disconnection_Table.First .. Disconnection_Table.Last loop
+ declare
+ E : Disconnection_Entry renames Disconnection_Table.Table (I);
+ begin
+ Set_Disconnection (E.Sig, E.Time);
+ end;
+ end loop;
+ end Create_Disconnections;
+
+ type Connect_Mode is (Connect_Source, Connect_Effective);
+
+ -- Add a driving value PORT to signal SIG, ie: PORT is a source for SIG.
+ -- As a side effect, this connect the signal SIG with the port PORT.
+ -- PORT is the formal, while SIG is the actual.
+ procedure Connect (Sig: Iir_Value_Literal_Acc;
+ Port: Iir_Value_Literal_Acc;
+ Mode : Connect_Mode)
+ is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Array =>
+ if Port.Kind /= Sig.Kind then
+ raise Internal_Error;
+ end if;
+
+ if Sig.Val_Array.Len /= Port.Val_Array.Len then
+ raise Internal_Error;
+ end if;
+ for I in Sig.Val_Array.V'Range loop
+ Connect (Sig.Val_Array.V (I), Port.Val_Array.V (I), Mode);
+ end loop;
+ return;
+ when Iir_Value_Record =>
+ if Port.Kind /= Sig.Kind then
+ raise Internal_Error;
+ end if;
+ if Sig.Val_Record.Len /= Port.Val_Record.Len then
+ raise Internal_Error;
+ end if;
+ for I in Sig.Val_Record.V'Range loop
+ Connect (Sig.Val_Record.V (I), Port.Val_Record.V (I), Mode);
+ end loop;
+ return;
+ when Iir_Value_Signal =>
+ case Port.Kind is
+ when Iir_Value_Signal =>
+ -- Here, SIG and PORT are simple signals (not composite).
+ -- PORT is a source for SIG.
+ case Mode is
+ when Connect_Source =>
+ Grt.Signals.Ghdl_Signal_Add_Source
+ (Sig.Sig, Port.Sig);
+ when Connect_Effective =>
+ Grt.Signals.Ghdl_Signal_Effective_Value
+ (Port.Sig, Sig.Sig);
+ end case;
+ when Iir_Value_Access
+ | Iir_Value_File
+ | Iir_Value_Range
+ | Iir_Value_Scalars -- FIXME: by value
+ | Iir_Value_Record
+ | Iir_Value_Array
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ -- These cannot be driving value for a signal.
+ raise Internal_Error;
+ end case;
+ when Iir_Value_E32 =>
+ if Mode = Connect_Source then
+ raise Internal_Error;
+ end if;
+ Grt.Signals.Ghdl_Signal_Associate_E32 (Port.Sig, Sig.E32);
+ when Iir_Value_I64 =>
+ if Mode = Connect_Source then
+ raise Internal_Error;
+ end if;
+ Grt.Signals.Ghdl_Signal_Associate_I64 (Port.Sig, Sig.I64);
+ when Iir_Value_B1 =>
+ if Mode = Connect_Source then
+ raise Internal_Error;
+ end if;
+ Grt.Signals.Ghdl_Signal_Associate_B1 (Port.Sig, Sig.B1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Connect;
+
+ function Get_Leftest_Signal (Val : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc is
+ begin
+ case Val.Kind is
+ when Iir_Value_Signal =>
+ return Val;
+ when Iir_Value_Array =>
+ return Get_Leftest_Signal (Val.Val_Array.V (1));
+ when Iir_Value_Record =>
+ return Get_Leftest_Signal (Val.Val_Record.V (1));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Leftest_Signal;
+
+ procedure Add_Conversion (Conv : Convert_Instance_Acc)
+ is
+ Src_Left : Grt.Signals.Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst_Left : Grt.Signals.Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type;
+ begin
+ Conv.Src := Unshare_Bounds (Conv.Src, Instance_Pool);
+ Conv.Dst := Unshare_Bounds (Conv.Dst, Instance_Pool);
+
+ Src_Left := Get_Leftest_Signal (Conv.Src).Sig;
+ Src_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Src));
+
+ Dst_Left := Get_Leftest_Signal (Conv.Dst).Sig;
+ Dst_Len := Ghdl_Index_Type (Get_Nbr_Of_Scalars (Conv.Dst));
+
+ case Conv.Mode is
+ when Convert_In =>
+ Grt.Signals.Ghdl_Signal_In_Conversion (Conversion_Proc'Address,
+ Conv.all'Address,
+ Src_Left, Src_Len,
+ Dst_Left, Dst_Len);
+ when Convert_Out =>
+ Grt.Signals.Ghdl_Signal_Out_Conversion (Conversion_Proc'Address,
+ Conv.all'Address,
+ Src_Left, Src_Len,
+ Dst_Left, Dst_Len);
+ end case;
+ end Add_Conversion;
+
+ function Create_Shadow_Signal (Sig : Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc
+ is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Signal =>
+ case Sig.Sig.Mode is
+ when Mode_I64 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_I64
+ (0, null, System.Null_Address));
+ when Mode_B1 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_B1
+ (False, null, System.Null_Address));
+ when Mode_E32 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_E32
+ (0, null, System.Null_Address));
+ when Mode_F64 =>
+ return Create_Signal_Value
+ (Grt.Signals.Ghdl_Create_Signal_F64
+ (0.0, null, System.Null_Address));
+ when Mode_E8
+ | Mode_I32 =>
+ raise Internal_Error;
+ end case;
+ when Iir_Value_Array =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Unshare_Bounds (Sig, Instance_Pool);
+ for I in Res.Val_Array.V'Range loop
+ Res.Val_Array.V (I) :=
+ Create_Shadow_Signal (Sig.Val_Array.V (I));
+ end loop;
+ return Res;
+ end;
+ when Iir_Value_Record =>
+ declare
+ Res : Iir_Value_Literal_Acc;
+ begin
+ Res := Create_Record_Value
+ (Sig.Val_Record.Len, Instance_Pool);
+ for I in Res.Val_Record.V'Range loop
+ Res.Val_Record.V (I) :=
+ Create_Shadow_Signal (Sig.Val_Record.V (I));
+ end loop;
+ return Res;
+ end;
+ when Iir_Value_Scalars
+ | Iir_Value_Access
+ | Iir_Value_Range
+ | Iir_Value_Protected
+ | Iir_Value_Terminal
+ | Iir_Value_Quantity
+ | Iir_Value_File =>
+ raise Internal_Error;
+ end case;
+ end Create_Shadow_Signal;
+
+ procedure Set_Connect
+ (Formal_Instance : Block_Instance_Acc;
+ Formal_Expr : Iir_Value_Literal_Acc;
+ Local_Instance : Block_Instance_Acc;
+ Local_Expr : Iir_Value_Literal_Acc;
+ Assoc : Iir_Association_Element_By_Expression)
+ is
+ pragma Unreferenced (Formal_Instance);
+ Formal : constant Iir := Get_Formal (Assoc);
+ Inter : constant Iir := Get_Association_Interface (Assoc);
+ begin
+ if False and Trace_Elaboration then
+ Put ("connect formal ");
+ Put (Iir_Mode'Image (Get_Mode (Inter)));
+ Put (" ");
+ Disp_Iir_Value (Formal_Expr, Get_Type (Formal));
+ Put (" with actual ");
+ Disp_Iir_Value (Local_Expr, Get_Type (Get_Actual (Assoc)));
+ New_Line;
+ end if;
+
+ case Get_Mode (Inter) is
+ when Iir_Out_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode
+ | Iir_Linkage_Mode =>
+ -- FORMAL_EXPR is a source for LOCAL_EXPR.
+ declare
+ Out_Conv : constant Iir := Get_Out_Conversion (Assoc);
+ Src : Iir_Value_Literal_Acc;
+ begin
+ if Out_Conv /= Null_Iir then
+ Src := Create_Shadow_Signal (Local_Expr);
+ Add_Conversion
+ (new Convert_Instance_Type'
+ (Mode => Convert_Out,
+ Instance => Local_Instance,
+ Func => Out_Conv,
+ Src => Formal_Expr,
+ Dst => Src));
+ else
+ Src := Formal_Expr;
+ end if;
+ -- LRM93 �12.6.2
+ -- A signal is said to be active [...] if one of its source
+ -- is active.
+ Connect (Local_Expr, Src, Connect_Source);
+ end;
+
+ when Iir_In_Mode =>
+ null;
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ end case;
+
+ case Get_Mode (Inter) is
+ when Iir_In_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode
+ | Iir_Linkage_Mode =>
+ declare
+ In_Conv : constant Iir := Get_In_Conversion (Assoc);
+ Src : Iir_Value_Literal_Acc;
+ begin
+ if In_Conv /= Null_Iir then
+ Src := Create_Shadow_Signal (Formal_Expr);
+ Add_Conversion
+ (new Convert_Instance_Type'
+ (Mode => Convert_In,
+ Instance => Local_Instance,
+ Func => Get_Implementation (In_Conv),
+ Src => Local_Expr,
+ Dst => Src));
+ else
+ Src := Local_Expr;
+ end if;
+ Connect (Src, Formal_Expr, Connect_Effective);
+ end;
+ when Iir_Out_Mode =>
+ null;
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ end case;
+ end Set_Connect;
+
+ procedure Create_Connects is
+ begin
+ -- New signals may be created (because of conversions).
+ Instance_Pool := Global_Pool'Access;
+
+ for I in Connect_Table.First .. Connect_Table.Last loop
+ declare
+ E : Connect_Entry renames Connect_Table.Table (I);
+ begin
+ Set_Connect (E.Formal_Instance, E.Formal,
+ E.Actual_Instance, E.Actual,
+ E.Assoc);
+ end;
+ end loop;
+
+ Instance_Pool := null;
+ end Create_Connects;
+
+ procedure Create_Guard_Signal
+ (Instance : Block_Instance_Acc;
+ Sig_Guard : Iir_Value_Literal_Acc;
+ Guard : Iir)
+ is
+ procedure Add_Guard_Sensitivity (Sig : Iir_Value_Literal_Acc) is
+ begin
+ case Sig.Kind is
+ when Iir_Value_Signal =>
+ Grt.Signals.Ghdl_Signal_Guard_Dependence (Sig.Sig);
+ when Iir_Value_Array =>
+ for I in Sig.Val_Array.V'Range loop
+ Add_Guard_Sensitivity (Sig.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Sig.Val_Record.V'Range loop
+ Add_Guard_Sensitivity (Sig.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Add_Guard_Sensitivity;
+
+ Dep_List : Iir_List;
+ Dep : Iir;
+ Data : Guard_Instance_Acc;
+ begin
+ Data := new Guard_Instance_Type'(Instance => Instance,
+ Guard => Guard);
+ Sig_Guard.Sig := Grt.Signals.Ghdl_Signal_Create_Guard
+ (Data.all'Address, Guard_Func'Access);
+ Dep_List := Get_Guard_Sensitivity_List (Guard);
+ for I in Natural loop
+ Dep := Get_Nth_Element (Dep_List, I);
+ exit when Dep = Null_Iir;
+ Add_Guard_Sensitivity (Execute_Name (Instance, Dep, True));
+ end loop;
+
+ -- FIXME: free mem
+ end Create_Guard_Signal;
+
+ procedure Create_Implicit_Signal (Sig : Iir_Value_Literal_Acc;
+ Time : Ghdl_I64;
+ Prefix : Iir_Value_Literal_Acc;
+ Kind : Signal_Type_Kind)
+ is
+ procedure Register_Prefix (Pfx : Iir_Value_Literal_Acc) is
+ begin
+ case Pfx.Kind is
+ when Iir_Value_Signal =>
+ Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix (Pfx.Sig);
+ when Iir_Value_Array =>
+ for I in Pfx.Val_Array.V'Range loop
+ Register_Prefix (Pfx.Val_Array.V (I));
+ end loop;
+ when Iir_Value_Record =>
+ for I in Pfx.Val_Record.V'Range loop
+ Register_Prefix (Pfx.Val_Record.V (I));
+ end loop;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Register_Prefix;
+ begin
+ case Kind is
+ when Implicit_Stable =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Stable_Signal (Std_Time (Time));
+ when Implicit_Quiet =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Quiet_Signal (Std_Time (Time));
+ when Implicit_Transaction =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Transaction_Signal;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Register_Prefix (Prefix);
+ end Create_Implicit_Signal;
+
+ procedure Create_Delayed_Signal
+ (Sig : Iir_Value_Literal_Acc; Pfx : Iir_Value_Literal_Acc; Val : Std_Time)
+ is
+ begin
+ case Pfx.Kind is
+ when Iir_Value_Array =>
+ for I in Sig.Val_Array.V'Range loop
+ Create_Delayed_Signal
+ (Sig.Val_Array.V (I), Pfx.Val_Array.V (I), Val);
+ end loop;
+ when Iir_Value_Record =>
+ for I in Pfx.Val_Record.V'Range loop
+ Create_Delayed_Signal
+ (Sig.Val_Record.V (I), Pfx.Val_Array.V (I), Val);
+ end loop;
+ when Iir_Value_Signal =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Delayed_Signal (Pfx.Sig, Val);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Create_Delayed_Signal;
+
+ -- Create a new signal, using DEFAULT as initial value.
+ -- Set its number.
+ procedure Create_User_Signal (Block: Block_Instance_Acc;
+ Signal: Iir;
+ Sig : Iir_Value_Literal_Acc;
+ Default : Iir_Value_Literal_Acc)
+ is
+ use Grt.Rtis;
+
+ procedure Create_Signal (Lit: Iir_Value_Literal_Acc;
+ Sig : Iir_Value_Literal_Acc;
+ Sig_Type: Iir;
+ Already_Resolved : Boolean)
+ is
+ Sub_Resolved : Boolean := Already_Resolved;
+ Resolv_Func : Iir;
+ Resolv_Instance : Resolv_Instance_Acc;
+ begin
+ if not Already_Resolved
+ and then Get_Kind (Sig_Type) in Iir_Kinds_Subtype_Definition
+ then
+ Resolv_Func := Get_Resolution_Function (Sig_Type);
+ else
+ Resolv_Func := Null_Iir;
+ end if;
+ if Resolv_Func /= Null_Iir then
+ Sub_Resolved := True;
+ Resolv_Instance := new Resolv_Instance_Type'
+ (Func => Get_Named_Entity (Resolv_Func),
+ Block => Block,
+ Sig => Sig);
+ Grt.Signals.Ghdl_Signal_Create_Resolution
+ (Resolution_Proc'Access,
+ Resolv_Instance.all'Address,
+ System.Null_Address,
+ Ghdl_Index_Type (Get_Nbr_Of_Scalars (Lit)));
+ end if;
+ case Lit.Kind is
+ when Iir_Value_Array =>
+ declare
+ Sig_El_Type : constant Iir :=
+ Get_Element_Subtype (Get_Base_Type (Sig_Type));
+ begin
+ for I in Lit.Val_Array.V'Range loop
+ Create_Signal (Lit.Val_Array.V (I), Sig.Val_Array.V (I),
+ Sig_El_Type, Sub_Resolved);
+ end loop;
+ end;
+ when Iir_Value_Record =>
+ declare
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List
+ (Get_Base_Type (Sig_Type));
+ for I in Lit.Val_Record.V'Range loop
+ El := Get_Nth_Element (List, Natural (I - 1));
+ Create_Signal (Lit.Val_Record.V (I), Sig.Val_Record.V (I),
+ Get_Type (El), Sub_Resolved);
+ end loop;
+ end;
+
+ when Iir_Value_I64 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_I64
+ (Lit.I64, null, System.Null_Address);
+ when Iir_Value_B1 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_B1
+ (Lit.B1, null, System.Null_Address);
+ when Iir_Value_E32 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_E32
+ (Lit.E32, null, System.Null_Address);
+ when Iir_Value_F64 =>
+ Sig.Sig := Grt.Signals.Ghdl_Create_Signal_F64
+ (Lit.F64, null, System.Null_Address);
+
+ when Iir_Value_Signal
+ | Iir_Value_Range
+ | Iir_Value_File
+ | Iir_Value_Access
+ | Iir_Value_Protected
+ | Iir_Value_Quantity
+ | Iir_Value_Terminal =>
+ raise Internal_Error;
+ end case;
+ end Create_Signal;
+
+ Sig_Type: constant Iir := Get_Type (Signal);
+ Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+
+ type Iir_Mode_To_Mode_Signal_Type is
+ array (Iir_Mode) of Mode_Signal_Type;
+ Iir_Mode_To_Mode_Signal : constant Iir_Mode_To_Mode_Signal_Type :=
+ (Iir_Unknown_Mode => Mode_Signal,
+ Iir_Linkage_Mode => Mode_Linkage,
+ Iir_Buffer_Mode => Mode_Buffer,
+ Iir_Out_Mode => Mode_Out,
+ Iir_Inout_Mode => Mode_Inout,
+ Iir_In_Mode => Mode_In);
+
+ type Iir_Kind_To_Kind_Signal_Type is
+ array (Iir_Signal_Kind) of Kind_Signal_Type;
+ Iir_Kind_To_Kind_Signal : constant Iir_Kind_To_Kind_Signal_Type :=
+ (Iir_No_Signal_Kind => Kind_Signal_No,
+ Iir_Register_Kind => Kind_Signal_Register,
+ Iir_Bus_Kind => Kind_Signal_Bus);
+ begin
+ case Get_Kind (Signal) is
+ when Iir_Kind_Signal_Interface_Declaration =>
+ Mode := Iir_Mode_To_Mode_Signal (Get_Mode (Signal));
+ when Iir_Kind_Signal_Declaration =>
+ Mode := Mode_Signal;
+ when others =>
+ Error_Kind ("elaborate_signal", Signal);
+ end case;
+
+ Kind := Iir_Kind_To_Kind_Signal (Get_Signal_Kind (Signal));
+
+ Grt.Signals.Ghdl_Signal_Set_Mode (Mode, Kind, True);
+
+ Create_Signal (Default, Sig, Sig_Type, False);
+ end Create_User_Signal;
+
+ procedure Create_Signals is
+ begin
+ for I in Signals_Table.First .. Signals_Table.Last loop
+ declare
+ E : Signal_Entry renames Signals_Table.Table (I);
+ begin
+ case E.Kind is
+ when Guard_Signal =>
+ Create_Guard_Signal (E.Instance, E.Sig, E.Decl);
+ when Implicit_Stable | Implicit_Quiet | Implicit_Transaction =>
+ Create_Implicit_Signal (E.Sig, E.Time, E.Prefix, E.Kind);
+ when Implicit_Delayed =>
+ Create_Delayed_Signal (E.Sig, E.Prefix, Std_Time (E.Time));
+ when User_Signal =>
+ Create_User_Signal (E.Instance, E.Decl, E.Sig, E.Init);
+ end case;
+ end;
+ end loop;
+ end Create_Signals;
+
+ procedure Ghdl_Elaborate
+ is
+ Entity: Iir_Entity_Declaration;
+
+ -- Number of input ports of the top entity.
+ In_Signals: Natural;
+ El : Iir;
+ begin
+ Instance_Pool := Global_Pool'Access;
+
+ Elaboration.Elaborate_Design (Top_Config);
+ Entity := Iirs_Utils.Get_Entity (Get_Library_Unit (Top_Config));
+
+ if not Is_Empty (Expr_Pool) then
+ raise Internal_Error;
+ end if;
+
+ Instance_Pool := null;
+
+ -- Be sure there is no IN ports in the top entity.
+ El := Get_Port_Chain (Entity);
+ In_Signals := 0;
+ while El /= Null_Iir loop
+ if Get_Mode (El) = Iir_In_Mode then
+ In_Signals := In_Signals + 1;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ if In_Signals /= 0 then
+ Error_Msg ("top entity should not have inputs signals");
+ -- raise Simulation_Error;
+ end if;
+
+ if Disp_Stats then
+ Disp_Design_Stats;
+ end if;
+
+ if Disp_Ams then
+ Simulation.AMS.Debugger.Disp_Characteristic_Expressions;
+ end if;
+
+ -- There is no inputs.
+ -- All the simulation is done via time, so it must be displayed.
+ Disp_Time_Before_Values := True;
+
+ -- Initialisation.
+ if Trace_Simulation then
+ Put_Line ("Initialisation:");
+ end if;
+
+ Create_Signals;
+ Create_Connects;
+ Create_Disconnections;
+ Create_Processes;
+
+ if Disp_Tree then
+ Debugger.Disp_Instances_Tree;
+ end if;
+
+ if Flag_Interractive then
+ Debug (Reason_Elab);
+ end if;
+ end Ghdl_Elaborate;
+
+ procedure Simulation_Entity (Top_Conf : Iir_Design_Unit) is
+ begin
+ Top_Config := Top_Conf;
+ Grt.Processes.One_Stack := True;
+
+ Grt.Errors.Error_Hook := Debug_Error'Access;
+
+ if Flag_Interractive then
+ Debug (Reason_Start);
+ end if;
+
+ Grt.Main.Run;
+ exception
+ when Debugger_Quit =>
+ null;
+ when Simulation_Finished =>
+ null;
+ end Simulation_Entity;
+
+end Simulation;
diff --git a/src/simulate/simulation.ads b/src/simulate/simulation.ads
new file mode 100644
index 000000000..b910b4306
--- /dev/null
+++ b/src/simulate/simulation.ads
@@ -0,0 +1,128 @@
+-- Interpreted simulation
+-- 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 System;
+with Grt.Types; use Grt.Types;
+with Iirs; use Iirs;
+with Iir_Values; use Iir_Values;
+with Elaboration; use Elaboration;
+with Execution; use Execution;
+
+package Simulation is
+ Trace_Simulation : Boolean := False;
+ Disp_Tree : Boolean := False;
+ Disp_Stats : Boolean := False;
+ Disp_Ams : Boolean := False;
+ Flag_Debugger : Boolean := False;
+ Flag_Interractive : Boolean := False;
+
+ type Resolv_Instance_Type is record
+ Func : Iir;
+ Block : Block_Instance_Acc;
+ Sig : Iir_Value_Literal_Acc;
+ end record;
+ type Resolv_Instance_Acc is access Resolv_Instance_Type;
+
+ -- The resolution procedure for GRT.
+ procedure Resolution_Proc (Instance_Addr : System.Address;
+ Val : System.Address;
+ Bool_Vec : System.Address;
+ Vec_Len : Ghdl_Index_Type;
+ Nbr_Drv : Ghdl_Index_Type;
+ Nbr_Ports : Ghdl_Index_Type);
+ pragma Convention (C, Resolution_Proc);
+
+ type Guard_Instance_Type is record
+ Instance : Block_Instance_Acc;
+ Guard : Iir;
+ end record;
+
+ type Guard_Instance_Acc is access Guard_Instance_Type;
+
+ function Guard_Func (Data : System.Address) return Ghdl_B1;
+ pragma Convention (C, Guard_Func);
+
+ -- The entry point of the simulator.
+ procedure Simulation_Entity (Top_Conf : Iir_Design_Unit);
+
+ type Process_State_Array is
+ array (Process_Index_Type range <>) of aliased Process_State_Type;
+ type Process_State_Array_Acc is access Process_State_Array;
+
+ -- Array containing all processes.
+ Processes_State: Process_State_Array_Acc;
+
+ function Execute_Signal_Value (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ function Execute_Event_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean;
+
+ function Execute_Active_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean;
+ function Execute_Driving_Attribute (Lit: Iir_Value_Literal_Acc)
+ return Boolean;
+
+ function Execute_Last_Value_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+ function Execute_Driving_Value_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Iir_Value_Literal_Acc;
+
+ -- Return the Last_Event absolute time.
+ function Execute_Last_Event_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Ghdl_I64;
+ function Execute_Last_Active_Attribute (Indirect: Iir_Value_Literal_Acc)
+ return Ghdl_I64;
+
+ -- Type for a transaction: it contains the value, the absolute time at which
+ -- the transaction should occur and a pointer to the next transaction.
+ -- This constitute a simple linked list, the elements must be ordered
+ -- according to time.
+ type Transaction_El_Type is record
+ -- The value of the waveform element.
+ -- Can't be an array.
+ -- Life must be target.
+ Value: Iir_Value_Literal_Acc;
+
+ -- After time at which the transaction should occur.
+ After : Grt.Types.Std_Time;
+ end record;
+
+ type Transaction_Array is array (Natural range <>) of Transaction_El_Type;
+
+ type Transaction_Type (Len : Natural) is record
+ -- Statement that created this transaction. Used to disp location
+ -- in case of error (constraint error).
+ Stmt: Iir;
+
+ Reject : Std_Time;
+
+ Els : Transaction_Array (1 .. Len);
+ end record;
+
+ procedure Assign_Value_To_Signal (Instance: Block_Instance_Acc;
+ Target: Iir_Value_Literal_Acc;
+ Transaction: Transaction_Type);
+
+ procedure Disconnect_Signal (Sig : Iir_Value_Literal_Acc);
+
+ -- Return true if the process should be suspended.
+ function Execute_Wait_Statement (Instance : Block_Instance_Acc;
+ Stmt: Iir_Wait_Statement)
+ return Boolean;
+end Simulation;
diff --git a/src/std_names.adb b/src/std_names.adb
new file mode 100644
index 000000000..98b4f062c
--- /dev/null
+++ b/src/std_names.adb
@@ -0,0 +1,482 @@
+-- Well known name table entries.
+-- 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 Name_Table;
+with Tokens; use Tokens;
+with Ada.Exceptions;
+
+package body Std_Names is
+ procedure Std_Names_Initialize is
+ procedure Def (S : String; Id : Name_Id) is
+ begin
+ if Name_Table.Get_Identifier (S) /= Id then
+ Ada.Exceptions.Raise_Exception
+ (Program_Error'Identity, "wrong name_id for " & S);
+ end if;
+ end Def;
+ begin
+ Name_Table.Initialize;
+
+ -- Create reserved words.
+ for I in Tok_Mod .. Tok_Tolerance loop
+ Def (Image (I),
+ Name_First_Keyword +
+ Token_Type'Pos (I) - Token_Type'Pos (Tok_First_Keyword));
+ end loop;
+
+ -- Create operators.
+ Def ("=", Name_Op_Equality);
+ Def ("/=", Name_Op_Inequality);
+ Def ("<", Name_Op_Less);
+ Def ("<=", Name_Op_Less_Equal);
+ Def (">", Name_Op_Greater);
+ Def (">=", Name_Op_Greater_Equal);
+ Def ("+", Name_Op_Plus);
+ Def ("-", Name_Op_Minus);
+ Def ("*", Name_Op_Mul);
+ Def ("/", Name_Op_Div);
+ Def ("**", Name_Op_Exp);
+ Def ("&", Name_Op_Concatenation);
+ Def ("??", Name_Op_Condition);
+ Def ("?=", Name_Op_Match_Equality);
+ Def ("?/=", Name_Op_Match_Inequality);
+ Def ("?<", Name_Op_Match_Less);
+ Def ("?<=", Name_Op_Match_Less_Equal);
+ Def ("?>", Name_Op_Match_Greater);
+ Def ("?>=", Name_Op_Match_Greater_Equal);
+
+ -- Create Attributes.
+ Def ("base", Name_Base);
+ Def ("left", Name_Left);
+ Def ("right", Name_Right);
+ Def ("high", Name_High);
+ Def ("low", Name_Low);
+ Def ("pos", Name_Pos);
+ Def ("val", Name_Val);
+ Def ("succ", Name_Succ);
+ Def ("pred", Name_Pred);
+ Def ("leftof", Name_Leftof);
+ Def ("rightof", Name_Rightof);
+ Def ("reverse_range", Name_Reverse_Range);
+ Def ("length", Name_Length);
+ Def ("delayed", Name_Delayed);
+ Def ("stable", Name_Stable);
+ Def ("quiet", Name_Quiet);
+ Def ("transaction", Name_Transaction);
+ Def ("event", Name_Event);
+ Def ("active", Name_Active);
+ Def ("last_event", Name_Last_Event);
+ Def ("last_active", Name_Last_Active);
+ Def ("last_value", Name_Last_Value);
+
+ Def ("behavior", Name_Behavior);
+ Def ("structure", Name_Structure);
+
+ Def ("ascending", Name_Ascending);
+ Def ("image", Name_Image);
+ Def ("value", Name_Value);
+ Def ("driving", Name_Driving);
+ Def ("driving_value", Name_Driving_Value);
+ Def ("simple_name", Name_Simple_Name);
+ Def ("instance_name", Name_Instance_Name);
+ Def ("path_name", Name_Path_Name);
+
+ Def ("contribution", Name_Contribution);
+ Def ("dot", Name_Dot);
+ Def ("integ", Name_Integ);
+ Def ("above", Name_Above);
+ Def ("zoh", Name_ZOH);
+ Def ("ltf", Name_LTF);
+ Def ("ztf", Name_ZTF);
+ Def ("ramp", Name_Ramp);
+ Def ("slew", Name_Slew);
+
+ -- Create standard.
+ Def ("std", Name_Std);
+ Def ("standard", Name_Standard);
+ Def ("boolean", Name_Boolean);
+ Def ("false", Name_False);
+ Def ("true", Name_True);
+ Def ("bit", Name_Bit);
+ Def ("character", Name_Character);
+ Def ("severity_level", Name_Severity_Level);
+ Def ("note", Name_Note);
+ Def ("warning", Name_Warning);
+ Def ("error", Name_Error);
+ Def ("failure", Name_Failure);
+ Def ("UNIVERSAL_INTEGER", Name_Universal_Integer);
+ Def ("UNIVERSAL_REAL", Name_Universal_Real);
+ Def ("CONVERTIBLE_INTEGER", Name_Convertible_Integer);
+ Def ("CONVERTIBLE_REAL", Name_Convertible_Real);
+ Def ("integer", Name_Integer);
+ Def ("real", Name_Real);
+ Def ("time", Name_Time);
+ Def ("fs", Name_Fs);
+ Def ("ps", Name_Ps);
+ Def ("ns", Name_Ns);
+ Def ("us", Name_Us);
+ Def ("ms", Name_Ms);
+ Def ("sec", Name_Sec);
+ Def ("min", Name_Min);
+ Def ("hr", Name_Hr);
+ Def ("delay_length", Name_Delay_Length);
+ Def ("now", Name_Now);
+ Def ("natural", Name_Natural);
+ Def ("positive", Name_Positive);
+ Def ("string", Name_String);
+ Def ("bit_vector", Name_Bit_Vector);
+ Def ("file_open_kind", Name_File_Open_Kind);
+ Def ("read_mode", Name_Read_Mode);
+ Def ("write_mode", Name_Write_Mode);
+ Def ("append_mode", Name_Append_Mode);
+ Def ("file_open_status", Name_File_Open_Status);
+ Def ("open_ok", Name_Open_Ok);
+ Def ("status_error", Name_Status_Error);
+ Def ("name_error", Name_Name_Error);
+ Def ("mode_error", Name_Mode_Error);
+ Def ("foreign", Name_Foreign);
+
+ Def ("boolean_vector", Name_Boolean_Vector);
+ Def ("to_bstring", Name_To_Bstring);
+ Def ("to_binary_string", Name_To_Binary_String);
+ Def ("to_ostring", Name_To_Ostring);
+ Def ("to_octal_string", Name_To_Octal_String);
+ Def ("to_hstring", Name_To_Hstring);
+ Def ("to_hex_string", Name_To_Hex_String);
+ Def ("integer_vector", Name_Integer_Vector);
+ Def ("real_vector", Name_Real_Vector);
+ Def ("time_vector", Name_Time_Vector);
+ Def ("digits", Name_Digits);
+ Def ("format", Name_Format);
+ Def ("unit", Name_Unit);
+
+ Def ("domain_type", Name_Domain_Type);
+ Def ("quiescent_domain", Name_Quiescent_Domain);
+ Def ("time_domain", Name_Time_Domain);
+ Def ("frequency_domain", Name_Frequency_Domain);
+ Def ("domain", Name_Domain);
+ Def ("frequency", Name_Frequency);
+ Def ("real_vector", Name_Real_Vector);
+
+ Def ("nul", Name_Nul);
+ Def ("soh", Name_Soh);
+ Def ("stx", Name_Stx);
+ Def ("etx", Name_Etx);
+ Def ("eot", Name_Eot);
+ Def ("enq", Name_Enq);
+ Def ("ack", Name_Ack);
+ Def ("bel", Name_Bel);
+ Def ("bs", Name_Bs);
+ Def ("ht", Name_Ht);
+ Def ("lf", Name_Lf);
+ Def ("vt", Name_Vt);
+ Def ("ff", Name_Ff);
+ Def ("cr", Name_Cr);
+ Def ("so", Name_So);
+ Def ("si", Name_Si);
+ Def ("dle", Name_Dle);
+ Def ("dc1", Name_Dc1);
+ Def ("dc2", Name_Dc2);
+ Def ("dc3", Name_Dc3);
+ Def ("dc4", Name_Dc4);
+ Def ("nak", Name_Nak);
+ Def ("syn", Name_Syn);
+ Def ("etb", Name_Etb);
+ Def ("can", Name_Can);
+ Def ("em", Name_Em);
+ Def ("sub", Name_Sub);
+ Def ("esc", Name_Esc);
+ Def ("fsp", Name_Fsp);
+ Def ("gsp", Name_Gsp);
+ Def ("rsp", Name_Rsp);
+ Def ("usp", Name_Usp);
+ Def ("del", Name_Del);
+
+ Def ("c128", Name_C128);
+ Def ("c129", Name_C129);
+ Def ("c130", Name_C130);
+ Def ("c131", Name_C131);
+ Def ("c132", Name_C132);
+ Def ("c133", Name_C133);
+ Def ("c134", Name_C134);
+ Def ("c135", Name_C135);
+ Def ("c136", Name_C136);
+ Def ("c137", Name_C137);
+ Def ("c138", Name_C138);
+ Def ("c139", Name_C139);
+ Def ("c140", Name_C140);
+ Def ("c141", Name_C141);
+ Def ("c142", Name_C142);
+ Def ("c143", Name_C143);
+ Def ("c144", Name_C144);
+ Def ("c145", Name_C145);
+ Def ("c146", Name_C146);
+ Def ("c147", Name_C147);
+ Def ("c148", Name_C148);
+ Def ("c149", Name_C149);
+ Def ("c150", Name_C150);
+ Def ("c151", Name_C151);
+ Def ("c152", Name_C152);
+ Def ("c153", Name_C153);
+ Def ("c154", Name_C154);
+ Def ("c155", Name_C155);
+ Def ("c156", Name_C156);
+ Def ("c157", Name_C157);
+ Def ("c158", Name_C158);
+ Def ("c159", Name_C159);
+
+ -- Create misc.
+ Def ("guard", Name_Guard);
+ Def ("deallocate", Name_Deallocate);
+ Def ("file_open", Name_File_Open);
+ Def ("file_close", Name_File_Close);
+ Def ("read", Name_Read);
+ Def ("write", Name_Write);
+ Def ("flush", Name_Flush);
+ Def ("endfile", Name_Endfile);
+ Def ("p", Name_P);
+ Def ("f", Name_F);
+ Def ("l", Name_L);
+ Def ("r", Name_R);
+ Def ("s", Name_S);
+ Def ("external_name", Name_External_Name);
+ Def ("open_kind", Name_Open_Kind);
+ Def ("status", Name_Status);
+ Def ("first", Name_First);
+ Def ("last", Name_Last);
+ Def ("textio", Name_Textio);
+ Def ("work", Name_Work);
+ Def ("text", Name_Text);
+ Def ("to_string", Name_To_String);
+ Def ("minimum", Name_Minimum);
+ Def ("maximum", Name_Maximum);
+ Def ("untruncated_text_read", Name_Untruncated_Text_Read);
+ Def ("get_resolution_limit", Name_Get_Resolution_Limit);
+ Def ("control_simulation", Name_Control_Simulation);
+
+ Def ("ieee", Name_Ieee);
+ Def ("std_logic_1164", Name_Std_Logic_1164);
+ Def ("std_ulogic", Name_Std_Ulogic);
+ Def ("std_ulogic_vector", Name_Std_Ulogic_Vector);
+ Def ("std_logic", Name_Std_Logic);
+ Def ("std_logic_vector", Name_Std_Logic_Vector);
+ Def ("rising_edge", Name_Rising_Edge);
+ Def ("falling_edge", Name_Falling_Edge);
+ Def ("vital_timing", Name_VITAL_Timing);
+ Def ("vital_level0", Name_VITAL_Level0);
+ Def ("vital_level1", Name_VITAL_Level1);
+
+ -- Verilog keywords
+ Def ("always", Name_Always);
+ Def ("assign", Name_Assign);
+ Def ("buf", Name_Buf);
+ Def ("bufif0", Name_Bufif0);
+ Def ("bufif1", Name_Bufif1);
+ Def ("casex", Name_Casex);
+ Def ("casez", Name_Casez);
+ Def ("cmos", Name_Cmos);
+ Def ("deassign", Name_Deassign);
+ Def ("default", Name_Default);
+ Def ("defparam", Name_Defparam);
+ Def ("disable", Name_Disable);
+ Def ("endcase", Name_Endcase);
+ Def ("endfunction", Name_Endfunction);
+ Def ("endmodule", Name_Endmodule);
+ Def ("endprimitive", Name_Endprimitive);
+ Def ("endspecify", Name_Endspecify);
+ Def ("endtable", Name_Endtable);
+ Def ("endtask", Name_Endtask);
+ Def ("forever", Name_Forever);
+ Def ("fork", Name_Fork);
+ Def ("highz0", Name_Highz0);
+ Def ("highz1", Name_Highz1);
+ Def ("initial", Name_Initial);
+ Def ("input", Name_Input);
+ Def ("join", Name_Join);
+ Def ("large", Name_Large);
+ Def ("medium", Name_Medium);
+ Def ("module", Name_Module);
+ Def ("negedge", Name_Negedge);
+ Def ("nmos", Name_Nmos);
+ Def ("notif0", Name_Notif0);
+ Def ("notif1", Name_Notif1);
+ Def ("output", Name_Output);
+ Def ("parameter", Name_Parameter);
+ Def ("pmos", Name_Pmos);
+ Def ("posedge", Name_Posedge);
+ Def ("primitive", Name_Primitive);
+ Def ("pull0", Name_Pull0);
+ Def ("pull1", Name_Pull1);
+ Def ("pulldown", Name_Pulldown);
+ Def ("pullup", Name_Pullup);
+ Def ("reg", Name_Reg);
+ Def ("repeat", Name_Repeat);
+ Def ("rcmos", Name_Rcmos);
+ Def ("rnmos", Name_Rnmos);
+ Def ("rpmos", Name_Rpmos);
+ Def ("rtran", Name_Rtran);
+ Def ("rtranif0", Name_Rtranif0);
+ Def ("rtranif1", Name_Rtranif1);
+ Def ("small", Name_Small);
+ Def ("specify", Name_Specify);
+ Def ("specparam", Name_Specparam);
+ Def ("strong0", Name_Strong0);
+ Def ("strong1", Name_Strong1);
+ Def ("supply0", Name_Supply0);
+ Def ("supply1", Name_Supply1);
+ Def ("table", Name_Tablex);
+ Def ("task", Name_Task);
+ Def ("tran", Name_Tran);
+ Def ("tranif0", Name_Tranif0);
+ Def ("tranif1", Name_Tranif1);
+ Def ("tri", Name_Tri);
+ Def ("tri0", Name_Tri0);
+ Def ("tri1", Name_Tri1);
+ Def ("trireg", Name_Trireg);
+ Def ("wand", Name_Wand);
+ Def ("weak0", Name_Weak0);
+ Def ("weak1", Name_Weak1);
+ Def ("wire", Name_Wire);
+ Def ("wor", Name_Wor);
+
+ Def ("define", Name_Define);
+ Def ("endif", Name_Endif);
+ Def ("ifdef", Name_Ifdef);
+ Def ("include", Name_Include);
+ Def ("timescale", Name_Timescale);
+ Def ("undef", Name_Undef);
+
+ -- Verilog system tasks
+ Def ("display", Name_Display);
+ Def ("finish", Name_Finish);
+
+ -- BSV keywords
+ Def ("Action", Name_uAction);
+ Def ("ActionValue", Name_uActionValue);
+ Def ("BVI", Name_BVI);
+ Def ("C", Name_uC);
+ Def ("CF", Name_uCF);
+ Def ("E", Name_uE);
+ Def ("SB", Name_uSB);
+ Def ("SBR", Name_uSBR);
+ Def ("action", Name_Action);
+ Def ("endaction", Name_Endaction);
+ Def ("actionvalue", Name_Actionvalue);
+ Def ("endactionvalue", Name_Endactionvalue);
+ Def ("ancestor", Name_Ancestor);
+ Def ("clocked_by", Name_Clocked_By);
+ Def ("continue", Name_Continue);
+ Def ("default_clock", Name_Default_Clock);
+ Def ("default_reset", Name_Default_Reset);
+ Def ("dependencies", Name_Dependencies);
+ Def ("deriving", Name_Deriving);
+ Def ("determines", Name_Determines);
+ Def ("enable", Name_Enable);
+ Def ("enum", Name_Enum);
+ Def ("export", Name_Export);
+ Def ("ifc_inout", Name_Ifc_Inout);
+ Def ("import", Name_Import);
+ Def ("input_clock", Name_Input_Clock);
+ Def ("input_reset", Name_Input_Reset);
+ Def ("instance", Name_Instance);
+ Def ("endinstance", Name_Endinstance);
+ Def ("interface", Name_Interface);
+ Def ("endinterface", Name_Endinterface);
+ Def ("let", Name_Let);
+ Def ("match", Name_Match);
+ Def ("matches", Name_Matches);
+ Def ("method", Name_Method);
+ Def ("endmethod", Name_Endmethod);
+ Def ("numeric", Name_Numeric);
+ Def ("output_clock", Name_Output_Clock);
+ Def ("output_reset", Name_Output_Reset);
+ Def ("endpackage", Name_Endpackage);
+ Def ("par", Name_Par);
+ Def ("endpar", Name_Endpar);
+ Def ("path", Name_Path);
+ Def ("provisos", Name_Provisos);
+ Def ("ready", Name_Ready);
+ Def ("reset_by", Name_Reset_By);
+ Def ("rule", Name_Rule);
+ Def ("endrule", Name_Endrule);
+ Def ("rules", Name_Rules);
+ Def ("endrules", Name_Endrules);
+ Def ("same_family", Name_Same_Family);
+ Def ("schedule", Name_Schedule);
+ Def ("seq", Name_Seq);
+ Def ("endseq", Name_Endseq);
+ Def ("struct", Name_Struct);
+ Def ("tagged", Name_Tagged);
+ Def ("typeclass", Name_Typeclass);
+ Def ("endtypeclass", Name_Endtypeclass);
+ Def ("typedef", Name_Typedef);
+ Def ("union", Name_Union);
+ Def ("valueof", Name_Valueof);
+ Def ("valueOf", Name_uValueof);
+ Def ("void", Name_Void);
+
+ -- VHDL special comments
+ Def ("psl", Name_Psl);
+ Def ("pragma", Name_Pragma);
+
+ -- PSL keywords
+ Def ("a", Name_A);
+ Def ("af", Name_Af);
+ Def ("ag", Name_Ag);
+ Def ("ax", Name_Ax);
+ Def ("abort", Name_Abort);
+ Def ("assume", Name_Assume);
+ Def ("assume_guarantee", Name_Assume_Guarantee);
+ Def ("before", Name_Before);
+ Def ("clock", Name_Clock);
+ Def ("const", Name_Const);
+ Def ("cover", Name_Cover);
+ Def ("e", Name_E);
+ Def ("ef", Name_Ef);
+ Def ("eg", Name_Eg);
+ Def ("ex", Name_Ex);
+ Def ("endpoint", Name_Endpoint);
+ Def ("eventually", Name_Eventually);
+ Def ("fairness", Name_Fairness);
+ Def ("fell ", Name_Fell);
+ Def ("forall", Name_Forall);
+ Def ("g", Name_G);
+ Def ("inf", Name_Inf);
+ Def ("inherit", Name_Inherit);
+ Def ("never", Name_Never);
+ Def ("next_a", Name_Next_A);
+ Def ("next_e", Name_Next_E);
+ Def ("next_event", Name_Next_Event);
+ Def ("next_event_a", Name_Next_Event_A);
+ Def ("next_event_e", Name_Next_Event_E);
+ Def ("property", Name_Property);
+ Def ("prev", Name_Prev);
+ Def ("restrict", Name_Restrict);
+ Def ("restrict_guarantee", Name_Restrict_Guarantee);
+ Def ("rose", Name_Rose);
+ Def ("sequence", Name_Sequence);
+ Def ("strong", Name_Strong);
+ Def ("union", Name_Union);
+ Def ("vmode", Name_Vmode);
+ Def ("vprop", Name_Vprop);
+ Def ("vunit", Name_Vunit);
+ Def ("w", Name_W);
+ Def ("whilenot", Name_Whilenot);
+ Def ("within", Name_Within);
+ Def ("x", Name_X);
+ end Std_Names_Initialize;
+end Std_Names;
diff --git a/src/std_names.ads b/src/std_names.ads
new file mode 100644
index 000000000..0a44c91c0
--- /dev/null
+++ b/src/std_names.ads
@@ -0,0 +1,727 @@
+-- Well known name table entries.
+-- 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;
+
+-- Note: since all identifiers declared in this package begins with either
+-- std_names or name, this package is expected to be use'd.
+
+package Std_Names is
+ -- Predefined names.
+ Name_First_Character : constant Name_Id := 1;
+ Name_Last_Character : constant Name_Id :=
+ Name_First_Character + Character'Pos (Character'Last)
+ - Character'Pos (Character'First);
+ subtype Name_Characters is Name_Id
+ range Name_First_Character .. Name_Last_Character;
+
+ Name_First_Keyword : constant Name_Id := Name_Last_Character + 1;
+
+ -- Word operators.
+ Name_Mod : constant Name_Id := Name_First_Keyword + 000;
+ Name_Rem : constant Name_Id := Name_First_Keyword + 001;
+
+ Name_And : constant Name_Id := Name_First_Keyword + 002;
+ Name_Or : constant Name_Id := Name_First_Keyword + 003;
+ Name_Xor : constant Name_Id := Name_First_Keyword + 004;
+ Name_Nand : constant Name_Id := Name_First_Keyword + 005;
+ Name_Nor : constant Name_Id := Name_First_Keyword + 006;
+
+ Name_Abs : constant Name_Id := Name_First_Keyword + 007;
+ Name_Not : constant Name_Id := Name_First_Keyword + 008;
+
+ subtype Name_Logical_Operators is Name_Id range Name_And .. Name_Nor;
+ subtype Name_Word_Operators is Name_Id range Name_Mod .. Name_Not;
+
+ Name_Access : constant Name_Id := Name_First_Keyword + 009;
+ Name_After : constant Name_Id := Name_First_Keyword + 010;
+ Name_Alias : constant Name_Id := Name_First_Keyword + 011;
+ Name_All : constant Name_Id := Name_First_Keyword + 012;
+ Name_Architecture : constant Name_Id := Name_First_Keyword + 013;
+ Name_Array : constant Name_Id := Name_First_Keyword + 014;
+ Name_Assert : constant Name_Id := Name_First_Keyword + 015;
+ Name_Attribute : constant Name_Id := Name_First_Keyword + 016;
+
+ Name_Begin : constant Name_Id := Name_First_Keyword + 017;
+ Name_Block : constant Name_Id := Name_First_Keyword + 018;
+ Name_Body : constant Name_Id := Name_First_Keyword + 019;
+ Name_Buffer : constant Name_Id := Name_First_Keyword + 020;
+ Name_Bus : constant Name_Id := Name_First_Keyword + 021;
+
+ Name_Case : constant Name_Id := Name_First_Keyword + 022;
+ Name_Component : constant Name_Id := Name_First_Keyword + 023;
+ Name_Configuration : constant Name_Id := Name_First_Keyword + 024;
+ Name_Constant : constant Name_Id := Name_First_Keyword + 025;
+
+ Name_Disconnect : constant Name_Id := Name_First_Keyword + 026;
+ Name_Downto : constant Name_Id := Name_First_Keyword + 027;
+
+ Name_Else : constant Name_Id := Name_First_Keyword + 028;
+ Name_Elsif : constant Name_Id := Name_First_Keyword + 029;
+ Name_End : constant Name_Id := Name_First_Keyword + 030;
+ Name_Entity : constant Name_Id := Name_First_Keyword + 031;
+ Name_Exit : constant Name_Id := Name_First_Keyword + 032;
+
+ Name_File : constant Name_Id := Name_First_Keyword + 033;
+ Name_For : constant Name_Id := Name_First_Keyword + 034;
+ Name_Function : constant Name_Id := Name_First_Keyword + 035;
+
+ Name_Generate : constant Name_Id := Name_First_Keyword + 036;
+ Name_Generic : constant Name_Id := Name_First_Keyword + 037;
+ Name_Guarded : constant Name_Id := Name_First_Keyword + 038;
+
+ Name_If : constant Name_Id := Name_First_Keyword + 039;
+ Name_In : constant Name_Id := Name_First_Keyword + 040;
+ Name_Inout : constant Name_Id := Name_First_Keyword + 041;
+ Name_Is : constant Name_Id := Name_First_Keyword + 042;
+
+ Name_Label : constant Name_Id := Name_First_Keyword + 043;
+ Name_Library : constant Name_Id := Name_First_Keyword + 044;
+ Name_Linkage : constant Name_Id := Name_First_Keyword + 045;
+ Name_Loop : constant Name_Id := Name_First_Keyword + 046;
+
+ Name_Map : constant Name_Id := Name_First_Keyword + 047;
+
+ Name_New : constant Name_Id := Name_First_Keyword + 048;
+ Name_Next : constant Name_Id := Name_First_Keyword + 049;
+ Name_Null : constant Name_Id := Name_First_Keyword + 050;
+
+ Name_Of : constant Name_Id := Name_First_Keyword + 051;
+ Name_On : constant Name_Id := Name_First_Keyword + 052;
+ Name_Open : constant Name_Id := Name_First_Keyword + 053;
+ Name_Others : constant Name_Id := Name_First_Keyword + 054;
+ Name_Out : constant Name_Id := Name_First_Keyword + 055;
+
+ Name_Package : constant Name_Id := Name_First_Keyword + 056;
+ Name_Port : constant Name_Id := Name_First_Keyword + 057;
+ Name_Procedure : constant Name_Id := Name_First_Keyword + 058;
+ Name_Process : constant Name_Id := Name_First_Keyword + 059;
+
+ Name_Range : constant Name_Id := Name_First_Keyword + 060;
+ Name_Record : constant Name_Id := Name_First_Keyword + 061;
+ Name_Register : constant Name_Id := Name_First_Keyword + 062;
+ Name_Report : constant Name_Id := Name_First_Keyword + 063;
+ Name_Return : constant Name_Id := Name_First_Keyword + 064;
+
+ Name_Select : constant Name_Id := Name_First_Keyword + 065;
+ Name_Severity : constant Name_Id := Name_First_Keyword + 066;
+ Name_Signal : constant Name_Id := Name_First_Keyword + 067;
+ Name_Subtype : constant Name_Id := Name_First_Keyword + 068;
+
+ Name_Then : constant Name_Id := Name_First_Keyword + 069;
+ Name_To : constant Name_Id := Name_First_Keyword + 070;
+ Name_Transport : constant Name_Id := Name_First_Keyword + 071;
+ Name_Type : constant Name_Id := Name_First_Keyword + 072;
+
+ Name_Units : constant Name_Id := Name_First_Keyword + 073;
+ Name_Until : constant Name_Id := Name_First_Keyword + 074;
+ Name_Use : constant Name_Id := Name_First_Keyword + 075;
+
+ Name_Variable : constant Name_Id := Name_First_Keyword + 076;
+
+ Name_Wait : constant Name_Id := Name_First_Keyword + 077;
+ Name_When : constant Name_Id := Name_First_Keyword + 078;
+ Name_While : constant Name_Id := Name_First_Keyword + 079;
+ Name_With : constant Name_Id := Name_First_Keyword + 080;
+
+ Name_Last_Vhdl87 : constant Name_Id := Name_With;
+ subtype Name_Id_Vhdl87_Reserved_Words is
+ Name_Id range Name_First_Keyword .. Name_With;
+
+ -- VHDL93 reserved words.
+ Name_Xnor : constant Name_Id := Name_First_Keyword + 081;
+ Name_Group : constant Name_Id := Name_First_Keyword + 082;
+ Name_Impure : constant Name_Id := Name_First_Keyword + 083;
+ Name_Inertial : constant Name_Id := Name_First_Keyword + 084;
+ Name_Literal : constant Name_Id := Name_First_Keyword + 085;
+ Name_Postponed : constant Name_Id := Name_First_Keyword + 086;
+ Name_Pure : constant Name_Id := Name_First_Keyword + 087;
+ Name_Reject : constant Name_Id := Name_First_Keyword + 088;
+ Name_Shared : constant Name_Id := Name_First_Keyword + 089;
+ Name_Unaffected : constant Name_Id := Name_First_Keyword + 090;
+
+ Name_Sll : constant Name_Id := Name_First_Keyword + 091;
+ Name_Sla : constant Name_Id := Name_First_Keyword + 092;
+ Name_Sra : constant Name_Id := Name_First_Keyword + 093;
+ Name_Srl : constant Name_Id := Name_First_Keyword + 094;
+ Name_Rol : constant Name_Id := Name_First_Keyword + 095;
+ Name_Ror : constant Name_Id := Name_First_Keyword + 096;
+ subtype Name_Shift_Operators is Name_Id range Name_Sll .. Name_Ror;
+
+ Name_Last_Vhdl93 : constant Name_Id := Name_Ror;
+ subtype Name_Id_Vhdl93_Reserved_Words is
+ Name_Id range Name_Xnor .. Name_Ror;
+
+ Name_Protected : constant Name_Id := Name_First_Keyword + 097;
+
+ Name_Last_Vhdl00 : constant Name_Id := Name_Protected;
+ subtype Name_Id_Vhdl00_Reserved_Words is
+ Name_Id range Name_Protected .. Name_Protected;
+
+ Name_Across : constant Name_Id := Name_First_Keyword + 098;
+ Name_Break : constant Name_Id := Name_First_Keyword + 099;
+ Name_Limit : constant Name_Id := Name_First_Keyword + 100;
+ Name_Nature : constant Name_Id := Name_First_Keyword + 101;
+ Name_Noise : constant Name_Id := Name_First_Keyword + 102;
+ Name_Procedural : constant Name_Id := Name_First_Keyword + 103;
+ Name_Quantity : constant Name_Id := Name_First_Keyword + 104;
+ Name_Reference : constant Name_Id := Name_First_Keyword + 105;
+ Name_Spectrum : constant Name_Id := Name_First_Keyword + 106;
+ Name_Subnature : constant Name_Id := Name_First_Keyword + 107;
+ Name_Terminal : constant Name_Id := Name_First_Keyword + 108;
+ Name_Through : constant Name_Id := Name_First_Keyword + 109;
+ Name_Tolerance : constant Name_Id := Name_First_Keyword + 110;
+
+ Name_Last_AMS_Vhdl : constant Name_Id := Name_Tolerance;
+
+ subtype Name_Id_AMS_Reserved_Words is
+ Name_Id range Name_Across .. Name_Tolerance;
+
+ Name_Last_Keyword : constant Name_Id := Name_Tolerance;
+
+ subtype Name_Id_Keywords is
+ Name_Id range Name_First_Keyword .. Name_Last_Keyword;
+
+ Name_First_Operator : constant Name_Id := Name_Last_Keyword + 1;
+ Name_Op_Equality : constant Name_Id := Name_First_Operator + 000;
+ Name_Op_Inequality : constant Name_Id := Name_First_Operator + 001;
+ Name_Op_Less : constant Name_Id := Name_First_Operator + 002;
+ Name_Op_Less_Equal : constant Name_Id := Name_First_Operator + 003;
+ Name_Op_Greater : constant Name_Id := Name_First_Operator + 004;
+ Name_Op_Greater_Equal : constant Name_Id := Name_First_Operator + 5;
+ Name_Op_Plus : constant Name_Id := Name_First_Operator + 006;
+ Name_Op_Minus : constant Name_Id := Name_First_Operator + 007;
+ Name_Op_Mul : constant Name_Id := Name_First_Operator + 008;
+ Name_Op_Div : constant Name_Id := Name_First_Operator + 009;
+ Name_Op_Exp : constant Name_Id := Name_First_Operator + 010;
+ Name_Op_Concatenation : constant Name_Id := Name_First_Operator + 011;
+ Name_Op_Condition : constant Name_Id := Name_First_Operator + 012;
+ Name_Op_Match_Equality : constant Name_Id := Name_First_Operator + 013;
+ Name_Op_Match_Inequality : constant Name_Id := Name_First_Operator + 014;
+ Name_Op_Match_Less : constant Name_Id := Name_First_Operator + 015;
+ Name_Op_Match_Less_Equal : constant Name_Id := Name_First_Operator + 016;
+ Name_Op_Match_Greater : constant Name_Id := Name_First_Operator + 017;
+ Name_Op_Match_Greater_Equal : constant Name_Id := Name_First_Operator + 018;
+ Name_Last_Operator : constant Name_Id := Name_Op_Match_Greater_Equal;
+
+ subtype Name_Relational_Operators is Name_Id
+ range Name_Op_Equality .. Name_Op_Greater_Equal;
+
+ -- List of symbolic operators (available as string).
+ subtype Name_Id_Operators is Name_Id
+ range Name_First_Operator .. Name_Last_Operator;
+
+ Name_First_Attribute : constant Name_Id := Name_Last_Operator + 1;
+ Name_Base : constant Name_Id := Name_First_Attribute + 000;
+ Name_Left : constant Name_Id := Name_First_Attribute + 001;
+ Name_Right : constant Name_Id := Name_First_Attribute + 002;
+ Name_High : constant Name_Id := Name_First_Attribute + 003;
+ Name_Low : constant Name_Id := Name_First_Attribute + 004;
+ Name_Pos : constant Name_Id := Name_First_Attribute + 005;
+ Name_Val : constant Name_Id := Name_First_Attribute + 006;
+ Name_Succ : constant Name_Id := Name_First_Attribute + 007;
+ Name_Pred : constant Name_Id := Name_First_Attribute + 008;
+ Name_Leftof : constant Name_Id := Name_First_Attribute + 009;
+ Name_Rightof : constant Name_Id := Name_First_Attribute + 010;
+ Name_Reverse_Range : constant Name_Id := Name_First_Attribute + 011;
+ Name_Length : constant Name_Id := Name_First_Attribute + 012;
+ Name_Delayed : constant Name_Id := Name_First_Attribute + 013;
+ Name_Stable : constant Name_Id := Name_First_Attribute + 014;
+ Name_Quiet : constant Name_Id := Name_First_Attribute + 015;
+ Name_Transaction : constant Name_Id := Name_First_Attribute + 016;
+ Name_Event : constant Name_Id := Name_First_Attribute + 017;
+ Name_Active : constant Name_Id := Name_First_Attribute + 018;
+ Name_Last_Event : constant Name_Id := Name_First_Attribute + 019;
+ Name_Last_Active : constant Name_Id := Name_First_Attribute + 020;
+ Name_Last_Value : constant Name_Id := Name_First_Attribute + 021;
+ Name_Last_Attribute : constant Name_Id := Name_Last_Value;
+
+ subtype Name_Id_Attributes is Name_Id
+ range Name_First_Attribute ..Name_Last_Attribute;
+
+ Name_First_Vhdl87_Attribute : constant Name_Id := Name_Last_Value + 1;
+ Name_Behavior : constant Name_Id := Name_First_Attribute + 022;
+ Name_Structure : constant Name_Id := Name_First_Attribute + 023;
+ Name_Last_Vhdl87_Attribute : constant Name_Id := Name_Structure;
+
+ subtype Name_Id_Vhdl87_Attributes is Name_Id
+ range Name_First_Vhdl87_Attribute ..Name_Last_Vhdl87_Attribute;
+
+ Name_First_Vhdl93_Attribute : constant Name_Id := Name_Structure + 1;
+ Name_Ascending : constant Name_Id := Name_First_Attribute + 024;
+ Name_Image : constant Name_Id := Name_First_Attribute + 025;
+ Name_Value : constant Name_Id := Name_First_Attribute + 026;
+ Name_Driving : constant Name_Id := Name_First_Attribute + 027;
+ Name_Driving_Value : constant Name_Id := Name_First_Attribute + 028;
+ Name_Simple_Name : constant Name_Id := Name_First_Attribute + 029;
+ Name_Instance_Name : constant Name_Id := Name_First_Attribute + 030;
+ Name_Path_Name : constant Name_Id := Name_First_Attribute + 031;
+ Name_Last_Vhdl93_Attribute : constant Name_Id := Name_Path_Name;
+
+ subtype Name_Id_Vhdl93_Attributes is Name_Id
+ range Name_First_Vhdl93_Attribute ..Name_Last_Vhdl93_Attribute;
+
+ Name_First_AMS_Attribute : constant Name_Id :=
+ Name_Last_Vhdl93_Attribute + 1;
+ Name_Contribution : constant Name_Id := Name_First_AMS_Attribute + 000;
+ Name_Dot : constant Name_Id := Name_First_AMS_Attribute + 001;
+ Name_Integ : constant Name_Id := Name_First_AMS_Attribute + 002;
+ Name_Above : constant Name_Id := Name_First_AMS_Attribute + 003;
+ Name_ZOH : constant Name_Id := Name_First_AMS_Attribute + 004;
+ Name_LTF : constant Name_Id := Name_First_AMS_Attribute + 005;
+ Name_ZTF : constant Name_Id := Name_First_AMS_Attribute + 006;
+ Name_Ramp : constant Name_Id := Name_First_AMS_Attribute + 007;
+ Name_Slew : constant Name_Id := Name_First_AMS_Attribute + 008;
+ Name_Last_AMS_Attribute : constant Name_Id := Name_Slew;
+
+ subtype Name_Id_Name_Attributes is Name_Id
+ range Name_Simple_Name .. Name_Path_Name;
+
+ -- Names used in std.standard package.
+ Name_First_Standard : constant Name_Id := Name_Last_AMS_Attribute + 1;
+ Name_Std : constant Name_Id := Name_First_Standard + 000;
+ Name_Standard : constant Name_Id := Name_First_Standard + 001;
+ Name_Boolean : constant Name_Id := Name_First_Standard + 002;
+ Name_False : constant Name_Id := Name_First_Standard + 003;
+ Name_True : constant Name_Id := Name_First_Standard + 004;
+ Name_Bit : constant Name_Id := Name_First_Standard + 005;
+ Name_Character : constant Name_Id := Name_First_Standard + 006;
+ Name_Severity_Level : constant Name_Id := Name_First_Standard + 007;
+ Name_Note : constant Name_Id := Name_First_Standard + 008;
+ Name_Warning : constant Name_Id := Name_First_Standard + 009;
+ Name_Error : constant Name_Id := Name_First_Standard + 010;
+ Name_Failure : constant Name_Id := Name_First_Standard + 011;
+ Name_Universal_Integer : constant Name_Id := Name_First_Standard + 012;
+ Name_Universal_Real : constant Name_Id := Name_First_Standard + 013;
+ Name_Convertible_Integer : constant Name_Id := Name_First_Standard + 014;
+ Name_Convertible_Real : constant Name_Id := Name_First_Standard + 015;
+ Name_Integer : constant Name_Id := Name_First_Standard + 016;
+ Name_Real : constant Name_Id := Name_First_Standard + 017;
+ Name_Time : constant Name_Id := Name_First_Standard + 018;
+ Name_Fs : constant Name_Id := Name_First_Standard + 019;
+ Name_Ps : constant Name_Id := Name_First_Standard + 020;
+ Name_Ns : constant Name_Id := Name_First_Standard + 021;
+ Name_Us : constant Name_Id := Name_First_Standard + 022;
+ Name_Ms : constant Name_Id := Name_First_Standard + 023;
+ Name_Sec : constant Name_Id := Name_First_Standard + 024;
+ Name_Min : constant Name_Id := Name_First_Standard + 025;
+ Name_Hr : constant Name_Id := Name_First_Standard + 026;
+ Name_Delay_Length : constant Name_Id := Name_First_Standard + 027;
+ Name_Now : constant Name_Id := Name_First_Standard + 028;
+ Name_Natural : constant Name_Id := Name_First_Standard + 029;
+ Name_Positive : constant Name_Id := Name_First_Standard + 030;
+ Name_String : constant Name_Id := Name_First_Standard + 031;
+ Name_Bit_Vector : constant Name_Id := Name_First_Standard + 032;
+ Name_File_Open_Kind : constant Name_Id := Name_First_Standard + 033;
+ Name_Read_Mode : constant Name_Id := Name_First_Standard + 034;
+ Name_Write_Mode : constant Name_Id := Name_First_Standard + 035;
+ Name_Append_Mode : constant Name_Id := Name_First_Standard + 036;
+ Name_File_Open_Status : constant Name_Id := Name_First_Standard + 037;
+ Name_Open_Ok : constant Name_Id := Name_First_Standard + 038;
+ Name_Status_Error : constant Name_Id := Name_First_Standard + 039;
+ Name_Name_Error : constant Name_Id := Name_First_Standard + 040;
+ Name_Mode_Error : constant Name_Id := Name_First_Standard + 041;
+ Name_Foreign : constant Name_Id := Name_First_Standard + 042;
+
+ -- Added by VHDL 08
+ Name_Boolean_Vector : constant Name_Id := Name_First_Standard + 043;
+ Name_To_Bstring : constant Name_Id := Name_First_Standard + 044;
+ Name_To_Binary_String : constant Name_Id := Name_First_Standard + 045;
+ Name_To_Ostring : constant Name_Id := Name_First_Standard + 046;
+ Name_To_Octal_String : constant Name_Id := Name_First_Standard + 047;
+ Name_To_Hstring : constant Name_Id := Name_First_Standard + 048;
+ Name_To_Hex_String : constant Name_Id := Name_First_Standard + 049;
+ Name_Integer_Vector : constant Name_Id := Name_First_Standard + 050;
+ Name_Real_Vector : constant Name_Id := Name_First_Standard + 051;
+ Name_Time_Vector : constant Name_Id := Name_First_Standard + 052;
+ Name_Digits : constant Name_Id := Name_First_Standard + 053;
+ Name_Format : constant Name_Id := Name_First_Standard + 054;
+ Name_Unit : constant Name_Id := Name_First_Standard + 055;
+
+ -- Added by AMS vhdl.
+ Name_Domain_Type : constant Name_Id := Name_First_Standard + 056;
+ Name_Quiescent_Domain : constant Name_Id := Name_First_Standard + 057;
+ Name_Time_Domain : constant Name_Id := Name_First_Standard + 058;
+ Name_Frequency_Domain : constant Name_Id := Name_First_Standard + 059;
+ Name_Domain : constant Name_Id := Name_First_Standard + 060;
+ Name_Frequency : constant Name_Id := Name_First_Standard + 061;
+
+ Name_Last_Standard : constant Name_Id := Name_Frequency;
+
+ Name_First_Charname : constant Name_Id := Name_Last_Standard + 1;
+ Name_Nul : constant Name_Id := Name_First_Charname + 00;
+ Name_Soh : constant Name_Id := Name_First_Charname + 01;
+ Name_Stx : constant Name_Id := Name_First_Charname + 02;
+ Name_Etx : constant Name_Id := Name_First_Charname + 03;
+ Name_Eot : constant Name_Id := Name_First_Charname + 04;
+ Name_Enq : constant Name_Id := Name_First_Charname + 05;
+ Name_Ack : constant Name_Id := Name_First_Charname + 06;
+ Name_Bel : constant Name_Id := Name_First_Charname + 07;
+ Name_Bs : constant Name_Id := Name_First_Charname + 08;
+ Name_Ht : constant Name_Id := Name_First_Charname + 09;
+ Name_Lf : constant Name_Id := Name_First_Charname + 10;
+ Name_Vt : constant Name_Id := Name_First_Charname + 11;
+ Name_Ff : constant Name_Id := Name_First_Charname + 12;
+ Name_Cr : constant Name_Id := Name_First_Charname + 13;
+ Name_So : constant Name_Id := Name_First_Charname + 14;
+ Name_Si : constant Name_Id := Name_First_Charname + 15;
+ Name_Dle : constant Name_Id := Name_First_Charname + 16;
+ Name_Dc1 : constant Name_Id := Name_First_Charname + 17;
+ Name_Dc2 : constant Name_Id := Name_First_Charname + 18;
+ Name_Dc3 : constant Name_Id := Name_First_Charname + 19;
+ Name_Dc4 : constant Name_Id := Name_First_Charname + 20;
+ Name_Nak : constant Name_Id := Name_First_Charname + 21;
+ Name_Syn : constant Name_Id := Name_First_Charname + 22;
+ Name_Etb : constant Name_Id := Name_First_Charname + 23;
+ Name_Can : constant Name_Id := Name_First_Charname + 24;
+ Name_Em : constant Name_Id := Name_First_Charname + 25;
+ Name_Sub : constant Name_Id := Name_First_Charname + 26;
+ Name_Esc : constant Name_Id := Name_First_Charname + 27;
+ Name_Fsp : constant Name_Id := Name_First_Charname + 28;
+ Name_Gsp : constant Name_Id := Name_First_Charname + 29;
+ Name_Rsp : constant Name_Id := Name_First_Charname + 30;
+ Name_Usp : constant Name_Id := Name_First_Charname + 31;
+
+ Name_Del : constant Name_Id := Name_First_Charname + 32;
+
+ Name_C128 : constant Name_Id := Name_First_Charname + 33;
+ Name_C129 : constant Name_Id := Name_First_Charname + 34;
+ Name_C130 : constant Name_Id := Name_First_Charname + 35;
+ Name_C131 : constant Name_Id := Name_First_Charname + 36;
+ Name_C132 : constant Name_Id := Name_First_Charname + 37;
+ Name_C133 : constant Name_Id := Name_First_Charname + 38;
+ Name_C134 : constant Name_Id := Name_First_Charname + 39;
+ Name_C135 : constant Name_Id := Name_First_Charname + 40;
+ Name_C136 : constant Name_Id := Name_First_Charname + 41;
+ Name_C137 : constant Name_Id := Name_First_Charname + 42;
+ Name_C138 : constant Name_Id := Name_First_Charname + 43;
+ Name_C139 : constant Name_Id := Name_First_Charname + 44;
+ Name_C140 : constant Name_Id := Name_First_Charname + 45;
+ Name_C141 : constant Name_Id := Name_First_Charname + 46;
+ Name_C142 : constant Name_Id := Name_First_Charname + 47;
+ Name_C143 : constant Name_Id := Name_First_Charname + 48;
+ Name_C144 : constant Name_Id := Name_First_Charname + 49;
+ Name_C145 : constant Name_Id := Name_First_Charname + 50;
+ Name_C146 : constant Name_Id := Name_First_Charname + 51;
+ Name_C147 : constant Name_Id := Name_First_Charname + 52;
+ Name_C148 : constant Name_Id := Name_First_Charname + 53;
+ Name_C149 : constant Name_Id := Name_First_Charname + 54;
+ Name_C150 : constant Name_Id := Name_First_Charname + 55;
+ Name_C151 : constant Name_Id := Name_First_Charname + 56;
+ Name_C152 : constant Name_Id := Name_First_Charname + 57;
+ Name_C153 : constant Name_Id := Name_First_Charname + 58;
+ Name_C154 : constant Name_Id := Name_First_Charname + 59;
+ Name_C155 : constant Name_Id := Name_First_Charname + 60;
+ Name_C156 : constant Name_Id := Name_First_Charname + 61;
+ Name_C157 : constant Name_Id := Name_First_Charname + 62;
+ Name_C158 : constant Name_Id := Name_First_Charname + 63;
+ Name_C159 : constant Name_Id := Name_First_Charname + 64;
+ Name_Last_Charname : constant Name_Id := Name_C159;
+
+ Name_First_Misc : constant Name_Id := Name_Last_Charname + 1;
+ Name_Guard : constant Name_Id := Name_First_Misc + 000;
+ Name_Deallocate : constant Name_Id := Name_First_Misc + 001;
+ Name_File_Open : constant Name_Id := Name_First_Misc + 002;
+ Name_File_Close : constant Name_Id := Name_First_Misc + 003;
+ Name_Read : constant Name_Id := Name_First_Misc + 004;
+ Name_Write : constant Name_Id := Name_First_Misc + 005;
+ Name_Flush : constant Name_Id := Name_First_Misc + 006;
+ Name_Endfile : constant Name_Id := Name_First_Misc + 007;
+ Name_P : constant Name_Id := Name_First_Misc + 008;
+ Name_F : constant Name_Id := Name_First_Misc + 009;
+ Name_L : constant Name_Id := Name_First_Misc + 010;
+ Name_R : constant Name_Id := Name_First_Misc + 011;
+ Name_S : constant Name_Id := Name_First_Misc + 012;
+ Name_External_Name : constant Name_Id := Name_First_Misc + 013;
+ Name_Open_Kind : constant Name_Id := Name_First_Misc + 014;
+ Name_Status : constant Name_Id := Name_First_Misc + 015;
+ Name_First : constant Name_Id := Name_First_Misc + 016;
+ Name_Last : constant Name_Id := Name_First_Misc + 017;
+ Name_Textio : constant Name_Id := Name_First_Misc + 018;
+ Name_Work : constant Name_Id := Name_First_Misc + 019;
+ Name_Text : constant Name_Id := Name_First_Misc + 020;
+ Name_To_String : constant Name_Id := Name_First_Misc + 021;
+ Name_Minimum : constant Name_Id := Name_First_Misc + 022;
+ Name_Maximum : constant Name_Id := Name_First_Misc + 023;
+ Name_Untruncated_Text_Read : constant Name_Id := Name_First_Misc + 024;
+ Name_Get_Resolution_Limit : constant Name_Id := Name_First_Misc + 025;
+ Name_Control_Simulation : constant Name_Id := Name_First_Misc + 026;
+ Name_Last_Misc : constant Name_Id := Name_Control_Simulation;
+
+ Name_First_Ieee : constant Name_Id := Name_Last_Misc + 1;
+ Name_Ieee : constant Name_Id := Name_First_Ieee + 000;
+ Name_Std_Logic_1164 : constant Name_Id := Name_First_Ieee + 001;
+ Name_Std_Ulogic : constant Name_Id := Name_First_Ieee + 002;
+ Name_Std_Ulogic_Vector : constant Name_Id := Name_First_Ieee + 003;
+ Name_Std_Logic : constant Name_Id := Name_First_Ieee + 004;
+ Name_Std_Logic_Vector : constant Name_Id := Name_First_Ieee + 005;
+ Name_Rising_Edge : constant Name_Id := Name_First_Ieee + 006;
+ Name_Falling_Edge : constant Name_Id := Name_First_Ieee + 007;
+ Name_VITAL_Timing : constant Name_Id := Name_First_Ieee + 008;
+ Name_VITAL_Level0 : constant Name_Id := Name_First_Ieee + 009;
+ Name_VITAL_Level1 : constant Name_Id := Name_First_Ieee + 010;
+ Name_Last_Ieee : constant Name_Id := Name_VITAL_Level1;
+
+ -- Verilog keywords.
+ Name_First_Verilog : constant Name_Id := Name_Last_Ieee + 1;
+ Name_Always : constant Name_Id := Name_First_Verilog + 00;
+ Name_Assign : constant Name_Id := Name_First_Verilog + 01;
+ Name_Buf : constant Name_Id := Name_First_Verilog + 02;
+ Name_Bufif0 : constant Name_Id := Name_First_Verilog + 03;
+ Name_Bufif1 : constant Name_Id := Name_First_Verilog + 04;
+ Name_Casex : constant Name_Id := Name_First_Verilog + 05;
+ Name_Casez : constant Name_Id := Name_First_Verilog + 06;
+ Name_Cmos : constant Name_Id := Name_First_Verilog + 07;
+ Name_Deassign : constant Name_Id := Name_First_Verilog + 08;
+ Name_Default : constant Name_Id := Name_First_Verilog + 09;
+ Name_Defparam : constant Name_Id := Name_First_Verilog + 10;
+ Name_Disable : constant Name_Id := Name_First_Verilog + 11;
+ Name_Endcase : constant Name_Id := Name_First_Verilog + 12;
+ Name_Endfunction : constant Name_Id := Name_First_Verilog + 13;
+ Name_Endmodule : constant Name_Id := Name_First_Verilog + 14;
+ Name_Endprimitive : constant Name_Id := Name_First_Verilog + 15;
+ Name_Endspecify : constant Name_Id := Name_First_Verilog + 16;
+ Name_Endtable : constant Name_Id := Name_First_Verilog + 17;
+ Name_Endtask : constant Name_Id := Name_First_Verilog + 18;
+ Name_Forever : constant Name_Id := Name_First_Verilog + 19;
+ Name_Fork : constant Name_Id := Name_First_Verilog + 20;
+ Name_Highz0 : constant Name_Id := Name_First_Verilog + 21;
+ Name_Highz1 : constant Name_Id := Name_First_Verilog + 22;
+ Name_Initial : constant Name_Id := Name_First_Verilog + 23;
+ Name_Input : constant Name_Id := Name_First_Verilog + 24;
+ Name_Join : constant Name_Id := Name_First_Verilog + 25;
+ Name_Large : constant Name_Id := Name_First_Verilog + 26;
+ Name_Medium : constant Name_Id := Name_First_Verilog + 27;
+ Name_Module : constant Name_Id := Name_First_Verilog + 28;
+ Name_Negedge : constant Name_Id := Name_First_Verilog + 29;
+ Name_Nmos : constant Name_Id := Name_First_Verilog + 30;
+ Name_Notif0 : constant Name_Id := Name_First_Verilog + 31;
+ Name_Notif1 : constant Name_Id := Name_First_Verilog + 32;
+ Name_Output : constant Name_Id := Name_First_Verilog + 33;
+ Name_Parameter : constant Name_Id := Name_First_Verilog + 34;
+ Name_Pmos : constant Name_Id := Name_First_Verilog + 35;
+ Name_Posedge : constant Name_Id := Name_First_Verilog + 36;
+ Name_Primitive : constant Name_Id := Name_First_Verilog + 37;
+ Name_Pull0 : constant Name_Id := Name_First_Verilog + 38;
+ Name_Pull1 : constant Name_Id := Name_First_Verilog + 39;
+ Name_Pulldown : constant Name_Id := Name_First_Verilog + 40;
+ Name_Pullup : constant Name_Id := Name_First_Verilog + 41;
+ Name_Reg : constant Name_Id := Name_First_Verilog + 42;
+ Name_Repeat : constant Name_Id := Name_First_Verilog + 43;
+ Name_Rcmos : constant Name_Id := Name_First_Verilog + 44;
+ Name_Rnmos : constant Name_Id := Name_First_Verilog + 45;
+ Name_Rpmos : constant Name_Id := Name_First_Verilog + 46;
+ Name_Rtran : constant Name_Id := Name_First_Verilog + 47;
+ Name_Rtranif0 : constant Name_Id := Name_First_Verilog + 48;
+ Name_Rtranif1 : constant Name_Id := Name_First_Verilog + 49;
+ Name_Small : constant Name_Id := Name_First_Verilog + 50;
+ Name_Specify : constant Name_Id := Name_First_Verilog + 51;
+ Name_Specparam : constant Name_Id := Name_First_Verilog + 52;
+ Name_Strong0 : constant Name_Id := Name_First_Verilog + 53;
+ Name_Strong1 : constant Name_Id := Name_First_Verilog + 54;
+ Name_Supply0 : constant Name_Id := Name_First_Verilog + 55;
+ Name_Supply1 : constant Name_Id := Name_First_Verilog + 56;
+ Name_Tablex : constant Name_Id := Name_First_Verilog + 57;
+ Name_Task : constant Name_Id := Name_First_Verilog + 58;
+ Name_Tran : constant Name_Id := Name_First_Verilog + 59;
+ Name_Tranif0 : constant Name_Id := Name_First_Verilog + 60;
+ Name_Tranif1 : constant Name_Id := Name_First_Verilog + 61;
+ Name_Tri : constant Name_Id := Name_First_Verilog + 62;
+ Name_Tri0 : constant Name_Id := Name_First_Verilog + 63;
+ Name_Tri1 : constant Name_Id := Name_First_Verilog + 64;
+ Name_Trireg : constant Name_Id := Name_First_Verilog + 65;
+ Name_Wand : constant Name_Id := Name_First_Verilog + 66;
+ Name_Weak0 : constant Name_Id := Name_First_Verilog + 67;
+ Name_Weak1 : constant Name_Id := Name_First_Verilog + 68;
+ Name_Wire : constant Name_Id := Name_First_Verilog + 69;
+ Name_Wor : constant Name_Id := Name_First_Verilog + 70;
+ Name_Last_Verilog : constant Name_Id := Name_Wor;
+
+ -- Verilog Directives.
+ Name_First_Directive : constant Name_Id := Name_Last_Verilog + 1;
+ Name_Define : constant Name_Id := Name_First_Directive + 00;
+ Name_Endif : constant Name_Id := Name_First_Directive + 01;
+ Name_Ifdef : constant Name_Id := Name_First_Directive + 02;
+ Name_Include : constant Name_Id := Name_First_Directive + 03;
+ Name_Timescale : constant Name_Id := Name_First_Directive + 04;
+ Name_Undef : constant Name_Id := Name_First_Directive + 05;
+ Name_Last_Directive : constant Name_Id := Name_Undef;
+
+ -- Verilog system tasks.
+ Name_First_Systask : constant Name_Id := Name_Last_Directive + 1;
+ Name_Display : constant Name_Id := Name_First_Systask + 00;
+ Name_Finish : constant Name_Id := Name_First_Systask + 01;
+ Name_Last_Systask : constant Name_Id := Name_Finish;
+
+ -- BSV names
+ Name_First_BSV : constant Name_Id := Name_Last_Systask + 1;
+ Name_uAction : constant Name_Id := Name_First_BSV + 0;
+ Name_uActionValue : constant Name_Id := Name_First_BSV + 1;
+ Name_BVI : constant Name_Id := Name_First_BSV + 2;
+ Name_uC : constant Name_Id := Name_First_BSV + 3;
+ Name_uCF : constant Name_Id := Name_First_BSV + 4;
+ Name_uE : constant Name_Id := Name_First_BSV + 5;
+ Name_uSB : constant Name_Id := Name_First_BSV + 6;
+ Name_uSBR : constant Name_Id := Name_First_BSV + 7;
+ Name_Action : constant Name_Id := Name_First_BSV + 8;
+ Name_Endaction : constant Name_Id := Name_First_BSV + 9;
+ Name_Actionvalue : constant Name_Id := Name_First_BSV + 10;
+ Name_Endactionvalue : constant Name_Id := Name_First_BSV + 11;
+ Name_Ancestor : constant Name_Id := Name_First_BSV + 12;
+ -- begin
+ -- bit
+ -- case
+ -- endcase
+ Name_Clocked_By : constant Name_Id := Name_First_BSV + 13;
+ Name_Continue : constant Name_Id := Name_First_BSV + 14;
+ -- default
+ Name_Default_Clock : constant Name_Id := Name_First_BSV + 15;
+ Name_Default_Reset : constant Name_Id := Name_First_BSV + 16;
+ Name_Dependencies : constant Name_Id := Name_First_BSV + 17;
+ Name_Deriving : constant Name_Id := Name_First_BSV + 18;
+ Name_Determines : constant Name_Id := Name_First_BSV + 19;
+ -- e
+ -- else
+ Name_Enable : constant Name_Id := Name_First_BSV + 20;
+ -- end
+ Name_Enum : constant Name_Id := Name_First_BSV + 21;
+ Name_Export : constant Name_Id := Name_First_BSV + 22;
+ -- for
+ -- function
+ -- endfunction
+ -- if
+ Name_Ifc_Inout : constant Name_Id := Name_First_BSV + 23;
+ Name_Import : constant Name_Id := Name_First_BSV + 24;
+ -- inout
+ Name_Input_Clock : constant Name_Id := Name_First_BSV + 25;
+ Name_Input_Reset : constant Name_Id := Name_First_BSV + 26;
+ Name_Instance : constant Name_Id := Name_First_BSV + 27;
+ Name_Endinstance : constant Name_Id := Name_First_BSV + 28;
+ Name_Interface : constant Name_Id := Name_First_BSV + 29;
+ Name_Endinterface : constant Name_Id := Name_First_BSV + 30;
+ Name_Let : constant Name_Id := Name_First_BSV + 31;
+ Name_Match : constant Name_Id := Name_First_BSV + 32;
+ Name_Matches : constant Name_Id := Name_First_BSV + 33;
+ Name_Method : constant Name_Id := Name_First_BSV + 34;
+ Name_Endmethod : constant Name_Id := Name_First_BSV + 35;
+ -- module
+ -- endmodule
+ Name_Numeric : constant Name_Id := Name_First_BSV + 36;
+ Name_Output_Clock : constant Name_Id := Name_First_BSV + 37;
+ Name_Output_Reset : constant Name_Id := Name_First_BSV + 38;
+ -- package
+ Name_Endpackage : constant Name_Id := Name_First_BSV + 39;
+ -- parameter
+ Name_Par : constant Name_Id := Name_First_BSV + 40;
+ Name_Endpar : constant Name_Id := Name_First_BSV + 41;
+ Name_Path : constant Name_Id := Name_First_BSV + 42;
+ -- port
+ Name_Provisos : constant Name_Id := Name_First_BSV + 43;
+ Name_Ready : constant Name_Id := Name_First_BSV + 44;
+ Name_Reset_By : constant Name_Id := Name_First_BSV + 45;
+ -- return
+ Name_Rule : constant Name_Id := Name_First_BSV + 46;
+ Name_Endrule : constant Name_Id := Name_First_BSV + 47;
+ Name_Rules : constant Name_Id := Name_First_BSV + 48;
+ Name_Endrules : constant Name_Id := Name_First_BSV + 49;
+ Name_Same_Family : constant Name_Id := Name_First_BSV + 50;
+ Name_Schedule : constant Name_Id := Name_First_BSV + 51;
+ Name_Seq : constant Name_Id := Name_First_BSV + 52;
+ Name_Endseq : constant Name_Id := Name_First_BSV + 53;
+ Name_Struct : constant Name_Id := Name_First_BSV + 54;
+ Name_Tagged : constant Name_Id := Name_First_BSV + 55;
+ -- type
+ Name_Typeclass : constant Name_Id := Name_First_BSV + 56;
+ Name_Endtypeclass : constant Name_Id := Name_First_BSV + 57;
+ Name_Typedef : constant Name_Id := Name_First_BSV + 58;
+ Name_Union : constant Name_Id := Name_First_BSV + 59;
+ Name_Valueof : constant Name_Id := Name_First_BSV + 60;
+ Name_uValueof : constant Name_Id := Name_First_BSV + 61;
+ Name_Void : constant Name_Id := Name_First_BSV + 62;
+ -- while
+ Name_Last_BSV : constant Name_Id := Name_First_BSV + 62;
+
+ -- VHDL special comments
+ Name_First_Comment : constant Name_Id := Name_Last_BSV + 1;
+ Name_Psl : constant Name_Id := Name_First_Comment + 0;
+ Name_Pragma : constant Name_Id := Name_First_Comment + 1;
+ Name_Last_Comment : constant Name_Id := Name_First_Comment + 1;
+
+ -- PSL words.
+ Name_First_PSL : constant Name_Id := Name_Last_Comment + 1;
+ Name_A : constant Name_Id := Name_First_PSL + 00;
+ Name_Af : constant Name_Id := Name_First_PSL + 01;
+ Name_Ag : constant Name_Id := Name_First_PSL + 02;
+ Name_Ax : constant Name_Id := Name_First_PSL + 03;
+ Name_Abort : constant Name_Id := Name_First_PSL + 04;
+ -- Name_Always
+ -- Name_And
+ Name_Assume : constant Name_Id := Name_First_PSL + 05;
+ Name_Assume_Guarantee : constant Name_Id := Name_First_PSL + 06;
+ Name_Before : constant Name_Id := Name_First_PSL + 07;
+ -- Name_Boolean
+ Name_Clock : constant Name_Id := Name_First_PSL + 08;
+ Name_Const : constant Name_Id := Name_First_PSL + 09;
+ Name_Cover : constant Name_Id := Name_First_PSL + 10;
+ -- Name_Default
+ Name_E : constant Name_Id := Name_First_PSL + 11;
+ Name_Ef : constant Name_Id := Name_First_PSL + 12;
+ Name_Eg : constant Name_Id := Name_First_PSL + 13;
+ Name_Ex : constant Name_Id := Name_First_PSL + 14;
+ Name_Endpoint : constant Name_Id := Name_First_PSL + 15;
+ Name_Eventually : constant Name_Id := Name_First_PSL + 16;
+ Name_Fairness : constant Name_Id := Name_First_PSL + 17;
+ Name_Fell : constant Name_Id := Name_First_PSL + 18;
+ Name_Forall : constant Name_Id := Name_First_PSL + 19;
+ Name_G : constant Name_Id := Name_First_PSL + 20;
+ -- Name_In
+ Name_Inf : constant Name_Id := Name_First_PSL + 21;
+ Name_Inherit : constant Name_Id := Name_First_PSL + 22;
+ -- Name_Is
+ Name_Never : constant Name_Id := Name_First_PSL + 23;
+ -- Name_Next
+ Name_Next_A : constant Name_Id := Name_First_PSL + 24;
+ Name_Next_E : constant Name_Id := Name_First_PSL + 25;
+ Name_Next_Event : constant Name_Id := Name_First_PSL + 26;
+ Name_Next_Event_A : constant Name_Id := Name_First_PSL + 27;
+ Name_Next_Event_E : constant Name_Id := Name_First_PSL + 28;
+ -- Name_Not
+ -- Name_Or
+ Name_Property : constant Name_Id := Name_First_PSL + 29;
+ Name_Prev : constant Name_Id := Name_First_PSL + 30;
+ Name_Restrict : constant Name_Id := Name_First_PSL + 31;
+ Name_Restrict_Guarantee : constant Name_Id := Name_First_PSL + 32;
+ Name_Rose : constant Name_Id := Name_First_PSL + 33;
+ Name_Sequence : constant Name_Id := Name_First_PSL + 34;
+ Name_Strong : constant Name_Id := Name_First_PSL + 35;
+ -- union
+ -- until
+ Name_Vmode : constant Name_Id := Name_First_PSL + 36;
+ Name_Vprop : constant Name_Id := Name_First_PSL + 37;
+ Name_Vunit : constant Name_Id := Name_First_PSL + 38;
+ Name_W : constant Name_Id := Name_First_PSL + 39;
+ Name_Whilenot : constant Name_Id := Name_First_PSL + 40;
+ Name_Within : constant Name_Id := Name_First_PSL + 41;
+ Name_X : constant Name_Id := Name_First_PSL + 42;
+ Name_Last_PSL : constant Name_Id := Name_First_PSL + 42;
+
+ subtype Name_Id_PSL_Keywords is
+ Name_Id range Name_First_PSL .. Name_Last_PSL;
+
+ -- Initialize the name table with the values defined here.
+ procedure Std_Names_Initialize;
+end Std_Names;
diff --git a/src/std_package.adb b/src/std_package.adb
new file mode 100644
index 000000000..1edfb6cda
--- /dev/null
+++ b/src/std_package.adb
@@ -0,0 +1,1200 @@
+-- std.standard package declarations.
+-- 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 Files_Map;
+with Name_Table;
+with Str_Table;
+with Std_Names; use Std_Names;
+with Flags; use Flags;
+with Iirs_Utils;
+with Sem;
+with Sem_Decls;
+with Iir_Chains;
+
+package body Std_Package is
+ type Bound_Array is array (Boolean) of Iir_Int64;
+ Low_Bound : constant Bound_Array := (False => -(2 ** 31),
+ True => -(2 ** 63));
+ High_Bound : constant Bound_Array := (False => (2 ** 31) - 1,
+ True => (2 ** 63) - 1);
+
+ Std_Location: Location_Type := Location_Nil;
+ Std_Filename : Name_Id := Null_Identifier;
+
+ function Create_Std_Iir (Kind : Iir_Kind) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Kind);
+ Set_Location (Res, Std_Location);
+ return Res;
+ end Create_Std_Iir;
+
+ function Create_Std_Decl (Kind : Iir_Kind) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Std_Iir (Kind);
+ Set_Parent (Res, Standard_Package);
+ return Res;
+ end Create_Std_Decl;
+
+ function Create_Std_Type_Mark (Ref : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Iirs_Utils.Build_Simple_Name (Ref, Std_Location);
+ Set_Type (Res, Get_Type (Ref));
+ return Res;
+ end Create_Std_Type_Mark;
+
+ procedure Create_First_Nodes
+ is
+ begin
+ Std_Filename := Name_Table.Get_Identifier ("*std_standard*");
+ Std_Location := Files_Map.Source_File_To_Location
+ (Files_Map.Create_Virtual_Source_File (Std_Filename));
+
+ if Create_Iir_Error /= Error_Mark then
+ raise Internal_Error;
+ end if;
+ Set_Location (Error_Mark, Std_Location);
+
+ if Create_Std_Iir (Iir_Kind_Integer_Type_Definition)
+ /= Universal_Integer_Type_Definition
+ then
+ raise Internal_Error;
+ end if;
+
+ if Create_Std_Iir (Iir_Kind_Floating_Type_Definition)
+ /= Universal_Real_Type_Definition
+ then
+ raise Internal_Error;
+ end if;
+
+ if Create_Std_Iir (Iir_Kind_Integer_Type_Definition)
+ /= Convertible_Integer_Type_Definition
+ then
+ raise Internal_Error;
+ end if;
+
+ if Create_Std_Iir (Iir_Kind_Floating_Type_Definition)
+ /= Convertible_Real_Type_Definition
+ then
+ raise Internal_Error;
+ end if;
+ end Create_First_Nodes;
+
+ procedure Create_Std_Standard_Package (Parent : Iir_Library_Declaration)
+ is
+ function Get_Std_Character (Char: Character) return Name_Id
+ renames Name_Table.Get_Identifier;
+
+ procedure Set_Std_Identifier (Decl : Iir; Name : Name_Id) is
+ begin
+ Set_Identifier (Decl, Name);
+ Set_Visible_Flag (Decl, True);
+ end Set_Std_Identifier;
+
+ function Create_Std_Integer (Val : Iir_Int64; Lit_Type : Iir)
+ return Iir_Integer_Literal
+ is
+ Res : Iir_Integer_Literal;
+ begin
+ Res := Create_Std_Iir (Iir_Kind_Integer_Literal);
+ Set_Value (Res, Val);
+ Set_Type (Res, Lit_Type);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Create_Std_Integer;
+
+ function Create_Std_Fp (Val : Iir_Fp64; Lit_Type : Iir)
+ return Iir_Floating_Point_Literal
+ is
+ Res : Iir_Floating_Point_Literal;
+ begin
+ Res := Create_Std_Iir (Iir_Kind_Floating_Point_Literal);
+ Set_Fp_Value (Res, Val);
+ Set_Type (Res, Lit_Type);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Create_Std_Fp;
+
+ function Create_Std_Range_Expr (Left, Right : Iir; Rtype : Iir)
+ return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Std_Iir (Iir_Kind_Range_Expression);
+ Set_Left_Limit (Res, Left);
+ Set_Direction (Res, Iir_To);
+ Set_Right_Limit (Res, Right);
+ Set_Expr_Staticness (Res, Locally);
+ Set_Type (Res, Rtype);
+ return Res;
+ end Create_Std_Range_Expr;
+
+ function Create_Std_Literal
+ (Name : Name_Id; Sub_Type : Iir_Enumeration_Type_Definition)
+ return Iir_Enumeration_Literal
+ is
+ Res : Iir_Enumeration_Literal;
+ List : Iir_List;
+ begin
+ Res := Create_Std_Decl (Iir_Kind_Enumeration_Literal);
+ List := Get_Enumeration_Literal_List (Sub_Type);
+ Set_Std_Identifier (Res, Name);
+ Set_Type (Res, Sub_Type);
+ Set_Expr_Staticness (Res, Locally);
+ Set_Name_Staticness (Res, Locally);
+ Set_Enumeration_Decl (Res, Res);
+ Set_Enum_Pos (Res, Iir_Int32 (Get_Nbr_Elements (List)));
+ Sem.Compute_Subprogram_Hash (Res);
+ Append_Element (List, Res);
+ return Res;
+ end Create_Std_Literal;
+
+ -- Append a declaration DECL to Standard_Package.
+ Last_Decl : Iir := Null_Iir;
+ procedure Add_Decl (Decl : Iir) is
+ begin
+ if Last_Decl = Null_Iir then
+ Set_Declaration_Chain (Standard_Package, Decl);
+ else
+ Set_Chain (Last_Decl, Decl);
+ end if;
+ Last_Decl := Decl;
+ end Add_Decl;
+
+ procedure Add_Implicit_Operations (Decl : Iir)
+ is
+ Nxt : Iir;
+ begin
+ Sem_Decls.Create_Implicit_Operations (Decl, True);
+ loop
+ Nxt := Get_Chain (Last_Decl);
+ exit when Nxt = Null_Iir;
+ Last_Decl := Nxt;
+ end loop;
+ end Add_Implicit_Operations;
+
+ procedure Create_Std_Type (Decl : out Iir;
+ Def : Iir;
+ Name : Name_Id)
+ is
+ begin
+ Decl := Create_Std_Decl (Iir_Kind_Type_Declaration);
+ Set_Std_Identifier (Decl, Name);
+ Set_Type_Definition (Decl, Def);
+ Add_Decl (Decl);
+ Set_Type_Declarator (Def, Decl);
+ end Create_Std_Type;
+
+ procedure Create_Integer_Type (Type_Definition : Iir;
+ Type_Decl : out Iir;
+ Type_Name : Name_Id)
+ is
+ begin
+ --Integer_Type_Definition :=
+ -- Create_Std_Iir (Iir_Kind_Integer_Type_Definition);
+ Set_Base_Type (Type_Definition, Type_Definition);
+ Set_Type_Staticness (Type_Definition, Locally);
+ Set_Signal_Type_Flag (Type_Definition, True);
+ Set_Has_Signal_Flag (Type_Definition, not Flags.Flag_Whole_Analyze);
+
+ Type_Decl := Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Type_Decl, Type_Name);
+ Set_Type_Definition (Type_Decl, Type_Definition);
+ Set_Type_Declarator (Type_Definition, Type_Decl);
+ end Create_Integer_Type;
+
+ procedure Create_Integer_Subtype (Type_Definition : Iir;
+ Type_Decl : Iir;
+ Subtype_Definition : out Iir;
+ Subtype_Decl : out Iir)
+ is
+ Constraint : Iir;
+ begin
+ Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Set_Base_Type (Subtype_Definition, Type_Definition);
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Integer (Low_Bound (Flags.Flag_Integer_64),
+ Universal_Integer_Type_Definition),
+ Create_Std_Integer (High_Bound (Flags.Flag_Integer_64),
+ Universal_Integer_Type_Definition),
+ Universal_Integer_Type_Definition);
+ Set_Range_Constraint (Subtype_Definition, Constraint);
+ Set_Type_Staticness (Subtype_Definition, Locally);
+ Set_Signal_Type_Flag (Subtype_Definition, True);
+ Set_Has_Signal_Flag (Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- subtype is
+ Subtype_Decl := Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Subtype_Decl, Get_Identifier (Type_Decl));
+ Set_Type (Subtype_Decl, Subtype_Definition);
+ Set_Type_Declarator (Subtype_Definition, Subtype_Decl);
+ Set_Subtype_Definition (Type_Decl, Subtype_Definition);
+ end Create_Integer_Subtype;
+
+ -- Create an array of EL_TYPE, indexed by Natural.
+ procedure Create_Array_Type
+ (Def : out Iir; Decl : out Iir; El_Decl : Iir; Name : Name_Id)
+ is
+ Index_List : Iir_List;
+ Index : Iir;
+ Element : Iir;
+ begin
+ Element := Create_Std_Type_Mark (El_Decl);
+ Index := Create_Std_Type_Mark (Natural_Subtype_Declaration);
+
+ Def := Create_Std_Iir (Iir_Kind_Array_Type_Definition);
+ Set_Base_Type (Def, Def);
+
+ Index_List := Create_Iir_List;
+ Set_Index_Subtype_Definition_List (Def, Index_List);
+ Set_Index_Subtype_List (Def, Index_List);
+ Append_Element (Index_List, Index);
+
+ Set_Element_Subtype_Indication (Def, Element);
+ Set_Element_Subtype (Def, Get_Type (El_Decl));
+ Set_Type_Staticness (Def, None);
+ Set_Signal_Type_Flag (Def, True);
+ Set_Has_Signal_Flag (Def, not Flags.Flag_Whole_Analyze);
+
+ Create_Std_Type (Decl, Def, Name);
+
+ Add_Implicit_Operations (Decl);
+ end Create_Array_Type;
+
+ -- Create:
+ -- function TO_STRING (VALUE: inter_type) return STRING;
+ procedure Create_To_String (Inter_Type : Iir;
+ Imp : Iir_Predefined_Functions;
+ Name : Name_Id := Std_Names.Name_To_String;
+ Inter2_Id : Name_Id := Null_Identifier;
+ Inter2_Type : Iir := Null_Iir)
+ is
+ Decl : Iir_Implicit_Function_Declaration;
+ Inter : Iir_Interface_Constant_Declaration;
+ Inter2 : Iir_Interface_Constant_Declaration;
+ begin
+ Decl := Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration);
+ Set_Std_Identifier (Decl, Name);
+ Set_Return_Type (Decl, String_Type_Definition);
+ Set_Pure_Flag (Decl, True);
+ Set_Implicit_Definition (Decl, Imp);
+
+ Inter := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_Value);
+ Set_Type (Inter, Inter_Type);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+ Set_Interface_Declaration_Chain (Decl, Inter);
+
+ if Inter2_Id /= Null_Identifier then
+ Inter2 := Create_Iir (Iir_Kind_Interface_Constant_Declaration);
+ Set_Identifier (Inter2, Inter2_Id);
+ Set_Type (Inter2, Inter2_Type);
+ Set_Mode (Inter2, Iir_In_Mode);
+ Set_Lexical_Layout (Inter2, Iir_Lexical_Has_Type);
+ Set_Chain (Inter, Inter2);
+ end if;
+
+ Sem.Compute_Subprogram_Hash (Decl);
+ Add_Decl (Decl);
+ end Create_To_String;
+
+ -- Create:
+ -- function NAME (signal S : I inter_type) return BOOLEAN;
+ procedure Create_Edge_Function
+ (Name : Name_Id; Func : Iir_Predefined_Functions; Inter_Type : Iir)
+ is
+ Decl : Iir_Implicit_Function_Declaration;
+ Inter : Iir_Interface_Constant_Declaration;
+ begin
+ Decl := Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration);
+ Set_Std_Identifier (Decl, Name);
+ Set_Return_Type (Decl, Boolean_Type_Definition);
+ Set_Pure_Flag (Decl, True);
+ Set_Implicit_Definition (Decl, Func);
+
+ Inter := Create_Iir (Iir_Kind_Interface_Signal_Declaration);
+ Set_Identifier (Inter, Std_Names.Name_S);
+ Set_Type (Inter, Inter_Type);
+ Set_Mode (Inter, Iir_In_Mode);
+ Set_Interface_Declaration_Chain (Decl, Inter);
+ Set_Lexical_Layout (Inter, Iir_Lexical_Has_Type);
+
+ Sem.Compute_Subprogram_Hash (Decl);
+ Add_Decl (Decl);
+ end Create_Edge_Function;
+
+ begin
+ -- Create design file.
+ Std_Standard_File := Create_Std_Iir (Iir_Kind_Design_File);
+ Set_Parent (Std_Standard_File, Parent);
+ Set_Design_File_Filename (Std_Standard_File, Std_Filename);
+
+ declare
+ use Str_Table;
+ Std_Time_Stamp : constant Time_Stamp_String :=
+ "20020601000000.000";
+ Id : Time_Stamp_Id;
+ begin
+ Id := Time_Stamp_Id (Str_Table.Start);
+ for I in Time_Stamp_String'Range loop
+ Str_Table.Append (Std_Time_Stamp (I));
+ end loop;
+ Str_Table.Finish;
+ Set_Analysis_Time_Stamp (Std_Standard_File, Id);
+ end;
+
+ -- Create design unit.
+ Std_Standard_Unit := Create_Std_Iir (Iir_Kind_Design_Unit);
+ Set_Identifier (Std_Standard_Unit, Name_Standard);
+ Set_First_Design_Unit (Std_Standard_File, Std_Standard_Unit);
+ Set_Last_Design_Unit (Std_Standard_File, Std_Standard_Unit);
+ Set_Design_File (Std_Standard_Unit, Std_Standard_File);
+ Set_Date_State (Std_Standard_Unit, Date_Analyze);
+ Set_Dependence_List (Std_Standard_Unit, Create_Iir_List);
+
+ Set_Date (Std_Standard_Unit, Date_Valid'First);
+
+ -- Adding "package STANDARD is"
+ Standard_Package := Create_Std_Iir (Iir_Kind_Package_Declaration);
+ Set_Std_Identifier (Standard_Package, Name_Standard);
+ Set_Need_Body (Standard_Package, False);
+
+ Set_Library_Unit (Std_Standard_Unit, Standard_Package);
+ Set_Design_Unit (Standard_Package, Std_Standard_Unit);
+
+ -- boolean
+ begin
+ -- (false, true)
+ Boolean_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Base_Type (Boolean_Type_Definition, Boolean_Type_Definition);
+ Set_Enumeration_Literal_List
+ (Boolean_Type_Definition, Create_Iir_List);
+ Boolean_False := Create_Std_Literal
+ (Name_False, Boolean_Type_Definition);
+ Boolean_True := Create_Std_Literal
+ (Name_True, Boolean_Type_Definition);
+ Set_Type_Staticness (Boolean_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Boolean_Type_Definition, True);
+ Set_Has_Signal_Flag (Boolean_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- type boolean is
+ Create_Std_Type (Boolean_Type_Declaration, Boolean_Type_Definition,
+ Name_Boolean);
+
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (Boolean_Type_Definition);
+ Add_Implicit_Operations (Boolean_Type_Declaration);
+ end;
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- Rising_Edge and Falling_Edge
+ Create_Edge_Function
+ (Std_Names.Name_Rising_Edge, Iir_Predefined_Boolean_Rising_Edge,
+ Boolean_Type_Definition);
+ Create_Edge_Function
+ (Std_Names.Name_Falling_Edge, Iir_Predefined_Boolean_Falling_Edge,
+ Boolean_Type_Definition);
+ end if;
+
+ -- bit.
+ begin
+ -- ('0', '1')
+ Bit_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Enumeration_Literal_List
+ (Bit_Type_Definition, Create_Iir_List);
+ Set_Base_Type (Bit_Type_Definition, Bit_Type_Definition);
+ Bit_0 := Create_Std_Literal
+ (Get_Std_Character ('0'), Bit_Type_Definition);
+ Bit_1 := Create_Std_Literal
+ (Get_Std_Character ('1'), Bit_Type_Definition);
+ Set_Type_Staticness (Bit_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Bit_Type_Definition, True);
+ Set_Has_Signal_Flag (Bit_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+ Set_Only_Characters_Flag (Bit_Type_Definition, True);
+
+ -- type bit is
+ Create_Std_Type (Bit_Type_Declaration, Bit_Type_Definition, Name_Bit);
+
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (Bit_Type_Definition);
+ Add_Implicit_Operations (Bit_Type_Declaration);
+ end;
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- Rising_Edge and Falling_Edge
+ Create_Edge_Function
+ (Std_Names.Name_Rising_Edge, Iir_Predefined_Bit_Rising_Edge,
+ Bit_Type_Definition);
+ Create_Edge_Function
+ (Std_Names.Name_Falling_Edge, Iir_Predefined_Bit_Falling_Edge,
+ Bit_Type_Definition);
+ end if;
+
+ -- characters.
+ declare
+ El: Iir;
+ pragma Unreferenced (El);
+ begin
+ Character_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Base_Type (Character_Type_Definition, Character_Type_Definition);
+ Set_Enumeration_Literal_List
+ (Character_Type_Definition, Create_Iir_List);
+
+ for I in Name_Nul .. Name_Usp loop
+ El := Create_Std_Literal (I, Character_Type_Definition);
+ end loop;
+ for I in Character'(' ') .. Character'('~') loop
+ El := Create_Std_Literal
+ (Get_Std_Character (I), Character_Type_Definition);
+ end loop;
+ El := Create_Std_Literal (Name_Del, Character_Type_Definition);
+ if Vhdl_Std /= Vhdl_87 then
+ for I in Name_C128 .. Name_C159 loop
+ El := Create_Std_Literal (I, Character_Type_Definition);
+ end loop;
+ for I in Character'Val (160) .. Character'Val (255) loop
+ El := Create_Std_Literal
+ (Get_Std_Character (I), Character_Type_Definition);
+ end loop;
+ end if;
+ Set_Type_Staticness (Character_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Character_Type_Definition, True);
+ Set_Has_Signal_Flag (Character_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- type character is
+ Create_Std_Type
+ (Character_Type_Declaration, Character_Type_Definition,
+ Name_Character);
+
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (Character_Type_Definition);
+ Add_Implicit_Operations (Character_Type_Declaration);
+ end;
+
+ -- severity level.
+ begin
+ -- (note, warning, error, failure)
+ Severity_Level_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Base_Type (Severity_Level_Type_Definition,
+ Severity_Level_Type_Definition);
+ Set_Enumeration_Literal_List
+ (Severity_Level_Type_Definition, Create_Iir_List);
+
+ Severity_Level_Note := Create_Std_Literal
+ (Name_Note, Severity_Level_Type_Definition);
+ Severity_Level_Warning := Create_Std_Literal
+ (Name_Warning, Severity_Level_Type_Definition);
+ Severity_Level_Error := Create_Std_Literal
+ (Name_Error, Severity_Level_Type_Definition);
+ Severity_Level_Failure := Create_Std_Literal
+ (Name_Failure, Severity_Level_Type_Definition);
+ Set_Type_Staticness (Severity_Level_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Severity_Level_Type_Definition, True);
+ Set_Has_Signal_Flag (Severity_Level_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- type severity_level is
+ Create_Std_Type
+ (Severity_Level_Type_Declaration, Severity_Level_Type_Definition,
+ Name_Severity_Level);
+
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (Severity_Level_Type_Definition);
+ Add_Implicit_Operations (Severity_Level_Type_Declaration);
+ end;
+
+ -- universal integer
+ begin
+ Create_Integer_Type (Universal_Integer_Type_Definition,
+ Universal_Integer_Type_Declaration,
+ Name_Universal_Integer);
+ Add_Decl (Universal_Integer_Type_Declaration);
+
+ Create_Integer_Subtype (Universal_Integer_Type_Definition,
+ Universal_Integer_Type_Declaration,
+ Universal_Integer_Subtype_Definition,
+ Universal_Integer_Subtype_Declaration);
+
+ Add_Decl (Universal_Integer_Subtype_Declaration);
+ Set_Subtype_Definition (Universal_Integer_Type_Declaration,
+ Universal_Integer_Subtype_Definition);
+
+ -- Do not create implicit operations yet, since "**" needs integer
+ -- type.
+ end;
+
+ -- Universal integer constant 1.
+ Universal_Integer_One :=
+ Create_Std_Integer (1, Universal_Integer_Type_Definition);
+
+ -- Universal real.
+ declare
+ Constraint : Iir_Range_Expression;
+ begin
+ Set_Base_Type (Universal_Real_Type_Definition,
+ Universal_Real_Type_Definition);
+ Set_Type_Staticness (Universal_Real_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Universal_Real_Type_Definition, True);
+ Set_Has_Signal_Flag (Universal_Real_Type_Definition, False);
+
+ Universal_Real_Type_Declaration :=
+ Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Universal_Real_Type_Declaration, Name_Universal_Real);
+ Set_Type_Definition (Universal_Real_Type_Declaration,
+ Universal_Real_Type_Definition);
+ Set_Type_Declarator (Universal_Real_Type_Definition,
+ Universal_Real_Type_Declaration);
+ Add_Decl (Universal_Real_Type_Declaration);
+
+ Universal_Real_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Floating_Subtype_Definition);
+ Set_Base_Type (Universal_Real_Subtype_Definition,
+ Universal_Real_Type_Definition);
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Fp (Iir_Fp64'First, Universal_Real_Type_Definition),
+ Create_Std_Fp (Iir_Fp64'Last, Universal_Real_Type_Definition),
+ Universal_Real_Type_Definition);
+ Set_Range_Constraint (Universal_Real_Subtype_Definition, Constraint);
+ Set_Type_Staticness (Universal_Real_Subtype_Definition, Locally);
+ Set_Signal_Type_Flag (Universal_Real_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Universal_Real_Subtype_Definition, False);
+
+ -- type is
+ Universal_Real_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Identifier (Universal_Real_Subtype_Declaration,
+ Name_Universal_Real);
+ Set_Type (Universal_Real_Subtype_Declaration,
+ Universal_Real_Subtype_Definition);
+ Set_Type_Declarator (Universal_Real_Subtype_Definition,
+ Universal_Real_Subtype_Declaration);
+ Set_Subtype_Definition (Universal_Real_Type_Declaration,
+ Universal_Real_Subtype_Definition);
+
+ Add_Decl (Universal_Real_Subtype_Declaration);
+
+ -- Do not create implicit operations yet, since "**" needs integer
+ -- type.
+ end;
+
+ -- Convertible type.
+ begin
+ Create_Integer_Type (Convertible_Integer_Type_Definition,
+ Convertible_Integer_Type_Declaration,
+ Name_Convertible_Integer);
+ Create_Integer_Subtype (Convertible_Integer_Type_Definition,
+ Convertible_Integer_Type_Declaration,
+ Convertible_Integer_Subtype_Definition,
+ Convertible_Integer_Subtype_Declaration);
+
+ -- Not added in std.standard.
+ end;
+
+ begin
+ Set_Base_Type (Convertible_Real_Type_Definition,
+ Convertible_Real_Type_Definition);
+ Set_Type_Staticness (Convertible_Real_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Convertible_Real_Type_Definition, True);
+ Set_Has_Signal_Flag (Convertible_Real_Type_Definition, False);
+
+ Convertible_Real_Type_Declaration :=
+ Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Convertible_Real_Type_Declaration,
+ Name_Convertible_Real);
+ Set_Type_Definition (Convertible_Real_Type_Declaration,
+ Convertible_Real_Type_Definition);
+ Set_Type_Declarator (Convertible_Real_Type_Definition,
+ Convertible_Real_Type_Declaration);
+ end;
+
+ -- integer type.
+ begin
+ Integer_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Integer_Type_Definition);
+ Create_Integer_Type (Integer_Type_Definition,
+ Integer_Type_Declaration,
+ Name_Integer);
+ Add_Decl (Integer_Type_Declaration);
+
+ Add_Implicit_Operations (Integer_Type_Declaration);
+ Add_Implicit_Operations (Universal_Integer_Type_Declaration);
+ Add_Implicit_Operations (Universal_Real_Type_Declaration);
+
+ Create_Integer_Subtype (Integer_Type_Definition,
+ Integer_Type_Declaration,
+ Integer_Subtype_Definition,
+ Integer_Subtype_Declaration);
+ Add_Decl (Integer_Subtype_Declaration);
+ end;
+
+ -- Real type.
+ declare
+ Constraint : Iir_Range_Expression;
+ begin
+ Real_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Floating_Type_Definition);
+ Set_Base_Type (Real_Type_Definition, Real_Type_Definition);
+ Set_Type_Staticness (Real_Type_Definition, Locally);
+ Set_Signal_Type_Flag (Real_Type_Definition, True);
+ Set_Has_Signal_Flag (Real_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ Real_Type_Declaration :=
+ Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Real_Type_Declaration, Name_Real);
+ Set_Type_Definition (Real_Type_Declaration, Real_Type_Definition);
+ Set_Type_Declarator (Real_Type_Definition, Real_Type_Declaration);
+ Add_Decl (Real_Type_Declaration);
+
+ Add_Implicit_Operations (Real_Type_Declaration);
+
+ Real_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Floating_Subtype_Definition);
+ Set_Base_Type (Real_Subtype_Definition, Real_Type_Definition);
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Fp (Iir_Fp64'First, Universal_Real_Type_Definition),
+ Create_Std_Fp (Iir_Fp64'Last, Universal_Real_Type_Definition),
+ Universal_Real_Type_Definition);
+ Set_Range_Constraint (Real_Subtype_Definition, Constraint);
+ Set_Type_Staticness (Real_Subtype_Definition, Locally);
+ Set_Signal_Type_Flag (Real_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Real_Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ Real_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Real_Subtype_Declaration, Name_Real);
+ Set_Type (Real_Subtype_Declaration, Real_Subtype_Definition);
+ Set_Type_Declarator
+ (Real_Subtype_Definition, Real_Subtype_Declaration);
+ Add_Decl (Real_Subtype_Declaration);
+
+ Set_Subtype_Definition
+ (Real_Type_Declaration, Real_Subtype_Definition);
+ end;
+
+ -- time definition
+ declare
+ Time_Staticness : Iir_Staticness;
+ Last_Unit : Iir_Unit_Declaration;
+ use Iir_Chains.Unit_Chain_Handling;
+
+ function Create_Std_Phys_Lit (Value : Iir_Int64;
+ Unit : Iir_Simple_Name)
+ return Iir_Physical_Int_Literal
+ is
+ Lit: Iir_Physical_Int_Literal;
+ begin
+ Lit := Create_Std_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Value (Lit, Value);
+ pragma Assert (Get_Kind (Unit) = Iir_Kind_Simple_Name);
+ Set_Unit_Name (Lit, Unit);
+ Set_Type (Lit, Time_Type_Definition);
+ Set_Expr_Staticness (Lit, Time_Staticness);
+ return Lit;
+ end Create_Std_Phys_Lit;
+
+ procedure Create_Unit (Unit : out Iir_Unit_Declaration;
+ Multiplier_Value : Iir_Int64;
+ Multiplier : in Iir_Unit_Declaration;
+ Name : Name_Id)
+ is
+ Lit: Iir_Physical_Int_Literal;
+ Mul_Name : Iir;
+ begin
+ Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration);
+ Set_Std_Identifier (Unit, Name);
+ Set_Type (Unit, Time_Type_Definition);
+
+ Mul_Name := Iirs_Utils.Build_Simple_Name
+ (Multiplier, Std_Location);
+ Lit := Create_Std_Phys_Lit (Multiplier_Value, Mul_Name);
+ Set_Physical_Literal (Unit, Lit);
+ Lit := Create_Std_Phys_Lit
+ (Multiplier_Value
+ * Get_Value (Get_Physical_Unit_Value (Multiplier)),
+ Get_Unit_Name (Get_Physical_Unit_Value (Multiplier)));
+ Set_Physical_Unit_Value (Unit, Lit);
+
+ Set_Expr_Staticness (Unit, Time_Staticness);
+ Set_Name_Staticness (Unit, Locally);
+ Append (Last_Unit, Time_Type_Definition, Unit);
+ end Create_Unit;
+
+ Time_Fs_Name : Iir;
+ Time_Fs_Unit: Iir_Unit_Declaration;
+ Time_Ps_Unit: Iir_Unit_Declaration;
+ Time_Ns_Unit: Iir_Unit_Declaration;
+ Time_Us_Unit: Iir_Unit_Declaration;
+ Time_Ms_Unit: Iir_Unit_Declaration;
+ Time_Sec_Unit: Iir_Unit_Declaration;
+ Time_Min_Unit: Iir_Unit_Declaration;
+ Time_Hr_Unit: Iir_Unit_Declaration;
+ Constraint : Iir_Range_Expression;
+ begin
+ if Vhdl_Std >= Vhdl_93c then
+ Time_Staticness := Globally;
+ else
+ Time_Staticness := Locally;
+ end if;
+
+ Time_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Physical_Type_Definition);
+ Set_Base_Type (Time_Type_Definition, Time_Type_Definition);
+ Set_Type_Staticness (Time_Type_Definition, Locally);--Time_Staticness
+ Set_Signal_Type_Flag (Time_Type_Definition, True);
+ Set_Has_Signal_Flag (Time_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+ Set_End_Has_Reserved_Id (Time_Type_Definition, True);
+
+ Build_Init (Last_Unit);
+
+ Time_Fs_Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration);
+ Set_Std_Identifier (Time_Fs_Unit, Name_Fs);
+ Set_Type (Time_Fs_Unit, Time_Type_Definition);
+ Set_Expr_Staticness (Time_Fs_Unit, Time_Staticness);
+ Set_Name_Staticness (Time_Fs_Unit, Locally);
+ Time_Fs_Name := Iirs_Utils.Build_Simple_Name
+ (Time_Fs_Unit, Std_Location);
+ Set_Physical_Unit_Value
+ (Time_Fs_Unit, Create_Std_Phys_Lit (1, Time_Fs_Name));
+ Append (Last_Unit, Time_Type_Definition, Time_Fs_Unit);
+
+ Create_Unit (Time_Ps_Unit, 1000, Time_Fs_Unit, Name_Ps);
+ Create_Unit (Time_Ns_Unit, 1000, Time_Ps_Unit, Name_Ns);
+ Create_Unit (Time_Us_Unit, 1000, Time_Ns_Unit, Name_Us);
+ Create_Unit (Time_Ms_Unit, 1000, Time_Us_Unit, Name_Ms);
+ Create_Unit (Time_Sec_Unit, 1000, Time_Ms_Unit, Name_Sec);
+ Create_Unit (Time_Min_Unit, 60, Time_Sec_Unit, Name_Min);
+ Create_Unit (Time_Hr_Unit, 60, Time_Min_Unit, Name_Hr);
+
+ -- type is
+ Time_Type_Declaration :=
+ Create_Std_Decl (Iir_Kind_Anonymous_Type_Declaration);
+ Set_Identifier (Time_Type_Declaration, Name_Time);
+ Set_Type_Definition (Time_Type_Declaration, Time_Type_Definition);
+ Set_Type_Declarator (Time_Type_Definition, Time_Type_Declaration);
+ Add_Decl (Time_Type_Declaration);
+
+ Add_Implicit_Operations (Time_Type_Declaration);
+
+ Time_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Physical_Subtype_Definition);
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Phys_Lit (Low_Bound (Flags.Flag_Time_64),
+ Time_Fs_Name),
+ Create_Std_Phys_Lit (High_Bound (Flags.Flag_Time_64),
+ Time_Fs_Name),
+ Time_Type_Definition);
+ Set_Range_Constraint (Time_Subtype_Definition, Constraint);
+ Set_Base_Type (Time_Subtype_Definition, Time_Type_Definition);
+ --Set_Subtype_Type_Mark (Time_Subtype_Definition,
+ -- Time_Type_Definition);
+ Set_Type_Staticness (Time_Subtype_Definition, Time_Staticness);
+ Set_Signal_Type_Flag (Time_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Time_Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- subtype time is
+ Time_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Time_Subtype_Declaration, Name_Time);
+ Set_Type (Time_Subtype_Declaration, Time_Subtype_Definition);
+ Set_Type_Declarator (Time_Subtype_Definition,
+ Time_Subtype_Declaration);
+ Add_Decl (Time_Subtype_Declaration);
+ Set_Subtype_Definition
+ (Time_Type_Declaration, Time_Subtype_Definition);
+
+ -- The default time base.
+ case Flags.Time_Resolution is
+ when 'f' =>
+ Time_Base := Time_Fs_Unit;
+ when 'p' =>
+ Time_Base := Time_Ps_Unit;
+ when 'n' =>
+ Time_Base := Time_Ns_Unit;
+ when 'u' =>
+ Time_Base := Time_Us_Unit;
+ when 'm' =>
+ Time_Base := Time_Ms_Unit;
+ when 's' =>
+ Time_Base := Time_Sec_Unit;
+ when 'M' =>
+ Time_Base := Time_Min_Unit;
+ when 'h' =>
+ Time_Base := Time_Hr_Unit;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- VHDL93
+ -- subtype DELAY_LENGTH is TIME range 0 to TIME'HIGH
+ if Vhdl_Std >= Vhdl_93c then
+ Delay_Length_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Physical_Subtype_Definition);
+ Set_Subtype_Type_Mark
+ (Delay_Length_Subtype_Definition,
+ Create_Std_Type_Mark (Time_Subtype_Declaration));
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Phys_Lit (0, Time_Fs_Name),
+ Create_Std_Phys_Lit (High_Bound (Flags.Flag_Time_64),
+ Time_Fs_Name),
+ Time_Type_Definition);
+ Set_Range_Constraint (Delay_Length_Subtype_Definition, Constraint);
+ Set_Base_Type
+ (Delay_Length_Subtype_Definition, Time_Type_Definition);
+ Set_Type_Staticness
+ (Delay_Length_Subtype_Definition, Time_Staticness);
+ Set_Signal_Type_Flag (Delay_Length_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Delay_Length_Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- subtype delay_length is ...
+ Delay_Length_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Delay_Length_Subtype_Declaration,
+ Name_Delay_Length);
+ Set_Type (Delay_Length_Subtype_Declaration,
+ Delay_Length_Subtype_Definition);
+ Set_Type_Declarator (Delay_Length_Subtype_Definition,
+ Delay_Length_Subtype_Declaration);
+ Set_Subtype_Indication (Delay_Length_Subtype_Declaration,
+ Delay_Length_Subtype_Definition);
+ Add_Decl (Delay_Length_Subtype_Declaration);
+ else
+ Delay_Length_Subtype_Definition := Null_Iir;
+ Delay_Length_Subtype_Declaration := Null_Iir;
+ end if;
+ end;
+
+ -- VHDL87:
+ -- function NOW return TIME
+ --
+ -- impure function NOW return DELAY_LENGTH.
+ declare
+ Function_Now : Iir_Implicit_Function_Declaration;
+ begin
+ Function_Now :=
+ Create_Std_Decl (Iir_Kind_Implicit_Function_Declaration);
+ Set_Std_Identifier (Function_Now, Std_Names.Name_Now);
+ if Vhdl_Std = Vhdl_87 then
+ Set_Return_Type (Function_Now, Time_Subtype_Definition);
+ else
+ Set_Return_Type (Function_Now, Delay_Length_Subtype_Definition);
+ end if;
+ if Vhdl_Std = Vhdl_02 then
+ Set_Pure_Flag (Function_Now, True);
+ else
+ Set_Pure_Flag (Function_Now, False);
+ end if;
+ Set_Implicit_Definition (Function_Now, Iir_Predefined_Now_Function);
+ Sem.Compute_Subprogram_Hash (Function_Now);
+ Add_Decl (Function_Now);
+ end;
+
+ -- natural subtype
+ declare
+ Constraint : Iir_Range_Expression;
+ begin
+ Natural_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Set_Base_Type (Natural_Subtype_Definition, Integer_Type_Definition);
+ Set_Subtype_Type_Mark
+ (Natural_Subtype_Definition,
+ Create_Std_Type_Mark (Integer_Subtype_Declaration));
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Integer (0, Integer_Type_Definition),
+ Create_Std_Integer (High_Bound (Flags.Flag_Integer_64),
+ Integer_Type_Definition),
+ Integer_Type_Definition);
+ Set_Range_Constraint (Natural_Subtype_Definition, Constraint);
+ Set_Type_Staticness (Natural_Subtype_Definition, Locally);
+ Set_Signal_Type_Flag (Natural_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Natural_Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ Natural_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Natural_Subtype_Declaration, Name_Natural);
+ Set_Type (Natural_Subtype_Declaration, Natural_Subtype_Definition);
+ Set_Subtype_Indication (Natural_Subtype_Declaration,
+ Natural_Subtype_Definition);
+ Add_Decl (Natural_Subtype_Declaration);
+ Set_Type_Declarator (Natural_Subtype_Definition,
+ Natural_Subtype_Declaration);
+ end;
+
+ -- positive subtype
+ declare
+ Constraint : Iir_Range_Expression;
+ begin
+ Positive_Subtype_Definition :=
+ Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Set_Base_Type (Positive_Subtype_Definition,
+ Integer_Type_Definition);
+ Set_Subtype_Type_Mark
+ (Positive_Subtype_Definition,
+ Create_Std_Type_Mark (Integer_Subtype_Declaration));
+ Constraint := Create_Std_Range_Expr
+ (Create_Std_Integer (1, Integer_Type_Definition),
+ Create_Std_Integer (High_Bound (Flags.Flag_Integer_64),
+ Integer_Type_Definition),
+ Integer_Type_Definition);
+ Set_Range_Constraint (Positive_Subtype_Definition, Constraint);
+ Set_Type_Staticness (Positive_Subtype_Definition, Locally);
+ Set_Signal_Type_Flag (Positive_Subtype_Definition, True);
+ Set_Has_Signal_Flag (Positive_Subtype_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ Positive_Subtype_Declaration :=
+ Create_Std_Decl (Iir_Kind_Subtype_Declaration);
+ Set_Std_Identifier (Positive_Subtype_Declaration, Name_Positive);
+ Set_Type (Positive_Subtype_Declaration, Positive_Subtype_Definition);
+ Set_Subtype_Indication (Positive_Subtype_Declaration,
+ Positive_Subtype_Definition);
+ Add_Decl (Positive_Subtype_Declaration);
+ Set_Type_Declarator (Positive_Subtype_Definition,
+ Positive_Subtype_Declaration);
+ end;
+
+ -- string type.
+ -- type string is array (positive range <>) of character;
+ declare
+ Element : Iir;
+ Index_List : Iir_List;
+ begin
+ Element := Create_Std_Type_Mark (Character_Type_Declaration);
+
+ String_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Array_Type_Definition);
+ Set_Base_Type (String_Type_Definition, String_Type_Definition);
+ Index_List := Create_Iir_List;
+ Append_Element (Index_List,
+ Create_Std_Type_Mark (Positive_Subtype_Declaration));
+ Set_Index_Subtype_Definition_List (String_Type_Definition,
+ Index_List);
+ Set_Index_Subtype_List (String_Type_Definition, Index_List);
+ Set_Element_Subtype_Indication (String_Type_Definition, Element);
+ Set_Element_Subtype (String_Type_Definition,
+ Character_Type_Definition);
+ Set_Type_Staticness (String_Type_Definition, None);
+ Set_Signal_Type_Flag (String_Type_Definition, True);
+ Set_Has_Signal_Flag (String_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ Create_Std_Type
+ (String_Type_Declaration, String_Type_Definition, Name_String);
+
+ Add_Implicit_Operations (String_Type_Declaration);
+ end;
+
+ if Vhdl_Std >= Vhdl_08 then
+ -- type Boolean_Vector is array (Natural range <>) of Boolean;
+ Create_Array_Type
+ (Boolean_Vector_Type_Definition, Boolean_Vector_Type_Declaration,
+ Boolean_Type_Declaration, Name_Boolean_Vector);
+ end if;
+
+ -- bit_vector type.
+ -- type bit_vector is array (natural range <>) of bit;
+ Create_Array_Type
+ (Bit_Vector_Type_Definition, Bit_Vector_Type_Declaration,
+ Bit_Type_Declaration, Name_Bit_Vector);
+
+ -- LRM08 5.3.2.4 Predefined operations on array types
+ -- The following operations are implicitly declared in package
+ -- STD.STANDARD immediately following the declaration of type
+ -- BIT_VECTOR:
+ if Vhdl_Std >= Vhdl_08 then
+ Create_To_String (Bit_Vector_Type_Definition,
+ Iir_Predefined_Bit_Vector_To_Ostring,
+ Name_To_Ostring);
+ Create_To_String (Bit_Vector_Type_Definition,
+ Iir_Predefined_Bit_Vector_To_Hstring,
+ Name_To_Hstring);
+ end if;
+
+ -- VHDL 2008
+ -- Vector types
+ if Vhdl_Std >= Vhdl_08 then
+ -- type integer_vector is array (natural range <>) of Integer;
+ Create_Array_Type
+ (Integer_Vector_Type_Definition, Integer_Vector_Type_Declaration,
+ Integer_Subtype_Declaration, Name_Integer_Vector);
+
+ -- type Real_vector is array (natural range <>) of Real;
+ Create_Array_Type
+ (Real_Vector_Type_Definition, Real_Vector_Type_Declaration,
+ Real_Subtype_Declaration, Name_Real_Vector);
+
+ -- type Time_vector is array (natural range <>) of Time;
+ Create_Array_Type
+ (Time_Vector_Type_Definition, Time_Vector_Type_Declaration,
+ Time_Subtype_Declaration, Name_Time_Vector);
+ end if;
+
+ -- VHDL93:
+ -- type file_open_kind is (read_mode, write_mode, append_mode);
+ if Vhdl_Std >= Vhdl_93c then
+ File_Open_Kind_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Base_Type (File_Open_Kind_Type_Definition,
+ File_Open_Kind_Type_Definition);
+ Set_Enumeration_Literal_List
+ (File_Open_Kind_Type_Definition, Create_Iir_List);
+
+ File_Open_Kind_Read_Mode := Create_Std_Literal
+ (Name_Read_Mode, File_Open_Kind_Type_Definition);
+ File_Open_Kind_Write_Mode := Create_Std_Literal
+ (Name_Write_Mode, File_Open_Kind_Type_Definition);
+ File_Open_Kind_Append_Mode := Create_Std_Literal
+ (Name_Append_Mode, File_Open_Kind_Type_Definition);
+ Set_Type_Staticness (File_Open_Kind_Type_Definition, Locally);
+ Set_Signal_Type_Flag (File_Open_Kind_Type_Definition, True);
+ Set_Has_Signal_Flag (File_Open_Kind_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- type file_open_kind is
+ Create_Std_Type
+ (File_Open_Kind_Type_Declaration, File_Open_Kind_Type_Definition,
+ Name_File_Open_Kind);
+
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (File_Open_Kind_Type_Definition);
+ Add_Implicit_Operations (File_Open_Kind_Type_Declaration);
+ else
+ File_Open_Kind_Type_Declaration := Null_Iir;
+ File_Open_Kind_Type_Definition := Null_Iir;
+ File_Open_Kind_Read_Mode := Null_Iir;
+ File_Open_Kind_Write_Mode := Null_Iir;
+ File_Open_Kind_Append_Mode := Null_Iir;
+ end if;
+
+ -- VHDL93:
+ -- type file_open_status is
+ -- (open_ok, status_error, name_error, mode_error);
+ if Vhdl_Std >= Vhdl_93c then
+ File_Open_Status_Type_Definition :=
+ Create_Std_Iir (Iir_Kind_Enumeration_Type_Definition);
+ Set_Base_Type (File_Open_Status_Type_Definition,
+ File_Open_Status_Type_Definition);
+ Set_Enumeration_Literal_List
+ (File_Open_Status_Type_Definition, Create_Iir_List);
+
+ File_Open_Status_Open_Ok := Create_Std_Literal
+ (Name_Open_Ok, File_Open_Status_Type_Definition);
+ File_Open_Status_Status_Error := Create_Std_Literal
+ (Name_Status_Error, File_Open_Status_Type_Definition);
+ File_Open_Status_Name_Error := Create_Std_Literal
+ (Name_Name_Error, File_Open_Status_Type_Definition);
+ File_Open_Status_Mode_Error := Create_Std_Literal
+ (Name_Mode_Error, File_Open_Status_Type_Definition);
+ Set_Type_Staticness (File_Open_Status_Type_Definition, Locally);
+ Set_Signal_Type_Flag (File_Open_Status_Type_Definition, True);
+ Set_Has_Signal_Flag (File_Open_Status_Type_Definition,
+ not Flags.Flag_Whole_Analyze);
+
+ -- type file_open_kind is
+ Create_Std_Type (File_Open_Status_Type_Declaration,
+ File_Open_Status_Type_Definition,
+ Name_File_Open_Status);
+ Iirs_Utils.Create_Range_Constraint_For_Enumeration_Type
+ (File_Open_Status_Type_Definition);
+ Add_Implicit_Operations (File_Open_Status_Type_Declaration);
+ else
+ File_Open_Status_Type_Declaration := Null_Iir;
+ File_Open_Status_Type_Definition := Null_Iir;
+ File_Open_Status_Open_Ok := Null_Iir;
+ File_Open_Status_Status_Error := Null_Iir;
+ File_Open_Status_Name_Error := Null_Iir;
+ File_Open_Status_Mode_Error := Null_Iir;
+ end if;
+
+ -- VHDL93:
+ -- attribute FOREIGN: string;
+ if Vhdl_Std >= Vhdl_93c then
+ Foreign_Attribute := Create_Std_Decl (Iir_Kind_Attribute_Declaration);
+ Set_Std_Identifier (Foreign_Attribute, Name_Foreign);
+ Set_Type_Mark (Foreign_Attribute,
+ Create_Std_Type_Mark (String_Type_Declaration));
+ Set_Type (Foreign_Attribute, String_Type_Definition);
+ Add_Decl (Foreign_Attribute);
+ else
+ Foreign_Attribute := Null_Iir;
+ end if;
+
+ if Vhdl_Std >= Vhdl_08 then
+ Create_To_String (Boolean_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+ Create_To_String (Bit_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+ Create_To_String (Character_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+ Create_To_String (Severity_Level_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+ Create_To_String (Universal_Integer_Type_Definition,
+ Iir_Predefined_Integer_To_String);
+ Create_To_String (Universal_Real_Type_Definition,
+ Iir_Predefined_Floating_To_String);
+ Create_To_String (Integer_Type_Definition,
+ Iir_Predefined_Integer_To_String);
+ Create_To_String (Real_Type_Definition,
+ Iir_Predefined_Floating_To_String);
+ Create_To_String (Time_Type_Definition,
+ Iir_Predefined_Physical_To_String);
+ Create_To_String (File_Open_Kind_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+ Create_To_String (File_Open_Status_Type_Definition,
+ Iir_Predefined_Enum_To_String);
+
+ -- Predefined overload TO_STRING operations
+ Create_To_String (Real_Type_Definition,
+ Iir_Predefined_Real_To_String_Digits,
+ Name_To_String,
+ Name_Digits,
+ Natural_Subtype_Definition);
+ Create_To_String (Real_Type_Definition,
+ Iir_Predefined_Real_To_String_Format,
+ Name_To_String,
+ Name_Format,
+ String_Type_Definition);
+ Create_To_String (Time_Type_Definition,
+ Iir_Predefined_Time_To_String_Unit,
+ Name_To_String,
+ Name_Unit,
+ Time_Subtype_Definition);
+ end if;
+
+ end Create_Std_Standard_Package;
+end Std_Package;
diff --git a/src/std_package.ads b/src/std_package.ads
new file mode 100644
index 000000000..166c3c789
--- /dev/null
+++ b/src/std_package.ads
@@ -0,0 +1,182 @@
+-- std.standard package declarations.
+-- 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 Std_Package is
+
+ -- This is a special node, not really declared in the STANDARD package,
+ -- used to mark a node as erroneous.
+ -- Its kind is Iir_Kind_Error.
+ Error_Mark : constant Iir;
+
+ -- Some well know values declared in the STANDARD package.
+ -- These values (except time_base) *must* not be modified, and are set by
+ -- create_std_standard_package.
+ -- Time_base is the base unit of time. It is set during the creation of
+ -- all these nodes, and can be modified only *immediatly* after.
+
+ Time_Base: Iir_Unit_Declaration := Null_Iir;
+
+ Std_Standard_File: Iir_Design_File := Null_Iir;
+ Std_Standard_Unit : Iir_Design_Unit := Null_Iir;
+ Standard_Package : Iir_Package_Declaration := Null_Iir;
+
+ -- Boolean values.
+ Boolean_Type_Declaration : Iir_Type_Declaration := Null_Iir;
+ Boolean_Type_Definition : Iir_Enumeration_Type_Definition;
+ Boolean_False : Iir_Enumeration_Literal;
+ Boolean_True : Iir_Enumeration_Literal;
+
+ -- Bit values.
+ Bit_Type_Declaration : Iir_Type_Declaration := Null_Iir;
+ Bit_Type_Definition : Iir_Enumeration_Type_Definition;
+ Bit_0 : Iir_Enumeration_Literal;
+ Bit_1 : Iir_Enumeration_Literal;
+
+ -- Predefined character.
+ Character_Type_Declaration : Iir_Type_Declaration;
+ Character_Type_Definition : Iir_Enumeration_Type_Definition;
+
+ -- severity level.
+ Severity_Level_Type_Declaration : Iir_Type_Declaration;
+ Severity_Level_Type_Definition : Iir_Enumeration_Type_Definition;
+ Severity_Level_Note : Iir_Enumeration_Literal;
+ Severity_Level_Warning : Iir_Enumeration_Literal;
+ Severity_Level_Error : Iir_Enumeration_Literal;
+ Severity_Level_Failure : Iir_Enumeration_Literal;
+
+ -- Universal types.
+ Universal_Integer_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Universal_Integer_Type_Definition : constant Iir_Integer_Type_Definition;
+ Universal_Integer_Subtype_Declaration : Iir_Subtype_Declaration;
+ Universal_Integer_Subtype_Definition : Iir_Integer_Subtype_Definition;
+
+ Universal_Integer_One : Iir_Integer_Literal;
+
+ Universal_Real_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Universal_Real_Type_Definition : constant Iir_Floating_Type_Definition;
+ Universal_Real_Subtype_Declaration : Iir_Subtype_Declaration;
+ Universal_Real_Subtype_Definition : Iir_Floating_Subtype_Definition;
+
+ -- Predefined integer type.
+ Integer_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Integer_Type_Definition : Iir_Integer_Type_Definition;
+ Integer_Subtype_Declaration : Iir_Subtype_Declaration;
+ Integer_Subtype_Definition : Iir_Integer_Subtype_Definition;
+
+ -- Type used when a subtype indication cannot be semantized.
+ -- FIXME: To be improved.
+ Error_Type : Iir_Integer_Type_Definition renames Integer_Type_Definition;
+
+ -- Predefined real type.
+ Real_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Real_Type_Definition : Iir_Floating_Type_Definition;
+ Real_Subtype_Declaration : Iir_Subtype_Declaration;
+ Real_Subtype_Definition : Iir_Floating_Subtype_Definition;
+
+ -- Predefined natural subtype.
+ Natural_Subtype_Declaration : Iir_Subtype_Declaration;
+ Natural_Subtype_Definition : Iir_Integer_Subtype_Definition;
+
+ -- Predefined positive subtype.
+ Positive_Subtype_Declaration : Iir_Subtype_Declaration;
+ Positive_Subtype_Definition : Iir_Integer_Subtype_Definition;
+
+ -- Predefined positive subtype.
+ String_Type_Declaration : Iir_Type_Declaration;
+ String_Type_Definition : Iir_Array_Type_Definition;
+
+ -- Predefined positive subtype.
+ Bit_Vector_Type_Declaration : Iir_Type_Declaration;
+ Bit_Vector_Type_Definition : Iir_Array_Type_Definition;
+
+ -- predefined time subtype
+ Time_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Time_Type_Definition: Iir_Physical_Type_Definition;
+ Time_Subtype_Definition: Iir_Physical_Subtype_Definition;
+ Time_Subtype_Declaration : Iir_Subtype_Declaration;
+
+ -- For VHDL-93
+ Delay_Length_Subtype_Definition : Iir_Physical_Subtype_Definition;
+ Delay_Length_Subtype_Declaration : Iir_Subtype_Declaration;
+
+ -- For VHDL-93:
+ -- type File_Open_Kind
+ File_Open_Kind_Type_Declaration : Iir_Type_Declaration;
+ File_Open_Kind_Type_Definition : Iir_Enumeration_Type_Definition;
+ File_Open_Kind_Read_Mode : Iir_Enumeration_Literal;
+ File_Open_Kind_Write_Mode : Iir_Enumeration_Literal;
+ File_Open_Kind_Append_Mode : Iir_Enumeration_Literal;
+
+ -- For VHDL-93:
+ -- type File_Open_Status
+ File_Open_Status_Type_Declaration : Iir_Type_Declaration;
+ File_Open_Status_Type_Definition : Iir_Enumeration_Type_Definition;
+ File_Open_Status_Open_Ok : Iir_Enumeration_Literal;
+ File_Open_Status_Status_Error : Iir_Enumeration_Literal;
+ File_Open_Status_Name_Error : Iir_Enumeration_Literal;
+ File_Open_Status_Mode_Error : Iir_Enumeration_Literal;
+
+ -- For VHDL-93:
+ -- atribute foreign : string;
+ Foreign_Attribute : Iir_Attribute_Declaration;
+
+ -- For VHDL-08
+ Boolean_Vector_Type_Definition : Iir_Array_Type_Definition;
+ Boolean_Vector_Type_Declaration : Iir_Type_Declaration;
+
+ Integer_Vector_Type_Definition : Iir_Array_Type_Definition;
+ Integer_Vector_Type_Declaration : Iir_Type_Declaration;
+
+ Real_Vector_Type_Definition : Iir_Array_Type_Definition;
+ Real_Vector_Type_Declaration : Iir_Type_Declaration;
+
+ Time_Vector_Type_Definition : Iir_Array_Type_Definition;
+ Time_Vector_Type_Declaration : Iir_Type_Declaration;
+
+ -- Internal use only.
+ -- These types should be considered like universal types, but
+ -- furthermore, they can be converted to any integer/real types while
+ -- universal cannot.
+ Convertible_Integer_Type_Definition : constant Iir_Integer_Type_Definition;
+ Convertible_Real_Type_Definition : constant Iir_Floating_Type_Definition;
+ Convertible_Integer_Type_Declaration : Iir_Anonymous_Type_Declaration;
+ Convertible_Real_Type_Declaration : Iir_Anonymous_Type_Declaration;
+
+ Convertible_Integer_Subtype_Definition : Iir_Integer_Subtype_Definition;
+ Convertible_Integer_Subtype_Declaration : Iir_Subtype_Declaration;
+
+ -- Create the first well-known nodes.
+ procedure Create_First_Nodes;
+
+ -- Create the node for the standard package.
+ procedure Create_Std_Standard_Package (Parent : Iir_Library_Declaration);
+
+private
+ -- For speed reasons, some often used nodes are hard-coded.
+ Error_Mark : constant Iir := 2;
+ Universal_Integer_Type_Definition : constant Iir_Integer_Type_Definition
+ := 3;
+ Universal_Real_Type_Definition : constant Iir_Floating_Type_Definition
+ := 4;
+
+ Convertible_Integer_Type_Definition : constant Iir_Integer_Type_Definition
+ := 5;
+ Convertible_Real_Type_Definition : constant Iir_Floating_Type_Definition
+ := 6;
+end Std_Package;
diff --git a/src/str_table.adb b/src/str_table.adb
new file mode 100644
index 000000000..947c98792
--- /dev/null
+++ b/src/str_table.adb
@@ -0,0 +1,92 @@
+-- String 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 Ada.Unchecked_Conversion;
+with GNAT.Table;
+
+package body Str_Table is
+ package String_Table is new GNAT.Table
+ (Table_Index_Type => String_Id,
+ Table_Component_Type => Character,
+ Table_Low_Bound => Null_String + 1,
+ Table_Initial => 4096,
+ Table_Increment => 100);
+
+ Nul : constant Character := Character'Val (0);
+
+ In_String : Boolean := False;
+ function Start return String_Id
+ is
+ begin
+ pragma Assert (In_String = False);
+ In_String := True;
+ return String_Table.Last + 1;
+ end Start;
+
+ procedure Append (C : Character) is
+ begin
+ pragma Assert (In_String);
+ String_Table.Append (C);
+ end Append;
+
+ procedure Finish is
+ begin
+ pragma Assert (In_String);
+ String_Table.Append (Nul);
+ In_String := False;
+ end Finish;
+
+ function Get_String_Fat_Acc (Id : String_Id) return String_Fat_Acc
+ is
+ function To_String_Fat_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => String_Fat_Acc);
+ begin
+ return To_String_Fat_Acc (String_Table.Table (Id)'Address);
+ end Get_String_Fat_Acc;
+
+ function Get_Length (Id : String_Id) return Natural
+ is
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ begin
+ Ptr := Get_String_Fat_Acc (Id);
+ Len := 1;
+ loop
+ if Ptr (Len) = Nul then
+ return Natural (Len - 1);
+ end if;
+ Len := Len + 1;
+ end loop;
+ end Get_Length;
+
+ function Image (Id : String_Id) return String
+ is
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ begin
+ Len := Nat32 (Get_Length (Id));
+ Ptr := Get_String_Fat_Acc (Id);
+ return String (Ptr (1 .. Len));
+ end Image;
+
+ procedure Initialize is
+ begin
+ String_Table.Free;
+ String_Table.Init;
+ end Initialize;
+end Str_Table;
diff --git a/src/str_table.ads b/src/str_table.ads
new file mode 100644
index 000000000..de65070e3
--- /dev/null
+++ b/src/str_table.ads
@@ -0,0 +1,44 @@
+-- String 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 Types; use Types;
+
+package Str_Table is
+ -- Create a new entry in the string table and returns a number to it.
+ function Start return String_Id;
+ pragma Inline (Start);
+
+ -- Add a new character in the current entry.
+ procedure Append (C : Character);
+ pragma Inline (Append);
+
+ -- Finish the current entry.
+ procedure Finish;
+ pragma Inline (Finish);
+
+ -- Get a fat access to the string ID.
+ function Get_String_Fat_Acc (Id : String_Id) return String_Fat_Acc;
+ pragma Inline (Get_String_Fat_Acc);
+
+ -- Get ID as a string.
+ -- This function is slow, to be used only for debugging.
+ function Image (Id : String_Id) return String;
+
+ -- Free all the memory and reinitialize the package.
+ procedure Initialize;
+end Str_Table;
+
diff --git a/src/tokens.adb b/src/tokens.adb
new file mode 100644
index 000000000..5d27be8d9
--- /dev/null
+++ b/src/tokens.adb
@@ -0,0 +1,443 @@
+-- Scanner token 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.
+package body Tokens is
+ -- Return the name of the token.
+ function Image (Token: Token_Type) return String is
+ begin
+ case Token is
+ when Tok_Invalid =>
+ return "<invalid>";
+ when Tok_Left_Paren =>
+ return "(";
+ when Tok_Right_Paren =>
+ return ")";
+ when Tok_Left_Bracket =>
+ return "[";
+ when Tok_Right_Bracket =>
+ return "]";
+ when Tok_Colon =>
+ return ":";
+ when Tok_Semi_Colon =>
+ return ";";
+ when Tok_Comma =>
+ return ",";
+ when Tok_Tick =>
+ return "'";
+ when Tok_Double_Star =>
+ return "**";
+ when Tok_Double_Arrow =>
+ return "=>";
+ when Tok_Assign =>
+ return ":=";
+ when Tok_Bar =>
+ return "|";
+ when Tok_Box =>
+ return "<>";
+ when Tok_Dot =>
+ return ".";
+
+ when Tok_Eof =>
+ return "<EOF>";
+ when Tok_Newline =>
+ return "<newline>";
+ when Tok_Comment =>
+ return "<comment>";
+ when Tok_Character =>
+ return "<character>";
+ when Tok_Identifier =>
+ return "<identifier>";
+ when Tok_Integer =>
+ return "<integer>";
+ when Tok_Real =>
+ return "<real>";
+ when Tok_String =>
+ return "<string>";
+ when Tok_Bit_String =>
+ return "<bit string>";
+
+ when Tok_Equal_Equal =>
+ return "==";
+
+ -- relational_operator:
+ when Tok_Equal =>
+ return "=";
+ when Tok_Not_Equal =>
+ return "/=";
+ when Tok_Less =>
+ return "<";
+ when Tok_Less_Equal =>
+ return "<=";
+ when Tok_Greater =>
+ return ">";
+ when Tok_Greater_Equal =>
+ return ">=";
+
+ when Tok_Match_Equal =>
+ return "?=";
+ when Tok_Match_Not_Equal =>
+ return "?/=";
+ when Tok_Match_Less =>
+ return "?<";
+ when Tok_Match_Less_Equal =>
+ return "?<=";
+ when Tok_Match_Greater =>
+ return "?>";
+ when Tok_Match_Greater_Equal =>
+ return "?>=";
+
+ -- sign token
+ when Tok_Plus =>
+ return "+";
+ when Tok_Minus =>
+ return "-";
+ -- and adding_operator
+ when Tok_Ampersand =>
+ return "&";
+
+ when Tok_Condition =>
+ return "??";
+
+ -- multiplying operator
+ when Tok_Star =>
+ return "*";
+ when Tok_Slash =>
+ return "/";
+ when Tok_Mod =>
+ return "mod";
+ when Tok_Rem =>
+ return "rem";
+
+ -- relation token:
+ when Tok_And =>
+ return "and";
+ when Tok_Or =>
+ return "or";
+ when Tok_Xor =>
+ return "xor";
+ when Tok_Nand =>
+ return "nand";
+ when Tok_Nor =>
+ return "nor";
+ when Tok_Xnor =>
+ return "xnor";
+
+ -- Reserved words.
+ when Tok_Abs =>
+ return "abs";
+ when Tok_Access =>
+ return "access";
+ when Tok_After =>
+ return "after";
+ when Tok_Alias =>
+ return "alias";
+ when Tok_All =>
+ return "all";
+ when Tok_Architecture =>
+ return "architecture";
+ when Tok_Array =>
+ return "array";
+ when Tok_Assert =>
+ return "assert";
+ when Tok_Attribute =>
+ return "attribute";
+
+ when Tok_Begin =>
+ return "begin";
+ when Tok_Block =>
+ return "block";
+ when Tok_Body =>
+ return "body";
+ when Tok_Buffer =>
+ return "buffer";
+ when Tok_Bus =>
+ return "bus";
+
+ when Tok_Case =>
+ return "case";
+ when Tok_Component =>
+ return "component";
+ when Tok_Configuration =>
+ return "configuration";
+ when Tok_Constant =>
+ return "constant";
+
+ when Tok_Disconnect =>
+ return "disconnect";
+ when Tok_Downto =>
+ return "downto";
+
+ when Tok_Else =>
+ return "else";
+ when Tok_Elsif =>
+ return "elsif";
+ when Tok_End =>
+ return "end";
+ when Tok_Entity =>
+ return "entity";
+ when Tok_Exit =>
+ return "exit";
+
+ when Tok_File =>
+ return "file";
+ when Tok_For =>
+ return "for";
+ when Tok_Function =>
+ return "function";
+
+ when Tok_Generate =>
+ return "generate";
+ when Tok_Generic =>
+ return "generic";
+ when Tok_Group =>
+ return "group";
+ when Tok_Guarded =>
+ return "guarded";
+
+ when Tok_If =>
+ return "if";
+ when Tok_Impure =>
+ return "impure";
+ when Tok_In =>
+ return "in";
+ when Tok_Inertial =>
+ return "inertial";
+ when Tok_Inout =>
+ return "inout";
+ when Tok_Is =>
+ return "is";
+
+ when Tok_Label =>
+ return "label";
+ when Tok_Library =>
+ return "library";
+ when Tok_Linkage =>
+ return "linkage";
+ when Tok_Literal =>
+ return "literal";
+ when Tok_Loop =>
+ return "loop";
+
+ when Tok_Map =>
+ return "map";
+
+ when Tok_New =>
+ return "new";
+ when Tok_Next =>
+ return "next";
+ when Tok_Not =>
+ return "not";
+ when Tok_Null =>
+ return "null";
+
+ when Tok_Of =>
+ return "of";
+ when Tok_On =>
+ return "on";
+ when Tok_Open =>
+ return "open";
+ when Tok_Out =>
+ return "out";
+ when Tok_Others =>
+ return "others";
+
+ when Tok_Package =>
+ return "package";
+ when Tok_Port =>
+ return "port";
+ when Tok_Postponed =>
+ return "postponed";
+ when Tok_Procedure =>
+ return "procedure";
+ when Tok_Process =>
+ return "process";
+ when Tok_Pure =>
+ return "pure";
+
+ when Tok_Range =>
+ return "range";
+ when Tok_Record =>
+ return "record";
+ when Tok_Register =>
+ return "register";
+ when Tok_Reject =>
+ return "reject";
+ when Tok_Report =>
+ return "report";
+ when Tok_Return =>
+ return "return";
+
+ when Tok_Select =>
+ return "select";
+ when Tok_Severity =>
+ return "severity";
+ when Tok_Shared =>
+ return "shared";
+ when Tok_Signal =>
+ return "signal";
+ when Tok_Subtype =>
+ return "subtype";
+
+ when Tok_Then =>
+ return "then";
+ when Tok_To =>
+ return "to";
+ when Tok_Transport =>
+ return "transport";
+ when Tok_Type =>
+ return "type";
+
+ when Tok_Unaffected =>
+ return "unaffected";
+ when Tok_Units =>
+ return "units";
+ when Tok_Until =>
+ return "until";
+ when Tok_Use =>
+ return "use";
+
+ when Tok_Variable =>
+ return "variable";
+
+ when Tok_Wait =>
+ return "wait";
+ when Tok_When =>
+ return "when";
+ when Tok_While =>
+ return "while";
+ when Tok_With =>
+ return "with";
+
+ -- shift_operator
+ when Tok_Sll =>
+ return "sll";
+ when Tok_Sla =>
+ return "sla";
+ when Tok_Sra =>
+ return "sra";
+ when Tok_Srl =>
+ return "srl";
+ when Tok_Rol =>
+ return "rol";
+ when Tok_Ror =>
+ return "ror";
+
+ -- VHDL 00
+ when Tok_Protected =>
+ return "protected";
+
+ -- AMS-VHDL
+ when Tok_Across =>
+ return "across";
+ when Tok_Break =>
+ return "break";
+ when Tok_Limit =>
+ return "limit";
+ when Tok_Nature =>
+ return "nature";
+ when Tok_Noise =>
+ return "noise";
+ when Tok_Procedural =>
+ return "procedural";
+ when Tok_Quantity =>
+ return "quantity";
+ when Tok_Reference =>
+ return "reference";
+ when Tok_Spectrum =>
+ return "spectrum";
+ when Tok_Subnature =>
+ return "subnature";
+ when Tok_Terminal =>
+ return "terminal";
+ when Tok_Through =>
+ return "through";
+ when Tok_Tolerance =>
+ return "tolerance";
+
+ when Tok_And_And =>
+ return "&&";
+ when Tok_Bar_Bar =>
+ return "||";
+ when Tok_Left_Curly =>
+ return "{";
+ when Tok_Right_Curly =>
+ return "}";
+ when Tok_Exclam_Mark =>
+ return "!";
+ when Tok_Brack_Star =>
+ return "[*";
+ when Tok_Brack_Plus_Brack =>
+ return "[+]";
+ when Tok_Brack_Arrow =>
+ return "[->";
+ when Tok_Brack_Equal =>
+ return "[=";
+ when Tok_Bar_Arrow =>
+ return "|->";
+ when Tok_Bar_Double_Arrow =>
+ return "|=>";
+ when Tok_Minus_Greater =>
+ return "->";
+ when Tok_Arobase =>
+ return "@";
+
+ when Tok_Psl_Default =>
+ return "default";
+ when Tok_Psl_Clock =>
+ return "clock";
+ when Tok_Psl_Property =>
+ return "property";
+ when Tok_Psl_Sequence =>
+ return "sequence";
+ when Tok_Psl_Endpoint =>
+ return "endpoint";
+ when Tok_Psl_Assert =>
+ return "assert";
+ when Tok_Psl_Cover =>
+ return "cover";
+ when Tok_Psl_Const =>
+ return "const";
+ when Tok_Psl_Boolean =>
+ return "boolean";
+ when Tok_Inf =>
+ return "inf";
+ when Tok_Within =>
+ return "within";
+ when Tok_Abort =>
+ return "abort";
+ when Tok_Before =>
+ return "before";
+ when Tok_Always =>
+ return "always";
+ when Tok_Never =>
+ return "never";
+ when Tok_Eventually =>
+ return "eventually";
+ when Tok_Next_A =>
+ return "next_a";
+ when Tok_Next_E =>
+ return "next_e";
+ when Tok_Next_Event =>
+ return "next_event";
+ when Tok_Next_Event_A =>
+ return "next_event_a";
+ when Tok_Next_Event_E =>
+ return "next_event_e";
+ end case;
+ end Image;
+
+end Tokens;
diff --git a/src/tokens.ads b/src/tokens.ads
new file mode 100644
index 000000000..c72873103
--- /dev/null
+++ b/src/tokens.ads
@@ -0,0 +1,279 @@
+-- Scanner token 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.
+package Tokens is
+ pragma Pure (Tokens);
+
+ type Token_Type is
+ (
+ Tok_Invalid, -- current_token is not valid.
+
+ Tok_Left_Paren, -- (
+ Tok_Right_Paren, -- )
+ Tok_Left_Bracket, -- [
+ Tok_Right_Bracket, -- ]
+ Tok_Colon, -- :
+ Tok_Semi_Colon, -- ;
+ Tok_Comma, -- ,
+ Tok_Double_Arrow, -- =>
+ Tok_Tick, -- '
+ Tok_Double_Star, -- **
+ Tok_Assign, -- :=
+ Tok_Bar, -- |
+ Tok_Box, -- <>
+ Tok_Dot, -- .
+
+ Tok_Equal_Equal, -- == (AMS Vhdl)
+
+ Tok_Eof, -- End of file.
+ Tok_Newline,
+ Tok_Comment,
+ Tok_Character,
+ Tok_Identifier,
+ Tok_Integer,
+ Tok_Real,
+ Tok_String,
+ Tok_Bit_String,
+
+ -- relational_operator
+ Tok_Equal, -- =
+ Tok_Not_Equal, -- /=
+ Tok_Less, -- <
+ Tok_Less_Equal, -- <=
+ Tok_Greater, -- >
+ Tok_Greater_Equal, -- >=
+
+ Tok_Match_Equal, -- ?=
+ Tok_Match_Not_Equal, -- ?/=
+ Tok_Match_Less, -- ?<
+ Tok_Match_Less_Equal, -- ?<=
+ Tok_Match_Greater, -- ?>
+ Tok_Match_Greater_Equal, -- ?>=
+
+ -- sign token
+ Tok_Plus, -- +
+ Tok_Minus, -- -
+ -- and adding_operator
+ Tok_Ampersand, -- &
+
+ Tok_Condition, -- ??
+
+ -- PSL
+ Tok_And_And, -- &&
+ Tok_Bar_Bar, -- ||
+ Tok_Left_Curly, -- {
+ Tok_Right_Curly, -- }
+ Tok_Exclam_Mark, -- !
+ Tok_Brack_Star, -- [*
+ Tok_Brack_Plus_Brack, -- [+]
+ Tok_Brack_Arrow, -- [->
+ Tok_Brack_Equal, -- [=
+ Tok_Bar_Arrow, -- |->
+ Tok_Bar_Double_Arrow, -- |=>
+ Tok_Minus_Greater, -- ->
+ Tok_Arobase, -- @
+
+ -- multiplying operator
+ Tok_Star, -- *
+ Tok_Slash, -- /
+ Tok_Mod, -- mod
+ Tok_Rem, -- rem
+
+ -- relation token:
+ Tok_And,
+ Tok_Or,
+ Tok_Xor,
+ Tok_Nand,
+ Tok_Nor,
+
+ -- miscellaneous operator
+ Tok_Abs,
+ Tok_Not,
+
+ -- Key words
+ Tok_Access,
+ Tok_After,
+ Tok_Alias,
+ Tok_All,
+ Tok_Architecture,
+ Tok_Array,
+ Tok_Assert,
+ Tok_Attribute,
+
+ Tok_Begin,
+ Tok_Block,
+ Tok_Body,
+ Tok_Buffer,
+ Tok_Bus,
+
+ Tok_Case,
+ Tok_Component,
+ Tok_Configuration,
+ Tok_Constant,
+
+ Tok_Disconnect,
+ Tok_Downto,
+
+ Tok_Else,
+ Tok_Elsif,
+ Tok_End,
+ Tok_Entity,
+ Tok_Exit,
+
+ Tok_File,
+ Tok_For,
+ Tok_Function,
+
+ Tok_Generate,
+ Tok_Generic,
+ Tok_Guarded,
+
+ Tok_If,
+ Tok_In,
+ Tok_Inout,
+ Tok_Is,
+
+ Tok_Label,
+ Tok_Library,
+ Tok_Linkage,
+ Tok_Loop,
+
+ Tok_Map,
+
+ Tok_New,
+ Tok_Next,
+ Tok_Null,
+
+ Tok_Of,
+ Tok_On,
+ Tok_Open,
+ Tok_Others,
+ Tok_Out,
+
+ Tok_Package,
+ Tok_Port,
+ Tok_Procedure,
+ Tok_Process,
+
+ Tok_Range,
+ Tok_Record,
+ Tok_Register,
+ Tok_Report,
+ Tok_Return,
+
+ Tok_Select,
+ Tok_Severity,
+ Tok_Signal,
+ Tok_Subtype,
+
+ Tok_Then,
+ Tok_To,
+ Tok_Transport,
+ Tok_Type,
+
+ Tok_Units,
+ Tok_Until,
+ Tok_Use,
+
+ Tok_Variable,
+
+ Tok_Wait,
+ Tok_When,
+ Tok_While,
+ Tok_With,
+
+ -- Tokens below this line are key words in vhdl93 but not in vhdl87
+ Tok_Xnor,
+ Tok_Group,
+ Tok_Impure,
+ Tok_Inertial,
+ Tok_Literal,
+ Tok_Postponed,
+ Tok_Pure,
+ Tok_Reject,
+ Tok_Shared,
+ Tok_Unaffected,
+
+ -- shift_operator
+ Tok_Sll,
+ Tok_Sla,
+ Tok_Sra,
+ Tok_Srl,
+ Tok_Rol,
+ Tok_Ror,
+
+ -- Added by Vhdl 2000:
+ Tok_Protected,
+
+ -- AMS reserved words
+ Tok_Across,
+ Tok_Break,
+ Tok_Limit,
+ Tok_Nature,
+ Tok_Noise,
+ Tok_Procedural,
+ Tok_Quantity,
+ Tok_Reference,
+ Tok_Spectrum,
+ Tok_Subnature,
+ Tok_Terminal,
+ Tok_Through,
+ Tok_Tolerance,
+
+ -- PSL words
+ Tok_Psl_Default,
+ Tok_Psl_Clock,
+ Tok_Psl_Property,
+ Tok_Psl_Sequence,
+ Tok_Psl_Endpoint,
+ Tok_Psl_Assert,
+ Tok_Psl_Cover,
+
+ Tok_Psl_Const,
+ Tok_Psl_Boolean,
+ Tok_Inf,
+
+ Tok_Within,
+ Tok_Abort,
+ Tok_Before,
+ Tok_Always,
+ Tok_Never,
+ Tok_Eventually,
+ Tok_Next_A,
+ Tok_Next_E,
+ Tok_Next_Event,
+ Tok_Next_Event_A,
+ Tok_Next_Event_E
+ );
+
+ -- subtype Token_Relation_Type is Token_Type range Tok_And .. Tok_Xnor;
+ subtype Token_Relational_Operator_Type is Token_Type range
+ Tok_Equal .. Tok_Match_Greater_Equal;
+ subtype Token_Shift_Operator_Type is Token_Type range
+ Tok_Sll .. Tok_Ror;
+ subtype Token_Sign_Type is Token_Type range
+ Tok_Plus .. Tok_Minus;
+ subtype Token_Adding_Operator_Type is Token_Type range
+ Tok_Plus .. Tok_Ampersand;
+ subtype Token_Multiplying_Operator_Type is Token_Type range
+ Tok_Star .. Tok_Rem;
+
+ Tok_First_Keyword : constant Tokens.Token_Type := Tokens.Tok_Mod;
+
+ -- Return the name of the token.
+ function Image (Token: Token_Type) return String;
+end Tokens;
diff --git a/src/translate/Makefile b/src/translate/Makefile
new file mode 100644
index 000000000..b331b5728
--- /dev/null
+++ b/src/translate/Makefile
@@ -0,0 +1,45 @@
+# -*- Makefile -*- for the GHDL translation back-end.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+BE=gcc
+ortho_srcdir=../ortho
+GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05
+#GNAT_FLAGS+=-O -gnatn
+LN=ln -s
+
+compiler: force # ortho_nodes.ads ortho_$(BE)_front.ads
+ $(MAKE) -f $(ortho_srcdir)/$(BE)/Makefile \
+ ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \
+ ortho_exec=ghdl1-$(BE) all
+
+all:
+ [ -d lib ] || mkdir lib
+ $(MAKE) -f $(ortho_srcdir)/gcc/Makefile \
+ ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \
+ ortho_exec=ghdl1-gcc all
+ $(MAKE) -C ghdldrv
+ $(MAKE) -C grt all libdir=`pwd`/lib
+ $(MAKE) -C ghdldrv install.v87 install.v93 install.standard
+
+clean:
+ $(RM) *.o *.ali ghdl1-* gen_tree ortho_nodes-main b~*.ad?
+ $(RM) *~ ortho_nodes.ads ortho_nodes.tmp
+
+force:
+
+.PHONY: compiler clean force all
diff --git a/src/translate/gcc/ANNOUNCE b/src/translate/gcc/ANNOUNCE
new file mode 100644
index 000000000..7b1060e20
--- /dev/null
+++ b/src/translate/gcc/ANNOUNCE
@@ -0,0 +1,21 @@
+I am happy to introduce GHDL.
+
+GHDL is a GCC front-end for the VHDL (IEEE 1076) language, an hardware design
+language.
+
+Currently, GHDL implements most of VHDL-1987 and some features of
+VHDL-1993. It is mature enough to compile and run some complex design (such
+as a DLX processor and leon1, a SPARCv7 processor)
+
+GHDL has been developped on a GNU/Linux x86 system, and only this configuration
+has been tested (porting to other processor or system should not be an hard
+task, but there are system dependent files in the run time).
+
+GHDL is written in Ada95 (using GNAT) and relies on agcc, an Ada
+binding for GCC. It also includes a run-time library (written in Ada), named
+grt. The front-end and the library are both distributed under the GPL licence.
+
+For sources, binary tarballs, or for more information, go to
+http://ghdl.free.fr
+
+Tristan Gingold.
diff --git a/src/translate/gcc/INSTALL b/src/translate/gcc/INSTALL
new file mode 100644
index 000000000..e710f9110
--- /dev/null
+++ b/src/translate/gcc/INSTALL
@@ -0,0 +1,24 @@
+Install file for the binary distribution of GHDL.
+
+GHDL is Copyright 2002 - 2010 Tristan Gingold.
+GHDL is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+The binary are installed in /usr/local directory. You cannot change this
+default location, unless you set links.
+
+You must be root to install this distribution.
+
+To install ghdl:
+$ su
+# tar -C / -jxvf @TARFILE@.tar.bz2
+
+Note: you must also have a C compiler and zlib installed.
+
+There is a mailing list for any questions. You can subscribe via:
+ https://mail.gna.org/listinfo/ghdl-discuss/
+
+Tristan Gingold.
+
diff --git a/src/translate/gcc/Make-lang.in b/src/translate/gcc/Make-lang.in
new file mode 100644
index 000000000..cde3e6c07
--- /dev/null
+++ b/src/translate/gcc/Make-lang.in
@@ -0,0 +1,190 @@
+# Top level -*- makefile -*- fragment for vhdl (GHDL).
+# Copyright (C) 2002
+# Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.info, foo.dvi,
+# foo.install-normal, foo.install-common, foo.install-info, foo.install-man,
+# foo.uninstall, foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: g++)
+# - the compiler proper (eg: cc1plus)
+# - define the names for selecting the language in LANGUAGES.
+# tool definitions
+MV = mv
+RM = rm -f
+
+# Extra flags to pass to recursive makes.
+GHDL_ADAFLAGS= -Wall -gnata
+VHDL_LIB_DIR=$(libsubdir)/vhdl
+GNATBIND = gnatbind
+GNATMAKE = gnatmake
+VHDL_FLAGS_TO_PASS = \
+ "GHDL_ADAFLAGS=$(GHDL_ADAFLAGS)" \
+ "GNATMAKE=$(GNATMAKE)" \
+ "GNATBIND=$(GNATBIND)" \
+ "CFLAGS=$(CFLAGS)" \
+ "VHDL_LIB_DIR=$(VHDL_LIB_DIR)" \
+ "INSTALL_DATA=$(INSTALL_DATA)" \
+ "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \
+ "libexecsubdir=$(libexecsubdir)"
+
+MAKE_IN_VHDL=$(MAKE) -C vhdl $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS)
+
+# Define the names for selecting vhdl in LANGUAGES.
+vhdl VHDL: ghdl1$(exeext) ghdl$(exeext) ghdllib
+
+# Tell GNU Make to ignore these, if they exist.
+.PHONY: vhdl VHDL ghdllib
+
+#ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \
+# $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \
+# $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h
+# $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES)
+
+GHDL1_OBJS = attribs.o vhdl/ortho-lang.o
+
+# To be put in ALL_HOST_FRONTEND_OBJS, so that generated files are created
+# before.
+vhdl_OBJS=vhdl/ortho-lang.o
+
+# The compiler proper.
+# It is compiled into the vhdl/ subdirectory to avoid file name clashes but
+# linked in in gcc directory to be able to access to gcc object files.
+ghdl1$(exeext): force $(GHDL1_OBJS) $(BACKEND) $(LIBDEPS)
+ CURDIR=`pwd`; cd $(srcdir)/vhdl; VHDLSRCDIR=`pwd`; cd $$CURDIR/vhdl; \
+ $(GNATMAKE) -c -aI$$VHDLSRCDIR ortho_gcc-main \
+ -cargs $(CFLAGS) $(GHDL_ADAFLAGS)
+ $(GNATMAKE) -o $@ -aI$(srcdir)/vhdl -aOvhdl ortho_gcc-main \
+ -bargs -E -cargs $(CFLAGS) $(GHDL_ADAFLAGS) \
+ -largs --LINK=$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) $(GHDL1_OBJS) \
+ $(filter-out main.o,$(BACKEND)) $(LIBS) $(BACKENDLIBS)
+
+# The driver for ghdl.
+ghdl$(exeext): force
+ $(MAKE_IN_VHDL) ../ghdl$(exeext)
+
+# Ghdl libraries.
+ghdllib: ghdl$(exeext) ghdl1$(exeext) $(GCC_PASSES) force
+ $(MAKE_IN_VHDL) GRT_FLAGS="-O -g" $(FLAGS_TO_PASS) \
+ ADAC=$(COMPILER_FOR_BUILD) ghdllib
+
+# Build hooks:
+
+vhdl.all.build:
+
+vhdl.all.cross:
+ @echo "No support for building vhdl cross-compiler"
+ exit 1
+
+vhdl.start.encap:
+vhdl.rest.encap:
+
+# Documentation hooks
+doc/ghdl.info: vhdl/ghdl.texi
+ -rm -f doc/ghdl.info*
+ $(MAKEINFO) $(MAKEINFOFLAGS) -o $@ $<
+
+doc/ghdl.dvi: vhdl/ghdl.texi
+ $(TEXI2DVI) -o $@ $<
+
+vhdl.info: doc/ghdl.info
+
+vhdl.man:
+
+vhdl.dvi: doc/ghdl.dvi
+
+vhdl.generated-manpages:
+
+# Install hooks:
+# ghdl1 is installed elsewhere as part of $(COMPILERS).
+
+vhdl.install-normal:
+
+vhdl.install-plugin:
+
+# Install the driver program as ghdl.
+vhdl.install-common: ghdl$(exeext)
+ -mkdir $(DESTDIR)$(bindir)
+ -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext)
+ $(INSTALL_PROGRAM) ghdl$(exeext) $(DESTDIR)$(bindir)/ghdl$(exeext)
+# Install the library
+ $(MAKE_IN_VHDL) install-ghdllib
+
+install-info:: $(DESTDIR)$(infodir)/ghdl.info
+
+vhdl.install-info: doc/ghdl.info
+ -rm -rf $(infodir)/ghdl.info*
+ $(INSTALL_DATA) doc/ghdl.info* $(DESTDIR)$(infodir)
+ -chmod a-x $(DESTDIR)$(infodir)/ghdl.info*
+
+install-ghdllib:
+ $(MAKE) -f vhdl/Makefile $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS) install-ghdllib
+
+vhdl.install-man: $(DESTDIR)$(man1dir)/ghdl$(man1ext)
+
+$(DESTDIR)$(man1dir)/ghdl$(man1ext): $(srcdir)/vhdl/ghdl.1
+ -rm -f $@
+ -$(INSTALL_DATA) $< $@
+ -chmod a-x $@
+
+vhdl.uninstall:
+ -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext)
+
+
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+
+vhdl.mostlyclean:
+ -$(RM) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c
+vhdl.clean:
+ -$(RM) vhdl/*$(objext)
+vhdl.distclean:
+ -$(RM) vhdl/Makefile
+ -$(RM) ghdl$(exeext)
+vhdl.extraclean:
+
+vhdl.maintainer-clean:
+
+
+# Stage hooks:
+# The main makefile has already created stage?/vhdl
+
+vhdl.stage1:
+ -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage1/vhdl
+ -$(MV) vhdl/stamp-* stage1/vhdl
+vhdl.stage2:
+ -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage2/vhdl
+ -$(MV) vhdl/stamp-* stage2/vhdl
+vhdl.stage3:
+ -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage3/vhdl
+ -$(MV) vhdl/stamp-* stage3/vhdl
+vhdl.stage4:
+ -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage4/vhdl
+ -$(MV) vhdl/stamp-* stage4/vhdl
diff --git a/src/translate/gcc/Makefile.in b/src/translate/gcc/Makefile.in
new file mode 100644
index 000000000..13f329660
--- /dev/null
+++ b/src/translate/gcc/Makefile.in
@@ -0,0 +1,299 @@
+# Makefile for GNU vhdl Compiler (GHDL).
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# The makefile built from this file lives in the language subdirectory.
+# It's purpose is to provide support for:
+#
+# 1) recursion where necessary, and only then (building .o's), and
+# 2) building and debugging cc1 from the language subdirectory, and
+# 3) nothing else.
+#
+# The parent makefile handles all other chores, with help from the
+# language makefile fragment, of course.
+#
+# The targets for external use are:
+# all, TAGS, ???mostlyclean, ???clean.
+
+# This makefile will only work with Gnu make.
+# The rules are written assuming a minimum subset of tools are available:
+#
+# Required:
+# MAKE: Only Gnu make will work.
+# MV: Must accept (at least) one, maybe wildcard, source argument,
+# a file or directory destination, and support creation/
+# modification date preservation. Gnu mv -f works.
+# RM: Must accept an arbitrary number of space separated file
+# arguments, or one wildcard argument. Gnu rm works.
+# RMDIR: Must delete a directory and all its contents. Gnu rm -rf works.
+# ECHO: Must support command line redirection. Any Unix-like
+# shell will typically provide this, otherwise a custom version
+# is trivial to write.
+# LN: ln -s works, cp should work bu was not tested.
+# CP: GNU cp -p works.
+# AR: Gnu ar works.
+# MKDIR: Gnu mkdir works.
+# CHMOD: Gnu chmod works.
+# true: Does nothing and returns a normal successful return code.
+# pwd: Prints the current directory on stdout.
+# cd: Change directory.
+
+# Tell GNU make 3.79 not to run this directory in parallel.
+# Not all of the required dependencies are present.
+.NOTPARALLEL:
+
+# Variables that exist for you to override.
+# See below for how to change them for certain systems.
+
+ALLOCA =
+# Various ways of specifying flags for compilations:
+# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2.
+# BOOT_CFLAGS is the value of CFLAGS to pass
+# to the stage2 and stage3 compilations
+# XCFLAGS is used for most compilations but not when using the GCC just built.
+XCFLAGS =
+CFLAGS = -g
+BOOT_CFLAGS = -O $(CFLAGS)
+# These exists to be overridden by the x-* and t-* files, respectively.
+X_CFLAGS =
+T_CFLAGS =
+
+X_CPPFLAGS =
+T_CPPFLAGS =
+
+X_ADAFLAGS =
+T_ADAFLAGS =
+
+ADAC = $(CC)
+
+ECHO = echo
+CHMOD = chmod
+CP = cp -p
+MV = mv -f
+RM = rm -f
+RMDIR = rm -rf
+MKDIR = mkdir -p
+LN = ln -s
+AR = ar
+# How to invoke ranlib.
+RANLIB = ranlib
+# Test to use to see whether ranlib exists on the system.
+RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ]
+SHELL = /bin/sh
+INSTALL_DATA = install -m 644
+MAKEINFO = makeinfo
+TEXI2DVI = texi2dvi
+GNATBIND = gnatbind
+GNATMAKE = gnatmake
+ADA_CFLAGS = $(CFLAGS)
+GHDL_ADAFLAGS = -Wall -gnata
+
+objext = .o
+exeext =
+arext = .a
+soext = .so
+shext =
+
+HOST_CC=$(CC)
+HOST_CFLAGS=$(ALL_CFLAGS)
+HOST_CLIB=$(CLIB)
+HOST_LDFLAGS=$(LDFLAGS)
+HOST_CPPFLAGS=$(ALL_CPPFLAGS)
+HOST_ALLOCA=$(ALLOCA)
+HOST_MALLOC=$(MALLOC)
+HOST_OBSTACK=$(OBSTACK)
+
+# We don't use cross-make. Instead we use the tools from the build tree,
+# if they are available.
+# program_transform_name and objdir are set by configure.in.
+program_transform_name =
+objdir = .
+
+target=@target@
+target_alias=@target_alias@
+target_noncanonical:=@target_noncanonical@
+xmake_file=@dep_host_xmake_file@
+tmake_file=@dep_tmake_file@
+#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c`
+#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c`
+
+# Directory where sources are, from where we are.
+srcdir = @srcdir@
+VPATH = @srcdir@
+
+# Top build directory, relative to here.
+top_builddir = ..
+
+version := $(shell cat $(srcdir)/../BASE-VER)
+
+# End of variables for you to override.
+
+# Definition of `all' is here so that new rules inserted by sed
+# do not specify the default target.
+all: all.indirect
+
+# This tells GNU Make version 3 not to put all variables in the environment.
+.NOEXPORT:
+
+# Now figure out from those variables how to compile and link.
+
+all.indirect: Makefile
+
+# This tells GNU make version 3 not to export all the variables
+# defined in this file into the environment.
+.NOEXPORT:
+
+Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure
+ cd ..; $(SHELL) config.status
+
+force:
+
+SED=sed
+
+drvdir/default_pathes.ads: drvdir Makefile
+ echo "-- DO NOT EDIT" > tmp-dpathes.ads
+ echo "-- This file is created by Makefile" >> tmp-dpathes.ads
+ echo "package Default_Pathes is" >> tmp-dpathes.ads
+ echo " -- Accept long lines." >> tmp-dpathes.ads
+ echo " pragma Style_Checks (\"M999\");" >> tmp-dpathes.ads
+ echo " Install_Prefix : constant String :=" >> tmp-dpathes.ads
+ echo " \"$(exec_prefix)\";" >> tmp-dpathes.ads
+ echo " Compiler_Gcc : constant String :=" >> tmp-dpathes.ads
+ echo " \"libexec/gcc/$(target_noncanonical)/$(version)/ghdl1$(exeext)\";" >> tmp-dpathes.ads
+ echo " Compiler_Debug : constant String := \"\";" >> tmp-dpathes.ads
+ echo " Compiler_Mcode : constant String := \"\";" >> tmp-dpathes.ads
+ echo " Compiler_Llvm : constant String := \"\";" >> tmp-dpathes.ads
+ echo " Post_Processor : constant String := \"\";" >> tmp-dpathes.ads
+ echo " Lib_Prefix : constant String :=">> tmp-dpathes.ads
+ echo " \"lib/gcc/$(target_noncanonical)/$(version)/vhdl/lib/\";" >> tmp-dpathes.ads
+ echo "end Default_Pathes;" >> tmp-dpathes.ads
+ $(srcdir)/../../move-if-change tmp-dpathes.ads $@
+
+../ghdl$(exeext): drvdir drvdir/default_pathes.ads force
+ CURDIR=`pwd`; cd $(srcdir); SRCDIR=`pwd`; cd $$CURDIR/drvdir; \
+ $(GNATMAKE) -o ../$@ -aI$$SRCDIR/ghdldrv -aI$$SRCDIR -aO.. ghdl_gcc \
+ -bargs -E -cargs $(ADA_CFLAGS) $(GHDL_ADAFLAGS) -largs $(LIBS)
+
+drvdir:
+ mkdir $@
+
+clean: grt-clean ghdllibs-clean force
+ $(RM) *.o *.ali
+ $(RM) default_pathes.ads
+
+# Additionnal rules
+
+LIB87_DIR:=./lib/v87
+LIB93_DIR:=./lib/v93
+LIB08_DIR:=./lib/v08
+LIBSRC_DIR:=$(srcdir)/libraries
+ANALYZE=../ghdl -a --GHDL1=../ghdl1 --ieee=none
+
+$(LIB93_DIR) $(LIB87_DIR):
+ $(srcdir)/../../mkinstalldirs $@
+
+####libraries Makefile.inc
+
+std87_standard.o: $(GHDL1)
+ $(GHDL1) --std=87 -quiet -o std_standard.s --compile-standard
+ ../xgcc -c -o std_standard.o std_standard.s
+ $(MV) std_standard.o $@
+
+std93_standard.o: $(GHDL1)
+ $(GHDL1) --std=93 -quiet -o std_standard.s --compile-standard
+ ../xgcc -c -o std_standard.o std_standard.s
+ $(MV) std_standard.o $@
+
+std08_standard.o: $(GHDL1)
+ $(GHDL1) --std=08 -quiet -o std_standard.s --compile-standard
+ ../xgcc -c -o std_standard.o std_standard.s
+ $(MV) std_standard.o $@
+
+ghdllib: std87_standard.o std93_standard.o std08_standard.o libgrt.a
+
+ghdllibs-clean: force
+ $(RM) -rf $(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR)
+
+PHONY: ghdllib ghdllibs-clean
+
+GHDL1=../ghdl1
+GRTSRCDIR=$(srcdir)/grt
+GRT_RANLIB=$(RANLIB)
+
+####grt Makefile.inc
+
+install-ghdllib: ghdllib grt.lst $(STD93_SRCS) $(STD87_SRCS) \
+ $(IEEE93_SRCS) $(IEEE87_SRCS) $(SYNOPSYS_SRCS) \
+ $(STD08_SRCS) $(IEEE08_SRCS)
+ $(RM) -rf $(DESTDIR)$(VHDL_LIB_DIR)
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)
+# Install libgrt
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib
+ $(INSTALL_DATA) libgrt.a $(DESTDIR)$(VHDL_LIB_DIR)/lib/libgrt.a
+ $(INSTALL_DATA) grt.lst $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.lst
+ $(INSTALL_DATA) $(GRTSRCDIR)/grt.ver $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.ver
+# Install VHDL sources.
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/std
+ for i in $(STD93_SRCS) $(STD87_SRCS) $(STD08_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/std; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee
+ for i in $(IEEE93_SRCS) $(IEEE87_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95
+ for i in $(VITAL95_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000
+ for i in $(VITAL2000_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys
+ for i in $(SYNOPSYS_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor
+ for i in $(MENTOR93_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor; \
+ done
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008
+ for i in $(IEEE08_SRCS); do \
+ $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008; \
+ done
+# Create library dirs
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87
+ $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08
+# Compile in place.
+ PDIR=`pwd` && cd $(DESTDIR)$(VHDL_LIB_DIR) && \
+ $(MAKE) -f $$PDIR/Makefile REL_DIR=../../.. LIBSRC_DIR="src" \
+ LIB93_DIR=lib/v93 LIB87_DIR=lib/v87 LIB08_DIR=lib/v08 \
+ ANALYZE="$$PDIR/../ghdl -a --GHDL1=$$PDIR/../ghdl1 --ieee=none" \
+ std.v87 ieee.v87 synopsys.v87 \
+ std.v93 ieee.v93 synopsys.v93 mentor.v93 \
+ std.v08 ieee.v08
+# Copy std_standard (this is done after libraries, since they remove dirs).
+ $(INSTALL_DATA) std87_standard.o \
+ $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87/std/std_standard.o
+ $(INSTALL_DATA) std93_standard.o \
+ $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93/std/std_standard.o
+ $(INSTALL_DATA) std08_standard.o \
+ $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08/std/std_standard.o
diff --git a/src/translate/gcc/README b/src/translate/gcc/README
new file mode 100644
index 000000000..1152e9908
--- /dev/null
+++ b/src/translate/gcc/README
@@ -0,0 +1,87 @@
+This is the README from the source distribution of GHDL.
+
+To get the binary distribution or more information, go to http://ghdl.free.fr
+
+Copyright:
+**********
+GHDL is copyright (c) 2002 - 2010 Tristan Gingold.
+See the GHDL manual for more details.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
+
+
+Building GHDL from sources:
+***************************
+
+Required:
+* the sources of @GCCVERSION@ (at least the core part).
+ Note: other versions of gcc sources have not been tested.
+* the Ada95 GNAT compiler (GNAT GPL 2008 are known to work;
+ Ada compilers in most Linux distributions are more or less buggy)
+* GNU/Linux for ix86 (pc systems) (porting is necessary for other systems)
+
+Procedure:
+* Check your Ada compiler. On some systems (or with some distribution), the
+ GNAT compiler seems broken. Try this very simple example, using file
+ example.adb
+<<<<<<<<<<<<<<<<<<
+procedure Example is
+begin
+ null;
+end Example;
+<<<<<<<<<<<<<<<<<<
+ Compile with
+ $ gnatmake example
+ It should create an executable, 'example'.
+ If this doesn't work, your GNAT installation is broken. It may be a PATH
+ problem or something else.
+* untar the gcc tarball
+* untar the ghdl tarball (this sould have been done, since you are reading a
+ file from it).
+* move or copy the vhdl directory of ghdl into the gcc subdirectory of
+ the gcc distribution.
+ You should have a @GCCVERSION@/gcc/vhdl directory.
+* configure gcc with the --enable-languages=vhdl option. You may of course
+ add other languages. Also you'd better to disable bootstraping using
+ --disable-bootstrap.
+ Refer to the gcc installation documentation.
+* compile gcc.
+ 'make CFLAGS="-O"' is OK
+* install gcc. This installs the ghdl driver too.
+ 'make install' is OK.
+
+There is a mailing list for any questions. You can subscribe via:
+ https://mail.gna.org/listinfo/ghdl-discuss/
+Please report bugs on https://gna.org/bugs/?group=ghdl
+
+If you cannot compile, please report the gcc version, GNAT version and gcc
+source version.
+
+* Note for ppc64 (and AIX ?) platform:
+The object file format contains an identifier for the source language. Because
+gcc doesn't know about the VHDL, gcc crashes very early. This could be fixed
+with a very simple change in gcc/config/rs6000/rs6000.c,
+function rs6000_output_function_epilogue (as of gcc 4.8):
+ else if (! strcmp (language_string, "GNU Objective-C"))
+ i = 14;
+ else
+- gcc_unreachable ();
++ i = 0;
+ fprintf (file, "%d,", i);
+
+ /* 8 single bit fields: global linkage (not set for C extern linkage,
+
+Tristan Gingold.
diff --git a/src/translate/gcc/config-lang.in b/src/translate/gcc/config-lang.in
new file mode 100644
index 000000000..7010b1127
--- /dev/null
+++ b/src/translate/gcc/config-lang.in
@@ -0,0 +1,38 @@
+# Top level configure fragment for GNU vhdl (GHDL).
+# Copyright (C) 1994-2001 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language - name of language as it would appear in $(LANGUAGES)
+# boot_language - "yes" if we need to build this language in stage1
+# compilers - value to add to $(COMPILERS)
+# stagestuff - files to add to $(STAGESTUFF)
+
+language="vhdl"
+boot_language=no
+
+compilers="ghdl1\$(exeext)"
+
+stagestuff="ghdl\$(exeext) ghdl1\$(exeext)"
+
+outputs=vhdl/Makefile
+
+gtfiles="\$(srcdir)/vhdl/ortho-lang.c"
diff --git a/src/translate/gcc/dist-common.sh b/src/translate/gcc/dist-common.sh
new file mode 100644
index 000000000..ad2229734
--- /dev/null
+++ b/src/translate/gcc/dist-common.sh
@@ -0,0 +1,337 @@
+# ghdl core files
+cfiles="
+evaluation.adb
+evaluation.ads
+scanner.ads
+scanner.adb
+scanner-scan_literal.adb
+back_end.ads
+back_end.adb
+files_map.adb
+files_map.ads
+sem.adb
+sem.ads
+sem_expr.adb
+sem_expr.ads
+sem_names.adb
+sem_names.ads
+sem_scopes.adb
+sem_scopes.ads
+sem_decls.ads
+sem_decls.adb
+sem_inst.ads
+sem_inst.adb
+sem_specs.ads
+sem_specs.adb
+sem_stmts.ads
+sem_stmts.adb
+sem_types.ads
+sem_types.adb
+sem_assocs.ads
+sem_assocs.adb
+sem_psl.ads
+sem_psl.adb
+canon.adb
+canon.ads
+canon_psl.ads
+canon_psl.adb
+flags.adb
+flags.ads
+configuration.adb
+configuration.ads
+nodes.ads
+nodes.adb
+nodes_gc.ads
+nodes_gc.adb
+nodes_meta.ads
+nodes_meta.adb
+options.ads
+options.adb
+psl-errors.ads
+lists.ads
+lists.adb
+iirs.adb
+iirs.ads
+iir_chains.ads
+iir_chains.adb
+iir_chain_handling.ads
+iir_chain_handling.adb
+iirs_walk.ads
+iirs_walk.adb
+std_names.adb
+std_names.ads
+disp_tree.adb
+disp_tree.ads
+iirs_utils.adb
+iirs_utils.ads
+std_package.adb
+std_package.ads
+disp_vhdl.adb
+disp_vhdl.ads
+libraries.adb
+libraries.ads
+tokens.adb
+tokens.ads
+name_table.adb
+name_table.ads
+str_table.ads
+str_table.adb
+types.ads
+version.ads
+errorout.adb
+errorout.ads
+parse.adb
+parse.ads
+parse_psl.ads
+parse_psl.adb
+post_sems.ads
+post_sems.adb
+ieee.ads
+ieee-std_logic_1164.ads
+ieee-std_logic_1164.adb
+ieee-vital_timing.ads
+ieee-vital_timing.adb
+xrefs.ads
+xrefs.adb
+bug.ads
+bug.adb
+"
+
+# translation file
+tfiles="
+translation.adb
+ortho_front.adb
+translation.ads
+trans_decls.ads
+trans_be.ads
+trans_be.adb
+trans_analyzes.ads
+trans_analyzes.adb"
+
+ortho_files="
+ortho_front.ads"
+
+ortho_gcc_files="
+lang.opt
+ortho-lang.c
+ortho_gcc-main.adb
+ortho_gcc-main.ads
+ortho_gcc.adb
+ortho_gcc.ads
+ortho_gcc_front.ads
+ortho_ident.adb
+ortho_ident.ads
+ortho_nodes.ads
+"
+
+ghdl_files="
+ghdl_gcc.adb
+ghdldrv.ads
+ghdldrv.adb
+ghdlprint.ads
+ghdlprint.adb
+ghdllocal.ads
+ghdllocal.adb
+ghdlmain.ads
+ghdlmain.adb
+"
+
+libraries_files="
+std/textio.vhdl
+std/textio_body.vhdl
+std/env.vhdl
+std/env_body.vhdl
+ieee/README.ieee
+ieee/numeric_bit-body.vhdl
+ieee/numeric_bit.vhdl
+ieee/numeric_std-body.vhdl
+ieee/numeric_std.vhdl
+ieee/std_logic_1164.vhdl
+ieee/std_logic_1164_body.vhdl
+ieee/math_real.vhdl
+ieee/math_real-body.vhdl
+ieee/math_complex.vhdl
+ieee/math_complex-body.vhdl
+ieee2008/README.ieee
+ieee2008/fixed_float_types.vhdl
+ieee2008/fixed_generic_pkg-body.vhdl
+ieee2008/fixed_generic_pkg.vhdl
+ieee2008/fixed_pkg.vhdl
+ieee2008/float_generic_pkg-body.vhdl
+ieee2008/float_generic_pkg.vhdl
+ieee2008/float_pkg.vhdl
+ieee2008/math_complex-body.vhdl
+ieee2008/math_complex.vhdl
+ieee2008/math_real-body.vhdl
+ieee2008/math_real.vhdl
+ieee2008/numeric_bit-body.vhdl
+ieee2008/numeric_bit.vhdl
+ieee2008/numeric_bit_unsigned-body.vhdl
+ieee2008/numeric_bit_unsigned.vhdl
+ieee2008/numeric_std-body.vhdl
+ieee2008/numeric_std.vhdl
+ieee2008/numeric_std_unsigned-body.vhdl
+ieee2008/numeric_std_unsigned.vhdl
+ieee2008/std_logic_1164-body.vhdl
+ieee2008/std_logic_1164.vhdl
+ieee2008/std_logic_textio.vhdl
+vital95/vital_primitives.vhdl
+vital95/vital_primitives_body.vhdl
+vital95/vital_timing.vhdl
+vital95/vital_timing_body.vhdl
+vital2000/memory_b.vhdl
+vital2000/memory_p.vhdl
+vital2000/prmtvs_b.vhdl
+vital2000/prmtvs_p.vhdl
+vital2000/timing_b.vhdl
+vital2000/timing_p.vhdl
+synopsys/std_logic_arith.vhdl
+synopsys/std_logic_misc.vhdl
+synopsys/std_logic_misc-body.vhdl
+synopsys/std_logic_signed.vhdl
+synopsys/std_logic_textio.vhdl
+synopsys/std_logic_unsigned.vhdl
+mentor/std_logic_arith.vhdl
+mentor/std_logic_arith_body.vhdl
+"
+
+grt_files="
+grt-cbinding.c
+grt-cvpi.c
+grt.adc
+grt-astdio.ads
+grt-astdio.adb
+grt-avhpi.adb
+grt-avhpi.ads
+grt-avls.ads
+grt-avls.adb
+grt-c.ads
+grt-disp.adb
+grt-disp.ads
+grt-disp_rti.adb
+grt-disp_rti.ads
+grt-disp_tree.adb
+grt-disp_tree.ads
+grt-disp_signals.adb
+grt-disp_signals.ads
+grt-errors.adb
+grt-errors.ads
+grt-files.adb
+grt-files.ads
+grt-hooks.adb
+grt-hooks.ads
+grt-images.adb
+grt-images.ads
+grt-lib.adb
+grt-lib.ads
+grt-main.adb
+grt-main.ads
+grt-modules.ads
+grt-modules.adb
+grt-names.adb
+grt-names.ads
+grt-options.adb
+grt-options.ads
+grt-processes.adb
+grt-processes.ads
+grt-rtis.ads
+grt-rtis.adb
+grt-rtis_addr.adb
+grt-rtis_addr.ads
+grt-rtis_utils.adb
+grt-rtis_utils.ads
+grt-rtis_binding.ads
+grt-rtis_types.ads
+grt-rtis_types.adb
+grt-sdf.adb
+grt-sdf.ads
+grt-shadow_ieee.ads
+grt-shadow_ieee.adb
+grt-signals.adb
+grt-signals.ads
+grt-stack2.adb
+grt-stack2.ads
+grt-stacks.adb
+grt-stacks.ads
+grt-stats.ads
+grt-stats.adb
+grt-stdio.ads
+grt-table.ads
+grt-table.adb
+grt-types.ads
+grt-unithread.ads
+grt-unithread.adb
+grt-values.adb
+grt-values.ads
+grt-vcd.adb
+grt-vcd.ads
+grt-vcdz.adb
+grt-vcdz.ads
+grt-vital_annotate.adb
+grt-vital_annotate.ads
+grt-vpi.adb
+grt-vpi.ads
+grt-vstrings.adb
+grt-vstrings.ads
+grt-waves.ads
+grt-waves.adb
+grt-zlib.ads
+grt-threads.ads
+grt-arch_none.ads
+grt-arch_none.adb
+grt-std_logic_1164.ads
+grt-std_logic_1164.adb
+grt.ads
+main.adb
+main.ads
+ghdl_main.ads
+ghdl_main.adb
+ghwlib.h
+ghwlib.c
+ghwdump.c
+grt.ver
+"
+
+grt_config_files="
+i386.S
+sparc.S
+ppc.S
+ia64.S
+amd64.S
+times.c
+clock.c
+linux.c
+pthread.c
+win32.c"
+
+psl_files="
+psl.ads
+psl-build.adb
+psl-build.ads
+psl-cse.adb
+psl-cse.ads
+psl-disp_nfas.adb
+psl-disp_nfas.ads
+psl-dump_tree.adb
+psl-dump_tree.ads
+psl-hash.adb
+psl-hash.ads
+psl-nfas.adb
+psl-nfas.ads
+psl-nfas-utils.adb
+psl-nfas-utils.ads
+psl-nodes.adb
+psl-nodes.ads
+psl-optimize.adb
+psl-optimize.ads
+psl-prints.adb
+psl-prints.ads
+psl-priorities.ads
+psl-qm.adb
+psl-qm.ads
+psl-rewrites.adb
+psl-rewrites.ads
+psl-subsets.adb
+psl-subsets.ads
+psl-tprint.adb
+psl-tprint.ads"
diff --git a/src/translate/gcc/dist.sh b/src/translate/gcc/dist.sh
new file mode 100755
index 000000000..8632dc574
--- /dev/null
+++ b/src/translate/gcc/dist.sh
@@ -0,0 +1,471 @@
+#!/bin/sh
+
+# Script used to create tar balls.
+# Copyright (C) 2002, 2003, 2004, 2005, 2006 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+# Building a distribution:
+# * update the 'version' variable in ../../Makefile
+# * Regenerate version.ads: make -f ../../Makefile version.ads
+# * Check NEWS, README and INSTALL files.
+# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb
+# * Check GCCVERSION below.
+# * Check lists of exported files in this file.
+# * Create source tar and build binaries: ./dist.sh dist_phase1
+# * su root
+# * Build binary tar: HOME=~user ./dist.sh dist_phase2
+# * Run the testsuites: GHDL=ghdl ./testsuite.sh gcc
+# * Update website/index.html (./dist.sh website helps)
+# * upload (./dist upload)
+# * CVS commit, tag + cd image.
+# * remove previous version in /usr/local
+
+## DO NOT MODIFY this file while it is running...
+
+set -e
+
+# GCC version
+GCCVERSION=4.9.2
+# Machine name used by GCC
+MACHINE=${MACHINE:i686-pc-linux-gnu}
+# Directory where GCC sources (and objects) stay.
+DISTDIR=${DISTDIR:-$HOME/dist}
+# GTKWave version.
+GTKWAVE_VERSION=3.3.50
+
+# GHDL version (extracted from version.ads)
+VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads`
+
+CWD=`pwd`
+
+distdir=ghdl-$VERSION
+tarfile=$distdir.tar
+
+GTKWAVE_BASE=$HOME/devel/gtkwave-$GTKWAVE_VERSION
+
+GCCDIST=$DISTDIR/gcc-$GCCVERSION
+GCCDISTOBJ=$GCCDIST-objs
+PREFIX=/usr/local
+GCCLIBDIR=$PREFIX/lib/gcc/$MACHINE/$GCCVERSION
+GCCLIBEXECDIR=$PREFIX/libexec/gcc/$MACHINE/$GCCVERSION
+bindirname=ghdl-$VERSION-$MACHINE
+TARINSTALL=$DISTDIR/$bindirname.tar.bz2
+VHDLDIR=$distdir/vhdl
+DOWNLOAD_HTML=../../website/download.html
+DESTDIR=$CWD/
+UNSTRIPDIR=${distdir}-unstripped
+
+PATH=/usr/gnat/bin:$PATH
+
+do_clean ()
+{
+ rm -rf $VHDLDIR
+ mkdir $VHDLDIR
+ mkdir $VHDLDIR/ghdldrv
+ mkdir $VHDLDIR/libraries
+ mkdir $VHDLDIR/libraries/std $VHDLDIR/libraries/ieee
+ mkdir $VHDLDIR/libraries/vital95 $VHDLDIR/libraries/vital2000
+ mkdir $VHDLDIR/libraries/synopsys $VHDLDIR/libraries/mentor
+ mkdir $VHDLDIR/libraries/ieee2008
+ mkdir $VHDLDIR/grt
+ mkdir $VHDLDIR/grt/config
+}
+
+# Build Makefile
+do_Makefile ()
+{
+ sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \
+ -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \
+ < Makefile.in > $VHDLDIR/Makefile.in
+ cp Make-lang.in $VHDLDIR/Make-lang.in
+}
+
+# Copy (or link) sources files into $VHDLDIR
+do_files ()
+{
+. ./dist-common.sh
+
+# Local files
+lfiles="config-lang.in lang-options.h lang-specs.h"
+for i in $lfiles; do ln -sf $CWD/$i $VHDLDIR/$i; done
+
+for i in $cfiles; do ln -sf $CWD/../../$i $VHDLDIR/$i; done
+
+for i in ghdl.texi ghdl.1; do ln -sf $CWD/../../doc/$i $VHDLDIR/$i; done
+
+for i in $tfiles; do ln -sf $CWD/../$i $VHDLDIR/$i; done
+
+for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $VHDLDIR/$i; done
+
+for i in $ortho_gcc_files; do
+ ln -sf $CWD/../../ortho/gcc/$i $VHDLDIR/$i
+done
+
+for i in $ghdl_files; do
+ ln -sf $CWD/../ghdldrv/$i $VHDLDIR/ghdldrv/$i
+done
+
+for i in $libraries_files; do
+ ln -sf $CWD/../../libraries/$i $VHDLDIR/libraries/$i
+done
+
+for i in $grt_files; do
+ ln -sf $CWD/../grt/$i $VHDLDIR/grt/$i
+done
+
+for i in $grt_config_files; do
+ ln -sf $CWD/../grt/config/$i $VHDLDIR/grt/config/$i
+done
+
+for i in $psl_files; do
+ ln -sf $CWD/../../psl/$i $VHDLDIR/$i
+done
+}
+
+# Create the tar of sources.
+do_sources ()
+{
+ \rm -rf $distdir
+ mkdir $distdir
+ VHDLDIR=$distdir/vhdl
+ do_clean $VHDLDIR
+ do_Makefile
+ do_files
+ ln -sf ../../../COPYING $distdir
+ sed -e "s/@GCCVERSION@/gcc-$GCCVERSION/g" < README > $distdir/README
+ tar cvhf $tarfile $distdir
+ bzip2 -f $tarfile
+ rm -rf $distdir
+}
+
+# Put GHDL sources in GCC.
+do_update_gcc_sources ()
+{
+ set -x
+
+ cd $GCCDIST/..
+ tar jxvf $CWD/$tarfile.bz2
+ rm -rf $GCCDIST/gcc/vhdl
+ mv $distdir/vhdl $GCCDIST/gcc
+}
+
+# Extract the source, configure and make.
+do_compile ()
+{
+ #set -x
+
+ do_update_gcc_sources;
+
+# gmp build with:
+# CFLAGS="-O -m32" ./configure --prefix=$HOME/dist/build \
+# --disable-shared --build=i686-pc-linux-gnu
+# make
+# make install
+# make check
+
+ # usegnat32!
+
+ rm -rf $GCCDISTOBJ
+ mkdir $GCCDISTOBJ
+ cd $GCCDISTOBJ
+ export CFLAGS="-O -g"
+
+ case $MACHINE in
+ i?86-*-linux*)
+ # gmp location (mpfr and mpc are supposed to be at the same place)
+ CONFIG_LIBS="--with-gmp=$PWD/../build"
+ ;;
+ x86_64-*-linux*)
+ CONFIG_LIBS=""
+ ;;
+ x86_64-*-darwin*)
+ CONFIG_LIBS="--with-gmp=$HOME/local --with-stage1-ldflags="
+ ;;
+ *)
+ exit 1
+ ;;
+ esac
+ ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=$MACHINE $CONFIG_LIBS --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp --disable-libquadmath
+
+ make -j4
+ make -C gcc vhdl.info
+ cd $CWD
+}
+
+# Re-package sources, update gcc sources and recompile without reconfiguring.
+do_recompile ()
+{
+ do_sources
+ do_update_gcc_sources;
+ cd $GCCDISTOBJ
+ export CFLAGS="-O -g"
+ make -j4
+}
+
+check_root ()
+{
+ if [ $UID -ne 0 ]; then
+ echo "$0: you must be root";
+ exit 1;
+ fi
+}
+
+# Do a make install
+do_gcc_install ()
+{
+ set -x
+ cd $GCCDISTOBJ
+ # Check the info file is not empty.
+ if [ -s gcc/doc/ghdl.info ]; then
+ echo "info file found"
+ else
+ echo "Error: ghdl.info not found".
+ exit 1;
+ fi
+ mkdir -p $DESTDIR/usr/local || true
+ make DESTDIR=$DESTDIR install
+ cd $CWD
+ if [ -d $UNSTRIPDIR ]; then
+ rm -rf $UNSTRIPDIR
+ fi
+ mkdir $UNSTRIPDIR
+ cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR
+ chmod -w $UNSTRIPDIR/*
+ strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl
+}
+
+# Create the tar file from the current installation.
+do_tar_install ()
+{
+ tar -C $DESTDIR -jcvf $TARINSTALL \
+ ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info ./$PREFIX/man/man1/ghdl.1 \
+ ./$GCCLIBDIR/vhdl \
+ ./$GCCLIBEXECDIR/ghdl1
+}
+
+do_extract_tar_install ()
+{
+ check_root;
+ cd /
+ tar jxvf $TARINSTALL
+ cd $CWD
+}
+
+# Create the tar file to be distributed.
+do_tar_dist ()
+{
+ rm -rf $bindirname
+ mkdir $bindirname
+ sed -e "s/@TARFILE@/$bindirname/" < INSTALL > $bindirname/INSTALL
+ ln ../../COPYING $bindirname
+ cp $TARINSTALL $bindirname
+ tar cvf $bindirname.tar $bindirname
+}
+
+# Remove the non-ghdl files of gcc in the current installation.
+do_distclean_gcc ()
+{
+ set -x
+ rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc
+ rm -f ${DESTDIR}${PREFIX}/bin/gcc-*
+ rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov
+ rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc*
+ rm -f ${DESTDIR}${PREFIX}/info/cpp.info*
+ rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gcc.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccint.info*
+ rm -f ${DESTDIR}${PREFIX}/lib/*.a
+ rm -f ${DESTDIR}${PREFIX}/lib/*.so*
+ rm -f ${DESTDIR}${PREFIX}/lib/*.la
+ rm -rf ${DESTDIR}${PREFIX}/share
+ rm -rf ${DESTDIR}${PREFIX}/man/man7
+ rm -rf ${DESTDIR}${PREFIX}/man/man1/{cpp,gcc,gcov}.1
+ rm -rf ${DESTDIR}${PREFIX}/include
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0
+ rm -rf ${DESTDIR}${GCCLIBEXECDIR}/plugin
+ rm -rf ${DESTDIR}${GCCLIBEXECDIR}/lto-wrapper
+ rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a
+ rm -f ${DESTDIR}${GCCLIBDIR}/specs
+ rm -rf ${DESTDIR}${GCCLIBDIR}/plugin
+ rm -rf ${DESTDIR}${GCCLIBDIR}/include
+ rm -rf ${DESTDIR}${GCCLIBDIR}/include-fixed
+ rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools
+ rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools
+}
+
+# Remove ghdl files in the current installation.
+do_distclean_ghdl ()
+{
+ check_root;
+ set -x
+ rm -f $PREFIX/bin/ghdl
+ rm -f $PREFIX/info/ghdl.info*
+ rm -f $GCCLIBEXECDIR/ghdl1
+ rm -rf $GCCLIBDIR/vhdl
+}
+
+# Build the source tar, and build the binaries.
+do_dist_phase1 ()
+{
+ do_sources;
+ do_compile;
+ do_gcc_install;
+ do_distclean_gcc;
+ do_tar_install;
+ do_tar_dist;
+ rm -rf ./$PREFIX
+}
+
+# Install the binaries and create the binary tar.
+do_dist_phase2 ()
+{
+ check_root;
+ do_distclean_ghdl;
+ do_extract_tar_install;
+ echo "dist_phase2 success"
+}
+
+# Create gtkwave patch
+do_gtkwave_patch ()
+{
+# rm -rf gtkwave-patch
+ mkdir gtkwave-patch
+ diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \
+ sed -e "/^Only in/d" \
+ > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs
+ cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch
+ sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README
+ tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch
+ rm -rf gtkwave-patch
+}
+
+# Update the index.html
+# Update the doc
+do_website ()
+{
+ cp "$DOWNLOAD_HTML" "$DOWNLOAD_HTML".old
+ sed -e "
+/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/
+/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/
+/HISTORY/ a \\
+ <tr>\\
+ <td>$VERSION</td>\\
+ <td>`date +'%b %e %Y'`</td>\\
+ <td>$GCCVERSION</td>\\
+ <td><a href=\"$tarfile.bz2\">$tarfile.bz2</a></td>\\
+ <td><a href=\"$bindirname.tar\">\\
+ $bindirname.tar</a></td>\\
+ </tr>
+" < "$DOWNLOAD_HTML".old > "$DOWNLOAD_HTML"
+ dir=../../website/ghdl
+ echo "Updating $dir"
+ rm -rf $dir
+ makeinfo --html -o $dir ../../doc/ghdl.texi
+}
+
+# Do ftp commands to upload
+do_upload ()
+{
+if tty -s; then
+ echo -n "Please, enter password: "
+ stty -echo
+ read pass
+ stty echo
+ echo
+else
+ echo "$0: upload must be done from a tty"
+ exit 1;
+fi
+ftp -n <<EOF
+open ftpperso.free.fr
+user ghdl $pass
+prompt
+hash
+bin
+passive
+put $tarfile.bz2
+put $bindirname.tar
+put INSTALL
+lcd ../../website
+put NEWS
+put index.html
+put download.html
+put features.html
+put roadmap.html
+put manual.html
+put more.html
+put links.html
+put bug.html
+put waveviewer.html
+put gtkwave-patch.tgz
+put favicon.ico
+lcd ghdl
+cd ghdl
+mput \*
+bye
+EOF
+}
+
+if [ $# -eq 0 ]; then
+ do_Makefile;
+else
+ for i ; do
+ case $i in
+ Makefile|makefile)
+ do_Makefile ;;
+ files)
+ do_files ;;
+ sources)
+ do_sources ;;
+ compile)
+ do_compile;;
+ recompile)
+ do_recompile;;
+ update_gcc)
+ do_update_gcc_sources;;
+ gcc_install)
+ do_gcc_install;;
+ tar_install)
+ do_tar_install;;
+ tar_dist)
+ do_tar_dist;;
+ -v | --version | version)
+ echo $VERSION
+ exit 0
+ ;;
+ website)
+ do_website;;
+ upload)
+ do_upload;;
+ distclean_gcc)
+ do_distclean_gcc;;
+ distclean_ghdl)
+ do_distclean_ghdl;;
+ dist_phase1)
+ do_dist_phase1;;
+ dist_phase2)
+ do_dist_phase2;;
+ gtkwave_patch)
+ do_gtkwave_patch;;
+ *)
+ echo "usage: $0 clean|Makefile|files|all"
+ exit 1 ;;
+ esac
+ done
+fi
diff --git a/src/translate/gcc/lang-options.h b/src/translate/gcc/lang-options.h
new file mode 100644
index 000000000..c92b12132
--- /dev/null
+++ b/src/translate/gcc/lang-options.h
@@ -0,0 +1,29 @@
+/* Definitions for switches for vhdl.
+ Copyright (C) 2002
+ Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+DEFINE_LANG_NAME ("vhdl")
+
+/* This is the contribution to the `lang_options' array in gcc.c for ghdl. */
+
+ {"--ghdl-", "Specify options to GHDL"},
+
+
+
diff --git a/src/translate/gcc/lang-specs.h b/src/translate/gcc/lang-specs.h
new file mode 100644
index 000000000..050443521
--- /dev/null
+++ b/src/translate/gcc/lang-specs.h
@@ -0,0 +1,28 @@
+/* Definitions for specs for vhdl.
+ Copyright (C) 2002
+ Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This is the contribution to the `default_compilers' array in gcc.c for
+ GHDL. */
+
+ {".vhd", "@vhdl", 0, 0, 0},
+ {".vhdl", "@vhdl", 0, 0, 0},
+ {"@vhdl",
+ "ghdl1 %i %(cc1_options) %{!fsyntax-only:%(invoke_as)}", 0, 0, 0},
diff --git a/src/translate/ghdldrv/Makefile b/src/translate/ghdldrv/Makefile
new file mode 100644
index 000000000..ebf23c2d1
--- /dev/null
+++ b/src/translate/ghdldrv/Makefile
@@ -0,0 +1,193 @@
+# -*- Makefile -*- for the GHDL drivers.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+GNATFLAGS=-gnaty3befhkmr -gnata -gnatwael -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf -gnat05
+GRT_FLAGS=-g
+LIB_CFLAGS=-g -O2
+GNATMAKE=gnatmake
+CC=gcc
+
+# Optimize, do not forget to use MODE=--genfast for iirs.adb.
+#GNATFLAGS+=-O -gnatn
+#GRT_FLAGS+=-O
+
+# Profiling.
+#GNATFLAGS+=-pg -gnatn -O
+#GRT_FLAGS+=-pg -O
+
+# Coverage
+#GNATFLAGS+=-fprofile-arcs -ftest-coverage
+
+GNAT_BARGS=-bargs -E
+
+LLVM_CONFIG=llvm-config
+
+#GNAT_LARGS= -static
+all: ghdl_mcode
+
+target=i686-pc-linux-gnu
+#target=x86_64-pc-linux-gnu
+#target=i686-apple-darwin
+#target=x86_64-apple-darwin
+#target=i386-pc-mingw32
+GRTSRCDIR=../grt
+include $(GRTSRCDIR)/Makefile.inc
+
+ifeq ($(filter-out i%86 linux,$(arch) $(osys)),)
+ ORTHO_X86_FLAGS=Flags_Linux
+endif
+ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),)
+ ORTHO_X86_FLAGS=Flags_Macosx
+endif
+ifeq ($(filter-out i%86 mingw32%,$(arch) $(osys)),)
+ ORTHO_X86_FLAGS=Flags_Windows
+endif
+ifdef ORTHO_X86_FLAGS
+ ORTHO_DEPS=ortho_code-x86-flags.ads
+endif
+
+ortho_code-x86-flags.ads:
+ echo "with Ortho_Code.X86.$(ORTHO_X86_FLAGS);" > $@
+ echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@
+
+ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME
+ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force
+ $(GNATMAKE) -o $@ -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB))
+
+memsegs_c.o: ../../ortho/mcode/memsegs_c.c
+ $(CC) -c -g -o $@ $<
+
+ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME
+ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) llvm-cbindings.o force
+ $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs llvm-cbindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++
+
+llvm-cbindings.o: ../../ortho/llvm/llvm-cbindings.cpp
+ $(CXX) -c -m64 `$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $<
+
+ghdl_simul: default_pathes.ads $(GRT_ADD_OBJS) force
+ $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB))
+
+ghdl_gcc: default_pathes.ads force
+ $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS)
+
+ghdl_llvm: default_pathes.ads force
+ $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS)
+
+default_pathes.ads: default_pathes.ads.in Makefile
+ curdir=`cd ..; pwd`; \
+ sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \
+ -e "s%@COMPILER_DEBUG@%$$curdir/ghdl1-debug%" \
+ -e "s%@COMPILER_MCODE@%$$curdir/ghdl1-mcode%" \
+ -e "s%@COMPILER_LLVM@%$$curdir/ghdl1-llvm%" \
+ -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \
+ -e "s%@INSTALL_PREFIX@%%" \
+ -e "s%@LIB_PREFIX@%$$curdir/lib/%" < $< > $@
+
+bootstrap.old: force
+ $(RM) ../../libraries/std-obj87.cf
+ $(MAKE) -C ../../libraries EXT=obj \
+ ANALYSE="$(PWD)/ghdl -a -g" std-obj87.cf
+ $(RM) ../../libraries/std-obj93.cf
+ $(MAKE) -C ../../libraries EXT=obj \
+ ANALYSE="$(PWD)/ghdl -a -g" std-obj93.cf
+
+LIB87_DIR:=../lib/v87
+LIB93_DIR:=../lib/v93
+LIB08_DIR:=../lib/v08
+
+LIBSRC_DIR:=../../libraries
+REL_DIR:=../..
+GHDL=ghdl
+ANALYZE:=../../../ghdldrv/$(GHDL) -a $(LIB_CFLAGS)
+LN=ln -s
+CP=cp
+
+$(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR):
+ [ -d ../lib ] || mkdir ../lib
+ [ -d $@ ] || mkdir $@
+
+include ../../libraries/Makefile.inc
+
+GHDL1=../ghdl1-gcc
+$(LIB93_DIR)/std/std_standard.o: $(GHDL1)
+ifeq ($(GHDL),ghdl_llvm)
+ $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard
+else
+ $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \
+ --compile-standard
+ $(CC) -c -o $@ std_standard.s
+ $(RM) std_standard.s
+endif
+
+$(LIB87_DIR)/std/std_standard.o: $(GHDL1)
+ifeq ($(GHDL),ghdl_llvm)
+ $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard
+else
+ $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \
+ --compile-standard
+ $(CC) -c -o $@ std_standard.s
+ $(RM) std_standard.s
+endif
+
+$(LIB08_DIR)/std/std_standard.o: $(GHDL1)
+ifeq ($(GHDL),ghdl_llvm)
+ $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard
+else
+ $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -o std_standard.s \
+ --compile-standard
+ $(CC) -c -o $@ std_standard.s
+ $(RM) std_standard.s
+endif
+
+install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93
+install.v87: std.v87 ieee.v87 synopsys.v87
+install.v08: std.v08 ieee.v08
+
+install.standard: $(LIB93_DIR)/std/std_standard.o \
+ $(LIB87_DIR)/std/std_standard.o \
+ $(LIB08_DIR)/std/std_standard.o
+
+grt.links:
+ cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver .
+
+install.all: install.v87 install.v93 install.v08
+
+install.gcc:
+ $(MAKE) GHDL=ghdl_gcc install.all
+ $(MAKE) GHDL1=../ghdl1-gcc install.standard
+
+install.mcode:
+ $(MAKE) GHDL=ghdl_mcode install.all
+
+install.simul:
+ $(MAKE) GHDL=ghdl_simul install.all
+
+install.llvm:
+ $(MAKE) GHDL=ghdl_llvm install.all
+ $(MAKE) GHDL1=../ghdl1-llvm install.standard
+
+clean: force
+ $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode ghdl_llvm ghdl_llvm_jit
+ $(RM) -f b~*.ad? *~ default_pathes.ads ghdl_simul
+ $(RM) -rf ../lib
+
+clean-c: force
+ $(RM) -f memsegs_c.o chkstk.o linux.o times.o grt-cbinding.o grt-cvpi.o
+
+force:
+
+.PHONY: force clean
diff --git a/src/translate/ghdldrv/default_pathes.ads.in b/src/translate/ghdldrv/default_pathes.ads.in
new file mode 100644
index 000000000..7f471a5ed
--- /dev/null
+++ b/src/translate/ghdldrv/default_pathes.ads.in
@@ -0,0 +1,39 @@
+-- GHDL driver pathes -*- ada -*-.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package Default_Pathes is
+
+ -- Accept long lines.
+ pragma Style_Checks ("M999");
+
+ Install_Prefix : constant String :=
+ "@INSTALL_PREFIX@";
+ Lib_Prefix : constant String :=
+ "@LIB_PREFIX@";
+
+ Compiler_Gcc : constant String :=
+ "@COMPILER_GCC@";
+ Compiler_Mcode : constant String :=
+ "@COMPILER_MCODE@";
+ Compiler_Llvm : constant String :=
+ "@COMPILER_LLVM@";
+ Compiler_Debug : constant String :=
+ "@COMPILER_DEBUG@";
+ Post_Processor : constant String :=
+ "@POST_PROCESSOR@";
+end Default_Pathes;
diff --git a/src/translate/ghdldrv/foreigns.adb b/src/translate/ghdldrv/foreigns.adb
new file mode 100644
index 000000000..15e3dd009
--- /dev/null
+++ b/src/translate/ghdldrv/foreigns.adb
@@ -0,0 +1,64 @@
+with Interfaces.C; use Interfaces.C;
+
+package body Foreigns is
+ function Sin (Arg : double) return double;
+ pragma Import (C, Sin);
+
+ function Log (Arg : double) return double;
+ pragma Import (C, Log);
+
+ function Exp (Arg : double) return double;
+ pragma Import (C, Exp);
+
+ function Sqrt (Arg : double) return double;
+ pragma Import (C, Sqrt);
+
+ function Asin (Arg : double) return double;
+ pragma Import (C, Asin);
+
+ function Acos (Arg : double) return double;
+ pragma Import (C, Acos);
+
+ function Asinh (Arg : double) return double;
+ pragma Import (C, Asinh);
+
+ function Acosh (Arg : double) return double;
+ pragma Import (C, Acosh);
+
+ function Atanh (X : double) return double;
+ pragma Import (C, Atanh);
+
+ function Atan2 (X, Y : double) return double;
+ pragma Import (C, Atan2);
+
+ type String_Cacc is access constant String;
+ type Foreign_Record is record
+ Name : String_Cacc;
+ Addr : Address;
+ end record;
+
+
+ Foreign_Arr : constant array (Natural range <>) of Foreign_Record :=
+ (
+ (new String'("sin"), Sin'Address),
+ (new String'("log"), Log'Address),
+ (new String'("exp"), Exp'Address),
+ (new String'("sqrt"), Sqrt'Address),
+ (new String'("asin"), Asin'Address),
+ (new String'("acos"), Acos'Address),
+ (new String'("asinh"), Asinh'Address),
+ (new String'("acosh"), Acosh'Address),
+ (new String'("atanh"), Atanh'Address),
+ (new String'("atan2"), Atan2'Address)
+ );
+
+ function Find_Foreign (Name : String) return Address is
+ begin
+ for I in Foreign_Arr'Range loop
+ if Foreign_Arr(I).Name.all = Name then
+ return Foreign_Arr(I).Addr;
+ end if;
+ end loop;
+ return Null_Address;
+ end Find_Foreign;
+end Foreigns;
diff --git a/src/translate/ghdldrv/foreigns.ads b/src/translate/ghdldrv/foreigns.ads
new file mode 100644
index 000000000..5759ae4f5
--- /dev/null
+++ b/src/translate/ghdldrv/foreigns.ads
@@ -0,0 +1,5 @@
+with System; use System;
+
+package Foreigns is
+ function Find_Foreign (Name : String) return Address;
+end Foreigns;
diff --git a/src/translate/ghdldrv/ghdl_gcc.adb b/src/translate/ghdldrv/ghdl_gcc.adb
new file mode 100644
index 000000000..615a8c5d6
--- /dev/null
+++ b/src/translate/ghdldrv/ghdl_gcc.adb
@@ -0,0 +1,34 @@
+-- GHDL driver for gcc.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ghdlmain;
+with Ghdllocal;
+with Ghdldrv;
+with Ghdlprint;
+
+procedure Ghdl_Gcc is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlmain.Version_String := new String'("GCC back-end code generator");
+ Ghdldrv.Compile_Kind := Ghdldrv.Compile_Gcc;
+ Ghdldrv.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Gcc;
diff --git a/src/translate/ghdldrv/ghdl_jit.adb b/src/translate/ghdldrv/ghdl_jit.adb
new file mode 100644
index 000000000..ba7087492
--- /dev/null
+++ b/src/translate/ghdldrv/ghdl_jit.adb
@@ -0,0 +1,35 @@
+-- GHDL driver for jit.
+-- Copyright (C) 2002-2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ghdlmain;
+with Ghdllocal;
+with Ghdlprint;
+with Ghdlrun;
+with Ortho_Jit;
+
+procedure Ghdl_Jit is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlmain.Version_String :=
+ new String'(Ortho_Jit.Get_Jit_Name & " code generator");
+ Ghdlrun.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Jit;
diff --git a/src/translate/ghdldrv/ghdl_simul.adb b/src/translate/ghdldrv/ghdl_simul.adb
new file mode 100644
index 000000000..d4d0abd7a
--- /dev/null
+++ b/src/translate/ghdldrv/ghdl_simul.adb
@@ -0,0 +1,33 @@
+-- GHDL driver for simulator.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ghdlmain;
+with Ghdllocal;
+with Ghdlprint;
+with Ghdlsimul;
+
+procedure Ghdl_Simul is
+begin
+ -- Manual elaboration so that the order is known (because it is the order
+ -- used to display help).
+ Ghdlmain.Version_String := new String'("interpretation");
+ Ghdlsimul.Register_Commands;
+ Ghdllocal.Register_Commands;
+ Ghdlprint.Register_Commands;
+ Ghdlmain.Register_Commands;
+ Ghdlmain.Main;
+end Ghdl_Simul;
diff --git a/src/translate/ghdldrv/ghdlcomp.adb b/src/translate/ghdldrv/ghdlcomp.adb
new file mode 100644
index 000000000..ba755af8a
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlcomp.adb
@@ -0,0 +1,757 @@
+-- GHDL driver - compile commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+
+with Ada.Command_Line;
+with Ada.Characters.Latin_1;
+with Ada.Text_IO;
+
+with Types;
+with Iirs; use Iirs;
+with Nodes_GC;
+with Flags;
+with Back_End;
+with Sem;
+with Name_Table;
+with Errorout; use Errorout;
+with Libraries;
+with Std_Package;
+with Files_Map;
+with Version;
+with Default_Pathes;
+
+package body Ghdlcomp is
+
+ Flag_Expect_Failure : Boolean := False;
+
+ Flag_Debug_Nodes_Leak : Boolean := False;
+ -- If True, detect unreferenced nodes at the end of analysis.
+
+ -- Commands which use the mcode compiler.
+ type Command_Comp is abstract new Command_Lib with null record;
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Disp_Long_Help (Cmd : Command_Comp);
+
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Option = "--debug-nodes-leak" then
+ Flag_Debug_Nodes_Leak := True;
+ Res := Option_Ok;
+ elsif Hooks.Decode_Option.all (Option) then
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+
+ procedure Disp_Long_Help (Cmd : Command_Comp)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Hooks.Disp_Long_Help.all;
+ Put_Line (" --expect-failure Expect analysis/elaboration failure");
+ end Disp_Long_Help;
+
+ -- Command -r
+ type Command_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-r" or Name = "--elab-run";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS] Run UNIT";
+ end Get_Short_Help;
+
+
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Opt_Arg : Natural;
+ begin
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Libraries.Load_Work_Library (False);
+ Flags.Flag_Elaborate_With_Outdated := False;
+ Flags.Flag_Only_Elab_Warnings := True;
+
+ Hooks.Compile_Elab.all ("-r", Args, Opt_Arg);
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end;
+ Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last));
+ Hooks.Run.all;
+ end Perform_Action;
+
+
+ -- Command -c xx -r
+ type Command_Compile is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Compile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Compile) return String;
+ procedure Decode_Option (Cmd : in out Command_Compile;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Perform_Action (Cmd : in out Command_Compile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Compile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-c";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Compile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS] "
+ & "Compile, elaborate and run UNIT";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Compile;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-r" or else Option = "-e" then
+ Res := Option_End;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Compile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Elab_Arg : Natural;
+ Run_Arg : Natural;
+ begin
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Flags.Flag_Elaborate_With_Outdated := True;
+ Flags.Flag_Only_Elab_Warnings := False;
+
+ if Args'Length > 1 and then
+ (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e")
+ then
+ -- If there is no files, then load the work library.
+ Libraries.Load_Work_Library (False);
+ -- Also, load all libraries and files, so that every design unit
+ -- is known.
+ Load_All_Libraries_And_Files;
+ Elab_Arg := Args'First + 1;
+ else
+ -- If there is at least one file, do not load the work library.
+ Libraries.Load_Work_Library (True);
+ Elab_Arg := Natural'Last;
+ for I in Args'Range loop
+ declare
+ Arg : constant String := Args (I).all;
+ Res : Iir_Design_File;
+ Design : Iir;
+ Next_Design : Iir;
+ begin
+ if Arg = "-r" or else Arg = "-e" then
+ Elab_Arg := I + 1;
+ exit;
+ else
+ Res := Libraries.Load_File
+ (Name_Table.Get_Identifier (Arg));
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Put units into library.
+ Design := Get_First_Design_Unit (Res);
+ while not Is_Null (Design) loop
+ Next_Design := Get_Chain (Design);
+ Set_Chain (Design, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Design);
+ Design := Next_Design;
+ end loop;
+ end if;
+ end;
+ end loop;
+ if Elab_Arg = Natural'Last then
+ Libraries.Save_Work_Library;
+ return;
+ end if;
+ end if;
+
+ Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg);
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end;
+ if Args (Elab_Arg - 1).all = "-r" then
+ Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last));
+ Hooks.Run.all;
+ else
+ if Run_Arg <= Args'Last then
+ Error_Msg_Option ("options after unit are ignored");
+ end if;
+ end if;
+ end Perform_Action;
+
+ -- Command -a
+ type Command_Analyze is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Analyze) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-a";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Analyze) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-a [OPTS] FILEs Analyze FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ New_Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ begin
+ Setup_Libraries (True);
+
+ Hooks.Compile_Init.all (True);
+
+ -- Parse all files.
+ for I in Args'Range loop
+ Id := Name_Table.Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if False then
+ -- Speed up analysis: remove all previous designs.
+ -- However, this is not in the LRM...
+ Libraries.Purge_Design_File (Design_File);
+ end if;
+
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Back_End.Finish_Compilation (Unit, True);
+
+ Next_Unit := Get_Chain (Unit);
+
+ if Errorout.Nbr_Errors = 0 then
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ New_Design_File := Get_Design_File (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ Free_Iir (Design_File);
+
+ -- Do late analysis checks.
+ Unit := Get_First_Design_Unit (New_Design_File);
+ while Unit /= Null_Iir loop
+ Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks);
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+ end if;
+ end loop;
+
+ if Flag_Expect_Failure then
+ raise Compilation_Error;
+ end if;
+
+ if Flag_Debug_Nodes_Leak then
+ Nodes_GC.Report_Unreferenced;
+ end if;
+
+ Libraries.Save_Work_Library;
+
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then
+ return;
+ else
+ raise;
+ end if;
+ end Perform_Action;
+
+ -- Command -e
+ type Command_Elab is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab) return String;
+ procedure Decode_Option (Cmd : in out Command_Elab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-e";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-e [OPTS] UNIT [ARCH] Elaborate UNIT";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Elab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Option = "-o" then
+ if Arg'Length = 0 then
+ Res := Option_Arg_Req;
+ else
+ -- Silently accepted.
+ Res := Option_Arg;
+ end if;
+ --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then
+ -- Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Run_Arg : Natural;
+ begin
+ Hooks.Compile_Init.all (False);
+
+ Libraries.Load_Work_Library (False);
+ Flags.Flag_Elaborate_With_Outdated := False;
+ Flags.Flag_Only_Elab_Warnings := True;
+
+ Hooks.Compile_Elab.all ("-e", Args, Run_Arg);
+ if Run_Arg <= Args'Last then
+ Error_Msg_Option ("options after unit are ignored");
+ end if;
+ if Flag_Expect_Failure then
+ raise Compilation_Error;
+ end if;
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then
+ return;
+ else
+ raise;
+ end if;
+ end Perform_Action;
+
+ -- Command dispconfig.
+ type Command_Dispconfig is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String;
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--dispconfig";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--dispconfig Disp tools path";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List)
+ is
+ use Ada.Text_IO;
+ use Libraries;
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("--dispconfig does not accept any argument");
+ raise Errorout.Option_Error;
+ end if;
+
+ Put ("command line prefix (--PREFIX): ");
+ if Prefix_Path = null then
+ Put_Line ("(not set)");
+ else
+ Put_Line (Prefix_Path.all);
+ end if;
+ Setup_Libraries (False);
+
+ Put ("environment prefix (GHDL_PREFIX): ");
+ if Prefix_Env = null then
+ Put_Line ("(not set)");
+ else
+ Put_Line (Prefix_Env.all);
+ end if;
+
+ Put_Line ("default prefix: " & Default_Pathes.Prefix);
+ Put_Line ("actual prefix: " & Prefix_Path.all);
+ Put_Line ("command_name: " & Ada.Command_Line.Command_Name);
+ Put_Line ("default library pathes:");
+ for I in 2 .. Get_Nbr_Pathes loop
+ Put (' ');
+ Put_Line (Name_Table.Image (Get_Path (I)));
+ end loop;
+ end Perform_Action;
+
+ -- Command Make.
+ type Command_Make is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Make) return String;
+ procedure Perform_Action (Cmd : in out Command_Make;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-m";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Make) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-m [OPTS] UNIT [ARCH] Make UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Next_Arg : Natural;
+ Date : Date_Type;
+ Unit : Iir_Design_Unit;
+ begin
+ Extract_Elab_Unit ("-m", Args, Next_Arg);
+ Setup_Libraries (True);
+
+ -- Create list of files.
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Date := Get_Date (Libraries.Work_Library);
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+
+ if Get_Library (File) = Libraries.Work_Library then
+ -- Mark this file as analyzed.
+ Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);
+
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if Get_Date (Unit) = Date_Analyzed
+ or else Get_Date (Unit) in Date_Valid
+ then
+ Date := Date + 1;
+ Set_Date (Unit, Date);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ Set_Date (Libraries.Work_Library, Date);
+ Libraries.Save_Work_Library;
+ exception
+ when Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end Perform_Action;
+
+ -- Command Gen_Makefile.
+ type Command_Gen_Makefile is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String;
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--gen-makefile";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT";
+ end Get_Short_Help;
+
+ function Is_Makeable_File (File : Iir_Design_File) return Boolean is
+ begin
+ if File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+ return True;
+ end Is_Makeable_File;
+
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Types;
+ use Ada.Text_IO;
+ use Ada.Command_Line;
+ use Name_Table;
+
+ HT : constant Character := Ada.Characters.Latin_1.HT;
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Lib : Iir_Library_Declaration;
+ Dir_Id : Name_Id;
+
+ Next_Arg : Natural;
+ begin
+ Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg);
+ Setup_Libraries (True);
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Put_Line ("# Makefile automatically generated by ghdl");
+ Put ("# Version: ");
+ Put (Version.Ghdl_Release);
+ Put (" - ");
+ if Version_String /= null then
+ Put (Version_String.all);
+ end if;
+ New_Line;
+ Put_Line ("# Command used to generate this makefile:");
+ Put ("# ");
+ Put (Command_Name);
+ for I in 1 .. Argument_Count loop
+ Put (' ');
+ Put (Argument (I));
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put ("GHDL=");
+ Put_Line (Command_Name);
+
+ -- Extract options for command line.
+ Put ("GHDLFLAGS=");
+ for I in 2 .. Argument_Count loop
+ declare
+ Arg : constant String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=")
+ or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=")
+ or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P")
+ then
+ Put (" ");
+ Put (Arg);
+ end if;
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ Put ("GHDLRUNFLAGS=");
+ for I in Next_Arg .. Args'Last loop
+ Put (' ');
+ Put (Args (I).all);
+ end loop;
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Default target : elaborate");
+ Put_Line ("all : elab");
+ New_Line;
+
+ Put_Line ("# Elaborate target. Almost useless");
+ Put_Line ("elab : force");
+ Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e ");
+ Put (Prim_Name.all);
+ if Sec_Name /= null then
+ Put (' ');
+ Put (Sec_Name.all);
+ end if;
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Run target");
+ Put_Line ("run : force");
+ Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r ");
+ Put (Prim_Name.all);
+ if Sec_Name /= null then
+ Put (' ');
+ Put (Sec_Name.all);
+ end if;
+ Put (" $(GHDLRUNFLAGS)");
+ New_Line;
+ New_Line;
+
+ Put_Line ("# Targets to analyze libraries");
+ Put_Line ("init: force");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Dir_Id := Get_Design_File_Directory (File);
+ if not Is_Makeable_File (File) then
+ -- Builtin file.
+ null;
+ elsif Dir_Id /= Files_Map.Get_Home_Directory then
+ -- Not locally built file.
+ Put (HT & "# ");
+ Put (Image (Dir_Id));
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+ else
+
+ Put (HT & "$(GHDL) -a $(GHDLFLAGS)");
+ Lib := Get_Library (File);
+ if Lib /= Libraries.Work_Library then
+ -- Overwrite some options.
+ Put (" --work=");
+ Put (Image (Get_Identifier (Lib)));
+ Dir_Id := Get_Library_Directory (Lib);
+ Put (" --workdir=");
+ if Dir_Id = Libraries.Local_Directory then
+ Put (".");
+ else
+ Put (Image (Dir_Id));
+ end if;
+ end if;
+ Put (' ');
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+ end if;
+ end loop;
+ New_Line;
+
+ Put_Line ("force:");
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Analyze);
+ Register_Command (new Command_Elab);
+ Register_Command (new Command_Run);
+ Register_Command (new Command_Compile);
+ Register_Command (new Command_Make);
+ Register_Command (new Command_Gen_Makefile);
+ Register_Command (new Command_Dispconfig);
+ end Register_Commands;
+
+end Ghdlcomp;
diff --git a/src/translate/ghdldrv/ghdlcomp.ads b/src/translate/ghdldrv/ghdlcomp.ads
new file mode 100644
index 000000000..f803ca4fa
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlcomp.ads
@@ -0,0 +1,67 @@
+-- GHDL driver - compile commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Ghdlcomp is
+ -- This procedure is called at start of commands which call
+ -- finish_compilation to generate code.
+ type Compile_Init_Acc is access procedure (Analyze_Only : Boolean);
+
+ -- This procedure is called for elaboration.
+ -- CMD_NAME is the name of the command, used to report errors.
+ -- ARGS is the argument list, starting from the unit name to be elaborated.
+ -- The procedure should extract the unit.
+ -- OPT_ARG is the index of the first argument from ARGS to be used as
+ -- a run option.
+ type Compile_Elab_Acc is access procedure
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural);
+
+ -- Use ARGS as run options.
+ -- Should do all the work.
+ type Set_Run_Options_Acc is access
+ procedure (Args : Argument_List);
+
+ -- Run the simulation.
+ -- All the parameters were set through calling Compile_Elab and
+ -- Set_Run_Options.
+ type Run_Acc is access procedure;
+
+ -- Called when an analysis/elaboration option is decoded.
+ -- Return True if OPTION is known (and do the side effects).
+ -- No parameters are allowed.
+ type Decode_Option_Acc is access function (Option : String) return Boolean;
+
+ -- Disp help for options decoded by Decode_Option.
+ type Disp_Long_Help_Acc is access procedure;
+
+ -- All the hooks gathered.
+ -- A record is used to be sure all hooks are set.
+ type Hooks_Type is record
+ Compile_Init : Compile_Init_Acc := null;
+ Compile_Elab : Compile_Elab_Acc := null;
+ Set_Run_Options : Set_Run_Options_Acc := null;
+ Run : Run_Acc := null;
+ Decode_Option : Decode_Option_Acc := null;
+ Disp_Long_Help : Disp_Long_Help_Acc := null;
+ end record;
+
+ Hooks : Hooks_Type;
+
+ -- Register commands.
+ procedure Register_Commands;
+end Ghdlcomp;
diff --git a/src/translate/ghdldrv/ghdldrv.adb b/src/translate/ghdldrv/ghdldrv.adb
new file mode 100644
index 000000000..be905f1af
--- /dev/null
+++ b/src/translate/ghdldrv/ghdldrv.adb
@@ -0,0 +1,1818 @@
+-- GHDL driver - commands invoking gcc.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Latin_1;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Table;
+with GNAT.Dynamic_Tables;
+with Libraries;
+with Name_Table; use Name_Table;
+with Std_Package;
+with Types; use Types;
+with Iirs; use Iirs;
+with Files_Map;
+with Flags;
+with Configuration;
+--with Disp_Tree;
+with Default_Pathes;
+with Interfaces.C_Streams;
+with System;
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with Errorout;
+with Version;
+with Options;
+
+package body Ghdldrv is
+ -- Name of the tools used.
+ Compiler_Cmd : String_Access := null;
+ Post_Processor_Cmd : String_Access := null;
+ Assembler_Cmd : constant String := "as";
+ Linker_Cmd : constant String := "gcc";
+
+ -- Path of the tools.
+ Compiler_Path : String_Access;
+ Post_Processor_Path : String_Access;
+ Assembler_Path : String_Access;
+ Linker_Path : String_Access;
+
+ -- Set by the '-o' option: the output filename. If the option is not
+ -- present, then null.
+ Output_File : String_Access;
+
+ -- "-o" string.
+ Dash_o : constant String_Access := new String'("-o");
+
+ -- "-c" string.
+ Dash_c : constant String_Access := new String'("-c");
+
+ -- "-quiet" option.
+ Dash_Quiet : constant String_Access := new String'("-quiet");
+
+ -- If set, do not assmble
+ Flag_Asm : Boolean;
+
+ -- If true, executed commands are displayed.
+ Flag_Disp_Commands : Boolean;
+
+ -- Flag not quiet
+ Flag_Not_Quiet : Boolean;
+
+ -- True if failure expected.
+ Flag_Expect_Failure : Boolean;
+
+ -- Argument table for the tools.
+ -- Each table low bound is 1 so that the length of a table is equal to
+ -- the last bound.
+ package Argument_Table_Pkg is new GNAT.Dynamic_Tables
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 4,
+ Table_Increment => 100);
+ use Argument_Table_Pkg;
+
+ -- Arguments for tools.
+ Compiler_Args : Argument_Table_Pkg.Instance;
+ Postproc_Args : Argument_Table_Pkg.Instance;
+ Assembler_Args : Argument_Table_Pkg.Instance;
+ Linker_Args : Argument_Table_Pkg.Instance;
+
+ -- Display the program spawned in Flag_Disp_Commands is TRUE.
+ -- Raise COMPILE_ERROR in case of failure.
+ procedure My_Spawn (Program_Name : String; Args : Argument_List)
+ is
+ Status : Integer;
+ begin
+ if Flag_Disp_Commands then
+ Put (Program_Name);
+ for I in Args'Range loop
+ Put (' ');
+ Put (Args (I).all);
+ end loop;
+ New_Line;
+ end if;
+ Status := Spawn (Program_Name, Args);
+ if Status = 0 then
+ return;
+ elsif Status = 1 then
+ Error ("compilation error");
+ raise Compile_Error;
+ elsif Status > 127 then
+ Error ("executable killed by a signal");
+ raise Exec_Error;
+ else
+ Error ("exec error");
+ raise Exec_Error;
+ end if;
+ end My_Spawn;
+
+ -- Compile FILE with additional argument OPTS.
+ procedure Do_Compile (Options : Argument_List; File : String)
+ is
+ Obj_File : String_Access;
+ Asm_File : String_Access;
+ Post_File : String_Access;
+ Success : Boolean;
+ begin
+ -- Create post file.
+ case Compile_Kind is
+ when Compile_Debug =>
+ Post_File := Append_Suffix (File, Post_Suffix);
+ when others =>
+ null;
+ end case;
+
+ -- Create asm file.
+ case Compile_Kind is
+ when Compile_Gcc
+ | Compile_Debug =>
+ Asm_File := Append_Suffix (File, Asm_Suffix);
+ when Compile_Llvm
+ | Compile_Mcode =>
+ null;
+ end case;
+
+ -- Create obj file (may not be used, but the condition isn't simple).
+ Obj_File := Append_Suffix (File, Get_Object_Suffix.all);
+
+ -- Compile.
+ declare
+ P : Natural;
+ Nbr_Args : constant Natural :=
+ Last (Compiler_Args) + Options'Length + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ begin
+ P := 0;
+ for I in First .. Last (Compiler_Args) loop
+ P := P + 1;
+ Args (P) := Compiler_Args.Table (I);
+ end loop;
+ for I in Options'Range loop
+ P := P + 1;
+ Args (P) := Options (I);
+ end loop;
+
+ -- Add -quiet.
+ case Compile_Kind is
+ when Compile_Gcc =>
+ if not Flag_Not_Quiet then
+ P := P + 1;
+ Args (P) := Dash_Quiet;
+ end if;
+ when Compile_Llvm =>
+ P := P + 1;
+ Args (P) := Dash_c;
+ when Compile_Debug
+ | Compile_Mcode =>
+ null;
+ end case;
+
+ Args (P + 1) := Dash_o;
+ case Compile_Kind is
+ when Compile_Debug =>
+ Args (P + 2) := Post_File;
+ when Compile_Gcc =>
+ Args (P + 2) := Asm_File;
+ when Compile_Mcode
+ | Compile_Llvm =>
+ Args (P + 2) := Obj_File;
+ end case;
+ Args (P + 3) := new String'(File);
+
+ My_Spawn (Compiler_Path.all, Args (1 .. P + 3));
+ Free (Args (P + 3));
+ exception
+ when Compile_Error =>
+ -- Delete temporary file in case of error.
+ Delete_File (Args (P + 2).all, Success);
+ -- FIXME: delete object file too ?
+ raise;
+ end;
+
+ -- Post-process.
+ if Compile_Kind = Compile_Debug then
+ declare
+ P : Natural;
+ Nbr_Args : constant Natural := Last (Postproc_Args) + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ begin
+ P := 0;
+ for I in First .. Last (Postproc_Args) loop
+ P := P + 1;
+ Args (P) := Postproc_Args.Table (I);
+ end loop;
+
+ if not Flag_Not_Quiet then
+ P := P + 1;
+ Args (P) := Dash_Quiet;
+ end if;
+
+ Args (P + 1) := Dash_o;
+ Args (P + 2) := Asm_File;
+ Args (P + 3) := Post_File;
+ My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3));
+ end;
+
+ Free (Post_File);
+ end if;
+
+ -- Assemble.
+ if Compile_Kind >= Compile_Gcc then
+ if Flag_Expect_Failure then
+ Delete_File (Asm_File.all, Success);
+ elsif not Flag_Asm then
+ declare
+ P : Natural;
+ Nbr_Args : constant Natural := Last (Assembler_Args) + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ Success : Boolean;
+ begin
+ P := 0;
+ for I in First .. Last (Assembler_Args) loop
+ P := P + 1;
+ Args (P) := Assembler_Args.Table (I);
+ end loop;
+
+ Args (P + 1) := Dash_o;
+ Args (P + 2) := Obj_File;
+ Args (P + 3) := Asm_File;
+ My_Spawn (Assembler_Path.all, Args (1 .. P + 3));
+ Delete_File (Asm_File.all, Success);
+ end;
+ end if;
+ end if;
+
+ Free (Asm_File);
+ Free (Obj_File);
+ end Do_Compile;
+
+ package Filelist is new GNAT.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ Link_Obj_Suffix : String_Access;
+
+ -- Read a list of files from file FILENAME.
+ -- Lines starting with a '#' are ignored (comments)
+ -- Lines starting with a '>' are directory lines
+ -- If first character of a line is a '@', it is replaced with
+ -- the lib_prefix_path.
+ -- If TO_OBJ is true, then each file is converted to an object file name
+ -- (suffix is replaced by the object file extension).
+ procedure Add_File_List (Filename : String; To_Obj : Boolean)
+ is
+ use Interfaces.C_Streams;
+ use System;
+ use Ada.Characters.Latin_1;
+
+ -- Replace the first '@' with the machine path.
+ function Substitute (Str : String) return String
+ is
+ begin
+ for I in Str'Range loop
+ if Str (I) = '@' then
+ return Str (Str'First .. I - 1)
+ & Get_Machine_Path_Prefix
+ & Str (I + 1 .. Str'Last);
+ end if;
+ end loop;
+ return Str;
+ end Substitute;
+
+ Dir : String (1 .. max_path_len);
+ Dir_Len : Natural;
+ Line : String (1 .. max_path_len);
+ Stream : Interfaces.C_Streams.FILEs;
+ Mode : constant String := "rt" & Ghdllocal.Nul;
+ L : Natural;
+ File : String_Access;
+ begin
+ Line (1 .. Filename'Length) := Filename;
+ Line (Filename'Length + 1) := Ghdllocal.Nul;
+ Stream := fopen (Line'Address, Mode'Address);
+ if Stream = NULL_Stream then
+ Error ("cannot open " & Filename);
+ raise Compile_Error;
+ end if;
+ Dir_Len := 0;
+ loop
+ exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream;
+ if Line (1) /= '#' then
+ -- Compute string length.
+ L := 0;
+ while Line (L + 1) /= Ghdllocal.Nul loop
+ L := L + 1;
+ end loop;
+
+ -- Remove trailing NL.
+ while L > 0 and then (Line (L) = LF or Line (L) = CR) loop
+ L := L - 1;
+ end loop;
+
+ if Line (1) = '>' then
+ Dir_Len := L - 1;
+ Dir (1 .. Dir_Len) := Line (2 .. L);
+ else
+ if To_Obj then
+ File := new String'(Dir (1 .. Dir_Len)
+ & Get_Base_Name (Line (1 .. L))
+ & Link_Obj_Suffix.all);
+ else
+ File := new String'(Substitute (Line (1 .. L)));
+ end if;
+
+ Filelist.Increment_Last;
+ Filelist.Table (Filelist.Last) := File;
+
+ Dir_Len := 0;
+ end if;
+ end if;
+ end loop;
+ if fclose (Stream) /= 0 then
+ Error ("cannot close " & Filename);
+ end if;
+ end Add_File_List;
+
+ function Get_Object_Filename (File : Iir_Design_File) return String
+ is
+ Dir : Name_Id;
+ Name : Name_Id;
+ begin
+ Dir := Get_Library_Directory (Get_Library (File));
+ Name := Get_Design_File_Filename (File);
+ return Image (Dir) & Get_Base_Name (Image (Name))
+ & Get_Object_Suffix.all;
+ end Get_Object_Filename;
+
+ Last_Stamp : Time_Stamp_Id;
+ Last_Stamp_File : Iir;
+
+ function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean
+ is
+ use Files_Map;
+
+ Name : Name_Id;
+
+ File : Source_File_Entry;
+ begin
+ -- Std.Standard is never outdated.
+ if Design_File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+
+ Name := Get_Design_File_Filename (Design_File);
+ declare
+ Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul;
+ Stamp : Time_Stamp_Id;
+ begin
+ Stamp := Get_File_Time_Stamp (Obj_Pathname'Address);
+
+ -- If the object file does not exist, recompile the file.
+ if Stamp = Null_Time_Stamp then
+ if Flag_Verbose then
+ Put_Line ("no object file for " & Image (Name));
+ end if;
+ return True;
+ end if;
+
+ -- Keep the time stamp of the most recently analyzed unit.
+ if Last_Stamp = Null_Time_Stamp
+ or else Is_Gt (Stamp, Last_Stamp)
+ then
+ Last_Stamp := Stamp;
+ Last_Stamp_File := Design_File;
+ end if;
+ end;
+
+ -- 2) file has been modified.
+ File := Load_Source_File (Get_Design_File_Directory (Design_File),
+ Get_Design_File_Filename (Design_File));
+ if not Is_Eq (Get_File_Time_Stamp (File),
+ Get_File_Time_Stamp (Design_File))
+ then
+ if Flag_Verbose then
+ Put_Line ("file " & Image (Get_File_Name (File))
+ & " has been modified");
+ end if;
+ return True;
+ end if;
+
+ return False;
+ end Is_File_Outdated;
+
+ function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean
+ is
+ Design_File : Iir_Design_File;
+ begin
+ -- Std.Standard is never outdated.
+ if Unit = Std_Package.Std_Standard_Unit then
+ return False;
+ end if;
+
+ Design_File := Get_Design_File (Unit);
+
+ -- 1) not yet analyzed:
+ if Get_Date (Unit) not in Date_Valid then
+ if Flag_Verbose then
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ Put_Line (" was not analyzed");
+ end if;
+ return True;
+ end if;
+
+ -- 3) the object file does not exist.
+ -- Already checked.
+
+ -- 4) one of the dependence is newer
+ declare
+ Depends : Iir_List;
+ El : Iir;
+ Dep : Iir_Design_Unit;
+ Stamp : Time_Stamp_Id;
+ Dep_File : Iir_Design_File;
+ begin
+ Depends := Get_Dependence_List (Unit);
+ Stamp := Get_Analysis_Time_Stamp (Design_File);
+ if Depends /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Depends, I);
+ exit when El = Null_Iir;
+ Dep := Libraries.Find_Design_Unit (El);
+ if Dep = Null_Iir then
+ if Flag_Verbose then
+ Disp_Library_Unit (Unit);
+ Put (" depends on an unknown unit ");
+ Disp_Library_Unit (El);
+ New_Line;
+ end if;
+ return True;
+ end if;
+ Dep_File := Get_Design_File (Dep);
+ if Dep /= Std_Package.Std_Standard_Unit
+ and then Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File),
+ Stamp)
+ then
+ if Flag_Verbose then
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ Put (" depends on: ");
+ Disp_Library_Unit (Get_Library_Unit (Dep));
+ Put (" (more recently analyzed)");
+ New_Line;
+ end if;
+ return True;
+ end if;
+ end loop;
+ end if;
+ end;
+
+ return False;
+ end Is_Unit_Outdated;
+
+ procedure Add_Argument (Inst : in out Instance; Arg : String_Access)
+ is
+ begin
+ Increment_Last (Inst);
+ Inst.Table (Last (Inst)) := Arg;
+ end Add_Argument;
+
+ -- Convert option "-Wx,OPTIONS" to arguments for tool X.
+ procedure Add_Arguments (Inst : in out Instance; Opt : String) is
+ begin
+ Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last)));
+ end Add_Arguments;
+
+ procedure Tool_Not_Found (Name : String) is
+ begin
+ Error ("installation problem: " & Name & " not found");
+ raise Option_Error;
+ end Tool_Not_Found;
+
+ -- Set the compiler command according to the configuration (and swicthes).
+ procedure Set_Tools_Name is
+ begin
+ -- Set tools name.
+ if Compiler_Cmd = null then
+ case Compile_Kind is
+ when Compile_Debug =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug);
+ when Compile_Gcc =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc);
+ when Compile_Mcode =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode);
+ when Compile_Llvm =>
+ Compiler_Cmd := new String'(Default_Pathes.Compiler_Llvm);
+ end case;
+ end if;
+ if Post_Processor_Cmd = null then
+ Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor);
+ end if;
+ end Set_Tools_Name;
+
+ function Locate_Exec_Tool (Toolname : String) return String_Access is
+ begin
+ if Is_Absolute_Path (Toolname) then
+ if Is_Executable_File (Toolname) then
+ return new String'(Toolname);
+ end if;
+ else
+ -- Try from install prefix
+ if Exec_Prefix /= null then
+ declare
+ Path : constant String :=
+ Exec_Prefix.all & Directory_Separator & Toolname;
+ begin
+ if Is_Executable_File (Path) then
+ return new String'(Path);
+ end if;
+ end;
+ end if;
+
+ -- Try configured prefix
+ declare
+ Path : constant String :=
+ Default_Pathes.Install_Prefix & Directory_Separator & Toolname;
+ begin
+ if Is_Executable_File (Path) then
+ return new String'(Path);
+ end if;
+ end;
+ end if;
+
+ -- Search the basename on path.
+ declare
+ Pos : constant Natural := Get_Basename_Pos (Toolname);
+ begin
+ if Pos = 0 then
+ return Locate_Exec_On_Path (Toolname);
+ else
+ return Locate_Exec_On_Path (Toolname (Pos .. Toolname'Last));
+ end if;
+ end;
+ end Locate_Exec_Tool;
+
+ procedure Locate_Tools is
+ begin
+ Compiler_Path := Locate_Exec_Tool (Compiler_Cmd.all);
+ if Compiler_Path = null then
+ Tool_Not_Found (Compiler_Cmd.all);
+ end if;
+ if Compile_Kind >= Compile_Debug then
+ Post_Processor_Path := Locate_Exec_Tool (Post_Processor_Cmd.all);
+ if Post_Processor_Path = null then
+ Tool_Not_Found (Post_Processor_Cmd.all);
+ end if;
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd);
+ if Assembler_Path = null and not Flag_Asm then
+ Tool_Not_Found (Assembler_Cmd);
+ end if;
+ end if;
+ Linker_Path := Locate_Exec_On_Path (Linker_Cmd);
+ if Linker_Path = null then
+ Tool_Not_Found (Linker_Cmd);
+ end if;
+ end Locate_Tools;
+
+ procedure Setup_Compiler (Load : Boolean)
+ is
+ use Libraries;
+ begin
+ Set_Tools_Name;
+ Setup_Libraries (Load);
+ Locate_Tools;
+ for I in 2 .. Get_Nbr_Pathes loop
+ Add_Argument (Compiler_Args,
+ new String'("-P" & Image (Get_Path (I))));
+ end loop;
+ end Setup_Compiler;
+
+ type Command_Comp is abstract new Command_Lib with null record;
+
+ -- Setup GHDL.
+ procedure Init (Cmd : in out Command_Comp);
+
+ -- Handle:
+ -- all ghdl flags.
+ -- some GCC flags.
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Disp_Long_Help (Cmd : Command_Comp);
+
+ procedure Init (Cmd : in out Command_Comp)
+ is
+ begin
+ -- Init options.
+ Flag_Not_Quiet := False;
+ Flag_Disp_Commands := False;
+ Flag_Asm := False;
+ Flag_Expect_Failure := False;
+ Output_File := null;
+
+ -- Initialize argument tables.
+ Init (Compiler_Args);
+ Init (Postproc_Args);
+ Init (Assembler_Args);
+ Init (Linker_Args);
+ Init (Command_Lib (Cmd));
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Comp;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ Str : String_Access;
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ Res := Option_Bad;
+ if Opt = "-v" and then Flag_Verbose = False then
+ -- Note: this is also decoded for command_lib, but we set
+ -- Flag_Disp_Commands too.
+ Flag_Verbose := True;
+ --Flags.Verbose := True;
+ Flag_Disp_Commands := True;
+ Res := Option_Ok;
+ elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then
+ Compiler_Cmd := new String'(Opt (9 .. Opt'Last));
+ Res := Option_Ok;
+ elsif Opt = "-S" then
+ Flag_Asm := True;
+ Res := Option_Ok;
+ elsif Opt = "--post" then
+ Compile_Kind := Compile_Debug;
+ Res := Option_Ok;
+ elsif Opt = "--mcode" then
+ Compile_Kind := Compile_Mcode;
+ Res := Option_Ok;
+ elsif Opt = "--llvm" then
+ Compile_Kind := Compile_Llvm;
+ Res := Option_Ok;
+ elsif Opt = "-o" then
+ if Arg'Length = 0 then
+ Res := Option_Arg_Req;
+ else
+ Output_File := new String'(Arg);
+ Res := Option_Arg;
+ end if;
+ elsif Opt = "-m32" then
+ Add_Argument (Compiler_Args, new String'("-m32"));
+ Add_Argument (Assembler_Args, new String'("--32"));
+ Add_Argument (Linker_Args, new String'("-m32"));
+ Decode_Option (Command_Lib (Cmd), Opt, Arg, Res);
+ elsif Opt'Length > 4
+ and then Opt (2) = 'W' and then Opt (4) = ','
+ then
+ if Opt (3) = 'c' then
+ Add_Arguments (Compiler_Args, Opt);
+ elsif Opt (3) = 'a' then
+ Add_Arguments (Assembler_Args, Opt);
+ elsif Opt (3) = 'p' then
+ Add_Arguments (Postproc_Args, Opt);
+ elsif Opt (3) = 'l' then
+ Add_Arguments (Linker_Args, Opt);
+ else
+ Error ("unknown tool name in '-W" & Opt (3) & ",' option");
+ raise Option_Error;
+ end if;
+ Res := Option_Ok;
+ elsif Opt'Length >= 2 and then Opt (2) = 'g' then
+ -- Debugging option.
+ Str := new String'(Opt);
+ Add_Argument (Compiler_Args, Str);
+ Add_Argument (Linker_Args, Str);
+ Res := Option_Ok;
+ elsif Opt = "-Q" then
+ Flag_Not_Quiet := True;
+ Res := Option_Ok;
+ elsif Opt = "--expect-failure" then
+ Add_Argument (Compiler_Args, new String'(Opt));
+ Flag_Expect_Failure := True;
+ Res := Option_Ok;
+ elsif Opt = "-C" then
+ -- Translate -C into --mb-comments, as gcc already has a definition
+ -- for -C. Done before Flags.Parse_Option.
+ Add_Argument (Compiler_Args, new String'("--mb-comments"));
+ Res := Option_Ok;
+ elsif Options.Parse_Option (Opt) then
+ Add_Argument (Compiler_Args, new String'(Opt));
+ Res := Option_Ok;
+ elsif Opt'Length >= 2
+ and then (Opt (2) = 'O' or Opt (2) = 'f')
+ then
+ -- Optimization option.
+ -- This is put after Flags.Parse_Option, since it may catch -fxxx
+ -- options.
+ Add_Argument (Compiler_Args, new String'(Opt));
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Opt, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Comp) is
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Put_Line (" -v Be verbose");
+ Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler");
+ Put_Line (" -S Do not assemble");
+ Put_Line (" -o FILE Set the name of the output file");
+ -- Put_Line (" -m32 Generate 32bit code on 64bit machines");
+ Put_Line (" -WX,OPTION Pass OPTION to X, where X is one of");
+ Put_Line (" c: compiler, a: assembler, l: linker");
+ Put_Line (" -g[XX] Pass debugging option to the compiler");
+ Put_Line (" -O[XX]/-f[XX] Pass optimization option to the compiler");
+ Put_Line (" -Q Do not add -quiet option to compiler");
+ Put_Line (" --expect-failure Expect analysis/elaboration failure");
+ end Disp_Long_Help;
+
+ -- Command dispconfig.
+ type Command_Dispconfig is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String;
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dispconfig; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--dispconfig" or else Name = "--disp-config";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dispconfig) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--disp-config Disp tools path";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dispconfig;
+ Args : Argument_List)
+ is
+ use Libraries;
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("--dispconfig does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Set_Tools_Name;
+ Put_Line ("Pathes at configuration:");
+ Put ("compiler command: ");
+ Put_Line (Compiler_Cmd.all);
+ if Compile_Kind >= Compile_Debug then
+ Put ("post-processor command: ");
+ Put_Line (Post_Processor_Cmd.all);
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Put ("assembler command: ");
+ Put_Line (Assembler_Cmd);
+ end if;
+ Put ("linker command: ");
+ Put_Line (Linker_Cmd);
+ Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix);
+
+ New_Line;
+
+ Put ("command line prefix (--PREFIX): ");
+ if Switch_Prefix_Path = null then
+ Put_Line ("(not set)");
+ else
+ Put_Line (Switch_Prefix_Path.all);
+ end if;
+
+ Put ("environment prefix (GHDL_PREFIX): ");
+ if Prefix_Env = null then
+ Put_Line ("(not set)");
+ else
+ Put_Line (Prefix_Env.all);
+ end if;
+
+ Setup_Libraries (False);
+
+ Put ("exec prefix (from program name): ");
+ if Exec_Prefix = null then
+ Put_Line ("(not found)");
+ else
+ Put_Line (Exec_Prefix.all);
+ end if;
+
+ New_Line;
+
+ Put_Line ("library prefix: " & Lib_Prefix_Path.all);
+ Put ("library directory: ");
+ Put_Line (Get_Machine_Path_Prefix);
+ Locate_Tools;
+ Put ("compiler path: ");
+ Put_Line (Compiler_Path.all);
+ if Compile_Kind >= Compile_Debug then
+ Put ("post-processor path: ");
+ Put_Line (Post_Processor_Path.all);
+ end if;
+ if Compile_Kind >= Compile_Gcc then
+ Put ("assembler path: ");
+ Put_Line (Assembler_Path.all);
+ end if;
+ Put ("linker path: ");
+ Put_Line (Linker_Path.all);
+
+ New_Line;
+
+ Put_Line ("default library pathes:");
+ for I in 2 .. Get_Nbr_Pathes loop
+ Put (' ');
+ Put_Line (Image (Get_Path (I)));
+ end loop;
+ end Perform_Action;
+
+ -- Command Analyze.
+ type Command_Analyze is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Analyze) return String;
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Analyze; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-a";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Analyze) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-a [OPTS] FILEs Analyze FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Analyze;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Nil_Opt : Argument_List (2 .. 1);
+ begin
+ if Args'Length = 0 then
+ Error ("no file to analyze");
+ raise Option_Error;
+ end if;
+ Setup_Compiler (False);
+
+ for I in Args'Range loop
+ Do_Compile (Nil_Opt, Args (I).all);
+ end loop;
+ end Perform_Action;
+
+ -- Elaboration.
+
+ Base_Name : String_Access;
+ Elab_Name : String_Access;
+ Filelist_Name : String_Access;
+ Unit_Name : String_Access;
+
+ procedure Set_Elab_Units (Cmd_Name : String;
+ Args : Argument_List;
+ Run_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Run_Arg);
+ if Sec_Name = null then
+ Base_Name := Prim_Name;
+ Unit_Name := Prim_Name;
+ else
+ Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
+ Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')');
+ end if;
+
+ Elab_Name := new String'(Elab_Prefix & Base_Name.all);
+ Filelist_Name := null;
+
+ if Output_File = null then
+ Output_File := new String'(Base_Name.all);
+ end if;
+ end Set_Elab_Units;
+
+ procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List)
+ is
+ Next_Arg : Natural;
+ begin
+ Set_Elab_Units (Cmd_Name, Args, Next_Arg);
+ if Next_Arg <= Args'Last then
+ Error ("too many unit names for command '" & Cmd_Name & "'");
+ raise Option_Error;
+ end if;
+ end Set_Elab_Units;
+
+ procedure Bind
+ is
+ Comp_List : Argument_List (1 .. 4);
+ begin
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+
+ Comp_List (1) := new String'("--elab");
+ Comp_List (2) := Unit_Name;
+ Comp_List (3) := new String'("-l");
+ Comp_List (4) := Filelist_Name;
+ Do_Compile (Comp_List, Elab_Name.all);
+ Free (Comp_List (3));
+ Free (Comp_List (1));
+ end Bind;
+
+ procedure Bind_Anaelab (Files : Argument_List)
+ is
+ Comp_List : Argument_List (1 .. Files'Length + 2);
+ Index : Natural;
+ begin
+ Comp_List (1) := new String'("--anaelab");
+ Comp_List (2) := Unit_Name;
+ Index := 3;
+ for I in Files'Range loop
+ Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all);
+ Index := Index + 1;
+ end loop;
+ Do_Compile (Comp_List, Elab_Name.all);
+ Free (Comp_List (1));
+ for I in 3 .. Comp_List'Last loop
+ Free (Comp_List (I));
+ end loop;
+ end Bind_Anaelab;
+
+ procedure Link (Add_Std : Boolean;
+ Disp_Only : Boolean)
+ is
+ Last_File : Natural;
+ begin
+ Link_Obj_Suffix := Get_Object_Suffix;
+
+ -- read files list
+ if Filelist_Name /= null then
+ Add_File_List (Filelist_Name.all, True);
+ end if;
+ Last_File := Filelist.Last;
+ Add_File_List (Get_Machine_Path_Prefix & "grt" & List_Suffix, False);
+
+ -- call the linker
+ declare
+ P : Natural;
+ Nbr_Args : constant Natural := Last (Linker_Args) + Filelist.Last + 4;
+ Args : Argument_List (1 .. Nbr_Args);
+ Obj_File : String_Access;
+ Std_File : String_Access;
+ begin
+ Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all);
+ P := 0;
+ Args (P + 1) := Dash_o;
+ Args (P + 2) := Output_File;
+ Args (P + 3) := Obj_File;
+ P := P + 3;
+ if Add_Std then
+ Std_File := new
+ String'(Get_Machine_Path_Prefix
+ & Get_Version_Path & Directory_Separator
+ & "std" & Directory_Separator
+ & "std_standard" & Link_Obj_Suffix.all);
+ P := P + 1;
+ Args (P) := Std_File;
+ else
+ Std_File := null;
+ end if;
+
+ -- Object files of the design.
+ for I in Filelist.First .. Last_File loop
+ P := P + 1;
+ Args (P) := Filelist.Table (I);
+ end loop;
+ -- User added options.
+ for I in First .. Last (Linker_Args) loop
+ P := P + 1;
+ Args (P) := Linker_Args.Table (I);
+ end loop;
+ -- GRT files (should be the last one, since it contains an
+ -- optional main).
+ for I in Last_File + 1 .. Filelist.Last loop
+ P := P + 1;
+ Args (P) := Filelist.Table (I);
+ end loop;
+
+ if Disp_Only then
+ for I in 3 .. P loop
+ Put_Line (Args (I).all);
+ end loop;
+ else
+ My_Spawn (Linker_Path.all, Args (1 .. P));
+ end if;
+
+ Free (Obj_File);
+ Free (Std_File);
+ end;
+
+ for I in Filelist.First .. Filelist.Last loop
+ Free (Filelist.Table (I));
+ end loop;
+ end Link;
+
+ -- Command Elab.
+ type Command_Elab is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab) return String;
+ procedure Perform_Action (Cmd : in out Command_Elab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-e";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-e [OPTS] UNIT [ARCH] Elaborate UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Success : Boolean;
+ pragma Unreferenced (Success);
+ begin
+ Set_Elab_Units ("-e", Args);
+ Setup_Compiler (False);
+
+ Bind;
+ if not Flag_Expect_Failure then
+ Link (Add_Std => True, Disp_Only => False);
+ end if;
+ Delete_File (Filelist_Name.all, Success);
+ end Perform_Action;
+
+ -- Command Run.
+ type Command_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run) return String;
+ procedure Perform_Action (Cmd : in out Command_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-r";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-r UNIT [ARCH] [OPTS] Run UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Opt_Arg : Natural;
+ begin
+ Extract_Elab_Unit ("-r", Args, Opt_Arg);
+ if Sec_Name = null then
+ Base_Name := Prim_Name;
+ else
+ Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all);
+ end if;
+ if not Is_Regular_File (Base_Name.all & Nul) then
+ Error ("file '" & Base_Name.all & "' does not exists");
+ Error ("Please elaborate your design.");
+ raise Exec_Error;
+ end if;
+ My_Spawn ('.' & Directory_Separator & Base_Name.all,
+ Args (Opt_Arg .. Args'Last));
+ end Perform_Action;
+
+ -- Command Elab_Run.
+ type Command_Elab_Run is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Elab_Run; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Elab_Run) return String;
+ procedure Perform_Action (Cmd : in out Command_Elab_Run;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Elab_Run; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--elab-run";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Elab_Run) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--elab-run [OPTS] UNIT [ARCH] [OPTS] Elaborate and run UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Elab_Run;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Success : Boolean;
+ Run_Arg : Natural;
+ begin
+ Set_Elab_Units ("-elab-run", Args, Run_Arg);
+ Setup_Compiler (False);
+
+ Bind;
+ if Flag_Expect_Failure then
+ Delete_File (Filelist_Name.all, Success);
+ else
+ Link (Add_Std => True, Disp_Only => False);
+ Delete_File (Filelist_Name.all, Success);
+ My_Spawn ('.' & Directory_Separator & Output_File.all,
+ Args (Run_Arg .. Args'Last));
+ end if;
+ end Perform_Action;
+
+ -- Command Bind.
+ type Command_Bind is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Bind; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Bind) return String;
+ procedure Perform_Action (Cmd : in out Command_Bind;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Bind; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--bind";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Bind) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--bind [OPTS] UNIT [ARCH] Bind UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--bind", Args);
+ Setup_Compiler (False);
+
+ Bind;
+ end Perform_Action;
+
+ -- Command Link.
+ type Command_Link is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Link; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Link) return String;
+ procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Link; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--link";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Link) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--link [OPTS] UNIT [ARCH] Link UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--link", Args);
+ Setup_Compiler (False);
+
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+ Link (Add_Std => True, Disp_Only => False);
+ end Perform_Action;
+
+
+ -- Command List_Link.
+ type Command_List_Link is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_List_Link; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_List_Link) return String;
+ procedure Perform_Action (Cmd : in out Command_List_Link;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_List_Link; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--list-link";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_List_Link) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--list-link [OPTS] UNIT [ARCH] List objects file to link UNIT";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_List_Link;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Set_Elab_Units ("--list-link", Args);
+ Setup_Compiler (False);
+
+ Filelist_Name := new String'(Elab_Name.all & List_Suffix);
+ Link (Add_Std => True, Disp_Only => True);
+ end Perform_Action;
+
+
+ -- Command analyze and elaborate
+ type Command_Anaelab is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Anaelab; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Anaelab) return String;
+ procedure Decode_Option (Cmd : in out Command_Anaelab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Perform_Action (Cmd : in out Command_Anaelab;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Anaelab; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-c";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Anaelab) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-c [OPTS] FILEs -e UNIT [ARCH] "
+ & "Generate whole code to elab UNIT from FILEs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Anaelab;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-e" then
+ Res := Option_End;
+ return;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Anaelab;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Elab_Index : Integer;
+ begin
+ Elab_Index := -1;
+ for I in Args'Range loop
+ if Args (I).all = "-e" then
+ Elab_Index := I;
+ exit;
+ end if;
+ end loop;
+ if Elab_Index < 0 then
+ Analyze_Files (Args, True);
+ else
+ Flags.Flag_Whole_Analyze := True;
+ Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last));
+ Setup_Compiler (False);
+
+ Bind_Anaelab (Args (Args'First .. Elab_Index - 1));
+ Link (Add_Std => False, Disp_Only => False);
+ end if;
+ end Perform_Action;
+
+ -- Command Make.
+ type Command_Make is new Command_Comp with record
+ -- Disp dependences during make.
+ Flag_Depend_Unit : Boolean;
+
+ -- Force recompilation of units in work library.
+ Flag_Force : Boolean;
+ end record;
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean;
+ procedure Init (Cmd : in out Command_Make);
+ procedure Decode_Option (Cmd : in out Command_Make;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ function Get_Short_Help (Cmd : Command_Make) return String;
+ procedure Disp_Long_Help (Cmd : Command_Make);
+
+ procedure Perform_Action (Cmd : in out Command_Make;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Make; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-m";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Make) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-m [OPTS] UNIT [ARCH] Make UNIT";
+ end Get_Short_Help;
+
+ procedure Disp_Long_Help (Cmd : Command_Make)
+ is
+ begin
+ Disp_Long_Help (Command_Comp (Cmd));
+ Put_Line (" -f Force recompilation of work units");
+ Put_Line (" -Mu Disp unit dependences (human format)");
+ end Disp_Long_Help;
+
+ procedure Init (Cmd : in out Command_Make) is
+ begin
+ Init (Command_Comp (Cmd));
+ Cmd.Flag_Depend_Unit := False;
+ Cmd.Flag_Force := False;
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Make;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res) is
+ begin
+ if Option = "-Mu" then
+ Cmd.Flag_Depend_Unit := True;
+ Res := Option_Ok;
+ elsif Option = "-f" then
+ Cmd.Flag_Force := True;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Comp (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List)
+ is
+ use Configuration;
+
+ File : Iir_Design_File;
+ Unit : Iir;
+ Lib_Unit : Iir;
+ Lib : Iir_Library_Declaration;
+ In_Work : Boolean;
+
+ Files_List : Iir_List;
+
+ -- Set when a design file has been compiled.
+ Has_Compiled : Boolean;
+
+ Need_Analyze : Boolean;
+
+ Need_Elaboration : Boolean;
+
+ Stamp : Time_Stamp_Id;
+ File_Id : Name_Id;
+
+ Nil_Args : Argument_List (2 .. 1);
+ Success : Boolean;
+ begin
+ Set_Elab_Units ("-m", Args);
+ Setup_Compiler (True);
+
+ -- Create list of files.
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ if Cmd.Flag_Depend_Unit then
+ Put_Line ("Units analysis order:");
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Put (" ");
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+-- Put (" file: ");
+-- File := Get_Design_File (Unit);
+-- Image (Get_Design_File_Filename (File));
+-- Put_Line (Name_Buffer (1 .. Name_Length));
+ end loop;
+ end if;
+ if Cmd.Flag_Depend_Unit then
+ Put_Line ("File analysis order:");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Image (Get_Design_File_Filename (File));
+ Put (" ");
+ Put (Name_Buffer (1 .. Name_Length));
+ if Flag_Verbose then
+ Put_Line (":");
+ declare
+ Dep_List : Iir_List;
+ Dep_File : Iir;
+ begin
+ Dep_List := Get_File_Dependence_List (File);
+ if Dep_List /= Null_Iir_List then
+ for J in Natural loop
+ Dep_File := Get_Nth_Element (Dep_List, J);
+ exit when Dep_File = Null_Iir;
+ Image (Get_Design_File_Filename (Dep_File));
+ Put (" ");
+ Put_Line (Name_Buffer (1 .. Name_Length));
+ end loop;
+ end if;
+ end;
+ else
+ New_Line;
+ end if;
+ end loop;
+ end if;
+
+ Has_Compiled := False;
+ Last_Stamp := Null_Time_Stamp;
+
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+
+ Need_Analyze := False;
+ if Is_File_Outdated (File) then
+ Need_Analyze := True;
+ else
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Lib_Unit := Get_Library_Unit (Unit);
+ if not (Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration
+ and then Get_Identifier (Lib_Unit) = Null_Identifier)
+ then
+ if Is_Unit_Outdated (Unit) then
+ Need_Analyze := True;
+ exit;
+ end if;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+
+ Lib := Get_Library (File);
+ In_Work := Lib = Libraries.Work_Library;
+
+ if Need_Analyze or else (Cmd.Flag_Force and In_Work) then
+ File_Id := Get_Design_File_Filename (File);
+ if not Flag_Verbose then
+ Put ("analyze ");
+ Put (Image (File_Id));
+ --Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+
+ if In_Work then
+ Do_Compile (Nil_Args, Image (File_Id));
+ else
+ declare
+ use Libraries;
+ Lib_Args : Argument_List (1 .. 2);
+ Prev_Workdir : Name_Id;
+ begin
+ Prev_Workdir := Work_Directory;
+
+ -- Must be set, since used to build the object filename.
+ Work_Directory := Get_Library_Directory (Lib);
+
+ -- Always overwrite --work and --workdir.
+ Lib_Args (1) := new String'
+ ("--work=" & Image (Get_Identifier (Lib)));
+ if Work_Directory = Libraries.Local_Directory then
+ Lib_Args (2) := new String'("--workdir=.");
+ else
+ Lib_Args (2) := new String'
+ ("--workdir=" & Image (Work_Directory));
+ end if;
+ Do_Compile (Lib_Args, Image (File_Id));
+
+ Work_Directory := Prev_Workdir;
+
+ Free (Lib_Args (1));
+ Free (Lib_Args (2));
+ end;
+ end if;
+
+ Has_Compiled := True;
+ -- Set the analysis time stamp since the file has just been
+ -- analyzed.
+ Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp);
+ end if;
+ end loop;
+
+ Need_Elaboration := False;
+ -- Elaboration.
+ -- if libgrt is more recent than the executable (FIXME).
+ if Has_Compiled then
+ if Flag_Verbose then
+ Put_Line ("link due to a file compilation");
+ end if;
+ Need_Elaboration := True;
+ else
+ declare
+ Exec_File : String := Output_File.all & Nul;
+ begin
+ Stamp := Files_Map.Get_File_Time_Stamp (Exec_File'Address);
+ end;
+
+ if Stamp = Null_Time_Stamp then
+ if Flag_Verbose then
+ Put_Line ("link due to no binary file");
+ end if;
+ Need_Elaboration := True;
+ else
+ if Files_Map.Is_Gt (Last_Stamp, Stamp) then
+ -- if a file is more recent than the executable.
+ if Flag_Verbose then
+ Put ("link due to outdated binary file: ");
+ Put (Image (Get_Design_File_Filename (Last_Stamp_File)));
+ Put (" (");
+ Put (Files_Map.Get_Time_Stamp_String (Last_Stamp));
+ Put (" > ");
+ Put (Files_Map.Get_Time_Stamp_String (Stamp));
+ Put (")");
+ New_Line;
+ end if;
+ Need_Elaboration := True;
+ end if;
+ end if;
+ end if;
+ if Need_Elaboration then
+ if not Flag_Verbose then
+ Put ("elaborate ");
+ Put (Prim_Name.all);
+ --Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+ Bind;
+ Link (Add_Std => True, Disp_Only => False);
+ Delete_File (Filelist_Name.all, Success);
+ end if;
+ exception
+ when Errorout.Compilation_Error =>
+ if Flag_Expect_Failure then
+ return;
+ else
+ raise;
+ end if;
+ end Perform_Action;
+
+ -- Command Gen_Makefile.
+ type Command_Gen_Makefile is new Command_Comp with null record;
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String;
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Gen_Makefile; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--gen-makefile";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Gen_Makefile) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT";
+ end Get_Short_Help;
+
+ function Is_Makeable_File (File : Iir_Design_File) return Boolean is
+ begin
+ if File = Std_Package.Std_Standard_File then
+ return False;
+ end if;
+ return True;
+ end Is_Makeable_File;
+
+ procedure Perform_Action (Cmd : in out Command_Gen_Makefile;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ HT : constant Character := Ada.Characters.Latin_1.HT;
+ Files_List : Iir_List;
+ File : Iir_Design_File;
+
+ Lib : Iir_Library_Declaration;
+ Dir_Id : Name_Id;
+
+ Dep_List : Iir_List;
+ Dep_File : Iir;
+ begin
+ Set_Elab_Units ("--gen-makefile", Args);
+ Setup_Libraries (True);
+ Files_List := Build_Dependence (Prim_Name, Sec_Name);
+
+ Put_Line ("# Makefile automatically generated by ghdl");
+ Put ("# Version: ");
+ Put (Version.Ghdl_Release);
+ Put (" - ");
+ if Version_String /= null then
+ Put (Version_String.all);
+ end if;
+ New_Line;
+ Put_Line ("# Command used to generate this makefile:");
+ Put ("# ");
+ Put (Command_Name);
+ for I in 1 .. Argument_Count loop
+ Put (' ');
+ Put (Argument (I));
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put ("GHDL=");
+ Put_Line (Command_Name);
+
+ -- Extract options for command line.
+ Put ("GHDLFLAGS=");
+ for I in 2 .. Argument_Count loop
+ declare
+ Arg : constant String := Argument (I);
+ begin
+ if Arg (1) = '-' then
+ if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=")
+ or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=")
+ or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=")
+ or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P")
+ then
+ Put (" ");
+ Put (Arg);
+ end if;
+ end if;
+ end;
+ end loop;
+ New_Line;
+
+ New_Line;
+
+ Put_Line ("# Default target");
+ Put ("all: ");
+ Put_Line (Base_Name.all);
+ New_Line;
+
+ Put_Line ("# Elaboration target");
+ Put (Base_Name.all);
+ Put (":");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ if Is_Makeable_File (File) then
+ Put (" ");
+ Put (Get_Object_Filename (File));
+ end if;
+ end loop;
+ New_Line;
+ Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@");
+ New_Line;
+
+ Put_Line ("# Run target");
+ Put_Line ("run: " & Base_Name.all);
+ Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)");
+ New_Line;
+
+ Put_Line ("# Targets to analyze files");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ Dir_Id := Get_Design_File_Directory (File);
+ if not Is_Makeable_File (File) then
+ -- Builtin file.
+ null;
+ else
+ Put (Get_Object_Filename (File));
+ Put (": ");
+ if Dir_Id /= Files_Map.Get_Home_Directory then
+ Put (Image (Dir_Id));
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+
+ Put_Line
+ (HT & "@echo ""This file was not locally built ($<)""");
+ Put_Line (HT & "exit 1");
+ else
+ Put (Image (Get_Design_File_Filename (File)));
+ New_Line;
+
+ Put (HT & "$(GHDL) -a $(GHDLFLAGS)");
+ Lib := Get_Library (File);
+ if Lib /= Libraries.Work_Library then
+ -- Overwrite some options.
+ Put (" --work=");
+ Put (Image (Get_Identifier (Lib)));
+ Dir_Id := Get_Library_Directory (Lib);
+ Put (" --workdir=");
+ if Dir_Id = Libraries.Local_Directory then
+ Put (".");
+ else
+ Put (Image (Dir_Id));
+ end if;
+ end if;
+ Put_Line (" $<");
+ end if;
+ end if;
+ end loop;
+ New_Line;
+
+ Put_Line ("# Files dependences");
+ for I in Natural loop
+ File := Get_Nth_Element (Files_List, I);
+ exit when File = Null_Iir;
+ if Is_Makeable_File (File) then
+ Put (Get_Object_Filename (File));
+ Put (": ");
+ Dep_List := Get_File_Dependence_List (File);
+ if Dep_List /= Null_Iir_List then
+ for J in Natural loop
+ Dep_File := Get_Nth_Element (Dep_List, J);
+ exit when Dep_File = Null_Iir;
+ if Dep_File /= File and then Is_Makeable_File (Dep_File)
+ then
+ Put (" ");
+ Put (Get_Object_Filename (Dep_File));
+ end if;
+ end loop;
+ end if;
+ New_Line;
+ end if;
+ end loop;
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Analyze);
+ Register_Command (new Command_Elab);
+ Register_Command (new Command_Run);
+ Register_Command (new Command_Elab_Run);
+ Register_Command (new Command_Bind);
+ Register_Command (new Command_Link);
+ Register_Command (new Command_List_Link);
+ Register_Command (new Command_Anaelab);
+ Register_Command (new Command_Make);
+ Register_Command (new Command_Gen_Makefile);
+ Register_Command (new Command_Dispconfig);
+ end Register_Commands;
+end Ghdldrv;
diff --git a/src/translate/ghdldrv/ghdldrv.ads b/src/translate/ghdldrv/ghdldrv.ads
new file mode 100644
index 000000000..3e37b38f1
--- /dev/null
+++ b/src/translate/ghdldrv/ghdldrv.ads
@@ -0,0 +1,25 @@
+-- GHDL driver - commands invoking gcc.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdldrv is
+ -- Compiler to use.
+ type Compile_Kind_Type is
+ (Compile_Mcode, Compile_Llvm, Compile_Gcc, Compile_Debug);
+ Compile_Kind : Compile_Kind_Type := Compile_Gcc;
+
+ procedure Register_Commands;
+end Ghdldrv;
diff --git a/src/translate/ghdldrv/ghdllocal.adb b/src/translate/ghdldrv/ghdllocal.adb
new file mode 100644
index 000000000..a1d94bd77
--- /dev/null
+++ b/src/translate/ghdldrv/ghdllocal.adb
@@ -0,0 +1,1415 @@
+-- GHDL driver - local commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.Directory_Operations;
+with Types; use Types;
+with Libraries;
+with Std_Package;
+with Flags;
+with Name_Table;
+with Std_Names;
+with Back_End;
+with Disp_Vhdl;
+with Default_Pathes;
+with Scanner;
+with Sem;
+with Canon;
+with Errorout;
+with Configuration;
+with Files_Map;
+with Post_Sems;
+with Disp_Tree;
+with Options;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Ghdllocal is
+ -- Version of the IEEE library to use. This just change pathes.
+ type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor);
+ Flag_Ieee : Ieee_Lib_Kind;
+
+ Flag_Create_Default_Config : constant Boolean := True;
+
+ -- If TRUE, generate 32bits code on 64bits machines.
+ Flag_32bit : Boolean := False;
+
+ procedure Finish_Compilation
+ (Unit : Iir_Design_Unit; Main : Boolean := False)
+ is
+ use Errorout;
+ use Ada.Text_IO;
+ Config : Iir_Design_Unit;
+ Lib : Iir;
+ begin
+ if (Main or Flags.Dump_All) and then Flags.Dump_Parse then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Flags.Verbose then
+ Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit)));
+ end if;
+
+ Sem.Semantic (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Sem then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Sem then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ Post_Sems.Post_Sem_Checks (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if Flags.Flag_Elaborate then
+ if Flags.Verbose then
+ Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit)));
+ end if;
+
+ Canon.Canonicalize (Unit);
+
+ if Flag_Create_Default_Config then
+ Lib := Get_Library_Unit (Unit);
+ if Get_Kind (Lib) = Iir_Kind_Architecture_Body then
+ Config := Canon.Create_Default_Configuration_Declaration (Lib);
+ Set_Default_Configuration_Declaration (Lib, Config);
+ end if;
+ end if;
+ end if;
+ end Finish_Compilation;
+
+ procedure Init (Cmd : in out Command_Lib)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Options.Initialize;
+ Flag_Ieee := Lib_Standard;
+ Back_End.Finish_Compilation := Finish_Compilation'Access;
+ Flag_Verbose := False;
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Lib;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ pragma Unreferenced (Cmd);
+ pragma Unreferenced (Arg);
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ Res := Option_Bad;
+ if Opt = "-v" and then Flag_Verbose = False then
+ Flag_Verbose := True;
+ Res := Option_Ok;
+ elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then
+ Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last));
+ Res := Option_Ok;
+ elsif Opt = "--ieee=synopsys" then
+ Flag_Ieee := Lib_Synopsys;
+ Res := Option_Ok;
+ elsif Opt = "--ieee=mentor" then
+ Flag_Ieee := Lib_Mentor;
+ Res := Option_Ok;
+ elsif Opt = "--ieee=none" then
+ Flag_Ieee := Lib_None;
+ Res := Option_Ok;
+ elsif Opt = "--ieee=standard" then
+ Flag_Ieee := Lib_Standard;
+ Res := Option_Ok;
+ elsif Opt = "-m32" then
+ Flag_32bit := True;
+ Res := Option_Ok;
+ elsif Opt'Length >= 2
+ and then (Opt (2) = 'g' or Opt (2) = 'O')
+ then
+ -- Silently accept -g and -O.
+ Res := Option_Ok;
+ else
+ if Options.Parse_Option (Opt) then
+ Res := Option_Ok;
+ end if;
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Lib)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P ("Main options (try --options-help for details):");
+ P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)");
+ P (" --work=NAME Set the name of the WORK library");
+ P (" -PDIR Add DIR in the library search path");
+ P (" --workdir=DIR Specify the directory of the WORK library");
+ P (" --PREFIX=DIR Specify installation prefix");
+ P (" --ieee=NAME Use NAME as ieee library, where name is:");
+ P (" standard: standard version (default)");
+ P (" synopsys, mentor: vendor version (not advised)");
+ P (" none: do not use a predefined ieee library");
+ end Disp_Long_Help;
+
+ function Is_Directory_Separator (C : Character) return Boolean is
+ begin
+ return C = '/' or else C = Directory_Separator;
+ end Is_Directory_Separator;
+
+ function Get_Basename_Pos (Pathname : String) return Natural is
+ begin
+ for I in reverse Pathname'Range loop
+ if Is_Directory_Separator (Pathname (I)) then
+ return I;
+ end if;
+ end loop;
+ return 0;
+ end Get_Basename_Pos;
+
+ procedure Set_Prefix_From_Program_Path (Prog_Path : String)
+ is
+ Dir_Pos : Natural;
+ begin
+ Dir_Pos := Get_Basename_Pos (Prog_Path);
+ if Dir_Pos = 0 then
+ -- No directory in Prog_Path. This is not expected.
+ return;
+ end if;
+
+ declare
+ Pathname : String :=
+ Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last),
+ Prog_Path (Prog_Path'First .. Dir_Pos - 1));
+ Pos : Natural;
+ begin
+ -- Stop now in case of error.
+ if Pathname'Length = 0 then
+ return;
+ end if;
+
+ -- Skip executable name
+ Dir_Pos := Get_Basename_Pos (Pathname);
+ if Dir_Pos = 0 then
+ return;
+ end if;
+
+ -- Simplify path:
+ -- /./ => /
+ -- // => /
+ Pos := Dir_Pos - 1;
+ while Pos >= Pathname'First loop
+ if Is_Directory_Separator (Pathname (Pos)) then
+ if Is_Directory_Separator (Pathname (Pos + 1)) then
+ -- // => /
+ Pathname (Pos .. Dir_Pos - 1) :=
+ Pathname (Pos + 1 .. Dir_Pos);
+ Dir_Pos := Dir_Pos - 1;
+ elsif Pos + 2 <= Dir_Pos
+ and then Pathname (Pos + 1) = '.'
+ and then Is_Directory_Separator (Pathname (Pos + 2))
+ then
+ -- /./ => /
+ Pathname (Pos .. Dir_Pos - 2) :=
+ Pathname (Pos + 2 .. Dir_Pos);
+ Dir_Pos := Dir_Pos - 2;
+ end if;
+ end if;
+ Pos := Pos - 1;
+ end loop;
+
+ -- Simplify path:
+ -- /xxx/../ => /
+ -- This is done after the previous simplication to avoid to deal
+ -- with cases like /xxx//../ or /xxx/./../
+ Pos := Dir_Pos - 3;
+ while Pos >= Pathname'First loop
+ if Is_Directory_Separator (Pathname (Pos))
+ and then Pathname (Pos + 1) = '.'
+ and then Pathname (Pos + 2) = '.'
+ and then Is_Directory_Separator (Pathname (Pos + 3))
+ then
+ declare
+ Pos2 : constant Natural :=
+ Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1));
+ -- /xxxxxxxxxx/../
+ -- ^ ^
+ -- Pos2 Pos
+ Len : Natural;
+ begin
+ if Pos2 = 0 then
+ -- Shouldn't happen.
+ return;
+ end if;
+ Len := Pos + 3 - Pos2;
+ Pathname (Pos2 + 1 .. Dir_Pos - Len) :=
+ Pathname (Pos + 4 .. Dir_Pos);
+ Dir_Pos := Dir_Pos - Len;
+ if Pos2 < Pathname'First + 3 then
+ exit;
+ end if;
+ Pos := Pos2 - 3;
+ end;
+ else
+ Pos := Pos - 1;
+ end if;
+ end loop;
+
+ -- Remove last '/'
+ Dir_Pos := Dir_Pos - 1;
+
+ -- Skip directory.
+ Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos));
+ if Dir_Pos = 0 then
+ return;
+ end if;
+
+ Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1));
+ end;
+ end Set_Prefix_From_Program_Path;
+
+ -- Extract Exec_Prefix from executable name.
+ procedure Set_Exec_Prefix
+ is
+ use GNAT.Directory_Operations;
+ Prog_Path : constant String := Ada.Command_Line.Command_Name;
+ Exec_Path : String_Access;
+ begin
+ -- If the command name is an absolute path, deduce prefix from it.
+ if Is_Absolute_Path (Prog_Path) then
+ Set_Prefix_From_Program_Path (Prog_Path);
+ return;
+ end if;
+
+ -- If the command name is a relative path, deduce prefix from it
+ -- and current path.
+ if Get_Basename_Pos (Prog_Path) /= 0 then
+ if Is_Executable_File (Prog_Path) then
+ Set_Prefix_From_Program_Path
+ (Get_Current_Dir & Directory_Separator & Prog_Path);
+ end if;
+ return;
+ end if;
+
+ -- Look for program name on the path.
+ Exec_Path := Locate_Exec_On_Path (Prog_Path);
+ if Exec_Path /= null then
+ Set_Prefix_From_Program_Path (Exec_Path.all);
+ Free (Exec_Path);
+ end if;
+ end Set_Exec_Prefix;
+
+ function Get_Version_Path return String
+ is
+ use Flags;
+ begin
+ case Vhdl_Std is
+ when Vhdl_87 =>
+ return "v87";
+ when Vhdl_93c
+ | Vhdl_93
+ | Vhdl_00
+ | Vhdl_02 =>
+ return "v93";
+ when Vhdl_08 =>
+ return "v08";
+ end case;
+ end Get_Version_Path;
+
+ function Get_Machine_Path_Prefix return String is
+ begin
+ if Flag_32bit then
+ return Lib_Prefix_Path.all & "32";
+ else
+ return Lib_Prefix_Path.all;
+ end if;
+ end Get_Machine_Path_Prefix;
+
+ procedure Add_Library_Path (Name : String)
+ is
+ begin
+ Libraries.Add_Library_Path
+ (Get_Machine_Path_Prefix & Directory_Separator
+ & Get_Version_Path & Directory_Separator
+ & Name & Directory_Separator);
+ end Add_Library_Path;
+
+ procedure Setup_Libraries (Load : Boolean)
+ is
+ begin
+ -- Get environment variable.
+ Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX");
+ if Prefix_Env = null or else Prefix_Env.all = "" then
+ Prefix_Env := null;
+ end if;
+
+ -- Compute Exec_Prefix.
+ Set_Exec_Prefix;
+
+ -- Set prefix path.
+ -- If not set by command line, try environment variable.
+ if Switch_Prefix_Path /= null then
+ Lib_Prefix_Path := Switch_Prefix_Path;
+ else
+ Lib_Prefix_Path := Prefix_Env;
+ end if;
+ -- Else try default path.
+ if Lib_Prefix_Path = null then
+ if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then
+ Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix);
+ else
+ if Exec_Prefix /= null then
+ Lib_Prefix_Path := new
+ String'(Exec_Prefix.all & Directory_Separator
+ & Default_Pathes.Lib_Prefix);
+ end if;
+ if Lib_Prefix_Path = null
+ or else not Is_Directory (Lib_Prefix_Path.all)
+ then
+ Free (Lib_Prefix_Path);
+ Lib_Prefix_Path := new
+ String'(Default_Pathes.Install_Prefix
+ & Directory_Separator
+ & Default_Pathes.Lib_Prefix);
+ end if;
+ end if;
+ else
+ -- Assume the user has set the correct path, so do not insert 32.
+ Flag_32bit := False;
+ end if;
+
+ -- Add pathes for predefined libraries.
+ if not Flags.Bootstrap then
+ Add_Library_Path ("std");
+ case Flag_Ieee is
+ when Lib_Standard =>
+ Add_Library_Path ("ieee");
+ when Lib_Synopsys =>
+ Add_Library_Path ("synopsys");
+ when Lib_Mentor =>
+ Add_Library_Path ("mentor");
+ when Lib_None =>
+ null;
+ end case;
+ end if;
+ if Load then
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+ end if;
+ end Setup_Libraries;
+
+ procedure Disp_Library_Unit (Unit : Iir)
+ is
+ use Ada.Text_IO;
+ use Name_Table;
+ Id : Name_Id;
+ begin
+ Id := Get_Identifier (Unit);
+ case Get_Kind (Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ Put ("entity ");
+ when Iir_Kind_Architecture_Body =>
+ Put ("architecture ");
+ when Iir_Kind_Configuration_Declaration =>
+ Put ("configuration ");
+ when Iir_Kind_Package_Declaration =>
+ Put ("package ");
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Put ("package instance ");
+ when Iir_Kind_Package_Body =>
+ Put ("package body ");
+ when others =>
+ Put ("???");
+ return;
+ end case;
+ Image (Id);
+ Put (Name_Buffer (1 .. Name_Length));
+ case Get_Kind (Unit) is
+ when Iir_Kind_Architecture_Body =>
+ Put (" of ");
+ Image (Get_Entity_Identifier_Of_Architecture (Unit));
+ Put (Name_Buffer (1 .. Name_Length));
+ when Iir_Kind_Configuration_Declaration =>
+ if Id = Null_Identifier then
+ Put ("<default> of entity ");
+ Image (Get_Entity_Identifier_Of_Architecture (Unit));
+ Put (Name_Buffer (1 .. Name_Length));
+ end if;
+ when others =>
+ null;
+ end case;
+ end Disp_Library_Unit;
+
+ procedure Disp_Library (Name : Name_Id)
+ is
+ use Ada.Text_IO;
+ use Libraries;
+ Lib : Iir_Library_Declaration;
+ File : Iir_Design_File;
+ Unit : Iir;
+ begin
+ if Name = Std_Names.Name_Work then
+ Lib := Work_Library;
+ elsif Name = Std_Names.Name_Std then
+ Lib := Std_Library;
+ else
+ Lib := Get_Library (Name, Command_Line_Location);
+ end if;
+
+ -- Disp contents of files.
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Disp_Library;
+
+ -- Return FILENAME without the extension.
+ function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True)
+ return String
+ is
+ First : Natural;
+ Last : Natural;
+ begin
+ First := Filename'First;
+ Last := Filename'Last;
+ for I in Filename'Range loop
+ if Filename (I) = '.' then
+ Last := I - 1;
+ elsif Remove_Dir and then Filename (I) = Directory_Separator then
+ First := I + 1;
+ Last := Filename'Last;
+ end if;
+ end loop;
+ return Filename (First .. Last);
+ end Get_Base_Name;
+
+ function Append_Suffix (File : String; Suffix : String) return String_Access
+ is
+ use Name_Table;
+ Basename : constant String := Get_Base_Name (File);
+ begin
+ Image (Libraries.Work_Directory);
+ Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) :=
+ Basename;
+ Name_Length := Name_Length + Basename'Length;
+ Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix;
+ Name_Length := Name_Length + Suffix'Length;
+ return new String'(Name_Buffer (1 .. Name_Length));
+ end Append_Suffix;
+
+
+ -- Command Dir.
+ type Command_Dir is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Dir) return String;
+ procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-d" or else Name = "--dir";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Dir) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-d or --dir Disp contents of the work library";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("command '-d' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Flags.Bootstrap := True;
+ -- Load word library.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ Disp_Library (Std_Names.Name_Work);
+
+-- else
+-- for L in Libs'Range loop
+-- Id := Get_Identifier (Libs (L).all);
+-- Disp_Library (Id);
+-- end loop;
+-- end if;
+ end Perform_Action;
+
+ -- Command Find.
+ type Command_Find is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Find; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Find) return String;
+ procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Find; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-f";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Find) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-f FILEs Disp units in FILES";
+ end Get_Short_Help;
+
+ -- Return TRUE is UNIT can be at the apex of a design hierarchy.
+ function Is_Top_Entity (Unit : Iir) return Boolean
+ is
+ begin
+ if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then
+ return False;
+ end if;
+ if Get_Port_Chain (Unit) /= Null_Iir then
+ return False;
+ end if;
+ if Get_Generic_Chain (Unit) /= Null_Iir then
+ return False;
+ end if;
+ return True;
+ end Is_Top_Entity;
+
+ -- Disp contents design files FILES.
+ procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Ada.Text_IO;
+ use Name_Table;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Lib : Iir;
+ Flag_Add : constant Boolean := False;
+ begin
+ Flags.Bootstrap := True;
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+ Disp_Library_Unit (Lib);
+ if Is_Top_Entity (Lib) then
+ Put (" **");
+ end if;
+ New_Line;
+ if Flag_Add then
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ if Flag_Add then
+ Libraries.Save_Work_Library;
+ end if;
+ end Perform_Action;
+
+ -- Command Import.
+ type Command_Import is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Import; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Import) return String;
+ procedure Perform_Action (Cmd : in out Command_Import;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Import; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-i";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Import) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-i [OPTS] FILEs Import units of FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ Lib : Iir;
+ begin
+ Setup_Libraries (True);
+
+ -- Parse all files.
+ for I in Args'Range loop
+ Id := Name_Table.Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File /= Null_Iir then
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ if Flag_Verbose then
+ Lib := Get_Library_Unit (Unit);
+ Disp_Library_Unit (Lib);
+ if Is_Top_Entity (Lib) then
+ Put (" **");
+ end if;
+ New_Line;
+ end if;
+ Next_Unit := Get_Chain (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ Unit := Next_Unit;
+ end loop;
+ end if;
+ end loop;
+
+ -- Analyze all files.
+ if False then
+ Design_File := Get_Design_File_Chain (Libraries.Work_Library);
+ while Design_File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ case Get_Date (Unit) is
+ when Date_Valid
+ | Date_Analyzed =>
+ null;
+ when Date_Parsed =>
+ Back_End.Finish_Compilation (Unit, False);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+ end if;
+
+ Libraries.Save_Work_Library;
+ exception
+ when Errorout.Compilation_Error =>
+ Error ("importation has failed due to compilation error");
+ raise;
+ end Perform_Action;
+
+ -- Command Check_Syntax.
+ type Command_Check_Syntax is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Check_Syntax) return String;
+ procedure Perform_Action (Cmd : in out Command_Check_Syntax;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Check_Syntax; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-s";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Check_Syntax) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-s [OPTS] FILEs Check syntax of FILEs";
+ end Get_Short_Help;
+
+ procedure Analyze_One_File (File_Name : String)
+ is
+ use Ada.Text_IO;
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Next_Unit : Iir;
+ begin
+ Id := Name_Table.Get_Identifier (File_Name);
+ if Flag_Verbose then
+ Put (File_Name);
+ Put_Line (":");
+ end if;
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Errorout.Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ if Flag_Verbose then
+ Put (' ');
+ Disp_Library_Unit (Get_Library_Unit (Unit));
+ New_Line;
+ end if;
+ -- Sem, canon, annotate a design unit.
+ Back_End.Finish_Compilation (Unit, True);
+
+ Next_Unit := Get_Chain (Unit);
+ if Errorout.Nbr_Errors = 0 then
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Errorout.Compilation_Error;
+ end if;
+ end Analyze_One_File;
+
+ procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is
+ begin
+ Setup_Libraries (True);
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Analyze_One_File (Files (I).all);
+ end loop;
+
+ if Save_Library then
+ Libraries.Save_Work_Library;
+ end if;
+ end Analyze_Files;
+
+ procedure Perform_Action (Cmd : in out Command_Check_Syntax;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ Analyze_Files (Args, False);
+ end Perform_Action;
+
+ -- Command --clean: remove object files.
+ type Command_Clean is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Clean) return String;
+ procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--clean";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Clean) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--clean Remove generated files";
+ end Get_Short_Help;
+
+ procedure Delete (Str : String)
+ is
+ use Ada.Text_IO;
+ Status : Boolean;
+ begin
+ Delete_File (Str'Address, Status);
+ if Flag_Verbose and Status then
+ Put_Line ("delete " & Str (Str'First .. Str'Last - 1));
+ end if;
+ end Delete;
+
+ procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Name_Table;
+
+ procedure Delete_Asm_Obj (Str : String) is
+ begin
+ Delete (Str & Get_Object_Suffix.all & Nul);
+ Delete (Str & Asm_Suffix & Nul);
+ end Delete_Asm_Obj;
+
+ procedure Delete_Top_Unit (Str : String) is
+ begin
+ -- Delete elaboration file
+ Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str);
+
+ -- Delete file list.
+ Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul);
+
+ -- Delete executable.
+ Delete (Str & Nul);
+ end Delete_Top_Unit;
+
+ File : Iir_Design_File;
+ Design_Unit : Iir_Design_Unit;
+ Lib_Unit : Iir;
+ Str : String_Access;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--clean' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Flags.Bootstrap := True;
+ -- Load libraries.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ -- Delete compiled file.
+ Str := Append_Suffix (Image (Get_Design_File_Filename (File)), "");
+ Delete_Asm_Obj (Str.all);
+ Free (Str);
+
+ Design_Unit := Get_First_Design_Unit (File);
+ while Design_Unit /= Null_Iir loop
+ Lib_Unit := Get_Library_Unit (Design_Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration =>
+ Delete_Top_Unit (Image (Get_Identifier (Lib_Unit)));
+ when Iir_Kind_Architecture_Body =>
+ Delete_Top_Unit
+ (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit))
+ & '-'
+ & Image (Get_Identifier (Lib_Unit)));
+ when others =>
+ null;
+ end case;
+ Design_Unit := Get_Chain (Design_Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Perform_Action;
+
+ -- Command --remove: remove object file and library file.
+ type Command_Remove is new Command_Clean with null record;
+ function Decode_Command (Cmd : Command_Remove; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Remove) return String;
+ procedure Perform_Action (Cmd : in out Command_Remove;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--remove";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Remove) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--remove Remove generated files and library file";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List)
+ is
+ use Name_Table;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--remove' does not accept any argument");
+ raise Option_Error;
+ end if;
+ Perform_Action (Command_Clean (Cmd), Args);
+ Delete (Image (Libraries.Work_Directory)
+ & Back_End.Library_To_File_Name (Libraries.Work_Library)
+ & Nul);
+ end Perform_Action;
+
+ -- Command --copy: copy work library to current directory.
+ type Command_Copy is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean;
+ function Get_Short_Help (Cmd : Command_Copy) return String;
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--copy";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Copy) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--copy Copy work library to current directory";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Name_Table;
+ use Libraries;
+
+ File : Iir_Design_File;
+ Dir : Name_Id;
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--copy' does not accept any argument");
+ raise Option_Error;
+ end if;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+ Dir := Work_Directory;
+ Work_Directory := Null_Identifier;
+ Libraries.Load_Work_Library;
+ Work_Directory := Dir;
+
+ Dir := Get_Library_Directory (Libraries.Work_Library);
+ if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then
+ Error ("cannot copy library on itself (use --remove first)");
+ raise Option_Error;
+ end if;
+
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ -- Copy object files (if any).
+ declare
+ Basename : constant String :=
+ Get_Base_Name (Image (Get_Design_File_Filename (File)));
+ Src : String_Access;
+ Dst : String_Access;
+ Success : Boolean;
+ pragma Unreferenced (Success);
+ begin
+ Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all);
+ Dst := new String'(Basename & Get_Object_Suffix.all);
+ Copy_File (Src.all, Dst.all, Success, Overwrite, Full);
+ -- Be silent in case of error.
+ Free (Src);
+ Free (Dst);
+ end;
+ if Get_Design_File_Directory (File) = Name_Nil then
+ Set_Design_File_Directory (File, Dir);
+ end if;
+
+ File := Get_Chain (File);
+ end loop;
+ Libraries.Work_Directory := Name_Nil;
+ Libraries.Save_Work_Library;
+ end Perform_Action;
+
+ -- Command --disp-standard.
+ type Command_Disp_Standard is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Disp_Standard) return String;
+ procedure Perform_Action (Cmd : in out Command_Disp_Standard;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Disp_Standard; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--disp-standard";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Disp_Standard) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--disp-standard Disp std.standard in pseudo-vhdl";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Disp_Standard;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error ("command '--disp-standard' does not accept any argument");
+ raise Option_Error;
+ end if;
+ Flags.Bootstrap := True;
+ Libraries.Load_Std_Library;
+ Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
+ end Perform_Action;
+
+ procedure Load_All_Libraries_And_Files
+ is
+ use Files_Map;
+ use Libraries;
+ use Errorout;
+
+ procedure Extract_Library_Clauses (Unit : Iir_Design_Unit)
+ is
+ Lib1 : Iir_Library_Declaration;
+ pragma Unreferenced (Lib1);
+ Ctxt_Item : Iir;
+ begin
+ -- Extract library clauses.
+ Ctxt_Item := Get_Context_Items (Unit);
+ while Ctxt_Item /= Null_Iir loop
+ if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then
+ Lib1 := Get_Library (Get_Identifier (Ctxt_Item),
+ Get_Location (Ctxt_Item));
+ end if;
+ Ctxt_Item := Get_Chain (Ctxt_Item);
+ end loop;
+ end Extract_Library_Clauses;
+
+ Lib : Iir_Library_Declaration;
+ Fe : Source_File_Entry;
+ File, Next_File : Iir_Design_File;
+ Unit, Next_Unit : Iir_Design_Unit;
+ Design_File : Iir_Design_File;
+
+ Old_Work : Iir_Library_Declaration;
+ begin
+ Lib := Std_Library;
+ Lib := Get_Chain (Lib);
+ Old_Work := Work_Library;
+ while Lib /= Null_Iir loop
+ -- Design units are always put in the work library.
+ Work_Library := Lib;
+
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Next_File := Get_Chain (File);
+ Fe := Load_Source_File (Get_Design_File_Directory (File),
+ Get_Design_File_Filename (File));
+ if Fe = No_Source_File_Entry then
+ -- FIXME: should remove all the design file from the library.
+ null;
+ elsif Is_Eq (Get_File_Time_Stamp (Fe),
+ Get_File_Time_Stamp (File))
+ then
+ -- File has not been modified.
+ -- Extract libraries.
+ -- Note: we can't parse it only, since we need to keep the
+ -- date.
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Load_Parse_Design_Unit (Unit, Null_Iir);
+ Extract_Library_Clauses (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+ else
+ -- File has been modified.
+ -- Parse it.
+ Design_File := Load_File (Fe);
+
+ -- Exit now in case of parse error.
+ if Design_File = Null_Iir
+ or else Nbr_Errors > 0
+ then
+ raise Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Extract_Library_Clauses (Unit);
+
+ Next_Unit := Get_Chain (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Add_Design_Unit_Into_Library (Unit);
+ Unit := Next_Unit;
+ end loop;
+ end if;
+ File := Next_File;
+ end loop;
+ Lib := Get_Chain (Lib);
+ end loop;
+ Work_Library := Old_Work;
+ end Load_All_Libraries_And_Files;
+
+ procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration)
+ is
+ File : Iir_Design_File;
+ Unit : Iir_Design_Unit;
+ begin
+ File := Get_Design_File_Chain (Lib);
+ while File /= Null_Iir loop
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if Get_Elab_Flag (Unit) then
+ raise Internal_Error;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ end Check_No_Elab_Flag;
+
+ function Build_Dependence (Prim : String_Access; Sec : String_Access)
+ return Iir_List
+ is
+ procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List)
+ is
+ El : Iir_Design_File;
+ Depend_List : Iir_List;
+ begin
+ if Get_Elab_Flag (File) then
+ return;
+ end if;
+
+ Set_Elab_Flag (File, True);
+ Depend_List := Get_File_Dependence_List (File);
+ if Depend_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Depend_List, I);
+ exit when El = Null_Iir;
+ Build_Dependence_List (El, List);
+ end loop;
+ end if;
+ Append_Element (List, File);
+ end Build_Dependence_List;
+
+ use Configuration;
+ use Name_Table;
+
+ Top : Iir;
+ Primary_Id : Name_Id;
+ Secondary_Id : Name_Id;
+
+ File : Iir_Design_File;
+ Unit : Iir;
+
+ Files_List : Iir_List;
+ begin
+ Check_No_Elab_Flag (Libraries.Work_Library);
+
+ Primary_Id := Get_Identifier (Prim.all);
+ if Sec /= null then
+ Secondary_Id := Get_Identifier (Sec.all);
+ else
+ Secondary_Id := Null_Identifier;
+ end if;
+
+ if True then
+ Load_All_Libraries_And_Files;
+ else
+ -- Re-parse modified files in order configure could find all design
+ -- units.
+ declare
+ use Files_Map;
+ Fe : Source_File_Entry;
+ Next_File : Iir_Design_File;
+ Design_File : Iir_Design_File;
+ begin
+ File := Get_Design_File_Chain (Libraries.Work_Library);
+ while File /= Null_Iir loop
+ Next_File := Get_Chain (File);
+ Fe := Load_Source_File (Get_Design_File_Directory (File),
+ Get_Design_File_Filename (File));
+ if Fe = No_Source_File_Entry then
+ -- FIXME: should remove all the design file from
+ -- the library.
+ null;
+ else
+ if not Is_Eq (Get_File_Time_Stamp (Fe),
+ Get_File_Time_Stamp (File))
+ then
+ -- FILE has been modified.
+ Design_File := Libraries.Load_File (Fe);
+ if Design_File /= Null_Iir then
+ Libraries.Add_Design_File_Into_Library (Design_File);
+ end if;
+ end if;
+ end if;
+ File := Next_File;
+ end loop;
+ end;
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Flags.Flag_Elaborate_With_Outdated := True;
+ Flag_Load_All_Design_Units := True;
+ Flag_Build_File_Dependence := True;
+
+ Top := Configure (Primary_Id, Secondary_Id);
+ if Top = Null_Iir then
+ --Error ("cannot find primary unit " & Prim.all);
+ raise Option_Error;
+ end if;
+
+ -- Add unused design units.
+ declare
+ N : Natural;
+ begin
+ N := Design_Units.First;
+ while N <= Design_Units.Last loop
+ Unit := Design_Units.Table (N);
+ N := N + 1;
+ File := Get_Design_File (Unit);
+ if not Get_Elab_Flag (File) then
+ Set_Elab_Flag (File, True);
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if not Get_Elab_Flag (Unit) then
+ Add_Design_Unit (Unit, Null_Iir);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end if;
+ end loop;
+ end;
+
+ -- Clear elab flag on design files.
+ for I in reverse Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ File := Get_Design_File (Unit);
+ Set_Elab_Flag (File, False);
+ end loop;
+
+ -- Create a list of files, from the last to the first.
+ Files_List := Create_Iir_List;
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ File := Get_Design_File (Unit);
+ Build_Dependence_List (File, Files_List);
+ end loop;
+
+ return Files_List;
+ end Build_Dependence;
+
+ -- Convert NAME to lower cases, unless it is an extended identifier.
+ function Convert_Name (Name : String_Access) return String_Access
+ is
+ use Name_Table;
+
+ function Is_Bad_Unit_Name return Boolean is
+ begin
+ if Name_Length = 0 then
+ return True;
+ end if;
+ -- Don't try to handle extended identifier.
+ if Name_Buffer (1) = '\' then
+ return False;
+ end if;
+ -- Look for suspicious characters.
+ -- Do not try to be exhaustive as the correct check will be done
+ -- by convert_identifier.
+ for I in 1 .. Name_Length loop
+ case Name_Buffer (I) is
+ when '.' | '/' | '\' =>
+ return True;
+ when others =>
+ null;
+ end case;
+ end loop;
+ return False;
+ end Is_Bad_Unit_Name;
+
+ function Is_A_File_Name return Boolean is
+ begin
+ -- Check .vhd
+ if Name_Length > 4
+ and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd"
+ then
+ return True;
+ end if;
+ -- Check .vhdl
+ if Name_Length > 5
+ and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl"
+ then
+ return True;
+ end if;
+ -- Check ../
+ if Name_Length > 3
+ and then Name_Buffer (1 .. 3) = "../"
+ then
+ return True;
+ end if;
+ -- Check ..\
+ if Name_Length > 3
+ and then Name_Buffer (1 .. 3) = "..\"
+ then
+ return True;
+ end if;
+ -- Should try to find the file ?
+ return False;
+ end Is_A_File_Name;
+ begin
+ Name_Length := Name'Length;
+ Name_Buffer (1 .. Name_Length) := Name.all;
+
+ -- Try to identifier bad names (such as file names), so that
+ -- friendly message can be displayed.
+ if Is_Bad_Unit_Name then
+ Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'");
+ if Is_A_File_Name then
+ Errorout.Error_Msg_Option_NR
+ ("(a unit name is required instead of a filename)");
+ end if;
+ raise Option_Error;
+ end if;
+ Scanner.Convert_Identifier;
+ return new String'(Name_Buffer (1 .. Name_Length));
+ end Convert_Name;
+
+ procedure Extract_Elab_Unit
+ (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural)
+ is
+ begin
+ if Args'Length = 0 then
+ Error ("command '" & Cmd_Name & "' required an unit name");
+ raise Option_Error;
+ end if;
+
+ Prim_Name := Convert_Name (Args (Args'First));
+ Next_Arg := Args'First + 1;
+ Sec_Name := null;
+
+ if Args'Length >= 2 then
+ declare
+ Sec : constant String_Access := Args (Next_Arg);
+ begin
+ if Sec (Sec'First) /= '-' then
+ Sec_Name := Convert_Name (Sec);
+ Next_Arg := Args'First + 2;
+ end if;
+ end;
+ end if;
+ end Extract_Elab_Unit;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Import);
+ Register_Command (new Command_Check_Syntax);
+ Register_Command (new Command_Dir);
+ Register_Command (new Command_Find);
+ Register_Command (new Command_Clean);
+ Register_Command (new Command_Remove);
+ Register_Command (new Command_Copy);
+ Register_Command (new Command_Disp_Standard);
+ end Register_Commands;
+end Ghdllocal;
diff --git a/src/translate/ghdldrv/ghdllocal.ads b/src/translate/ghdldrv/ghdllocal.ads
new file mode 100644
index 000000000..2c7018adc
--- /dev/null
+++ b/src/translate/ghdldrv/ghdllocal.ads
@@ -0,0 +1,116 @@
+-- GHDL driver - local commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ghdlmain; use Ghdlmain;
+with Iirs; use Iirs;
+
+package Ghdllocal is
+ type Command_Lib is abstract new Command_Type with null record;
+
+ -- Setup GHDL.
+ procedure Init (Cmd : in out Command_Lib);
+
+ -- Handle:
+ -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v
+ procedure Decode_Option (Cmd : in out Command_Lib;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ -- Disp detailled help.
+ procedure Disp_Long_Help (Cmd : Command_Lib);
+
+ -- Value of --PREFIX
+ Switch_Prefix_Path : String_Access := null;
+
+ -- getenv ("GHDL_PREFIX"). Set by Setup_Libraries.
+ Prefix_Env : String_Access := null;
+
+ -- Installation prefix (deduced from executable path).
+ Exec_Prefix : String_Access;
+
+ -- Path prefix for libraries.
+ Lib_Prefix_Path : String_Access := null;
+
+ -- Set with -v option.
+ Flag_Verbose : Boolean := False;
+
+ -- Suffix for asm files.
+ Asm_Suffix : constant String := ".s";
+
+ -- Suffix for llvm byte-code files.
+ Llvm_Suffix : constant String := ".bc";
+
+ -- Suffix for post files.
+ Post_Suffix : constant String := ".on";
+
+ -- Suffix for list files.
+ List_Suffix : constant String := ".lst";
+
+ -- Prefix for elab files.
+ Elab_Prefix : constant String := "e~";
+
+ Nul : constant Character := Character'Val (0);
+
+ -- Return FILENAME without the extension.
+ function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True)
+ return String;
+
+ -- Get the position of the last directory separator or 0 if none.
+ function Get_Basename_Pos (Pathname : String) return Natural;
+
+ function Append_Suffix (File : String; Suffix : String)
+ return String_Access;
+
+ -- Return TRUE is UNIT can be at the apex of a design hierarchy.
+ function Is_Top_Entity (Unit : Iir) return Boolean;
+
+ -- Display the name of library unit UNIT.
+ procedure Disp_Library_Unit (Unit : Iir);
+
+ -- Translate vhdl version into a path element.
+ -- Used to search Std and IEEE libraries.
+ function Get_Version_Path return String;
+
+ -- Get Prefix_Path, but with 32 added if -m32 is requested
+ function Get_Machine_Path_Prefix return String;
+
+ -- Setup standard libaries path. If LOAD is true, then load them now.
+ procedure Setup_Libraries (Load : Boolean);
+
+ -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the
+ -- work library only
+ procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean);
+
+ -- Load and parse all libraries and files, starting from the work library.
+ -- The work library must already be loaded.
+ -- Raise errorout.compilation_error in case of error (parse error).
+ procedure Load_All_Libraries_And_Files;
+
+ function Build_Dependence (Prim : String_Access; Sec : String_Access)
+ return Iir_List;
+
+ Prim_Name : String_Access;
+ Sec_Name : String_Access;
+
+ -- Set PRIM_NAME and SEC_NAME.
+ procedure Extract_Elab_Unit
+ (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural);
+
+ procedure Register_Commands;
+end Ghdllocal;
diff --git a/src/translate/ghdldrv/ghdlmain.adb b/src/translate/ghdldrv/ghdlmain.adb
new file mode 100644
index 000000000..45d9615f9
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlmain.adb
@@ -0,0 +1,359 @@
+-- GHDL driver - main part.
+-- Copyright (C) 2002 - 2010 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Text_IO;
+with Ada.Command_Line;
+with Version;
+with Bug;
+with Options;
+
+package body Ghdlmain is
+ procedure Init (Cmd : in out Command_Type)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ null;
+ end Init;
+
+ procedure Decode_Option (Cmd : in out Command_Type;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ pragma Unreferenced (Cmd);
+ pragma Unreferenced (Option);
+ pragma Unreferenced (Arg);
+ begin
+ Res := Option_Bad;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Type)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ Put_Line ("This command does not accept options.");
+ end Disp_Long_Help;
+
+ First_Cmd : Command_Acc := null;
+ Last_Cmd : Command_Acc := null;
+
+ procedure Register_Command (Cmd : Command_Acc) is
+ begin
+ if First_Cmd = null then
+ First_Cmd := Cmd;
+ else
+ Last_Cmd.Next := Cmd;
+ end if;
+ Last_Cmd := Cmd;
+ end Register_Command;
+
+ -- Find the command.
+ function Find_Command (Action : String) return Command_Acc
+ is
+ Cmd : Command_Acc;
+ begin
+ Cmd := First_Cmd;
+ while Cmd /= null loop
+ if Decode_Command (Cmd.all, Action) then
+ return Cmd;
+ end if;
+ Cmd := Cmd.Next;
+ end loop;
+ return null;
+ end Find_Command;
+
+ -- Command help.
+ type Command_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Help; Name : String) return Boolean;
+ procedure Decode_Option (Cmd : in out Command_Help;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ function Get_Short_Help (Cmd : Command_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Help; Name : String) return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-h" or else Name = "--help";
+ end Decode_Command;
+
+ procedure Decode_Option (Cmd : in out Command_Help;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ pragma Unreferenced (Cmd);
+ pragma Unreferenced (Option);
+ pragma Unreferenced (Arg);
+ begin
+ Res := Option_End;
+ end Decode_Option;
+
+ function Get_Short_Help (Cmd : Command_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-h or --help [CMD] Disp this help or [help on CMD]";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Ada.Text_IO;
+ use Ada.Command_Line;
+ C : Command_Acc;
+ begin
+ if Args'Length = 0 then
+ Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ...");
+ Put_Line ("COMMAND is one of:");
+ C := First_Cmd;
+ while C /= null loop
+ Put_Line (Get_Short_Help (C.all));
+ C := C.Next;
+ end loop;
+ New_Line;
+ Put_Line ("To display the options of a GHDL program,");
+ Put_Line (" run your program with the --help option.");
+ Put_Line ("Also see --options-help for analyzer options.");
+ New_Line;
+ Put_Line ("Please, refer to the GHDL manual for more information.");
+ Put_Line ("Report bugs on http://gna.org/projects/ghdl");
+ elsif Args'Length = 1 then
+ C := Find_Command (Args (1).all);
+ if C = null then
+ Error ("Command '" & Args (1).all & "' is unknown.");
+ raise Option_Error;
+ end if;
+ Put_Line (Get_Short_Help (C.all));
+ Disp_Long_Help (C.all);
+ else
+ Error ("Command '--help' accepts at most one argument.");
+ raise Option_Error;
+ end if;
+ end Perform_Action;
+
+ -- Command options help.
+ type Command_Option_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Option_Help; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Option_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Option_Help;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Option_Help; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--options-help";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Option_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--options-help Disp help for analyzer options";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Option_Help;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ if Args'Length /= 0 then
+ Error
+ ("warning: command '--option-help' does not accept any argument");
+ end if;
+ Options.Disp_Options_Help;
+ end Perform_Action;
+
+ -- Command Version
+ type Command_Version is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Version; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Version) return String;
+ procedure Perform_Action (Cmd : in out Command_Version;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Version; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "-v" or Name = "--version";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Version) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "-v or --version Disp ghdl version";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Version;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ Put_Line (Version.Ghdl_Release);
+ Put_Line (" Compiled with " & Bug.Get_Gnat_Version);
+ if Version_String /= null then
+ Put (" ");
+ Put (Version_String.all);
+ end if;
+ New_Line;
+ Put_Line ("Written by Tristan Gingold.");
+ New_Line;
+ -- Display copyright. Assume 80 cols terminal.
+ Put_Line ("Copyright (C) 2003 - 2014 Tristan Gingold.");
+ Put_Line ("GHDL is free software, covered by the "
+ & "GNU General Public License. There is NO");
+ Put_Line ("warranty; not even for MERCHANTABILITY or"
+ & " FITNESS FOR A PARTICULAR PURPOSE.");
+ if Args'Length /= 0 then
+ Error ("warning: command '--version' does not accept any argument");
+ end if;
+ end Perform_Action;
+
+ -- Disp MSG on the standard output with the command name.
+ procedure Error (Msg : String)
+ is
+ use Ada.Command_Line;
+ use Ada.Text_IO;
+ begin
+ Put (Standard_Error, Command_Name);
+ Put (Standard_Error, ": ");
+ Put_Line (Standard_Error, Msg);
+ --Has_Error := True;
+ end Error;
+
+ procedure Main
+ is
+ use Ada.Command_Line;
+ Cmd : Command_Acc;
+ Arg_Index : Natural;
+ First_Arg : Natural;
+
+ begin
+ if Argument_Count = 0 then
+ Error ("missing command, try " & Command_Name & " --help");
+ raise Option_Error;
+ end if;
+
+ Cmd := Find_Command (Argument (1));
+ if Cmd = null then
+ Error ("unknown command '" & Argument (1) & "', try --help");
+ raise Option_Error;
+ end if;
+
+ Init (Cmd.all);
+
+ -- decode options.
+
+ First_Arg := 0;
+ Arg_Index := 2;
+ while Arg_Index <= Argument_Count loop
+ declare
+ Arg : constant String := Argument (Arg_Index);
+ Res : Option_Res;
+ begin
+ if Arg (1) = '-' then
+ -- Argument is an option.
+
+ if First_Arg > 0 then
+ Error ("options after file");
+ raise Option_Error;
+ end if;
+
+ Decode_Option (Cmd.all, Arg, "", Res);
+ case Res is
+ when Option_Bad =>
+ Error ("unknown option '" & Arg & "' for command '"
+ & Argument (1) & "'");
+ raise Option_Error;
+ when Option_Ok =>
+ Arg_Index := Arg_Index + 1;
+ when Option_Arg_Req =>
+ if Arg_Index + 1 > Argument_Count then
+ Error ("option '" & Arg & "' requires an argument");
+ raise Option_Error;
+ end if;
+ Decode_Option
+ (Cmd.all, Arg, Argument (Arg_Index + 1), Res);
+ if Res /= Option_Arg then
+ raise Program_Error;
+ end if;
+ Arg_Index := Arg_Index + 2;
+ when Option_Arg =>
+ raise Program_Error;
+ when Option_End =>
+ First_Arg := Arg_Index;
+ exit;
+ end case;
+ else
+ First_Arg := Arg_Index;
+ exit;
+ end if;
+ end;
+ end loop;
+
+ if First_Arg = 0 then
+ First_Arg := Argument_Count + 1;
+ end if;
+
+ declare
+ Args : Argument_List (1 .. Argument_Count - First_Arg + 1);
+ begin
+ for I in Args'Range loop
+ Args (I) := new String'(Argument (First_Arg + I - 1));
+ end loop;
+ Perform_Action (Cmd.all, Args);
+ for I in Args'Range loop
+ Free (Args (I));
+ end loop;
+ end;
+ --if Flags.Dump_Stats then
+ -- Name_Table.Disp_Stats;
+ -- Iirs.Disp_Stats;
+ --end if;
+ Set_Exit_Status (Success);
+ exception
+ when Option_Error
+ | Compile_Error
+ | Errorout.Compilation_Error =>
+ Set_Exit_Status (Failure);
+ when Exec_Error =>
+ Set_Exit_Status (3);
+ when E: others =>
+ Bug.Disp_Bug_Box (E);
+ Set_Exit_Status (2);
+ end Main;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Help);
+ Register_Command (new Command_Version);
+ Register_Command (new Command_Option_Help);
+ end Register_Commands;
+end Ghdlmain;
+
diff --git a/src/translate/ghdldrv/ghdlmain.ads b/src/translate/ghdldrv/ghdlmain.ads
new file mode 100644
index 000000000..c01f1d63e
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlmain.ads
@@ -0,0 +1,85 @@
+-- GHDL driver - main part.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Errorout;
+
+package Ghdlmain is
+ type Command_Type;
+
+ type Command_Acc is access all Command_Type'Class;
+
+ type Command_Type is abstract tagged record
+ Next : Command_Acc;
+ end record;
+
+ -- Return TRUE iff CMD handle action ACTION.
+ function Decode_Command (Cmd : Command_Type; Name : String) return Boolean
+ is abstract;
+
+ -- Initialize the command, before decoding actions.
+ procedure Init (Cmd : in out Command_Type);
+
+ -- Option_OK: OPTION is handled.
+ -- Option_Bad: OPTION is unknown.
+ -- Option_Arg_Req: OPTION requires an argument. Must be set only when
+ -- ARG = "", the manager will recall Decode_Option.
+ -- Option_Arg: OPTION used the argument.
+ type Option_Res is
+ (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End);
+ procedure Decode_Option (Cmd : in out Command_Type;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ -- Get a one-line help for the command.
+ function Get_Short_Help (Cmd : Command_Type) return String
+ is abstract;
+
+ -- Disp detailled help.
+ procedure Disp_Long_Help (Cmd : Command_Type);
+
+ -- Perform the action.
+ procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List)
+ is abstract;
+
+ -- Register a command.
+ procedure Register_Command (Cmd : Command_Acc);
+
+ -- Disp MSG on the standard output with the command name.
+ procedure Error (Msg : String);
+
+ -- May be raise by perform_action if the arguments are bad.
+ Option_Error : exception renames Errorout.Option_Error;
+
+ -- Action failed.
+ Compile_Error : exception;
+
+ -- Exec failed: either the program was not found, or failed.
+ Exec_Error : exception;
+
+ procedure Main;
+
+ -- Additionnal one-line message displayed by the --version command,
+ -- if defined.
+ -- Used to customize.
+ type String_Cst_Acc is access constant String;
+ Version_String : String_Cst_Acc := null;
+
+ -- Registers all commands in this package.
+ procedure Register_Commands;
+end Ghdlmain;
diff --git a/src/translate/ghdldrv/ghdlprint.adb b/src/translate/ghdldrv/ghdlprint.adb
new file mode 100644
index 000000000..45e70e118
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlprint.adb
@@ -0,0 +1,1757 @@
+-- GHDL driver - print commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Characters.Latin_1;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Table;
+with Types; use Types;
+with Flags;
+with Name_Table; use Name_Table;
+with Files_Map;
+with Libraries;
+with Errorout; use Errorout;
+with Iirs; use Iirs;
+with Iirs_Utils; use Iirs_Utils;
+with Tokens;
+with Scanner;
+with Parse;
+with Version;
+with Xrefs;
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with Disp_Vhdl;
+with Back_End;
+
+package body Ghdlprint is
+ type Html_Format_Type is (Html_2, Html_Css);
+ Html_Format : Html_Format_Type := Html_2;
+
+ procedure Put_Html (C : Character) is
+ begin
+ case C is
+ when '>' =>
+ Put (">");
+ when '<' =>
+ Put ("<");
+ when '&' =>
+ Put ("&");
+ when others =>
+ Put (C);
+ end case;
+ end Put_Html;
+
+ procedure Put_Html (S : String) is
+ begin
+ for I in S'Range loop
+ Put_Html (S (I));
+ end loop;
+ end Put_Html;
+
+ package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural);
+ procedure Put_Nat (N : Natural) is
+ begin
+ Nat_IO.Put (N, Width => 0);
+ end Put_Nat;
+
+ type Filexref_Info_Type is record
+ Output : String_Acc;
+ Referenced : Boolean;
+ end record;
+ type Filexref_Info_Arr is array (Source_File_Entry range <>)
+ of Filexref_Info_Type;
+ type Filexref_Info_Arr_Acc is access Filexref_Info_Arr;
+ Filexref_Info : Filexref_Info_Arr_Acc := null;
+
+ -- If True, at least one xref is missing.
+ Missing_Xref : Boolean := False;
+
+ procedure PP_Html_File (File : Source_File_Entry)
+ is
+ use Flags;
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Line : Natural;
+ Buf : File_Buffer_Acc;
+ Prev_Tok : Token_Type;
+
+ -- Current logical column number. Used to expand TABs.
+ Col : Natural;
+
+ -- Position just after the last token.
+ Last_Tok : Source_Ptr;
+
+ -- Position just before the current token.
+ Bef_Tok : Source_Ptr;
+
+ -- Position just after the current token.
+ Aft_Tok : Source_Ptr;
+
+ procedure Disp_Ln
+ is
+ N : Natural;
+ Str : String (1 .. 5);
+ begin
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font size=-1>");
+ when Html_Css =>
+ Put ("<i>");
+ end case;
+ N := Line;
+ for I in reverse Str'Range loop
+ if N = 0 then
+ Str (I) := ' ';
+ else
+ Str (I) := Character'Val (48 + N mod 10);
+ N := N / 10;
+ end if;
+ end loop;
+ Put (Str);
+ case Html_Format is
+ when Html_2 =>
+ Put ("</font>");
+ when Html_Css =>
+ Put ("</i>");
+ end case;
+ Put (" ");
+ Col := 0;
+ end Disp_Ln;
+
+ procedure Disp_Spaces
+ is
+ C : Character;
+ P : Source_Ptr;
+ N_Col : Natural;
+ begin
+ P := Last_Tok;
+ while P < Bef_Tok loop
+ C := Buf (P);
+ if C = HT then
+ -- Expand TABS.
+ N_Col := Col + 8;
+ N_Col := N_Col - N_Col mod 8;
+ while Col < N_Col loop
+ Put (' ');
+ Col := Col + 1;
+ end loop;
+ else
+ Put (' ');
+ Col := Col + 1;
+ end if;
+ P := P + 1;
+ end loop;
+ end Disp_Spaces;
+
+ procedure Disp_Text
+ is
+ P : Source_Ptr;
+ begin
+ P := Bef_Tok;
+ while P < Aft_Tok loop
+ Put_Html (Buf (P));
+ Col := Col + 1;
+ P := P + 1;
+ end loop;
+ end Disp_Text;
+
+ procedure Disp_Reserved is
+ begin
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=red>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<em>");
+ Disp_Text;
+ Put ("</em>");
+ end case;
+ end Disp_Reserved;
+
+ procedure Disp_Href (Loc : Location_Type)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Location_To_File_Pos (Loc, L_File, L_Pos);
+ Put (" href=""");
+ if L_File /= File then
+ -- External reference.
+ if Filexref_Info (L_File).Output /= null then
+ Put (Filexref_Info (L_File).Output.all);
+ Put ("#");
+ Put_Nat (Natural (L_Pos));
+ else
+ -- Reference to an unused file.
+ Put ("index.html#f");
+ Put_Nat (Natural (L_File));
+ Filexref_Info (L_File).Referenced := True;
+ end if;
+ else
+ -- Local reference.
+ Put ("#");
+ Put_Nat (Natural (L_Pos));
+ end if;
+ Put ("""");
+ end Disp_Href;
+
+ procedure Disp_Anchor (Loc : Location_Type)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Put (" name=""");
+ Location_To_File_Pos (Loc, L_File, L_Pos);
+ Put_Nat (Natural (L_Pos));
+ Put ("""");
+ end Disp_Anchor;
+
+ procedure Disp_Identifier
+ is
+ use Xrefs;
+ Ref : Xref;
+ Decl : Iir;
+ Bod : Iir;
+ Loc : Location_Type;
+ begin
+ Disp_Spaces;
+ if Flags.Flag_Xref then
+ Loc := File_Pos_To_Location (File, Bef_Tok);
+ Ref := Find (Loc);
+ if Ref = Bad_Xref then
+ Disp_Text;
+ Warning_Msg_Sem ("cannot find xref", Loc);
+ Missing_Xref := True;
+ return;
+ end if;
+ else
+ Disp_Text;
+ return;
+ end if;
+ case Get_Xref_Kind (Ref) is
+ when Xref_Decl =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Decl := Get_Xref_Node (Ref);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Bod := Get_Subprogram_Body (Decl);
+ when Iir_Kind_Package_Declaration =>
+ Bod := Get_Package_Body (Decl);
+ when Iir_Kind_Type_Declaration =>
+ Decl := Get_Type (Decl);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Protected_Type_Declaration =>
+ Bod := Get_Protected_Type_Body (Decl);
+ when Iir_Kind_Incomplete_Type_Definition =>
+ Bod := Get_Type_Declarator (Decl);
+ when others =>
+ Bod := Null_Iir;
+ end case;
+ when others =>
+ Bod := Null_Iir;
+ end case;
+ if Bod /= Null_Iir then
+ Disp_Href (Get_Location (Bod));
+ end if;
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ when Xref_Ref
+ | Xref_End =>
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ if Loc /= Location_Nil then
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ else
+ -- This may happen for overload list, in use clauses.
+ Disp_Text;
+ end if;
+ when Xref_Body =>
+ Put ("<a");
+ Disp_Anchor (Loc);
+ Disp_Href (Get_Location (Get_Xref_Node (Ref)));
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end case;
+ end Disp_Identifier;
+
+ procedure Disp_Attribute
+ is
+ use Xrefs;
+ Ref : Xref;
+ Decl : Iir;
+ Loc : Location_Type;
+ begin
+ Disp_Spaces;
+ if Flags.Flag_Xref then
+ Loc := File_Pos_To_Location (File, Bef_Tok);
+ Ref := Find (Loc);
+ else
+ Ref := Bad_Xref;
+ end if;
+ if Ref = Bad_Xref then
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=orange>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<var>");
+ Disp_Text;
+ Put ("</var>");
+ end case;
+ else
+ Decl := Get_Xref_Node (Ref);
+ Loc := Get_Location (Decl);
+ Put ("<a");
+ Disp_Href (Loc);
+ Put (">");
+ Disp_Text;
+ Put ("</a>");
+ end if;
+ end Disp_Attribute;
+ begin
+ Scanner.Flag_Comment := True;
+ Scanner.Flag_Newline := True;
+
+ Set_File (File);
+ Buf := Get_File_Source (File);
+
+ Put_Line ("<pre>");
+ Line := 1;
+ Disp_Ln;
+ Last_Tok := Source_Ptr_Org;
+ Prev_Tok := Tok_Invalid;
+ loop
+ Scan;
+ Bef_Tok := Get_Token_Position;
+ Aft_Tok := Get_Position;
+ case Current_Token is
+ when Tok_Eof =>
+ exit;
+ when Tok_Newline =>
+ New_Line;
+ Line := Line + 1;
+ Disp_Ln;
+ when Tok_Comment =>
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=green>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<tt>");
+ Disp_Text;
+ Put ("</tt>");
+ end case;
+ when Tok_Access .. Tok_Elsif
+ | Tok_Entity .. Tok_With
+ | Tok_Mod .. Tok_Rem
+ | Tok_And .. Tok_Not =>
+ Disp_Reserved;
+ when Tok_End =>
+ Disp_Reserved;
+ when Tok_Semi_Colon =>
+ Disp_Spaces;
+ Disp_Text;
+ when Tok_Xnor .. Tok_Ror =>
+ Disp_Reserved;
+ when Tok_Protected =>
+ Disp_Reserved;
+ when Tok_Across .. Tok_Tolerance =>
+ Disp_Reserved;
+ when Tok_Psl_Default
+ | Tok_Psl_Clock
+ | Tok_Psl_Property
+ | Tok_Psl_Sequence
+ | Tok_Psl_Endpoint
+ | Tok_Psl_Assert
+ | Tok_Psl_Cover
+ | Tok_Psl_Boolean
+ | Tok_Psl_Const
+ | Tok_Inf
+ | Tok_Within
+ | Tok_Abort
+ | Tok_Before
+ | Tok_Always
+ | Tok_Never
+ | Tok_Eventually
+ | Tok_Next_A
+ | Tok_Next_E
+ | Tok_Next_Event
+ | Tok_Next_Event_A
+ | Tok_Next_Event_E =>
+ Disp_Spaces;
+ Disp_Text;
+ when Tok_String
+ | Tok_Bit_String
+ | Tok_Character =>
+ Disp_Spaces;
+ case Html_Format is
+ when Html_2 =>
+ Put ("<font color=blue>");
+ Disp_Text;
+ Put ("</font>");
+ when Html_Css =>
+ Put ("<kbd>");
+ Disp_Text;
+ Put ("</kbd>");
+ end case;
+ when Tok_Identifier =>
+ if Prev_Tok = Tok_Tick then
+ Disp_Attribute;
+ else
+ Disp_Identifier;
+ end if;
+ when Tok_Left_Paren .. Tok_Colon
+ | Tok_Comma .. Tok_Dot
+ | Tok_Equal_Equal
+ | Tok_Integer
+ | Tok_Real
+ | Tok_Equal .. Tok_Slash
+ | Tok_Invalid =>
+ Disp_Spaces;
+ Disp_Text;
+ end case;
+ Last_Tok := Aft_Tok;
+ Prev_Tok := Current_Token;
+ end loop;
+ Close_File;
+ New_Line;
+ Put_Line ("</pre>");
+ Put_Line ("<hr/>");
+ end PP_Html_File;
+
+ procedure Put_Html_Header
+ is
+ begin
+ Put ("<html>");
+ Put_Line (" <head>");
+ case Html_Format is
+ when Html_2 =>
+ null;
+ when Html_Css =>
+ Put_Line (" <link rel=stylesheet type=""text/css""");
+ Put_Line (" href=""ghdl.css"" title=""default""/>");
+ end case;
+ --Put_Line ("<?xml version=""1.0"" encoding=""utf-8"" ?>");
+ --Put_Line("<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Strict//EN""");
+ --Put_Line ("""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"">");
+ --Put_Line ("<html xmlns=""http://www.w3.org/1999/xhtml"""
+ -- & " xml:lang=""en"">");
+ --Put_Line ("<head>");
+ end Put_Html_Header;
+
+ procedure Put_Css is
+ begin
+ Put_Line ("/* EM is used for reserved words */");
+ Put_Line ("EM { color : red; font-style: normal }");
+ New_Line;
+ Put_Line ("/* TT is used for comments */");
+ Put_Line ("TT { color : green; font-style: normal }");
+ New_Line;
+ Put_Line ("/* KBD is used for literals and strings */");
+ Put_Line ("KBD { color : blue; font-style: normal }");
+ New_Line;
+ Put_Line ("/* I is used for line numbers */");
+ Put_Line ("I { color : gray; font-size: 50% }");
+ New_Line;
+ Put_Line ("/* VAR is used for attributes name */");
+ Put_Line ("VAR { color : orange; font-style: normal }");
+ New_Line;
+ Put_Line ("/* A is used for identifiers. */");
+ Put_Line ("A { color: blue; font-style: normal;");
+ Put_Line (" text-decoration: none }");
+ end Put_Css;
+
+ procedure Put_Html_Foot
+ is
+ begin
+ Put_Line ("<p>");
+ Put ("<small>This page was generated using ");
+ Put ("<a href=""http://ghdl.free.fr"">");
+ Put (Version.Ghdl_Release);
+ Put ("</a>, a program written by");
+ Put (" Tristan Gingold");
+ New_Line;
+ Put_Line ("</p>");
+ Put_Line ("</body>");
+ Put_Line ("</html>");
+ end Put_Html_Foot;
+
+ function Create_Output_Filename (Name : String; Num : Natural)
+ return String_Acc
+ is
+ -- Position of the extension. 0 if none.
+ Ext_Pos : Natural;
+
+ Num_Str : String := Natural'Image (Num);
+ begin
+ -- Search for the extension.
+ Ext_Pos := 0;
+ for I in reverse Name'Range loop
+ exit when Name (I) = Directory_Separator;
+ if Name (I) = '.' then
+ Ext_Pos := I - 1;
+ exit;
+ end if;
+ end loop;
+ if Ext_Pos = 0 then
+ Ext_Pos := Name'Last;
+ end if;
+ Num_Str (1) := '.';
+ return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html");
+ end Create_Output_Filename;
+
+ -- Command --chop.
+ type Command_Chop is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Chop; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Chop) return String;
+ procedure Perform_Action (Cmd : in out Command_Chop;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Chop; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--chop";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Chop) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--chop [OPTS] FILEs Chop FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Characters.Latin_1;
+
+ function Build_File_Name_Length (Lib : Iir) return Natural
+ is
+ Id : constant Name_Id := Get_Identifier (Lib);
+ Len : Natural;
+ Id1 : Name_Id;
+ begin
+ Len := Get_Name_Length (Id);
+ case Get_Kind (Lib) is
+ when Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ null;
+ when Iir_Kind_Package_Body =>
+ Len := Len + 1 + 4; -- add -body
+ when Iir_Kind_Architecture_Body =>
+ Id1 := Get_Entity_Identifier_Of_Architecture (Lib);
+ Len := Len + 1 + Get_Name_Length (Id1);
+ when others =>
+ Error_Kind ("build_file_name", Lib);
+ end case;
+ Len := Len + 1 + 4; -- add .vhdl
+ return Len;
+ end Build_File_Name_Length;
+
+ procedure Build_File_Name (Lib : Iir; Res : out String)
+ is
+ Id : constant Name_Id := Get_Identifier (Lib);
+ P : Natural;
+
+ procedure Append (Str : String) is
+ begin
+ Res (P + 1 .. P + Str'Length) := Str;
+ P := P + Str'Length;
+ end Append;
+ begin
+ P := Res'First - 1;
+ case Get_Kind (Lib) is
+ when Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ when Iir_Kind_Package_Body =>
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ Append ("-body");
+ when Iir_Kind_Architecture_Body =>
+ Image (Get_Entity_Identifier_Of_Architecture (Lib));
+ Append (Name_Buffer (1 .. Name_Length));
+ Append ("-");
+ Image (Id);
+ Append (Name_Buffer (1 .. Name_Length));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Append (".vhdl");
+ end Build_File_Name;
+
+ -- Scan source file BUF+START until end of line.
+ -- Return line kind to KIND and position of next line to NEXT.
+ type Line_Type is (Line_Blank, Line_Comment, Line_Text);
+ procedure Find_Eol (Buf : File_Buffer_Acc;
+ Start : Source_Ptr;
+ Next : out Source_Ptr;
+ Kind : out Line_Type)
+ is
+ P : Source_Ptr;
+ begin
+ P := Start;
+
+ Kind := Line_Blank;
+
+ -- Skip blanks.
+ while Buf (P) = ' ' or Buf (P) = HT loop
+ P := P + 1;
+ end loop;
+
+ -- Skip comment if any.
+ if Buf (P) = '-' and Buf (P + 1) = '-' then
+ Kind := Line_Comment;
+ P := P + 2;
+ elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then
+ Kind := Line_Text;
+ end if;
+
+ -- Skip until end of line.
+ while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop
+ P := P + 1;
+ end loop;
+
+ if Buf (P) = CR then
+ P := P + 1;
+ if Buf (P) = LF then
+ P := P + 1;
+ end if;
+ elsif Buf (P) = LF then
+ P := P + 1;
+ if Buf (P) = CR then
+ P := P + 1;
+ end if;
+ end if;
+
+ Next := P;
+ end Find_Eol;
+
+ Id : Name_Id;
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+ Lib : Iir;
+ Len : Natural;
+ begin
+ Flags.Bootstrap := True;
+ -- Load word library.
+ Libraries.Load_Std_Library;
+ Libraries.Load_Work_Library;
+
+ -- First loop: parse source file, check destination file does not
+ -- exist.
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Compile_Error;
+ end if;
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+ Len := Build_File_Name_Length (Lib);
+ declare
+ Filename : String (1 .. Len + 1);
+ begin
+ Build_File_Name (Lib, Filename);
+ Filename (Len + 1) := Ghdllocal.Nul;
+ if Is_Regular_File (Filename) then
+ Error ("file '" & Filename (1 .. Len) & "' already exists");
+ raise Compile_Error;
+ end if;
+ Put (Filename (1 .. Len));
+ Put (" (for ");
+ Disp_Library_Unit (Lib);
+ Put (")");
+ New_Line;
+ end;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end loop;
+
+ -- Second loop: do the real work.
+ for I in Args'Range loop
+ Id := Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ Unit := Get_First_Design_Unit (Design_File);
+ declare
+ use Files_Map;
+
+ File_Entry : Source_File_Entry;
+ Buffer : File_Buffer_Acc;
+
+ Start : Source_Ptr;
+ Lend : Source_Ptr;
+ First : Source_Ptr;
+ Next : Source_Ptr;
+ Kind : Line_Type;
+ begin
+ -- A design_file must have at least one design unit.
+ if Unit = Null_Iir then
+ raise Compile_Error;
+ end if;
+
+ Location_To_File_Pos
+ (Get_Location (Unit), File_Entry, Start);
+ Buffer := Get_File_Source (File_Entry);
+
+ First := Source_Ptr_Org;
+ if Get_Chain (Unit) /= Null_Iir then
+ -- If there is only one unit, then the whole file is written.
+ -- First last blank line.
+ Next := Source_Ptr_Org;
+ loop
+ Start := Next;
+ Find_Eol (Buffer, Start, Next, Kind);
+ exit when Kind = Line_Text;
+ if Kind = Line_Blank then
+ First := Next;
+ end if;
+ end loop;
+
+ -- FIXME: write header.
+ end if;
+
+ while Unit /= Null_Iir loop
+ Lib := Get_Library_Unit (Unit);
+
+ Location_To_File_Pos
+ (Get_End_Location (Unit), File_Entry, Lend);
+ if Lend < First then
+ raise Internal_Error;
+ end if;
+
+ Location_To_File_Pos
+ (Get_End_Location (Unit), File_Entry, Lend);
+ -- Find the ';'.
+ while Buffer (Lend) /= ';' loop
+ Lend := Lend + 1;
+ end loop;
+ Lend := Lend + 1;
+ -- Find end of line.
+ Find_Eol (Buffer, Lend, Next, Kind);
+ if Kind = Line_Text then
+ -- There is another unit on the same line.
+ Next := Lend;
+ -- Skip blanks.
+ while Buffer (Next) = ' ' or Buffer (Next) = HT loop
+ Next := Next + 1;
+ end loop;
+ else
+ -- Find first blank line.
+ loop
+ Start := Next;
+ Find_Eol (Buffer, Start, Next, Kind);
+ exit when Kind /= Line_Comment;
+ end loop;
+ if Kind = Line_Text then
+ -- There is not blank lines.
+ -- All the comments are supposed to belong to the next
+ -- unit.
+ Find_Eol (Buffer, Lend, Next, Kind);
+ Lend := Next;
+ else
+ Lend := Start;
+ end if;
+ end if;
+
+ if Get_Chain (Unit) = Null_Iir then
+ -- Last unit.
+ -- Put the end of the file in it.
+ Lend := Get_File_Length (File_Entry);
+ end if;
+
+ -- FIXME: file with only one unit.
+ -- FIXME: set extension.
+ Len := Build_File_Name_Length (Lib);
+ declare
+ Filename : String (1 .. Len + 1);
+ Fd : File_Descriptor;
+
+ Wlen : Integer;
+ begin
+ Build_File_Name (Lib, Filename);
+ Filename (Len + 1) := Character'Val (0);
+ Fd := Create_File (Filename, Binary);
+ if Fd = Invalid_FD then
+ Error
+ ("cannot create file '" & Filename (1 .. Len) & "'");
+ raise Compile_Error;
+ end if;
+ Wlen := Integer (Lend - First);
+ if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then
+ Error ("cannot write to '" & Filename (1 .. Len) & "'");
+ raise Compile_Error;
+ end if;
+ Close (Fd);
+ end;
+ First := Next;
+
+ Unit := Get_Chain (Unit);
+ end loop;
+ end;
+ end loop;
+ end Perform_Action;
+
+ -- Command --lines.
+ type Command_Lines is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Lines; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Lines) return String;
+ procedure Perform_Action (Cmd : in out Command_Lines;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Lines; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--lines";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Lines) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--lines FILEs Precede line with its number";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ Line : Natural;
+ File : Source_File_Entry;
+ Buf : File_Buffer_Acc;
+ Ptr : Source_Ptr;
+ Eptr : Source_Ptr;
+ C : Character;
+ N : Natural;
+ Log : Natural;
+ Str : String (1 .. 10);
+ begin
+ Local_Id := Get_Identifier ("");
+ for I in Args'Range loop
+ -- Load the file.
+ Id := Get_Identifier (Args (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Args (I).all);
+ raise Compile_Error;
+ end if;
+ Set_File (Fe);
+
+ -- Scan the content, to compute the number of lines.
+ loop
+ Scan;
+ exit when Current_Token = Tok_Eof;
+ end loop;
+ File := Get_Current_Source_File;
+ Line := Get_Current_Line;
+ Close_File;
+
+ -- Compute log10 of line.
+ N := Line;
+ Log := 0;
+ loop
+ N := N / 10;
+ Log := Log + 1;
+ exit when N = 0;
+ end loop;
+
+ -- Disp file name.
+ Put (Args (I).all);
+ Put (':');
+ New_Line;
+
+ Buf := Get_File_Source (File);
+ for J in 1 .. Line loop
+ Ptr := Line_To_Position (File, J);
+ exit when Ptr = Source_Ptr_Bad;
+ exit when Buf (Ptr) = Files_Map.EOT;
+
+ -- Disp line number.
+ N := J;
+ for K in reverse 1 .. Log loop
+ if N = 0 then
+ Str (K) := ' ';
+ else
+ Str (K) := Character'Val (48 + N mod 10);
+ N := N / 10;
+ end if;
+ end loop;
+ Put (Str (1 .. Log));
+ Put (": ");
+
+ -- Search for end of line (or end of file).
+ Eptr := Ptr;
+ loop
+ C := Buf (Eptr);
+ exit when C = Files_Map.EOT or C = LF or C = CR;
+ Eptr := Eptr + 1;
+ end loop;
+
+ -- Disp line.
+ if Eptr > Ptr then
+ -- Avoid constraint error on conversion of nul array.
+ Put (String (Buf (Ptr .. Eptr - 1)));
+ end if;
+ New_Line;
+ end loop;
+ end loop;
+ end Perform_Action;
+
+ -- Command Reprint.
+ type Command_Reprint is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Reprint; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Reprint) return String;
+ procedure Perform_Action (Cmd : in out Command_Reprint;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Reprint; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--reprint";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Reprint) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--reprint [OPTS] FILEs Redisplay FILEs";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Reprint;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ Design_File : Iir_Design_File;
+ Unit : Iir;
+
+ Id : Name_Id;
+ Next_Unit : Iir;
+ begin
+ Setup_Libraries (True);
+ Parse.Flag_Parse_Parenthesis := True;
+
+ -- Parse all files.
+ for I in Args'Range loop
+ Id := Name_Table.Get_Identifier (Args (I).all);
+ Design_File := Libraries.Load_File (Id);
+ if Design_File = Null_Iir then
+ raise Errorout.Compilation_Error;
+ end if;
+
+ Unit := Get_First_Design_Unit (Design_File);
+ while Unit /= Null_Iir loop
+ -- Analyze the design unit.
+ Back_End.Finish_Compilation (Unit, True);
+
+ Next_Unit := Get_Chain (Unit);
+ if Errorout.Nbr_Errors = 0 then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit);
+ end if;
+
+ Unit := Next_Unit;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Errorout.Compilation_Error;
+ end if;
+ end loop;
+ end Perform_Action;
+
+ -- Command compare tokens.
+ type Command_Compare_Tokens is new Command_Lib with null record;
+ function Decode_Command (Cmd : Command_Compare_Tokens; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Compare_Tokens) return String;
+ procedure Perform_Action (Cmd : in out Command_Compare_Tokens;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Compare_Tokens; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--compare-tokens";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Compare_Tokens) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Compare_Tokens;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Tokens;
+ use Scanner;
+
+ package Ref_Tokens is new GNAT.Table
+ (Table_Component_Type => Token_Type,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 0,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ Tok_Idx : Natural;
+ begin
+ if Args'Length < 1 then
+ Error ("missing ref file");
+ raise Compile_Error;
+ end if;
+
+ Local_Id := Get_Identifier ("");
+
+ for I in Args'Range loop
+ -- Load the file.
+ Id := Get_Identifier (Args (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Args (I).all);
+ raise Compile_Error;
+ end if;
+ Set_File (Fe);
+
+ if I = Args'First then
+ -- Scan ref file
+ loop
+ Scan;
+ Ref_Tokens.Append (Current_Token);
+ exit when Current_Token = Tok_Eof;
+ end loop;
+ else
+ -- Scane file
+ Tok_Idx := Ref_Tokens.First;
+ loop
+ Scan;
+ if Ref_Tokens.Table (Tok_Idx) /= Current_Token then
+ Error_Msg_Parse ("token mismatch");
+ exit;
+ end if;
+ case Current_Token is
+ when Tok_Eof =>
+ exit;
+ when others =>
+ null;
+ end case;
+ Tok_Idx := Tok_Idx + 1;
+ end loop;
+ end if;
+ Close_File;
+ end loop;
+
+ Ref_Tokens.Free;
+
+ if Nbr_Errors /= 0 then
+ raise Compilation_Error;
+ end if;
+ end Perform_Action;
+
+ -- Command html.
+ type Command_Html is abstract new Command_Lib with null record;
+
+ procedure Decode_Option (Cmd : in out Command_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+
+ procedure Disp_Long_Help (Cmd : Command_Html);
+
+ procedure Decode_Option (Cmd : in out Command_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "--format=css" then
+ Html_Format := Html_Css;
+ Res := Option_Ok;
+ elsif Option = "--format=html2" then
+ Html_Format := Html_2;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Lib (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Html) is
+ begin
+ Disp_Long_Help (Command_Lib (Cmd));
+ Put_Line ("--format=html2 Use FONT attributes");
+ Put_Line ("--format=css Use ghdl.css file");
+ end Disp_Long_Help;
+
+ -- Command --pp-html.
+ type Command_PP_Html is new Command_Html with null record;
+ function Decode_Command (Cmd : Command_PP_Html; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_PP_Html) return String;
+ procedure Perform_Action (Cmd : in out Command_PP_Html;
+ Files : Argument_List);
+
+ function Decode_Command (Cmd : Command_PP_Html; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--pp-html";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_PP_Html) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--pp-html FILEs Pretty-print FILEs in HTML";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_PP_Html;
+ Files : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Scanner;
+ use Tokens;
+ use Files_Map;
+ use Ada.Characters.Latin_1;
+
+ Id : Name_Id;
+ Fe : Source_File_Entry;
+ Local_Id : Name_Id;
+ begin
+ Local_Id := Get_Identifier ("");
+ Put_Html_Header;
+ Put_Line (" <title>");
+ for I in Files'Range loop
+ Put (" ");
+ Put_Line (Files (I).all);
+ end loop;
+ Put_Line (" </title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ for I in Files'Range loop
+ Id := Get_Identifier (Files (I).all);
+ Fe := Files_Map.Load_Source_File (Local_Id, Id);
+ if Fe = No_Source_File_Entry then
+ Error ("cannot open file " & Files (I).all);
+ raise Compile_Error;
+ end if;
+ Put (" <h1>");
+ Put (Files (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Fe);
+ end loop;
+ Put_Html_Foot;
+ end Perform_Action;
+
+ -- Command --xref-html.
+ type Command_Xref_Html is new Command_Html with record
+ Output_Dir : String_Access := null;
+ Check_Missing : Boolean := False;
+ end record;
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String;
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res);
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html);
+
+ procedure Perform_Action (Cmd : in out Command_Xref_Html;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref_Html; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref-html";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref_Html) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref-html FILEs Display FILEs in HTML with xrefs";
+ end Get_Short_Help;
+
+ procedure Decode_Option (Cmd : in out Command_Xref_Html;
+ Option : String;
+ Arg : String;
+ Res : out Option_Res)
+ is
+ begin
+ if Option = "-o" then
+ if Arg = "" then
+ Res := Option_Arg_Req;
+ else
+ Cmd.Output_Dir := new String'(Arg);
+ Res := Option_Arg;
+ end if;
+ elsif Option = "--check-missing" then
+ Cmd.Check_Missing := True;
+ Res := Option_Ok;
+ else
+ Decode_Option (Command_Html (Cmd), Option, Arg, Res);
+ end if;
+ end Decode_Option;
+
+ procedure Disp_Long_Help (Cmd : Command_Xref_Html) is
+ begin
+ Disp_Long_Help (Command_Html (Cmd));
+ Put_Line ("-o DIR Put generated files into DIR (def: html/)");
+ Put_Line ("--check-missing Fail if a reference is missing");
+ New_Line;
+ Put_Line ("When format is css, the CSS file 'ghdl.css' "
+ & "is never overwritten.");
+ end Disp_Long_Help;
+
+ procedure Analyze_Design_File_Units (File : Iir_Design_File)
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ case Get_Date_State (Unit) is
+ when Date_Extern
+ | Date_Disk =>
+ raise Internal_Error;
+ when Date_Parse =>
+ Libraries.Load_Design_Unit (Unit, Null_Iir);
+ when Date_Analyze =>
+ null;
+ end case;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end Analyze_Design_File_Units;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref_Html; Files_Name : Argument_List)
+ is
+ use GNAT.Directory_Operations;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ Output : String_Acc;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ Output : File_Type;
+ begin
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Load work library.
+ Setup_Libraries (True);
+
+ if Cmd.Output_Dir = null then
+ Cmd.Output_Dir := new String'("html");
+ elsif Cmd.Output_Dir.all = "-" then
+ Cmd.Output_Dir := null;
+ end if;
+
+ -- Try to create the directory.
+ if Cmd.Output_Dir /= null
+ and then not Is_Directory (Cmd.Output_Dir.all)
+ then
+ declare
+ begin
+ Make_Dir (Cmd.Output_Dir.all);
+ exception
+ when Directory_Error =>
+ Error ("cannot create directory " & Cmd.Output_Dir.all);
+ return;
+ end;
+ end if;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ Files (I).Output := Create_Output_Filename
+ (Base_Name (Files_Name (I).all), I);
+ if Is_Regular_File (Files (I).Output.all) then
+ -- Prevent overwrite.
+ null;
+ end if;
+ -- Put units in library.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Sort_By_Location;
+
+ if False then
+ for I in 1 .. Xrefs.Get_Last_Xref loop
+ declare
+ use Xrefs;
+
+ procedure Put_Loc (L : Location_Type)
+ is
+ use Files_Map;
+
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ begin
+ Files_Map.Location_To_File_Pos (L, L_File, L_Pos);
+ Put_Nat (Natural (L_File));
+ --Image (Get_File_Name (L_File));
+ --Put (Name_Buffer (1 .. Name_Length));
+ Put (":");
+ Put_Nat (Natural (L_Pos));
+ end Put_Loc;
+ begin
+ Put_Loc (Get_Xref_Location (I));
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Put (" decl ");
+ Put (Image (Get_Identifier (Get_Xref_Node (I))));
+ when Xref_Ref =>
+ Put (" use ");
+ Put_Loc (Get_Location (Get_Xref_Node (I)));
+ when Xref_End =>
+ Put (" end ");
+ when Xref_Body =>
+ Put (" body ");
+ end case;
+ New_Line;
+ end;
+ end loop;
+ end if;
+
+ -- Create filexref_info.
+ Filexref_Info := new Filexref_Info_Arr
+ (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry);
+ Filexref_Info.all := (others => (Output => null,
+ Referenced => False));
+ for I in Files'Range loop
+ Filexref_Info (Files (I).Fe).Output := Files (I).Output;
+ end loop;
+
+ for I in Files'Range loop
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator
+ & Files (I).Output.all);
+
+ Set_Output (Output);
+ end if;
+
+ Put_Html_Header;
+ Put_Line (" <title>");
+ Put_Html (Files_Name (I).all);
+ Put ("</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+
+ Put ("<h1>");
+ Put_Html (Files_Name (I).all);
+ Put ("</h1>");
+ New_Line;
+
+ PP_Html_File (Files (I).Fe);
+ Put_Html_Foot;
+
+ if Cmd.Output_Dir /= null then
+ Close (Output);
+ end if;
+ end loop;
+
+ -- Create indexes.
+ if Cmd.Output_Dir /= null then
+ Create (Output, Out_File,
+ Cmd.Output_Dir.all & Directory_Separator & "index.html");
+ Set_Output (Output);
+
+ Put_Html_Header;
+ Put_Line (" <title>Xrefs indexes</title>");
+ Put_Line ("</head>");
+ New_Line;
+ Put_Line ("<body>");
+ Put_Line ("<p>list of files:");
+ Put_Line ("<ul>");
+ for I in Files'Range loop
+ Put ("<li>");
+ Put ("<a href=""");
+ Put (Files (I).Output.all);
+ Put (""">");
+ Put_Html (Files_Name (I).all);
+ Put ("</a>");
+ Put ("</li>");
+ New_Line;
+ end loop;
+ Put_Line ("</ul></p>");
+ Put_Line ("<hr>");
+
+ -- TODO: list of design units.
+
+ Put_Line ("<p>list of files referenced but not available:");
+ Put_Line ("<ul>");
+ for I in No_Source_File_Entry + 1 .. Filexref_Info'Last loop
+ if Filexref_Info (I).Output = null
+ and then Filexref_Info (I).Referenced
+ then
+ Put ("<li><a name=""f");
+ Put_Nat (Natural (I));
+ Put (""">");
+ Put_Html (Image (Files_Map.Get_File_Name (I)));
+ Put ("</a></li>");
+ New_Line;
+ end if;
+ end loop;
+ Put_Line ("</ul></p><hr>");
+ Put_Html_Foot;
+
+ Close (Output);
+ end if;
+
+ if Html_Format = Html_Css
+ and then Cmd.Output_Dir /= null
+ then
+ declare
+ Css_Filename : constant String :=
+ Cmd.Output_Dir.all & Directory_Separator & "ghdl.css";
+ begin
+ if not Is_Regular_File (Css_Filename & Nul) then
+ Create (Output, Out_File, Css_Filename);
+ Set_Output (Output);
+ Put_Css;
+ Close (Output);
+ end if;
+ end;
+ end if;
+
+ if Missing_Xref and Cmd.Check_Missing then
+ Error ("missing xrefs");
+ raise Compile_Error;
+ end if;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+
+ -- Command --xref
+ type Command_Xref is new Command_Lib with null record;
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Xref) return String;
+
+ procedure Perform_Action (Cmd : in out Command_Xref;
+ Files_Name : Argument_List);
+
+ function Decode_Command (Cmd : Command_Xref; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--xref";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Xref) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--xref FILEs Generate xrefs";
+ end Get_Short_Help;
+
+ procedure Perform_Action
+ (Cmd : in out Command_Xref; Files_Name : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+
+ use Files_Map;
+
+ Id : Name_Id;
+ File : Source_File_Entry;
+
+ type File_Data is record
+ Fe : Source_File_Entry;
+ Design_File : Iir;
+ end record;
+ type File_Data_Array is array (Files_Name'Range) of File_Data;
+
+ Files : File_Data_Array;
+ begin
+ -- Load work library.
+ Setup_Libraries (True);
+
+ Xrefs.Init;
+ Flags.Flag_Xref := True;
+
+ -- Parse all files.
+ for I in Files'Range loop
+ Id := Get_Identifier (Files_Name (I).all);
+ File := Load_Source_File (Libraries.Local_Directory, Id);
+ if File = No_Source_File_Entry then
+ Error ("cannot open " & Image (Id));
+ return;
+ end if;
+ Files (I).Fe := File;
+ Files (I).Design_File := Libraries.Load_File (File);
+ if Files (I).Design_File = Null_Iir then
+ return;
+ end if;
+ -- Put units in library.
+ -- Note: design_units stay while design_file get empty.
+ Libraries.Add_Design_File_Into_Library (Files (I).Design_File);
+ end loop;
+
+ -- Analyze all files.
+ for I in Files'Range loop
+ Analyze_Design_File_Units (Files (I).Design_File);
+ end loop;
+
+ Xrefs.Fix_End_Xrefs;
+ Xrefs.Sort_By_Node_Location;
+
+ for F in Files'Range loop
+
+ Put ("GHDL-XREF V0");
+
+ declare
+ use Xrefs;
+
+ Cur_Decl : Iir;
+ Cur_File : Source_File_Entry;
+
+ procedure Emit_Loc (Loc : Location_Type; C : Character)
+ is
+ L_File : Source_File_Entry;
+ L_Pos : Source_Ptr;
+ L_Line : Natural;
+ L_Off : Natural;
+ begin
+ Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off);
+ --Put_Nat (Natural (L_File));
+ --Put (':');
+ Put_Nat (L_Line);
+ Put (C);
+ Put_Nat (L_Off);
+ end Emit_Loc;
+
+ procedure Emit_Decl (N : Iir)
+ is
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ C : Character;
+ Dir : Name_Id;
+ begin
+ New_Line;
+ Cur_Decl := N;
+ Loc := Get_Location (N);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File /= Cur_File then
+ Cur_File := Loc_File;
+ Put ("XFILE: ");
+ Dir := Get_Source_File_Directory (Cur_File);
+ if Dir /= Null_Identifier then
+ Image (Dir);
+ Put (Name_Buffer (1 .. Name_Length));
+ end if;
+ Image (Get_File_Name (Cur_File));
+ Put (Name_Buffer (1 .. Name_Length));
+ New_Line;
+ end if;
+
+ -- Letters:
+ -- b d fgh jk no qr uvwxyz
+ -- D H JK MNO QR U WXYZ
+ case Get_Kind (N) is
+ when Iir_Kind_Type_Declaration =>
+ C := 'T';
+ when Iir_Kind_Subtype_Declaration =>
+ C := 't';
+ when Iir_Kind_Entity_Declaration =>
+ C := 'E';
+ when Iir_Kind_Architecture_Body =>
+ C := 'A';
+ when Iir_Kind_Library_Declaration =>
+ C := 'L';
+ when Iir_Kind_Package_Declaration =>
+ C := 'P';
+ when Iir_Kind_Package_Body =>
+ C := 'B';
+ when Iir_Kind_Function_Declaration =>
+ C := 'F';
+ when Iir_Kind_Procedure_Declaration =>
+ C := 'p';
+ when Iir_Kind_Interface_Signal_Declaration =>
+ C := 's';
+ when Iir_Kind_Signal_Declaration =>
+ C := 'S';
+ when Iir_Kind_Interface_Constant_Declaration =>
+ C := 'c';
+ when Iir_Kind_Constant_Declaration =>
+ C := 'C';
+ when Iir_Kind_Variable_Declaration =>
+ C := 'V';
+ when Iir_Kind_Element_Declaration =>
+ C := 'e';
+ when Iir_Kind_Iterator_Declaration =>
+ C := 'i';
+ when Iir_Kind_Attribute_Declaration =>
+ C := 'a';
+ when Iir_Kind_Enumeration_Literal =>
+ C := 'l';
+ when Iir_Kind_Component_Declaration =>
+ C := 'm';
+ when Iir_Kind_Component_Instantiation_Statement =>
+ C := 'I';
+ when Iir_Kind_Generate_Statement =>
+ C := 'G';
+ when others =>
+ C := '?';
+ end case;
+ Emit_Loc (Loc, C);
+ --Disp_Tree.Disp_Iir_Address (N);
+ Put (' ');
+ case Get_Kind (N) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when others =>
+ Image (Get_Identifier (N));
+ Put (Name_Buffer (1 .. Name_Length));
+ end case;
+ end Emit_Decl;
+
+ procedure Emit_Ref (R : Xref; T : Character)
+ is
+ N : Iir;
+ begin
+ N := Get_Xref_Node (R);
+ if N /= Cur_Decl then
+ Emit_Decl (N);
+ end if;
+ Put (' ');
+ Emit_Loc (Get_Xref_Location (R), T);
+ end Emit_Ref;
+
+ Loc : Location_Type;
+ Loc_File : Source_File_Entry;
+ Loc_Pos : Source_Ptr;
+ begin
+ Cur_Decl := Null_Iir;
+ Cur_File := No_Source_File_Entry;
+
+ for I in First_Xref .. Get_Last_Xref loop
+ Loc := Get_Xref_Location (I);
+ Location_To_File_Pos (Loc, Loc_File, Loc_Pos);
+ if Loc_File = Files (F).Fe then
+ -- This is a local location.
+ case Get_Xref_Kind (I) is
+ when Xref_Decl =>
+ Emit_Decl (Get_Xref_Node (I));
+ when Xref_End =>
+ Emit_Ref (I, 'e');
+ when Xref_Ref =>
+ Emit_Ref (I, 'r');
+ when Xref_Body =>
+ Emit_Ref (I, 'b');
+ end case;
+ end if;
+ end loop;
+ New_Line;
+ end;
+ end loop;
+ exception
+ when Compilation_Error =>
+ Error ("xrefs has failed due to compilation error");
+ end Perform_Action;
+
+ procedure Register_Commands is
+ begin
+ Register_Command (new Command_Chop);
+ Register_Command (new Command_Lines);
+ Register_Command (new Command_Reprint);
+ Register_Command (new Command_Compare_Tokens);
+ Register_Command (new Command_PP_Html);
+ Register_Command (new Command_Xref_Html);
+ Register_Command (new Command_Xref);
+ end Register_Commands;
+end Ghdlprint;
diff --git a/src/translate/ghdldrv/ghdlprint.ads b/src/translate/ghdldrv/ghdlprint.ads
new file mode 100644
index 000000000..82c3e6072
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlprint.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - print commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlprint is
+ procedure Register_Commands;
+end Ghdlprint;
diff --git a/src/translate/ghdldrv/ghdlrun.adb b/src/translate/ghdldrv/ghdlrun.adb
new file mode 100644
index 000000000..f6237214e
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlrun.adb
@@ -0,0 +1,661 @@
+-- GHDL driver - JIT commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces.C;
+
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Ada.Unchecked_Conversion;
+with Ada.Command_Line;
+with Ada.Text_IO;
+
+with Ortho_Jit;
+with Ortho_Nodes; use Ortho_Nodes;
+with Interfaces;
+with System; use System;
+with Trans_Decls;
+with Iirs; use Iirs;
+with Flags;
+with Errorout; use Errorout;
+with Libraries;
+with Canon;
+with Trans_Be;
+with Translation;
+with Ieee.Std_Logic_1164;
+
+with Lists;
+with Str_Table;
+with Nodes;
+with Files_Map;
+with Name_Table;
+
+with Grt.Main;
+with Grt.Modules;
+with Grt.Lib;
+with Grt.Processes;
+with Grt.Rtis;
+with Grt.Files;
+with Grt.Signals;
+with Grt.Options;
+with Grt.Types;
+with Grt.Images;
+with Grt.Values;
+with Grt.Names;
+with Grt.Std_Logic_1164;
+
+with Ghdlcomp;
+with Foreigns;
+with Grtlink;
+
+package body Ghdlrun is
+ procedure Foreign_Hook (Decl : Iir;
+ Info : Translation.Foreign_Info_Type;
+ Ortho : O_Dnode);
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ if Analyze_Only then
+ return;
+ end if;
+
+ Translation.Foreign_Hook := Foreign_Hook'Access;
+
+ -- FIXME: add a flag to force unnesting.
+ -- Translation.Flag_Unnest_Subprograms := True;
+
+ -- The design is always analyzed in whole.
+ Flags.Flag_Whole_Analyze := True;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ Ortho_Jit.Init;
+
+ Translation.Initialize;
+ Canon.Canon_Flag_Add_Labels := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+ if Sec_Name = null then
+ Sec_Name := new String'("");
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+ end Compile_Elab;
+
+ -- Set options.
+ -- This is a little bit over-kill: from C to Ada and then again to C...
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ use Interfaces.C;
+ use Grt.Options;
+ use Grt.Types;
+
+ function Malloc (Size : size_t) return Argv_Type;
+ pragma Import (C, Malloc);
+
+ function Strdup (Str : String) return Ghdl_C_String;
+ pragma Import (C, Strdup);
+-- is
+-- T : Grt.Types.String_Access;
+-- begin
+-- T := new String'(Str & Ghdllocal.Nul);
+-- return To_Ghdl_C_String (T.all'Address);
+-- end Strdup;
+ begin
+ Argc := 1 + Args'Length;
+ Argv := Malloc
+ (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit)));
+ Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul);
+ Progname := Argv (0);
+ for I in Args'Range loop
+ Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul);
+ end loop;
+ end Set_Run_Options;
+
+ procedure Ghdl_Elaborate;
+ pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ type Elaborate_Acc is access procedure;
+ pragma Convention (C, Elaborate_Acc);
+ Elaborate_Proc : Elaborate_Acc := null;
+
+ procedure Ghdl_Elaborate is
+ begin
+ --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate");
+ Elaborate_Proc.all;
+ end Ghdl_Elaborate;
+
+ procedure Def (Decl : O_Dnode; Addr : Address)
+ renames Ortho_Jit.Set_Address;
+
+ procedure Foreign_Hook (Decl : Iir;
+ Info : Translation.Foreign_Info_Type;
+ Ortho : O_Dnode)
+ is
+ use Translation;
+ Res : Address;
+ begin
+ case Info.Kind is
+ when Foreign_Vhpidirect =>
+ declare
+ Name : constant String :=
+ Name_Table.Name_Buffer (Info.Subprg_First
+ .. Info.Subprg_Last);
+ begin
+ Res := Foreigns.Find_Foreign (Name);
+ if Res /= Null_Address then
+ Def (Ortho, Res);
+ else
+ Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'",
+ Decl);
+ end if;
+ end;
+ when Foreign_Intrinsic =>
+ Name_Table.Image (Get_Identifier (Decl));
+ declare
+ Name : constant String :=
+ Name_Table.Name_Buffer (1 .. Name_Table.Name_Length);
+ begin
+ if Name = "untruncated_text_read" then
+ Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address);
+ elsif Name = "control_simulation" then
+ Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address);
+ elsif Name = "get_resolution_limit" then
+ Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address);
+ else
+ Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'",
+ Decl);
+ end if;
+ end;
+ when Foreign_Unknown =>
+ null;
+ end case;
+ end Foreign_Hook;
+
+ procedure Run
+ is
+ use Interfaces;
+ --use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Elaborate_Acc);
+ Err : Boolean;
+ Decl : O_Dnode;
+ begin
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Linking in memory");
+ end if;
+
+ Def (Trans_Decls.Ghdl_Memcpy,
+ Grt.Lib.Ghdl_Memcpy'Address);
+ Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1,
+ Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address);
+ Def (Trans_Decls.Ghdl_Malloc0,
+ Grt.Lib.Ghdl_Malloc0'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array,
+ Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address);
+
+ Def (Trans_Decls.Ghdl_Report,
+ Grt.Lib.Ghdl_Report'Address);
+ Def (Trans_Decls.Ghdl_Assert_Failed,
+ Grt.Lib.Ghdl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Ieee_Assert_Failed,
+ Grt.Lib.Ghdl_Ieee_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Psl_Assert_Failed,
+ Grt.Lib.Ghdl_Psl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Psl_Cover,
+ Grt.Lib.Ghdl_Psl_Cover'Address);
+ Def (Trans_Decls.Ghdl_Psl_Cover_Failed,
+ Grt.Lib.Ghdl_Psl_Cover_Failed'Address);
+ Def (Trans_Decls.Ghdl_Program_Error,
+ Grt.Lib.Ghdl_Program_Error'Address);
+ Def (Trans_Decls.Ghdl_Malloc,
+ Grt.Lib.Ghdl_Malloc'Address);
+ Def (Trans_Decls.Ghdl_Deallocate,
+ Grt.Lib.Ghdl_Deallocate'Address);
+ Def (Trans_Decls.Ghdl_Real_Exp,
+ Grt.Lib.Ghdl_Real_Exp'Address);
+ Def (Trans_Decls.Ghdl_Integer_Exp,
+ Grt.Lib.Ghdl_Integer_Exp'Address);
+
+ Def (Trans_Decls.Ghdl_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Process_Register,
+ Grt.Processes.Ghdl_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Finalize_Register,
+ Grt.Processes.Ghdl_Finalize_Register'Address);
+
+ Def (Trans_Decls.Ghdl_Stack2_Allocate,
+ Grt.Processes.Ghdl_Stack2_Allocate'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Mark,
+ Grt.Processes.Ghdl_Stack2_Mark'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Release,
+ Grt.Processes.Ghdl_Stack2_Release'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Exit,
+ Grt.Processes.Ghdl_Process_Wait_Exit'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Suspend,
+ Grt.Processes.Ghdl_Process_Wait_Suspend'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Close,
+ Grt.Processes.Ghdl_Process_Wait_Close'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Add_Sensitivity'Address);
+
+ Def (Trans_Decls.Ghdl_Now,
+ Grt.Types.Current_Time'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Driver,
+ Grt.Signals.Ghdl_Process_Add_Driver'Address);
+ Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver,
+ Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Add_Source,
+ Grt.Signals.Ghdl_Signal_Add_Source'Address);
+ Def (Trans_Decls.Ghdl_Signal_In_Conversion,
+ Grt.Signals.Ghdl_Signal_In_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Out_Conversion,
+ Grt.Signals.Ghdl_Signal_Out_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Effective_Value,
+ Grt.Signals.Ghdl_Signal_Effective_Value'Address);
+ Def (Trans_Decls.Ghdl_Signal_Create_Resolution,
+ Grt.Signals.Ghdl_Signal_Create_Resolution'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Disconnect,
+ Grt.Signals.Ghdl_Signal_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Set_Disconnect,
+ Grt.Signals.Ghdl_Signal_Set_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Merge_Rti,
+ Grt.Signals.Ghdl_Signal_Merge_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Name_Rti,
+ Grt.Signals.Ghdl_Signal_Name_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Port,
+ Grt.Signals.Ghdl_Signal_Read_Port'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Driver,
+ Grt.Signals.Ghdl_Signal_Read_Driver'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Driving,
+ Grt.Signals.Ghdl_Signal_Driving'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_B1,
+ Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8,
+ Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32,
+ Grt.Signals.Ghdl_Signal_Driving_Value_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Create_Guard,
+ Grt.Signals.Ghdl_Signal_Create_Guard'Address);
+ Def (Trans_Decls.Ghdl_Signal_Guard_Dependence,
+ Grt.Signals.Ghdl_Signal_Guard_Dependence'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Direct_Assign,
+ Grt.Signals.Ghdl_Signal_Direct_Assign'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_B1,
+ Grt.Signals.Ghdl_Create_Signal_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_B1,
+ Grt.Signals.Ghdl_Signal_Init_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_B1,
+ Grt.Signals.Ghdl_Signal_Associate_B1'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_E8,
+ Grt.Signals.Ghdl_Create_Signal_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_E8,
+ Grt.Signals.Ghdl_Signal_Init_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_E8,
+ Grt.Signals.Ghdl_Signal_Associate_E8'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_E32,
+ Grt.Signals.Ghdl_Create_Signal_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_E32,
+ Grt.Signals.Ghdl_Signal_Init_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_E32,
+ Grt.Signals.Ghdl_Signal_Associate_E32'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I32,
+ Grt.Signals.Ghdl_Create_Signal_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I32,
+ Grt.Signals.Ghdl_Signal_Init_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I32,
+ Grt.Signals.Ghdl_Signal_Associate_I32'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I64,
+ Grt.Signals.Ghdl_Create_Signal_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I64,
+ Grt.Signals.Ghdl_Signal_Init_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I64,
+ Grt.Signals.Ghdl_Signal_Associate_I64'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_F64,
+ Grt.Signals.Ghdl_Create_Signal_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_F64,
+ Grt.Signals.Ghdl_Signal_Init_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_F64,
+ Grt.Signals.Ghdl_Signal_Associate_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix,
+ Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address);
+ Def (Trans_Decls.Ghdl_Create_Stable_Signal,
+ Grt.Signals.Ghdl_Create_Stable_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Quiet_Signal,
+ Grt.Signals.Ghdl_Create_Quiet_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Transaction_Signal,
+ Grt.Signals.Ghdl_Create_Transaction_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Delayed_Signal,
+ Grt.Signals.Ghdl_Create_Delayed_Signal'Address);
+
+ Def (Trans_Decls.Ghdl_Rti_Add_Package,
+ Grt.Rtis.Ghdl_Rti_Add_Package'Address);
+ Def (Trans_Decls.Ghdl_Rti_Add_Top,
+ Grt.Rtis.Ghdl_Rti_Add_Top'Address);
+
+ Def (Trans_Decls.Ghdl_Protected_Enter,
+ Grt.Processes.Ghdl_Protected_Enter'Address);
+ Def (Trans_Decls.Ghdl_Protected_Leave,
+ Grt.Processes.Ghdl_Protected_Leave'Address);
+ Def (Trans_Decls.Ghdl_Protected_Init,
+ Grt.Processes.Ghdl_Protected_Init'Address);
+ Def (Trans_Decls.Ghdl_Protected_Fini,
+ Grt.Processes.Ghdl_Protected_Fini'Address);
+
+ Def (Trans_Decls.Ghdl_Text_File_Elaborate,
+ Grt.Files.Ghdl_Text_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Finalize,
+ Grt.Files.Ghdl_Text_File_Finalize'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Open,
+ Grt.Files.Ghdl_Text_File_Open'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Open_Status,
+ Grt.Files.Ghdl_Text_File_Open_Status'Address);
+ Def (Trans_Decls.Ghdl_Text_Write,
+ Grt.Files.Ghdl_Text_Write'Address);
+ Def (Trans_Decls.Ghdl_Text_Read_Length,
+ Grt.Files.Ghdl_Text_Read_Length'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Close,
+ Grt.Files.Ghdl_Text_File_Close'Address);
+
+ Def (Trans_Decls.Ghdl_File_Elaborate,
+ Grt.Files.Ghdl_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_File_Finalize,
+ Grt.Files.Ghdl_File_Finalize'Address);
+ Def (Trans_Decls.Ghdl_File_Open,
+ Grt.Files.Ghdl_File_Open'Address);
+ Def (Trans_Decls.Ghdl_File_Open_Status,
+ Grt.Files.Ghdl_File_Open_Status'Address);
+ Def (Trans_Decls.Ghdl_File_Close,
+ Grt.Files.Ghdl_File_Close'Address);
+ Def (Trans_Decls.Ghdl_File_Flush,
+ Grt.Files.Ghdl_File_Flush'Address);
+ Def (Trans_Decls.Ghdl_Write_Scalar,
+ Grt.Files.Ghdl_Write_Scalar'Address);
+ Def (Trans_Decls.Ghdl_Read_Scalar,
+ Grt.Files.Ghdl_Read_Scalar'Address);
+
+ Def (Trans_Decls.Ghdl_File_Endfile,
+ Grt.Files.Ghdl_File_Endfile'Address);
+
+ Def (Trans_Decls.Ghdl_Image_B1,
+ Grt.Images.Ghdl_Image_B1'Address);
+ Def (Trans_Decls.Ghdl_Image_E8,
+ Grt.Images.Ghdl_Image_E8'Address);
+ Def (Trans_Decls.Ghdl_Image_E32,
+ Grt.Images.Ghdl_Image_E32'Address);
+ Def (Trans_Decls.Ghdl_Image_I32,
+ Grt.Images.Ghdl_Image_I32'Address);
+ Def (Trans_Decls.Ghdl_Image_F64,
+ Grt.Images.Ghdl_Image_F64'Address);
+ Def (Trans_Decls.Ghdl_Image_P64,
+ Grt.Images.Ghdl_Image_P64'Address);
+ Def (Trans_Decls.Ghdl_Image_P32,
+ Grt.Images.Ghdl_Image_P32'Address);
+
+ Def (Trans_Decls.Ghdl_Value_B1,
+ Grt.Values.Ghdl_Value_B1'Address);
+ Def (Trans_Decls.Ghdl_Value_E8,
+ Grt.Values.Ghdl_Value_E8'Address);
+ Def (Trans_Decls.Ghdl_Value_E32,
+ Grt.Values.Ghdl_Value_E32'Address);
+ Def (Trans_Decls.Ghdl_Value_I32,
+ Grt.Values.Ghdl_Value_I32'Address);
+ Def (Trans_Decls.Ghdl_Value_F64,
+ Grt.Values.Ghdl_Value_F64'Address);
+ Def (Trans_Decls.Ghdl_Value_P32,
+ Grt.Values.Ghdl_Value_P32'Address);
+ Def (Trans_Decls.Ghdl_Value_P64,
+ Grt.Values.Ghdl_Value_P64'Address);
+
+ Def (Trans_Decls.Ghdl_Get_Path_Name,
+ Grt.Names.Ghdl_Get_Path_Name'Address);
+ Def (Trans_Decls.Ghdl_Get_Instance_Name,
+ Grt.Names.Ghdl_Get_Instance_Name'Address);
+
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address);
+
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address);
+
+ Def (Trans_Decls.Ghdl_To_String_I32,
+ Grt.Images.Ghdl_To_String_I32'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64,
+ Grt.Images.Ghdl_To_String_F64'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64_Digits,
+ Grt.Images.Ghdl_To_String_F64_Digits'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64_Format,
+ Grt.Images.Ghdl_To_String_F64_Format'Address);
+ Def (Trans_Decls.Ghdl_To_String_B1,
+ Grt.Images.Ghdl_To_String_B1'Address);
+ Def (Trans_Decls.Ghdl_To_String_E8,
+ Grt.Images.Ghdl_To_String_E8'Address);
+ Def (Trans_Decls.Ghdl_To_String_E32,
+ Grt.Images.Ghdl_To_String_E32'Address);
+ Def (Trans_Decls.Ghdl_To_String_Char,
+ Grt.Images.Ghdl_To_String_Char'Address);
+ Def (Trans_Decls.Ghdl_To_String_P32,
+ Grt.Images.Ghdl_To_String_P32'Address);
+ Def (Trans_Decls.Ghdl_To_String_P64,
+ Grt.Images.Ghdl_To_String_P64'Address);
+ Def (Trans_Decls.Ghdl_Time_To_String_Unit,
+ Grt.Images.Ghdl_Time_To_String_Unit'Address);
+ Def (Trans_Decls.Ghdl_BV_To_Ostring,
+ Grt.Images.Ghdl_BV_To_Ostring'Address);
+ Def (Trans_Decls.Ghdl_BV_To_Hstring,
+ Grt.Images.Ghdl_BV_To_Hstring'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_B1,
+ Grt.Images.Ghdl_Array_Char_To_String_B1'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_E8,
+ Grt.Images.Ghdl_Array_Char_To_String_E8'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_E32,
+ Grt.Images.Ghdl_Array_Char_To_String_E32'Address);
+
+ Ortho_Jit.Link (Err);
+ if Err then
+ raise Compile_Error;
+ end if;
+
+ Grtlink.Std_Standard_Boolean_RTI_Ptr :=
+ Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti);
+ Grtlink.Std_Standard_Bit_RTI_Ptr :=
+ Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti);
+ if Ieee.Std_Logic_1164.Resolved /= Null_Iir then
+ Decl := Translation.Get_Resolv_Ortho_Decl
+ (Ieee.Std_Logic_1164.Resolved);
+ if Decl /= O_Dnode_Null then
+ Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr :=
+ Ortho_Jit.Get_Address (Decl);
+ end if;
+ end if;
+
+ Grtlink.Flag_String := Flags.Flag_String;
+
+ Elaborate_Proc :=
+ Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate));
+
+ Ortho_Jit.Finish;
+
+ Translation.Finalize;
+ Lists.Initialize;
+ Str_Table.Initialize;
+ Nodes.Initialize;
+ Files_Map.Initialize;
+ Name_Table.Initialize;
+
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Starting simulation");
+ end if;
+
+ Grt.Main.Run;
+ --V := Ghdl_Main (1, Gnat_Argv);
+ end Run;
+
+
+ -- Command run help.
+ type Command_Run_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--run-help";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--run-help Disp help for RUNOPTS options";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ if Args'Length /= 0 then
+ Error
+ ("warning: command '--run-help' does not accept any argument");
+ end if;
+ Put_Line ("These options can only be placed at [RUNOPTS]");
+ -- Register modules, since they add commands.
+ Grt.Modules.Register_Modules;
+ -- Bypass usual help header.
+ Grt.Options.Argc := 0;
+ Grt.Options.Help;
+ end Perform_Action;
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Ortho_Jit.Decode_Option'Access,
+ Ortho_Jit.Disp_Help'Access);
+ Ghdlcomp.Register_Commands;
+ Register_Command (new Command_Run_Help);
+ Trans_Be.Register_Translation_Back_End;
+ end Register_Commands;
+end Ghdlrun;
diff --git a/src/translate/ghdldrv/ghdlrun.ads b/src/translate/ghdldrv/ghdlrun.ads
new file mode 100644
index 000000000..07095bd5d
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlrun.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - JIT commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlrun is
+ procedure Register_Commands;
+end Ghdlrun;
diff --git a/src/translate/ghdldrv/ghdlsimul.adb b/src/translate/ghdldrv/ghdlsimul.adb
new file mode 100644
index 000000000..17cece726
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlsimul.adb
@@ -0,0 +1,209 @@
+-- GHDL driver - simulator commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Text_IO;
+with Ada.Command_Line;
+
+with Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Types;
+with Iirs; use Iirs;
+with Flags;
+with Back_End;
+with Name_Table;
+with Errorout; use Errorout;
+with Std_Package;
+with Libraries;
+with Canon;
+with Configuration;
+with Iirs_Utils;
+with Annotations;
+with Elaboration;
+with Sim_Be;
+with Simulation;
+with Execution;
+
+with Ghdlcomp;
+
+with Grt.Vpi;
+pragma Unreferenced (Grt.Vpi);
+with Grt.Types;
+with Grt.Options;
+with Grtlink;
+
+package body Ghdlsimul is
+
+ -- FIXME: reuse simulation.top_config
+ Top_Conf : Iir;
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ if Analyze_Only then
+ return;
+ end if;
+
+ -- Initialize.
+ Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access;
+ Back_End.Sem_Foreign := null;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ -- Here, time_base can be set.
+ Annotations.Annotate (Std_Package.Std_Standard_Unit);
+
+ Canon.Canon_Flag_Add_Labels := True;
+ Canon.Canon_Flag_Sequentials_Stmts := True;
+ Canon.Canon_Flag_Expressions := True;
+ Canon.Canon_Flag_All_Sensitivity := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ use Name_Table;
+ use Types;
+
+ First_Id : Name_Id;
+ Sec_Id : Name_Id;
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+
+ Flags.Flag_Elaborate := True;
+ -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+
+ First_Id := Get_Identifier (Prim_Name.all);
+ if Sec_Name = null then
+ Sec_Id := Null_Identifier;
+ else
+ Sec_Id := Get_Identifier (Sec_Name.all);
+ end if;
+ Top_Conf := Configuration.Configure (First_Id, Sec_Id);
+ if Top_Conf = Null_Iir then
+ raise Compilation_Error;
+ end if;
+
+ -- Check (and possibly abandon) if entity can be at the top of the
+ -- hierarchy.
+ declare
+ Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf);
+ Arch : constant Iir :=
+ Get_Block_Specification (Get_Block_Configuration (Conf_Unit));
+ Entity : constant Iir := Iirs_Utils.Get_Entity (Arch);
+ begin
+ Configuration.Check_Entity_Declaration_Top (Entity);
+ if Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+ end;
+ end Compile_Elab;
+
+ -- Set options.
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ use Grt.Options;
+ use Types;
+ Arg : String_Access;
+ Status : Decode_Option_Status;
+ Argv0 : String_Acc;
+ begin
+ -- Set progname (used for grt error messages)
+ Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul);
+ Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address);
+
+ for I in Args'Range loop
+ Arg := Args (I);
+ if Arg.all = "--disp-tree" then
+ Simulation.Disp_Tree := True;
+ elsif Arg.all = "--expect-failure" then
+ Decode_Option (Arg.all, Status);
+ pragma Assert (Status = Decode_Option_Ok);
+ elsif Arg.all = "--trace-elab" then
+ Elaboration.Trace_Elaboration := True;
+ elsif Arg.all = "--trace-drivers" then
+ Elaboration.Trace_Drivers := True;
+ elsif Arg.all = "--trace-annotation" then
+ Annotations.Trace_Annotation := True;
+ elsif Arg.all = "--trace-simu" then
+ Simulation.Trace_Simulation := True;
+ elsif Arg.all = "--trace-stmt" then
+ Execution.Trace_Statements := True;
+ elsif Arg.all = "--stats" then
+ Simulation.Disp_Stats := True;
+ elsif Arg.all = "-i" then
+ Simulation.Flag_Interractive := True;
+ else
+ Decode_Option (Arg.all, Status);
+ case Status is
+ when Decode_Option_Last =>
+ exit;
+ when Decode_Option_Help =>
+ -- FIXME: is that correct ?
+ exit;
+ when Decode_Option_Ok =>
+ null;
+ end case;
+ -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'");
+ -- raise Option_Error;
+ end if;
+ end loop;
+ end Set_Run_Options;
+
+ procedure Run is
+ begin
+ Grtlink.Flag_String := Flags.Flag_String;
+
+ Simulation.Simulation_Entity (Top_Conf);
+ end Run;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ begin
+ if Option = "--debug" then
+ Simulation.Flag_Debugger := True;
+ else
+ return False;
+ end if;
+ return True;
+ end Decode_Option;
+
+ procedure Disp_Long_Help
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (" --debug Run with debugger");
+ end Disp_Long_Help;
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Decode_Option'Access,
+ Disp_Long_Help'Access);
+ Ghdlcomp.Register_Commands;
+ end Register_Commands;
+end Ghdlsimul;
diff --git a/src/translate/ghdldrv/ghdlsimul.ads b/src/translate/ghdldrv/ghdlsimul.ads
new file mode 100644
index 000000000..264cbf8c6
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlsimul.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - simulator commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlsimul is
+ procedure Register_Commands;
+end Ghdlsimul;
diff --git a/src/translate/ghdldrv/grtlink.ads b/src/translate/ghdldrv/grtlink.ads
new file mode 100644
index 000000000..4b3951e78
--- /dev/null
+++ b/src/translate/ghdldrv/grtlink.ads
@@ -0,0 +1,39 @@
+-- GHDL driver - shared variables with grt.
+-- Copyright (C) 2011 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System; use System;
+
+package Grtlink is
+
+ Flag_String : String (1 .. 5);
+ pragma Export (C, Flag_String, "__ghdl_flag_string");
+
+ Std_Standard_Bit_RTI_Ptr : Address := Null_Address;
+
+ Std_Standard_Boolean_RTI_Ptr : Address := Null_Address;
+
+ pragma Export (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Export (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address;
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+end Grtlink;
diff --git a/src/translate/grt/Makefile b/src/translate/grt/Makefile
new file mode 100644
index 000000000..107aef7bf
--- /dev/null
+++ b/src/translate/grt/Makefile
@@ -0,0 +1,56 @@
+# -*- Makefile -*- for the GHDL Run Time library.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+GRT_FLAGS=-g -O
+GRT_ADAFLAGS=-gnatn
+
+ADAC=gcc
+CC=gcc
+GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu
+GHDL1=../ghdl1-gcc
+GRTSRCDIR=.
+GRT_RANLIB=ranlib
+
+INSTALL=install
+INSTALL_DATA=$(INSTALL) -m 644
+
+prefix=/usr/local
+exec_prefix=$(prefix)
+libdir=$(exec_prefix)/lib
+grt_libdir=$(libdir)
+
+target:=$(shell $(CC) -dumpmachine)
+
+all: grt-all
+install: grt-install
+clean: grt-clean
+ $(RM) *~
+
+show_target:
+ echo "Target is $(target)"
+
+include Makefile.inc
+
+
+GRT_CFLAGS=$(GRT_FLAGS) -Wall
+ghwdump: ghwdump.o ghwlib.o
+ $(CC) $(GRT_CFLAGS) -o $@ ghwdump.o ghwlib.o
+
+ghwlib.o: ghwlib.c ghwlib.h
+ $(CC) -c $(GRT_CFLAGS) -o $@ $<
+ghwdump.o: ghwdump.c ghwlib.h
+ $(CC) -c $(GRT_CFLAGS) -o $@ $<
diff --git a/src/translate/grt/Makefile.inc b/src/translate/grt/Makefile.inc
new file mode 100644
index 000000000..ec1b0df09
--- /dev/null
+++ b/src/translate/grt/Makefile.inc
@@ -0,0 +1,226 @@
+# -*- Makefile -*- for the GHDL Run Time library.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+# Variables used:
+# AR: ar command
+# RM
+# CC
+# ADAC: the GNAT compiler
+# GHDL1: the ghdl compiler
+# GRT_RANLIB: the ranlib tool for the grt library.
+# grt_libdir: the place to put grt.
+# GRTSRCDIR: the source directory of grt.
+# target: GCC target
+# GRT_FLAGS: common (Ada + C + asm) compilation flags.
+# GRT_ADAFLAGS: compilation flags for Ada
+
+# Convert the target variable into a space separated list of architecture,
+# manufacturer, and operating system and assign each of those to its own
+# variable.
+
+target1:=$(subst -gnu,,$(target))
+targ:=$(subst -, ,$(target1))
+arch:=$(word 1,$(targ))
+ifeq ($(words $(targ)),2)
+ osys:=$(word 2,$(targ))
+else
+ osys:=$(word 3,$(targ))
+endif
+
+GRT_ELF_OPTS:=-Wl,--version-script=@/grt.ver -Wl,--export-dynamic
+
+# Set target files.
+ifeq ($(filter-out i%86 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out i%86 freebsd%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS)
+ ADAC=ada
+endif
+ifeq ($(filter-out x86_64 freebsd%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS)
+ ADAC=ada
+endif
+ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=
+endif
+ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=
+endif
+ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=sparc.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm
+endif
+ifeq ($(filter-out powerpc linux%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=ppc.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out ia64 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=ia64.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out i%86 mingw32,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=win32.o clock.o
+endif
+# Doesn't work for unknown reasons.
+#ifeq ($(filter-out i%86 cygwin,$(arch) $(osys)),)
+# GRT_TARGET_OBJS=win32.o clock.o
+#endif
+# Fall-back: use a generic implementation based on pthreads.
+ifndef GRT_TARGET_OBJS
+ GRT_TARGET_OBJS=pthread.o times.o
+ GRT_EXTRA_LIB=-lpthread -ldl -lm
+endif
+
+# Additionnal object files (C or asm files).
+GRT_ADD_OBJS:=$(GRT_TARGET_OBJS) grt-cbinding.o grt-cvpi.o
+
+#GRT_USE_PTHREADS=y
+ifeq ($(GRT_USE_PTHREADS),y)
+ GRT_CFLAGS+=-DUSE_THREADS
+ GRT_ADD_OBJS+=grt-cthreads.o
+ GRT_EXTRA_LIB+=-lpthread
+endif
+
+GRT_ARCH?=None
+
+# Configuration pragmas.
+GRT_PRAGMA_FLAG=-gnatec$(GRTSRCDIR)/grt.adc -gnat05
+
+# Rule to compile an Ada file.
+GRT_ADACOMPILE=$(ADAC) -c $(GRT_FLAGS) $(GRT_PRAGMA_FLAG) -o $@ $<
+
+grt-all: libgrt.a grt.lst
+
+libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads
+ $(RM) -f $@
+ $(AR) rcv $@ `sed -e "/^-/d" < grt-files` $(GRT_ADD_OBJS) \
+ run-bind.o main.o
+ $(GRT_RANLIB) $@
+
+run-bind.adb: grt-force
+ gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \
+ ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS)
+ gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali
+
+#system.ads:
+# sed -e "/Configurable_Run_Time/s/False/True/" \
+# -e "/Suppress_Standard_Library/s/False/True/" \
+# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@
+
+run-bind.o: run-bind.adb
+ $(GRT_ADACOMPILE)
+
+main.o: $(GRTSRCDIR)/main.adb
+ $(GRT_ADACOMPILE)
+
+i386.o: $(GRTSRCDIR)/config/i386.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+chkstk.o: $(GRTSRCDIR)/config/chkstk.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+sparc.o: $(GRTSRCDIR)/config/sparc.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+ppc.o: $(GRTSRCDIR)/config/ppc.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+ia64.o: $(GRTSRCDIR)/config/ia64.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+amd64.o: $(GRTSRCDIR)/config/amd64.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+linux.o: $(GRTSRCDIR)/config/linux.c
+ $(CC) -c $(GRT_FLAGS) $(GRT_CFLAGS) -o $@ $<
+
+win32.o: $(GRTSRCDIR)/config/win32.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+win32thr.o: $(GRTSRCDIR)/config/win32thr.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+pthread.o: $(GRTSRCDIR)/config/pthread.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+times.o : $(GRTSRCDIR)/config/times.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+clock.o : $(GRTSRCDIR)/config/clock.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cbinding.o: $(GRTSRCDIR)/grt-cbinding.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cvpi.o: $(GRTSRCDIR)/grt-cvpi.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cthreads.o: $(GRTSRCDIR)/grt-cthreads.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-disp-config:
+ @echo "target: $(target)"
+ @echo "targ: $(targ)"
+ @echo "arch: $(arch)"
+ @echo "osys: $(osys)"
+
+grt-files: run-bind.adb
+ sed -e "1,/-- *BEGIN/d" -e "/-- *END/,\$$d" \
+ -e "s/ -- //" < $< > $@
+
+grt-arch.ads:
+ echo "With Grt.Arch_$(GRT_ARCH);" > $@
+ echo "Package Grt.Arch renames Grt.Arch_$(GRT_ARCH);" >> $@
+
+# Remove local files (they are now in the libgrt library).
+# Also, remove the -shared option, in order not to build a shared library
+# instead of an executable.
+# Also remove -lgnat and its associated -L flags. This appears to be required
+# with GNAT GPL 2005.
+grt-files.in: grt-files
+ sed -e "\!^./!d" -e "/-shared/d" -e "/-static/d" -e "/-lgnat/d" \
+ -e "\X-L/Xd" < $< > $@
+
+grt.lst: grt-files.in
+ echo "@/libgrt.a" > $@
+ifdef GRT_EXTRA_LIB
+ for i in $(GRT_EXTRA_LIB); do echo $$i >> $@; done
+endif
+ cat $< >> $@
+
+grt-install: libgrt.a grt.lst
+ $(INSTALL_DATA) libgrt.a $(DESTDIR)$(grt_libdir)/libgrt.a
+ $(INSTALL_DATA) grt.lst $(DESTDIR)$(grt_libdir)/grt.lst
+
+grt-force:
+
+grt-clean: grt-force
+ $(RM) *.o *.ali run-bind.adb run-bind.ads *.a std_standard.s
+ $(RM) grt-files grt-files.in grt.lst
+
+.PHONY: grt-all grt-force grt-clean grt-install
diff --git a/src/translate/grt/config/Makefile b/src/translate/grt/config/Makefile
new file mode 100644
index 000000000..7d5f57def
--- /dev/null
+++ b/src/translate/grt/config/Makefile
@@ -0,0 +1,14 @@
+CFLAGS=-Wall -g
+
+#ARCH_OBJS=i386.o linux.o
+ARCH_OBJS=ppc.o linux.o
+
+teststack: teststack.o $(ARCH_OBJS)
+ $(CC) -o $@ $< $(ARCH_OBJS)
+
+ppc.o: ppc.S
+ $(CC) -c -o $@ -g $<
+
+clean:
+ $(RM) -f *.o *~ teststack
+
diff --git a/src/translate/grt/config/amd64.S b/src/translate/grt/config/amd64.S
new file mode 100644
index 000000000..0a7f0044b
--- /dev/null
+++ b/src/translate/grt/config/amd64.S
@@ -0,0 +1,131 @@
+/* GRT stack implementation for amd64 (x86_64)
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "amd64.S"
+
+#ifdef __ELF__
+#define ENTRY(func) .align 4; .globl func; .type func,@function; func:
+#define END(func) .size func, . - func
+#define NAME(name) name
+#elif __APPLE__
+#define ENTRY(func) .align 4; .globl _##func; _##func:
+#define END(func)
+#define NAME(name) _##name
+#else
+#define ENTRY(func) .align 4; func:
+#define END(func)
+#define NAME(name) name
+#endif
+ .text
+
+ /* Function called to loop on the process. */
+ENTRY(grt_stack_loop)
+ mov 0(%rsp),%rdi
+ call *8(%rsp)
+ jmp NAME(grt_stack_loop)
+END(grt_stack_loop)
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type;
+ Args: FUNC (RDI), ARG (RSI)
+ */
+ENTRY(grt_stack_create)
+ /* Standard prologue. */
+ pushq %rbp
+ movq %rsp,%rbp
+ /* Save args. */
+ sub $0x10,%rsp
+ mov %rdi,-8(%rbp)
+ mov %rsi,-16(%rbp)
+
+ /* Allocate the stack, and exit in case of failure */
+ callq NAME(grt_stack_allocate)
+ test %rax,%rax
+ je .Ldone
+
+ /* Note: %RAX contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* The function to be executed. */
+ mov -8(%rbp), %rdi
+ mov %rdi, -8(%rax)
+ /* The argument. */
+ mov -16(%rbp), %rsi
+ mov %rsi, -16(%rax)
+ /* The return function. Must be 8 mod 16. */
+#if __APPLE__
+ movq _grt_stack_loop@GOTPCREL(%rip), %rsi
+ movq %rsi, -24(%rax)
+#else
+ movq $grt_stack_loop, -24(%rax)
+#endif
+ /* The context. */
+ mov %rbp, -32(%rax)
+ mov %rbx, -40(%rax)
+ mov %r12, -48(%rax)
+ mov %r13, -56(%rax)
+ mov %r14, -64(%rax)
+ mov %r15, -72(%rax)
+
+ /* Save the new stack pointer to the stack context. */
+ lea -72(%rax), %rsi
+ mov %rsi, (%rax)
+
+.Ldone:
+ leave
+ ret
+END(grt_stack_create)
+
+
+
+ /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)]
+ Both are pointers to a stack_context. */
+ENTRY(grt_stack_switch)
+ /* Save call-used registers. */
+ pushq %rbp
+ pushq %rbx
+ pushq %r12
+ pushq %r13
+ pushq %r14
+ pushq %r15
+ /* Save the current stack. */
+ movq %rsp, (%rsi)
+ /* Stack switch. */
+ movq (%rdi), %rsp
+ /* Restore call-used registers. */
+ popq %r15
+ popq %r14
+ popq %r13
+ popq %r12
+ popq %rbx
+ popq %rbp
+ /* Return val. */
+ movq %rdx, %rax
+ /* Run. */
+ ret
+END(grt_stack_switch)
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/chkstk.S b/src/translate/grt/config/chkstk.S
new file mode 100644
index 000000000..ab244d0cd
--- /dev/null
+++ b/src/translate/grt/config/chkstk.S
@@ -0,0 +1,53 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "chkstk.S"
+ .version "01.01"
+
+ .text
+
+#ifdef __APPLE__
+#define __chkstk ___chkstk
+#endif
+
+ /* Function called to loop on the process. */
+ .align 4
+#ifdef __ELF__
+ .type __chkstk,@function
+#endif
+ .globl __chkstk
+__chkstk:
+ testl %eax,%eax
+ je 0f
+ subl $4,%eax /* 4 bytes already used by call. */
+ subl %eax,%esp
+ jmp *(%esp,%eax)
+0:
+ ret
+#ifdef __ELF__
+ .size __chkstk, . - __chkstk
+#endif
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/clock.c b/src/translate/grt/config/clock.c
new file mode 100644
index 000000000..242af604b
--- /dev/null
+++ b/src/translate/grt/config/clock.c
@@ -0,0 +1,43 @@
+/* GRT C bindings for time.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#include <time.h>
+
+int
+grt_get_clk_tck (void)
+{
+ return CLOCKS_PER_SEC;
+}
+
+void
+grt_get_times (int *wall, int *user, int *sys)
+{
+ clock_t res;
+
+ *wall = clock ();
+ *user = 0;
+ *sys = 0;
+}
+
diff --git a/src/translate/grt/config/i386.S b/src/translate/grt/config/i386.S
new file mode 100644
index 000000000..00d4719ac
--- /dev/null
+++ b/src/translate/grt/config/i386.S
@@ -0,0 +1,141 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "i386.S"
+ .version "01.01"
+
+ .text
+
+#ifdef __ELF__
+#define ENTRY(func) .align 4; .globl func; .type func,@function; func:
+#define END(func) .size func, . - func
+#define NAME(name) name
+#elif __APPLE__
+#define ENTRY(func) .align 4; .globl _##func; _##func:
+#define END(func)
+#define NAME(name) _##name
+#else
+#define ENTRY(func) .align 4; func:
+#define END(func)
+#define NAME(name) name
+#endif
+
+ /* Function called to loop on the process. */
+ENTRY(grt_stack_loop)
+ call *4(%esp)
+ jmp NAME(grt_stack_loop)
+END(grt_stack_loop)
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type;
+ */
+ENTRY(grt_stack_create)
+ /* Standard prologue. */
+ pushl %ebp
+ movl %esp,%ebp
+ /* Keep aligned (call + pushl + 8 = 16 bytes). */
+ subl $8,%esp
+
+ /* Allocate the stack, and exit in case of failure */
+ call NAME(grt_stack_allocate)
+ testl %eax,%eax
+ je .Ldone
+
+ /* Note: %EAX contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* The function to be executed. */
+ movl 8(%ebp), %ecx
+ movl %ecx, -4(%eax)
+ /* The argument. */
+ movl 12(%ebp), %ecx
+ movl %ecx, -8(%eax)
+ /* The return function. */
+#if __APPLE__
+ call ___x86.get_pc_thunk.cx
+L1$pb:
+ movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %ecx
+ movl %ecx,-12(%eax)
+#else
+ movl $NAME(grt_stack_loop), -12(%eax)
+#endif
+ /* The context. */
+ movl %ebx, -16(%eax)
+ movl %esi, -20(%eax)
+ movl %edi, -24(%eax)
+ movl %ebp, -28(%eax)
+
+ /* Save the new stack pointer to the stack context. */
+ leal -28(%eax), %ecx
+ movl %ecx, (%eax)
+
+.Ldone:
+ leave
+ ret
+END(grt_stack_create)
+
+
+ /* Arguments: TO, FROM
+ Both are pointers to a stack_context. */
+ENTRY(grt_stack_switch)
+ /* TO -> ECX. */
+ movl 4(%esp), %ecx
+ /* FROM -> EDX. */
+ movl 8(%esp), %edx
+ /* Save call-used registers. */
+ pushl %ebx
+ pushl %esi
+ pushl %edi
+ pushl %ebp
+ /* Save the current stack. */
+ movl %esp, (%edx)
+ /* Stack switch. */
+ movl (%ecx), %esp
+ /* Restore call-used registers. */
+ popl %ebp
+ popl %edi
+ popl %esi
+ popl %ebx
+ /* Run. */
+ ret
+END(grt_stack_switch)
+
+
+#if __APPLE__
+ .section __TEXT,__textcoal_nt,coalesced,pure_instructions
+ .weak_definition ___x86.get_pc_thunk.cx
+ .private_extern ___x86.get_pc_thunk.cx
+___x86.get_pc_thunk.cx:
+ movl (%esp), %ecx
+ ret
+
+ .section __IMPORT,__pointers,non_lazy_symbol_pointers
+L_grt_stack_loop$non_lazy_ptr:
+ .indirect_symbol _grt_stack_loop
+ .long 0
+#endif
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/ia64.S b/src/translate/grt/config/ia64.S
new file mode 100644
index 000000000..9ce3800bb
--- /dev/null
+++ b/src/translate/grt/config/ia64.S
@@ -0,0 +1,331 @@
+/* GRT stack implementation for ia64.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "ia64.S"
+ .pred.safe_across_calls p1-p5,p16-p63
+
+ .text
+ .align 16
+ .proc grt_stack_loop
+grt_stack_loop:
+ alloc r32 = ar.pfs, 0, 1, 1, 0
+ .body
+ ;;
+1: mov r33 = r4
+ br.call.sptk.many b0 = b1
+ ;;
+ br 1b
+ .endp
+
+ frame_size = 480
+
+ .global grt_stack_switch#
+ .proc grt_stack_switch#
+ /* r32: struct stack_context *TO, r33: struct stack_context *FROM. */
+ // Registers to be saved:
+ // ar.rsc, ar.bsp, ar.pfs, ar.lc, ar.rnat [5]
+ // gp, r4-r7 (+ Nat) [6]
+ // f2-f5, f16-f31 [20]
+ // p1-p5, p16-p63 [1] ???
+ // b1-b5 [5]
+ // f2-f5, f16-f31 [20*16]
+grt_stack_switch:
+ .prologue 2, 2
+ .vframe r2
+ {
+ alloc r31=ar.pfs, 2, 0, 0, 0
+ mov r14 = ar.rsc
+ adds r12 = -frame_size, r12
+ .body
+ ;;
+ }
+ // Save ar.rsc, ar.bsp, ar.pfs
+ {
+ st8 [r12] = r14 // sp + 0 <- ar.rsc
+ mov r15 = ar.bsp
+ adds r22 = (5*8), r12
+ ;;
+ }
+ {
+ st8.spill [r22] = r1, 8 // sp + 40 <- r1
+ ;;
+ st8.spill [r22] = r4, 8 // sp + 48 <- r4
+ adds r20 = 8, r12
+ ;;
+ }
+ st8 [r20] = r15, 8 // sp + 8 <- ar.bsp
+ st8.spill [r22] = r5, 8 // sp + 56 <- r5
+ mov r15 = ar.lc
+ ;;
+ {
+ st8 [r20] = r31, 8 // sp + 16 <- ar.pfs
+ // Flush dirty registers to the backing store
+ flushrs
+ mov r14 = b0
+ ;;
+ }
+ {
+ st8 [r20] = r15, 8 // sp + 24 <- ar.lc
+ // Set the RSE in enforced lazy mode.
+ mov ar.rsc = 0
+ ;;
+ }
+ {
+ // Save sp.
+ st8 [r33] = r12
+ mov r15 = ar.rnat
+ mov r16 = b1
+ ;;
+ }
+ {
+ st8.spill [r22] = r6, 8 // sp + 64 <- r6
+ st8 [r20] = r15, 64 // sp + 32 <- ar.rnat
+ ;;
+ }
+ {
+ st8.spill [r22] = r7, 16 // sp + 72 <- r7
+ st8 [r20] = r14, 8 // sp + 96 <- b0
+ mov r15 = b2
+ ;;
+ }
+ {
+ mov r17 = ar.unat
+ ;;
+ st8 [r22] = r17, 24 // sp + 88 <- ar.unat
+ mov r14 = b3
+ ;;
+ }
+ {
+ st8 [r20] = r16, 16 // sp + 104 <- b1
+ st8 [r22] = r15, 16 // sp + 112 <- b2
+ mov r17 = b4
+ ;;
+ }
+ {
+ st8 [r20] = r14, 16 // sp + 120 <- b3
+ st8 [r22] = r17, 16 // sp + 128 <- b4
+ mov r15 = b5
+ ;;
+ }
+ {
+ // Read new sp.
+ ld8 r21 = [r32]
+ ;;
+ st8 [r20] = r15, 24 // sp + 136 <- b5
+ mov r14 = pr
+ ;;
+ }
+ ;;
+ st8 [r22] = r14, 32 // sp + 144 <- pr
+ stf.spill [r20] = f2, 32 // sp + 160 <- f2
+ ;;
+ stf.spill [r22] = f3, 32 // sp + 176 <- f3
+ stf.spill [r20] = f4, 32 // sp + 192 <- f4
+ ;;
+ stf.spill [r22] = f5, 32 // sp + 208 <- f5
+ stf.spill [r20] = f16, 32 // sp + 224 <- f16
+ ;;
+ stf.spill [r22] = f17, 32 // sp + 240 <- f17
+ stf.spill [r20] = f18, 32 // sp + 256 <- f18
+ ;;
+ stf.spill [r22] = f19, 32 // sp + 272 <- f19
+ stf.spill [r20] = f20, 32 // sp + 288 <- f20
+ ;;
+ stf.spill [r22] = f21, 32 // sp + 304 <- f21
+ stf.spill [r20] = f22, 32 // sp + 320 <- f22
+ ;;
+ stf.spill [r22] = f23, 32 // sp + 336 <- f23
+ stf.spill [r20] = f24, 32 // sp + 352 <- f24
+ ;;
+ stf.spill [r22] = f25, 32 // sp + 368 <- f25
+ stf.spill [r20] = f26, 32 // sp + 384 <- f26
+ ;;
+ stf.spill [r22] = f27, 32 // sp + 400 <- f27
+ stf.spill [r20] = f28, 32 // sp + 416 <- f28
+ ;;
+ stf.spill [r22] = f29, 32 // sp + 432 <- f29
+ stf.spill [r20] = f30, 32 // sp + 448 <- f30
+ ;;
+ {
+ stf.spill [r22] = f31, 32 // sp + 464 <- f31
+ invala
+ adds r20 = 8, r21
+ ;;
+ }
+ ld8 r14 = [r21], 88 // sp + 0 (ar.rsc)
+ ld8 r16 = [r20], 8 // sp + 8 (ar.bsp)
+ ;;
+ ld8 r15 = [r21], -56 // sp + 88 (ar.unat)
+ ;;
+ ld8 r18 = [r20], 8 // sp + 16 (ar.pfs)
+ mov ar.unat = r15
+ ld8 r17 = [r21], 8 // sp + 32 (ar.rnat)
+ ;;
+ ld8 r15 = [r20], 72 // sp + 24 (ar.lc)
+ ld8.fill r1 = [r21], 8 // sp + 40 (r1)
+ mov ar.bspstore = r16
+ ;;
+ ld8.fill r4 = [r21], 8 // sp + 48 (r4)
+ mov ar.pfs = r18
+ mov ar.rnat = r17
+ ;;
+ mov ar.rsc = r14
+ mov ar.lc = r15
+ ld8 r17 = [r20], 8 // sp + 96 (b0)
+ ;;
+ {
+ ld8.fill r5 = [r21], 8 // sp + 56 (r5)
+ ld8 r14 = [r20], 8 // sp + 104 (b1)
+ mov b0 = r17
+ ;;
+ }
+ {
+ ld8.fill r6 = [r21], 8 // sp + 64 (r6)
+ ld8 r15 = [r20], 8 // sp + 112 (b2)
+ mov b1 = r14
+ ;;
+ }
+ ld8.fill r7 = [r21], 64 // sp + 72 (r7)
+ ld8 r14 = [r20], 8 // sp + 120 (b3)
+ mov b2 = r15
+ ;;
+ ld8 r15 = [r20], 16 // sp + 128 (b4)
+ ld8 r16 = [r21], 40 // sp + 136 (b5)
+ mov b3 = r14
+ ;;
+ {
+ ld8 r14 = [r20], 16 // sp + 144 (pr)
+ ;;
+ ldf.fill f2 = [r20], 32 // sp + 160 (f2)
+ mov b4 = r15
+ ;;
+ }
+ ldf.fill f3 = [r21], 32 // sp + 176 (f3)
+ ldf.fill f4 = [r20], 32 // sp + 192 (f4)
+ mov b5 = r16
+ ;;
+ ldf.fill f5 = [r21], 32 // sp + 208 (f5)
+ ldf.fill f16 = [r20], 32 // sp + 224 (f16)
+ mov pr = r14, -1
+ ;;
+ ldf.fill f17 = [r21], 32 // sp + 240 (f17)
+ ldf.fill f18 = [r20], 32 // sp + 256 (f18)
+ ;;
+ ldf.fill f19 = [r21], 32 // sp + 272 (f19)
+ ldf.fill f20 = [r20], 32 // sp + 288 (f20)
+ ;;
+ ldf.fill f21 = [r21], 32 // sp + 304 (f21)
+ ldf.fill f22 = [r20], 32 // sp + 320 (f22)
+ ;;
+ ldf.fill f23 = [r21], 32 // sp + 336 (f23)
+ ldf.fill f24 = [r20], 32 // sp + 352 (f24)
+ ;;
+ ldf.fill f25 = [r21], 32 // sp + 368 (f25)
+ ldf.fill f26 = [r20], 32 // sp + 384 (f26)
+ ;;
+ ldf.fill f27 = [r21], 32 // sp + 400 (f27)
+ ldf.fill f28 = [r20], 32 // sp + 416 (f28)
+ ;;
+ ldf.fill f29 = [r21], 32 // sp + 432 (f29)
+ ldf.fill f30 = [r20], 32 // sp + 448 (f30)
+ ;;
+ ldf.fill f31 = [r21], 32 // sp + 464 (f31)
+ mov r12 = r20
+ br.ret.sptk.many b0
+ ;;
+ .endp grt_stack_switch#
+
+ .align 16
+ // r32: func, r33: arg
+ .global grt_stack_create#
+ .proc grt_stack_create#
+grt_stack_create:
+ .prologue 14, 34
+ .save ar.pfs, r35
+ alloc r35 = ar.pfs, 2, 3, 0, 0
+ .save rp, r34
+ // Compute backing store.
+ movl r14 = stack_max_size
+ ;;
+ .body
+ {
+ ld4 r36 = [r14] // r14: bsp
+ mov r34 = b0
+ br.call.sptk.many b0 = grt_stack_allocate#
+ ;;
+ }
+ {
+ ld8 r22 = [r32], 8 // read ip (-> b1)
+ ;;
+ ld8 r23 = [r32] // read r1 from func
+ adds r21 = -(frame_size + 16) + 32, r8
+ ;;
+ }
+ {
+ st8 [r21] = r0, -32 // sp + 32 (ar.rnat = 0)
+ ;;
+ st8 [r8] = r21 // Save cur_sp
+ mov r18 = 0x0f // ar.rsc: LE, PL=3, Eager
+ ;;
+ }
+ {
+ st8 [r21] = r18, 40 // sp + 0 (ar.rsc)
+ ;;
+ st8 [r21] = r23, 64 // sp + 40 (r1 = func.r1)
+ mov b0 = r34
+ ;;
+ }
+ {
+ st8 [r21] = r22, -96 // sp + 104 (b1 = func.ip)
+ movl r15 = grt_stack_loop
+ ;;
+ }
+ sub r14 = r8, r36 // Backing store base
+ ;;
+ adds r14 = 16, r14 // Add sizeof (stack_context)
+ adds r20 = 40, r21
+ ;;
+ {
+ st8 [r21] = r14, 88 // sp + 8 (ar.bsp)
+ ;;
+ st8 [r21] = r15, -80 // sp + 96 (b0 = grt_stack_loop)
+ mov r16 = (0 << 7) | 1 // CFM: sol=0, sof=1
+ ;;
+ }
+ {
+ st8 [r21] = r16, 8 // sp + 16 (ar.pfs)
+ ;;
+ st8 [r21] = r0, 24 // sp + 24 (ar.lc)
+ mov ar.pfs = r35
+ ;;
+ }
+ {
+ st8 [r20] = r0, 8 // sp + 32 (ar.rnat)
+ st8 [r21] = r33 // sp + 48 (r4 = arg)
+ br.ret.sptk.many b0
+ ;;
+ }
+ .endp grt_stack_create#
+ .ident "GCC: (GNU) 4.0.2"
diff --git a/src/translate/grt/config/linux.c b/src/translate/grt/config/linux.c
new file mode 100644
index 000000000..74dce0903
--- /dev/null
+++ b/src/translate/grt/config/linux.c
@@ -0,0 +1,361 @@
+/* GRT stacks implementation for linux and other *nix.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#define _GNU_SOURCE
+#include <unistd.h>
+#include <sys/mman.h>
+#include <signal.h>
+#include <fcntl.h>
+#include <sys/ucontext.h>
+#include <stdlib.h>
+//#include <stdint.h>
+
+#ifdef __APPLE__
+#define MAP_ANONYMOUS MAP_ANON
+#endif
+
+/* On x86, the stack growns downward. */
+#define STACK_GROWNS_DOWNWARD 1
+
+#ifdef __linux__
+/* If set, SIGSEGV is caught in order to automatically grow the stacks. */
+#define EXTEND_STACK 1
+#define STACK_SIGNAL SIGSEGV
+#endif
+#ifdef __FreeBSD__
+/* If set, SIGSEGV is caught in order to automatically grow the stacks. */
+#define EXTEND_STACK 1
+#define STACK_SIGNAL SIGSEGV
+#endif
+#ifdef __APPLE__
+/* If set, SIGSEGV is caught in order to automatically grow the stacks. */
+#define EXTEND_STACK 1
+#define STACK_SIGNAL SIGBUS
+#endif
+
+/* Defined in Grt.Options. */
+extern unsigned int stack_size;
+extern unsigned int stack_max_size;
+
+/* Size of a memory page. */
+static size_t page_size;
+
+extern void grt_stack_error_grow_failed (void);
+extern void grt_stack_error_null_access (void);
+extern void grt_stack_error_memory_access (void);
+extern void grt_overflow_error (void);
+
+/* Definitions:
+ The base of the stack is the address before the first available byte on the
+ stack. If the stack grows downward, the base is equal to the high bound.
+*/
+
+/* Per stack context.
+ This context is allocated at the top (or bottom if the stack grows
+ upward) of the stack.
+ Therefore, the base of the stack can be easily deduced from the context. */
+struct stack_context
+{
+ /* The current stack pointer. */
+ void *cur_sp;
+ /* The current stack length. */
+ size_t cur_length;
+};
+
+/* If MAP_ANONYMOUS is not defined, use /dev/zero. */
+#ifndef MAP_ANONYMOUS
+#define USE_DEV_ZERO
+static int dev_zero_fd;
+#define MAP_ANONYMOUS 0
+#define MMAP_FILEDES dev_zero_fd
+#else
+#define MMAP_FILEDES -1
+#endif
+
+#if EXTEND_STACK
+/* This is the current process being run. */
+extern struct stack_context *grt_get_current_process (void);
+
+/* Stack used for signals.
+ The stack must be different from the running stack, because we want to be
+ able to extend the running stack. When the stack need to be extended, the
+ current stack pointer does not point to a valid address. Therefore, the
+ stack cannot be used or else a second SIGSEGV is generated while the
+ arguments are pushed. */
+static unsigned long sig_stack[SIGSTKSZ / sizeof (long)];
+
+/* Signal stack descriptor. */
+static stack_t sig_stk;
+
+static struct sigaction prev_sigsegv_act;
+static struct sigaction sigsegv_act;
+
+/* The following code assumes stack grows downward. */
+#if !STACK_GROWNS_DOWNWARD
+#error "Not implemented"
+#endif
+
+#ifdef __APPLE__
+/* Handler for SIGFPE signal, raised in case of overflow (i386). */
+static void grt_overflow_handler (int signo, siginfo_t *info, void *ptr)
+{
+ grt_overflow_error ();
+}
+#endif
+
+/* Handler for SIGSEGV signal, which grow the stack. */
+static void grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr)
+{
+ static int in_handler;
+ void *addr;
+ struct stack_context *ctxt;
+ void *stack_high;
+ void *stack_low;
+ void *n_low;
+ size_t n_len;
+ ucontext_t *uctxt = (ucontext_t *)ptr;
+
+ in_handler++;
+
+#ifdef __linux__
+#ifdef __i386__
+ /* Linux generates a SIGSEGV (!) for an overflow exception. */
+ if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4)
+ {
+ grt_overflow_error ();
+ }
+#endif
+#endif
+
+ if (info == NULL || grt_get_current_process () == NULL || in_handler > 1)
+ {
+ /* We loose. */
+ sigaction (STACK_SIGNAL, &prev_sigsegv_act, NULL);
+ return;
+ }
+
+ addr = info->si_addr;
+
+ /* Check ADDR belong to the stack. */
+ ctxt = grt_get_current_process ()->cur_sp;
+ stack_high = (void *)(ctxt + 1);
+ stack_low = stack_high - stack_max_size;
+ if (addr > stack_high || addr < stack_low)
+ {
+ /* Out of the stack. */
+ if (addr < (void *)page_size)
+ grt_stack_error_null_access ();
+ else
+ grt_stack_error_memory_access ();
+ }
+ /* Compute the address of the faulting page. */
+ n_low = (void *)((unsigned long)addr & ~(page_size - 1));
+
+ /* Should not happen. */
+ if (n_low < stack_low)
+ abort ();
+
+ /* Allocate one more page, if possible. */
+ if (n_low != stack_low)
+ n_low -= page_size;
+
+ /* Compute the new length. */
+ n_len = stack_high - n_low;
+
+ if (mmap (n_low, n_len - ctxt->cur_length, PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0)
+ != n_low)
+ {
+ /* Cannot grow the stack. */
+ grt_stack_error_grow_failed ();
+ }
+
+ ctxt->cur_length = n_len;
+
+ sigaction (STACK_SIGNAL, &sigsegv_act, NULL);
+
+ in_handler--;
+
+ /* Hopes we can resume! */
+ return;
+}
+
+static void grt_signal_setup (void)
+{
+ sigsegv_act.sa_sigaction = &grt_sigsegv_handler;
+ sigemptyset (&sigsegv_act.sa_mask);
+ sigsegv_act.sa_flags = SA_ONSTACK | SA_SIGINFO;
+#ifdef SA_ONESHOT
+ sigsegv_act.sa_flags |= SA_ONESHOT;
+#elif defined (SA_RESETHAND)
+ sigsegv_act.sa_flags |= SA_RESETHAND;
+#endif
+
+ /* Use an alternate stack during signals. */
+ sig_stk.ss_sp = sig_stack;
+ sig_stk.ss_size = sizeof (sig_stack);
+ sig_stk.ss_flags = 0;
+ sigaltstack (&sig_stk, NULL);
+
+ /* We don't care about the return status.
+ If the handler is not installed, then some feature are lost. */
+ sigaction (STACK_SIGNAL, &sigsegv_act, &prev_sigsegv_act);
+
+#ifdef __APPLE__
+ {
+ struct sigaction sig_ovf_act;
+
+ sig_ovf_act.sa_sigaction = &grt_overflow_handler;
+ sigemptyset (&sig_ovf_act.sa_mask);
+ sig_ovf_act.sa_flags = SA_SIGINFO;
+
+ sigaction (SIGFPE, &sig_ovf_act, NULL);
+ }
+#endif
+}
+#endif
+
+/* Context for the main stack. */
+#ifdef USE_THREADS
+#define THREAD __thread
+#else
+#define THREAD
+#endif
+static THREAD struct stack_context main_stack_context;
+
+extern void grt_set_main_stack (struct stack_context *stack);
+
+void
+grt_stack_new_thread (void)
+{
+ main_stack_context.cur_sp = NULL;
+ main_stack_context.cur_length = 0;
+ grt_set_main_stack (&main_stack_context);
+}
+
+void
+grt_stack_init (void)
+{
+ size_t pg_round;
+
+ page_size = getpagesize ();
+ pg_round = page_size - 1;
+
+ /* Align size. */
+ stack_size = (stack_size + pg_round) & ~pg_round;
+ stack_max_size = (stack_max_size + pg_round) & ~pg_round;
+
+ /* Set mimum values. */
+ if (stack_size < 2 * page_size)
+ stack_size = 2 * page_size;
+ if (stack_max_size < (stack_size + 2 * page_size))
+ stack_max_size = stack_size + 2 * page_size;
+
+ /* Initialize the main stack context. */
+ main_stack_context.cur_sp = NULL;
+ main_stack_context.cur_length = 0;
+ grt_set_main_stack (&main_stack_context);
+
+#ifdef USE_DEV_ZERO
+ dev_zero_fd = open ("/dev/zero", O_RDWR);
+ if (dev_zero_fd < 0)
+ abort ();
+#endif
+
+#if EXTEND_STACK
+ grt_signal_setup ();
+#endif
+}
+
+/* Allocate a stack.
+ Called by i386.S */
+struct stack_context *
+grt_stack_allocate (void)
+{
+ struct stack_context *res;
+ void *r;
+ void *base;
+
+ /* Allocate the stack, but without any rights. This is a guard. */
+ base = (void *)mmap (NULL, stack_max_size, PROT_NONE,
+ MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0);
+
+ if (base == (void *)-1)
+ return NULL;
+
+ /* Set rights on the allocated stack. */
+#if STACK_GROWNS_DOWNWARD
+ r = base + stack_max_size - stack_size;
+#else
+ r = base;
+#endif
+ if (mmap (r, stack_size, PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0)
+ != r)
+ return NULL;
+
+#if STACK_GROWNS_DOWNWARD
+ res = (struct stack_context *)
+ (base + stack_max_size - sizeof (struct stack_context));
+#else
+ res = (struct stack_context *)(base + sizeof (struct stack_context));
+#endif
+
+#ifdef __ia64__
+ /* Also allocate BSP. */
+ if (mmap (base, page_size, PROT_READ | PROT_WRITE,
+ MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) != base)
+ return NULL;
+#endif
+
+ res->cur_sp = (void *)res;
+ res->cur_length = stack_size;
+ return res;
+}
+
+#include <setjmp.h>
+static int run_env_en;
+static jmp_buf run_env;
+
+void
+__ghdl_maybe_return_via_longjump (int val)
+{
+ if (run_env_en)
+ longjmp (run_env, val);
+}
+
+int
+__ghdl_run_through_longjump (int (*func)(void))
+{
+ int res;
+
+ run_env_en = 1;
+ res = setjmp (run_env);
+ if (res == 0)
+ res = (*func)();
+ run_env_en = 0;
+ return res;
+}
+
diff --git a/src/translate/grt/config/ppc.S b/src/translate/grt/config/ppc.S
new file mode 100644
index 000000000..bedd48ab4
--- /dev/null
+++ b/src/translate/grt/config/ppc.S
@@ -0,0 +1,334 @@
+/* GRT stack implementation for ppc.
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "ppc.S"
+
+ .section ".text"
+
+#define OFF 240
+
+#define GREG(x) x
+#define FREG(x) x
+
+#define r0 GREG(0)
+#define r1 GREG(1)
+#define r2 GREG(2)
+#define r3 GREG(3)
+#define r4 GREG(4)
+#define r5 GREG(5)
+#define r6 GREG(6)
+#define r7 GREG(7)
+#define r8 GREG(8)
+#define r9 GREG(9)
+#define r10 GREG(10)
+#define r11 GREG(11)
+#define r12 GREG(12)
+#define r13 GREG(13)
+#define r14 GREG(14)
+#define r15 GREG(15)
+#define r16 GREG(16)
+#define r17 GREG(17)
+#define r18 GREG(18)
+#define r19 GREG(19)
+#define r20 GREG(20)
+#define r21 GREG(21)
+#define r22 GREG(22)
+#define r23 GREG(23)
+#define r24 GREG(24)
+#define r25 GREG(25)
+#define r26 GREG(26)
+#define r27 GREG(27)
+#define r28 GREG(28)
+#define r29 GREG(29)
+#define r30 GREG(30)
+#define r31 GREG(31)
+
+#define f0 FREG(0)
+#define f1 FREG(1)
+#define f2 FREG(2)
+#define f3 FREG(3)
+#define f4 FREG(4)
+#define f5 FREG(5)
+#define f6 FREG(6)
+#define f7 FREG(7)
+#define f8 FREG(8)
+#define f9 FREG(9)
+#define f10 FREG(10)
+#define f11 FREG(11)
+#define f12 FREG(12)
+#define f13 FREG(13)
+#define f14 FREG(14)
+#define f15 FREG(15)
+#define f16 FREG(16)
+#define f17 FREG(17)
+#define f18 FREG(18)
+#define f19 FREG(19)
+#define f20 FREG(20)
+#define f21 FREG(21)
+#define f22 FREG(22)
+#define f23 FREG(23)
+#define f24 FREG(24)
+#define f25 FREG(25)
+#define f26 FREG(26)
+#define f27 FREG(27)
+#define f28 FREG(28)
+#define f29 FREG(29)
+#define f30 FREG(30)
+#define f31 FREG(31)
+
+ /* Stack structure is:
+ +4 : cur_length \ Stack
+ +0 : cur_sp / Context
+ -4 : arg
+ -8 : func
+
+ -12: pad
+ -16: pad
+ -20: LR save word
+ -24: Back chain
+
+ -28: fp/gp saved registers.
+ -4 : return address
+ -8 : process function to be executed
+ -12: function argument
+ ...
+ -72: %sp
+ */
+
+ /* Function called to loop on the process. */
+ .align 4
+ .type grt_stack_loop,@function
+grt_stack_loop:
+ /* Get function. */
+ lwz r0,16(r1)
+ /* Get argument. */
+ lwz r3,20(r1)
+ mtlr r0
+ blrl
+ b grt_stack_loop
+ .size grt_stack_loop, . - grt_stack_loop
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type; */
+ .align 4
+ .global grt_stack_create
+ .type grt_stack_create,@function
+grt_stack_create:
+ /* Standard prologue. */
+ stwu r1,-32(r1)
+ mflr r0
+ stw r0,36(r1)
+
+ /* Save arguments. */
+ stw r3,24(r1)
+ stw r4,28(r1)
+
+ /* Allocate the stack, and exit in case of failure */
+ bl grt_stack_allocate
+ cmpwi 0,r3,0
+ beq- .Ldone
+
+ /* Note: r3 contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* Align the stack. */
+ addi r5,r3,-24
+
+ /* Save the parameters. */
+ lwz r6,24(r1)
+ stw r6,16(r5)
+ lwz r7,28(r1)
+ stw r7,20(r5)
+
+ /* The return function. */
+ lis r4,grt_stack_loop@ha
+ la r4,grt_stack_loop@l(r4)
+ stw r4,4(r5)
+ /* Back-Chain. */
+ addi r4,r1,32
+ stw r4,0(r5)
+
+ /* Save register.
+ They should be considered as garbage. */
+ addi r4,r5,-OFF
+
+ stfd f31,(OFF - 8)(r4)
+ stfd f30,(OFF - 16)(r4)
+ stfd f29,(OFF - 24)(r4)
+ stfd f28,(OFF - 32)(r4)
+ stfd f27,(OFF - 40)(r4)
+ stfd f26,(OFF - 48)(r4)
+ stfd f25,(OFF - 56)(r4)
+ stfd f24,(OFF - 64)(r4)
+ stfd f23,(OFF - 72)(r4)
+ stfd f22,(OFF - 80)(r4)
+ stfd f21,(OFF - 88)(r4)
+ stfd f20,(OFF - 96)(r4)
+ stfd f19,(OFF - 104)(r4)
+ stfd f18,(OFF - 112)(r4)
+ stfd f17,(OFF - 120)(r4)
+ stfd f16,(OFF - 128)(r4)
+ stfd f15,(OFF - 136)(r4)
+ stfd f14,(OFF - 144)(r4)
+ stw r31,(OFF - 148)(r4)
+ stw r30,(OFF - 152)(r4)
+ stw r29,(OFF - 156)(r4)
+ stw r28,(OFF - 160)(r4)
+ stw r27,(OFF - 164)(r4)
+ stw r26,(OFF - 168)(r4)
+ stw r25,(OFF - 172)(r4)
+ stw r24,(OFF - 176)(r4)
+ stw r23,(OFF - 180)(r4)
+ stw r22,(OFF - 184)(r4)
+ stw r21,(OFF - 188)(r4)
+ stw r20,(OFF - 192)(r4)
+ stw r19,(OFF - 196)(r4)
+ stw r18,(OFF - 200)(r4)
+ stw r17,(OFF - 204)(r4)
+ stw r16,(OFF - 208)(r4)
+ stw r15,(OFF - 212)(r4)
+ stw r14,(OFF - 216)(r4)
+ mfcr r0
+ stw r0, (OFF - 220)(r4)
+
+ /* Save stack pointer. */
+ stw r4, 0(r3)
+
+.Ldone:
+ lwz r0,36(r1)
+ mtlr r0
+ addi r1,r1,32
+ blr
+ .size grt_stack_create,. - grt_stack_create
+
+
+ .align 4
+ .global grt_stack_switch
+ /* Arguments: TO, FROM.
+ Both are pointers to a stack_context. */
+ .type grt_stack_switch,@function
+grt_stack_switch:
+ /* Standard prologue, save return address. */
+ stwu r1,(-OFF)(r1)
+ mflr r0
+ stw r0,(OFF + 4)(r1)
+
+ /* Save r14-r31, f14-f31, CR
+ This is 18 words + 18 double words, ie 216 bytes. */
+ /* Maybe use the savefpr function ? */
+ stfd f31,(OFF - 8)(r1)
+ stfd f30,(OFF - 16)(r1)
+ stfd f29,(OFF - 24)(r1)
+ stfd f28,(OFF - 32)(r1)
+ stfd f27,(OFF - 40)(r1)
+ stfd f26,(OFF - 48)(r1)
+ stfd f25,(OFF - 56)(r1)
+ stfd f24,(OFF - 64)(r1)
+ stfd f23,(OFF - 72)(r1)
+ stfd f22,(OFF - 80)(r1)
+ stfd f21,(OFF - 88)(r1)
+ stfd f20,(OFF - 96)(r1)
+ stfd f19,(OFF - 104)(r1)
+ stfd f18,(OFF - 112)(r1)
+ stfd f17,(OFF - 120)(r1)
+ stfd f16,(OFF - 128)(r1)
+ stfd f15,(OFF - 136)(r1)
+ stfd f14,(OFF - 144)(r1)
+ stw r31,(OFF - 148)(r1)
+ stw r30,(OFF - 152)(r1)
+ stw r29,(OFF - 156)(r1)
+ stw r28,(OFF - 160)(r1)
+ stw r27,(OFF - 164)(r1)
+ stw r26,(OFF - 168)(r1)
+ stw r25,(OFF - 172)(r1)
+ stw r24,(OFF - 176)(r1)
+ stw r23,(OFF - 180)(r1)
+ stw r22,(OFF - 184)(r1)
+ stw r21,(OFF - 188)(r1)
+ stw r20,(OFF - 192)(r1)
+ stw r19,(OFF - 196)(r1)
+ stw r18,(OFF - 200)(r1)
+ stw r17,(OFF - 204)(r1)
+ stw r16,(OFF - 208)(r1)
+ stw r15,(OFF - 212)(r1)
+ stw r14,(OFF - 216)(r1)
+ mfcr r0
+ stw r0, (OFF - 220)(r1)
+
+ /* Save stack pointer. */
+ stw r1, 0(r4)
+
+ /* Load stack pointer. */
+ lwz r1, 0(r3)
+
+
+ lfd f31,(OFF - 8)(r1)
+ lfd f30,(OFF - 16)(r1)
+ lfd f29,(OFF - 24)(r1)
+ lfd f28,(OFF - 32)(r1)
+ lfd f27,(OFF - 40)(r1)
+ lfd f26,(OFF - 48)(r1)
+ lfd f25,(OFF - 56)(r1)
+ lfd f24,(OFF - 64)(r1)
+ lfd f23,(OFF - 72)(r1)
+ lfd f22,(OFF - 80)(r1)
+ lfd f21,(OFF - 88)(r1)
+ lfd f20,(OFF - 96)(r1)
+ lfd f19,(OFF - 104)(r1)
+ lfd f18,(OFF - 112)(r1)
+ lfd f17,(OFF - 120)(r1)
+ lfd f16,(OFF - 128)(r1)
+ lfd f15,(OFF - 136)(r1)
+ lfd f14,(OFF - 144)(r1)
+ lwz r31,(OFF - 148)(r1)
+ lwz r30,(OFF - 152)(r1)
+ lwz r29,(OFF - 156)(r1)
+ lwz r28,(OFF - 160)(r1)
+ lwz r27,(OFF - 164)(r1)
+ lwz r26,(OFF - 168)(r1)
+ lwz r25,(OFF - 172)(r1)
+ lwz r24,(OFF - 176)(r1)
+ lwz r23,(OFF - 180)(r1)
+ lwz r22,(OFF - 184)(r1)
+ lwz r21,(OFF - 188)(r1)
+ lwz r20,(OFF - 192)(r1)
+ lwz r19,(OFF - 196)(r1)
+ lwz r18,(OFF - 200)(r1)
+ lwz r17,(OFF - 204)(r1)
+ lwz r16,(OFF - 208)(r1)
+ lwz r15,(OFF - 212)(r1)
+ lwz r14,(OFF - 216)(r1)
+ lwz r0, (OFF - 220)(r1)
+ mtcr r0
+
+ lwz r0,(OFF + 4)(r1)
+ mtlr r0
+ addi r1,r1,OFF
+ blr
+ .size grt_stack_switch, . - grt_stack_switch
+
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/pthread.c b/src/translate/grt/config/pthread.c
new file mode 100644
index 000000000..189ae90c8
--- /dev/null
+++ b/src/translate/grt/config/pthread.c
@@ -0,0 +1,239 @@
+/* GRT stack implementation based on pthreads.
+ Copyright (C) 2003 - 2014 Felix Bertram & Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Project: GHDL - VHDL Simulator
+// Description: pthread port of stacks package, for use with MacOSX
+// Note: Tristan's original i386/Linux used assembly-code
+// to manually switch stacks for performance reasons.
+// History: 2003may22, FB, created.
+//-----------------------------------------------------------------------------
+
+#include <pthread.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <setjmp.h>
+#include <assert.h>
+
+//#define INFO printf
+#define INFO (void)
+
+// GHDL names an endless loop calling FUNC with ARG a 'stack'
+// at a given time, only one stack may be 'executed'
+typedef struct
+{
+ pthread_t thread; // stack's thread
+ pthread_mutex_t mutex; // mutex to suspend/resume thread
+#if defined(__CYGWIN__)
+ pthread_mutexattr_t mxAttr;
+#endif
+ void (*Func)(void*); // stack's FUNC
+ void* Arg; // ARG passed to FUNC
+} Stack_Type_t, *Stack_Type;
+
+static Stack_Type_t main_stack_context;
+static Stack_Type_t *current;
+extern void grt_set_main_stack (Stack_Type_t *stack);
+
+//----------------------------------------------------------------------------
+void grt_stack_init(void)
+// Initialize the stacks package.
+// This may adjust stack sizes.
+// Must be called after grt.options.decode.
+// => procedure Stack_Init;
+{
+ int res;
+ INFO("grt_stack_init\n");
+ INFO(" main_stack_context=0x%08x\n", &main_stack_context);
+
+
+#if defined(__CYGWIN__)
+ res = pthread_mutexattr_init (&main_stack_context.mxAttr);
+ assert (res == 0);
+ res = pthread_mutexattr_settype (&main_stack_context.mxAttr,
+ PTHREAD_MUTEX_DEFAULT);
+ assert (res == 0);
+ res = pthread_mutex_init (&main_stack_context.mutex,
+ &main_stack_context.mxAttr);
+ assert (res == 0);
+#else
+ res = pthread_mutex_init (&main_stack_context.mutex, NULL);
+ assert (res == 0);
+#endif
+ // lock the mutex, as we are currently running
+ res = pthread_mutex_lock (&main_stack_context.mutex);
+ assert (res == 0);
+
+ current = &main_stack_context;
+
+ grt_set_main_stack (&main_stack_context);
+}
+
+//----------------------------------------------------------------------------
+static void* grt_stack_loop(void* pv_myStack)
+{
+ Stack_Type myStack= (Stack_Type)pv_myStack;
+
+ INFO("grt_stack_loop\n");
+
+ INFO(" myStack=0x%08x\n", myStack);
+
+ // block until mutex becomes available again.
+ // this happens when this stack is enabled for the first time
+ pthread_mutex_lock(&(myStack->mutex));
+
+ // run stack's function in endless loop
+ while(1)
+ {
+ INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg);
+ myStack->Func(myStack->Arg);
+ }
+
+ // we never get here...
+ return 0;
+}
+
+//----------------------------------------------------------------------------
+Stack_Type grt_stack_create(void* Func, void* Arg)
+// Create a new stack, which on first execution will call FUNC with
+// an argument ARG.
+// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type;
+{
+ Stack_Type newStack;
+ int res;
+
+ INFO("grt_stack_create\n");
+ INFO(" call 0x%08x with 0x%08x\n", Func, Arg);
+
+ newStack = malloc (sizeof(Stack_Type_t));
+
+ // init function and argument
+ newStack->Func = Func;
+ newStack->Arg = Arg;
+
+ // create mutex
+#if defined(__CYGWIN__)
+ res = pthread_mutexattr_init (&newStack->mxAttr);
+ assert (res == 0);
+ res = pthread_mutexattr_settype (&newStack->mxAttr, PTHREAD_MUTEX_DEFAULT);
+ assert (res == 0);
+ res = pthread_mutex_init (&newStack->mutex, &newStack->mxAttr);
+ assert (res == 0);
+#else
+ res = pthread_mutex_init (&newStack->mutex, NULL);
+ assert (res == 0);
+#endif
+
+ // block the mutex, so that thread will blocked in grt_stack_loop
+ res = pthread_mutex_lock (&newStack->mutex);
+ assert (res == 0);
+
+ INFO(" newStack=0x%08x\n", newStack);
+
+ // create thread, which executes grt_stack_loop
+ pthread_create (&newStack->thread, NULL, grt_stack_loop, newStack);
+
+ return newStack;
+}
+
+static int need_longjmp;
+static int run_env_en;
+static jmp_buf run_env;
+
+//----------------------------------------------------------------------------
+void grt_stack_switch(Stack_Type To, Stack_Type From)
+// Resume stack TO and save the current context to the stack pointed by
+// CUR.
+// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type);
+{
+ int res;
+ INFO("grt_stack_switch\n");
+ INFO(" from 0x%08x to 0x%08x\n", From, To);
+
+ current = To;
+
+ // unlock 'To' mutex. this will make the other thread either
+ // - starts for first time in grt_stack_loop
+ // - resumes at lock below
+ res = pthread_mutex_unlock (&To->mutex);
+ assert (res == 0);
+
+ // block until 'From' mutex becomes available again
+ // as we are running, our mutex is locked and we block here
+ // when stacks are switched, with above unlock, we may proceed
+ res = pthread_mutex_lock (&From->mutex);
+ assert (res == 0);
+
+ if (From == &main_stack_context && need_longjmp != 0)
+ longjmp (run_env, need_longjmp);
+}
+
+//----------------------------------------------------------------------------
+void grt_stack_delete(Stack_Type Stack)
+// Delete stack STACK, which must not be currently executed.
+// => procedure Stack_Delete (Stack : Stack_Type);
+{
+ INFO("grt_stack_delete\n");
+}
+
+void
+__ghdl_maybe_return_via_longjump (int val)
+{
+ if (!run_env_en)
+ return;
+
+ if (current != &main_stack_context)
+ {
+ need_longjmp = val;
+ grt_stack_switch (&main_stack_context, current);
+ }
+ else
+ longjmp (run_env, val);
+}
+
+int
+__ghdl_run_through_longjump (int (*func)(void))
+{
+ int res;
+
+ run_env_en = 1;
+ res = setjmp (run_env);
+ if (res == 0)
+ res = (*func)();
+ run_env_en = 0;
+ return res;
+}
+
+
+//----------------------------------------------------------------------------
+
+#ifndef WITH_GNAT_RUN_TIME
+void __gnat_raise_storage_error(void)
+{
+ abort ();
+}
+
+void __gnat_raise_program_error(void)
+{
+ abort ();
+}
+#endif /* WITH_GNAT_RUN_TIME */
+
+//----------------------------------------------------------------------------
+// end of file
+
diff --git a/src/translate/grt/config/sparc.S b/src/translate/grt/config/sparc.S
new file mode 100644
index 000000000..0ffe412ed
--- /dev/null
+++ b/src/translate/grt/config/sparc.S
@@ -0,0 +1,141 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "sparc.S"
+
+ .section ".text"
+
+ /* Stack structure is:
+ +4 : cur_length
+ +0 : cur_sp
+ -4 : return address
+ -8 : process function to be executed
+ -12: function argument
+ ...
+ -72: %sp
+ */
+
+ /* Function called to loop on the process. */
+ .align 4
+ .type grt_stack_loop,#function
+grt_stack_loop:
+ ld [%sp + 64], %o1
+ jmpl %o1 + 0, %o7
+ ld [%sp + 68], %o0
+ ba grt_stack_loop
+ nop
+ .size grt_stack_loop, . - grt_stack_loop
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type; */
+ .align 4
+ .global grt_stack_create
+ .type grt_stack_create,#function
+grt_stack_create:
+ /* Standard prologue. */
+ save %sp,-80,%sp
+
+ /* Allocate the stack, and exit in case of failure */
+ call grt_stack_allocate
+ nop
+ cmp %o0, 0
+ be .Ldone
+ nop
+
+ /* Note: %o0 contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+
+ /* The return function. */
+ sethi %hi(grt_stack_loop - 8), %l2
+ or %lo(grt_stack_loop - 8), %l2, %l2
+
+ /* Create a frame for grt_stack_loop. */
+ sub %o0, (64 + 8), %l1
+
+ /* The function to be executed. */
+ st %i0, [%l1 + 64]
+ /* The argument. */
+ st %i1, [%l1 + 68]
+
+ /* Create a frame for grt_stack_switch. */
+ sub %l1, 64, %l0
+
+ /* Save frame pointer. */
+ st %l1, [%l0 + 56]
+ /* Save return address. */
+ st %l2, [%l0 + 60]
+
+ /* Save stack pointer. */
+ st %l0, [%o0]
+
+.Ldone:
+ ret
+ restore %o0, %g0, %o0
+ .size grt_stack_create,. - grt_stack_create
+
+
+ .align 4
+ .global grt_stack_switch
+ /* Arguments: TO, FROM.
+ Both are pointers to a stack_context. */
+ .type grt_stack_switch,#function
+grt_stack_switch:
+ /* Standard prologue. */
+ save %sp,-80,%sp
+
+ /* Flush and invalidate windows.
+ It is not clear wether the current window is saved or not,
+ therefore, I assume it is not.
+ */
+ ta 3
+
+ /* Only IN registers %fp and %i7 (return address) must be saved.
+ Of course, I could use std/ldd, but it is not as clear
+ */
+ /* Save current frame pointer. */
+ st %fp, [%sp + 56]
+ /* Save return address. */
+ st %i7, [%sp + 60]
+
+ /* Save stack pointer. */
+ st %sp, [%i1]
+
+ /* Load stack pointer. */
+ ld [%i0], %sp
+
+ /* Load return address. */
+ ld [%sp + 60], %i7
+ /* Load frame pointer. */
+ ld [%sp + 56], %fp
+
+ /* Return. */
+ ret
+ restore
+ .size grt_stack_switch, . - grt_stack_switch
+
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/teststack.c b/src/translate/grt/config/teststack.c
new file mode 100644
index 000000000..6a6966d6f
--- /dev/null
+++ b/src/translate/grt/config/teststack.c
@@ -0,0 +1,174 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+extern void grt_stack_init (void);
+extern void grt_stack_switch (void *from, void *to);
+extern void *grt_stack_create (void (*func)(void *), void *arg);
+
+int stack_size = 4096;
+int stack_max_size = 8 * 4096;
+
+static void *stack1;
+static void *stack2;
+void *grt_stack_main_stack;
+
+void *grt_cur_proc;
+
+static int step;
+
+void
+grt_overflow_error (void)
+{
+ abort ();
+}
+
+void
+grt_stack_error_null_access (void)
+{
+ abort ();
+}
+
+void
+grt_stack_error_memory_access (void)
+{
+ abort ();
+}
+
+void
+grt_stack_error_grow_failed (void)
+{
+ abort ();
+}
+
+void
+error (void)
+{
+ printf ("Test failure at step %d\n", step);
+ fflush (stdout);
+ exit (1);
+}
+
+static void
+func1 (void *ptr)
+{
+ if (ptr != (void *)1)
+ error ();
+
+ if (step != 0)
+ error ();
+
+ step = 1;
+
+ grt_stack_switch (grt_stack_main_stack, stack1);
+
+ if (step != 5)
+ error ();
+
+ step = 6;
+
+ grt_stack_switch (grt_stack_main_stack, stack1);
+
+ if (step != 7)
+ error ();
+
+ step = 8;
+
+ grt_stack_switch (stack2, stack1);
+
+ if (step != 9)
+ error ();
+
+ step = 10;
+
+ grt_stack_switch (grt_stack_main_stack, stack1);
+
+ error ();
+}
+
+static void
+func2 (void *ptr)
+{
+ if (ptr != (void *)2)
+ error ();
+
+ if (step == 11)
+ {
+ step = 12;
+
+ grt_stack_switch (grt_stack_main_stack, stack2);
+
+ error ();
+ }
+
+ if (step != 1)
+ error ();
+
+ step = 2;
+
+ grt_stack_switch (grt_stack_main_stack, stack2);
+
+ if (step != 3)
+ error ();
+
+ step = 4;
+
+ grt_stack_switch (grt_stack_main_stack, stack2);
+
+ if (step != 8)
+ error ();
+
+ step = 9;
+
+ grt_stack_switch (stack1, stack2);
+}
+
+int
+main (void)
+{
+ grt_stack_init ();
+
+ stack1 = grt_stack_create (&func1, (void *)1);
+ stack2 = grt_stack_create (&func2, (void *)2);
+
+ step = 0;
+ grt_stack_switch (stack1, grt_stack_main_stack);
+
+ if (step != 1)
+ error ();
+
+ grt_stack_switch (stack2, grt_stack_main_stack);
+
+ if (step != 2)
+ error ();
+
+ step = 3;
+
+ grt_stack_switch (stack2, grt_stack_main_stack);
+
+ if (step != 4)
+ error ();
+
+ step = 5;
+
+ grt_stack_switch (stack1, grt_stack_main_stack);
+
+ if (step != 6)
+ error ();
+
+ step = 7;
+
+ grt_stack_switch (stack1, grt_stack_main_stack);
+
+ if (step != 10)
+ error ();
+
+ step = 11;
+
+ grt_stack_switch (stack2, grt_stack_main_stack);
+
+ if (step != 12)
+ error ();
+
+ printf ("Test successful\n");
+ return 0;
+}
diff --git a/src/translate/grt/config/times.c b/src/translate/grt/config/times.c
new file mode 100644
index 000000000..9c0b4ebba
--- /dev/null
+++ b/src/translate/grt/config/times.c
@@ -0,0 +1,55 @@
+/* GRT C bindings for time.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#include <sys/times.h>
+#include <unistd.h>
+
+int
+grt_get_clk_tck (void)
+{
+ return sysconf (_SC_CLK_TCK);
+}
+
+void
+grt_get_times (int *wall, int *user, int *sys)
+{
+ clock_t res;
+ struct tms buf;
+
+ res = times (&buf);
+ if (res == (clock_t)-1)
+ {
+ *wall = 0;
+ *user = 0;
+ *sys = 0;
+ }
+ else
+ {
+ *wall = res;
+ *user = buf.tms_utime;
+ *sys = buf.tms_stime;
+ }
+}
+
diff --git a/src/translate/grt/config/win32.c b/src/translate/grt/config/win32.c
new file mode 100644
index 000000000..35322ba9f
--- /dev/null
+++ b/src/translate/grt/config/win32.c
@@ -0,0 +1,265 @@
+/* GRT stack implementation for Win32 using fibers.
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+
+#include <windows.h>
+#include <stdio.h>
+#include <setjmp.h>
+#include <assert.h>
+#include <excpt.h>
+
+static EXCEPTION_DISPOSITION
+ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT* ContextRecord,
+ void *DispatcherContext);
+
+struct exception_registration
+{
+ struct exception_registration *prev;
+ void *handler;
+};
+
+struct stack_type
+{
+ LPVOID fiber; // Win fiber.
+ void (*func)(void *); // Function
+ void *arg; // Function argument.
+};
+
+static struct stack_type main_stack_context;
+static struct stack_type *current;
+extern void grt_set_main_stack (struct stack_type *stack);
+
+void grt_stack_init(void)
+{
+ main_stack_context.fiber = ConvertThreadToFiber (NULL);
+ if (main_stack_context.fiber == NULL)
+ {
+ fprintf (stderr, "convertThreadToFiber failed (err=%lu)\n",
+ GetLastError ());
+ abort ();
+ }
+ grt_set_main_stack (&main_stack_context);
+ current = &main_stack_context;
+}
+
+static VOID __stdcall
+grt_stack_loop (void *v_stack)
+{
+ struct stack_type *stack = (struct stack_type *)v_stack;
+ struct exception_registration er;
+ struct exception_registration *prev;
+
+ /* Get current handler. */
+ asm ("mov %%fs:(0),%0" : "=r" (prev));
+
+ /* Build regisration. */
+ er.prev = prev;
+ er.handler = ghdl_SEH_handler;
+
+ /* Register. */
+ asm ("mov %0,%%fs:(0)" : : "r" (&er));
+
+ while (1)
+ {
+ (*stack->func)(stack->arg);
+ }
+}
+
+struct stack_type *
+grt_stack_create (void (*func)(void *), void *arg)
+{
+ struct stack_type *res;
+
+ res = malloc (sizeof (struct stack_type));
+ if (res == NULL)
+ return NULL;
+ res->func = func;
+ res->arg = arg;
+ res->fiber = CreateFiber (0, &grt_stack_loop, res);
+ if (res->fiber == NULL)
+ {
+ free (res);
+ return NULL;
+ }
+ return res;
+}
+
+static int run_env_en;
+static jmp_buf run_env;
+static int need_longjmp;
+
+void
+grt_stack_switch (struct stack_type *to, struct stack_type *from)
+{
+ assert (current == from);
+ current = to;
+ SwitchToFiber (to->fiber);
+ if (from == &main_stack_context && need_longjmp)
+ {
+ /* We returned to do the longjump. */
+ current = &main_stack_context;
+ longjmp (run_env, need_longjmp);
+ }
+}
+
+void
+grt_stack_delete (struct stack_type *stack)
+{
+ DeleteFiber (stack->fiber);
+ stack->fiber = NULL;
+}
+
+void
+__ghdl_maybe_return_via_longjump (int val)
+{
+ if (!run_env_en)
+ return;
+
+ if (current != &main_stack_context)
+ {
+ /* We are allowed to jump only in the same stack.
+ First switch back to the main thread. */
+ need_longjmp = val;
+ SwitchToFiber (main_stack_context.fiber);
+ }
+ else
+ longjmp (run_env, val);
+}
+
+extern void grt_stack_error_grow_failed (void);
+extern void grt_stack_error_null_access (void);
+extern void grt_stack_error_memory_access (void);
+extern void grt_overflow_error (void);
+
+static EXCEPTION_DISPOSITION
+ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT* ContextRecord,
+ void *DispatcherContext)
+{
+ const char *msg = "";
+
+ switch (ExceptionRecord->ExceptionCode)
+ {
+ case EXCEPTION_ACCESS_VIOLATION:
+ if (ExceptionRecord->ExceptionInformation[1] == 0)
+ grt_stack_error_null_access ();
+ else
+ grt_stack_error_memory_access ();
+ break;
+
+ case EXCEPTION_FLT_DENORMAL_OPERAND:
+ case EXCEPTION_FLT_DIVIDE_BY_ZERO:
+ case EXCEPTION_FLT_INVALID_OPERATION:
+ case EXCEPTION_FLT_OVERFLOW:
+ case EXCEPTION_FLT_STACK_CHECK:
+ case EXCEPTION_FLT_UNDERFLOW:
+ msg = "floating point error";
+ break;
+
+ case EXCEPTION_INT_DIVIDE_BY_ZERO:
+ msg = "division by 0";
+ break;
+
+ case EXCEPTION_INT_OVERFLOW:
+ grt_overflow_error ();
+ break;
+
+ case EXCEPTION_STACK_OVERFLOW:
+ msg = "stack overflow";
+ break;
+
+ default:
+ msg = "unknown reason";
+ break;
+ }
+
+ /* FIXME: is it correct? */
+ fprintf (stderr, "exception raised: %s\n", msg);
+
+ __ghdl_maybe_return_via_longjump (1);
+ return 0; /* This is never reached, avoid compiler warning */
+}
+
+int
+__ghdl_run_through_longjump (int (*func)(void))
+{
+ int res;
+ struct exception_registration er;
+ struct exception_registration *prev;
+
+ /* Get current handler. */
+ asm ("mov %%fs:(0),%0" : "=r" (prev));
+
+ /* Build regisration. */
+ er.prev = prev;
+ er.handler = ghdl_SEH_handler;
+
+ /* Register. */
+ asm ("mov %0,%%fs:(0)" : : "r" (&er));
+
+ run_env_en = 1;
+ res = setjmp (run_env);
+ if (res == 0)
+ res = (*func)();
+ run_env_en = 0;
+
+ /* Restore. */
+ asm ("mov %0,%%fs:(0)" : : "r" (prev));
+
+ return res;
+}
+
+#include <math.h>
+
+double acosh (double x)
+{
+ return log (x + sqrt (x*x - 1));
+}
+
+double asinh (double x)
+{
+ return log (x + sqrt (x*x + 1));
+}
+
+double atanh (double x)
+{
+ return log ((1 + x) / (1 - x)) / 2;
+}
+
+#ifndef WITH_GNAT_RUN_TIME
+void __gnat_raise_storage_error(void)
+{
+ abort ();
+}
+
+void __gnat_raise_program_error(void)
+{
+ abort ();
+}
+#endif
+
diff --git a/src/translate/grt/config/win32thr.c b/src/translate/grt/config/win32thr.c
new file mode 100644
index 000000000..bcebc49d5
--- /dev/null
+++ b/src/translate/grt/config/win32thr.c
@@ -0,0 +1,167 @@
+/* GRT stack implementation for Win32
+ Copyright (C) 2004, 2005 Felix Bertram.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Project: GHDL - VHDL Simulator
+// Description: Win32 port of stacks package
+// Note: Tristan's original i386/Linux used assembly-code
+// to manually switch stacks for performance reasons.
+// History: 2004feb09, FB, created.
+//-----------------------------------------------------------------------------
+
+#include <windows.h>
+//#include <pthread.h>
+//#include <stdlib.h>
+//#include <stdio.h>
+
+
+//#define INFO printf
+#define INFO (void)
+
+// GHDL names an endless loop calling FUNC with ARG a 'stack'
+// at a given time, only one stack may be 'executed'
+typedef struct
+{ HANDLE thread; // stack's thread
+ HANDLE mutex; // mutex to suspend/resume thread
+ void (*Func)(void*); // stack's FUNC
+ void* Arg; // ARG passed to FUNC
+} Stack_Type_t, *Stack_Type;
+
+
+static Stack_Type_t main_stack_context;
+extern void grt_set_main_stack (Stack_Type_t *stack);
+
+//------------------------------------------------------------------------------
+void grt_stack_init(void)
+// Initialize the stacks package.
+// This may adjust stack sizes.
+// Must be called after grt.options.decode.
+// => procedure Stack_Init;
+{ INFO("grt_stack_init\n");
+ INFO(" main_stack_context=0x%08x\n", &main_stack_context);
+
+ // create event. reset event, as we are currently running
+ main_stack_context.mutex = CreateEvent(NULL, // lpsa
+ FALSE, // fManualReset
+ FALSE, // fInitialState
+ NULL); // lpszEventName
+
+ grt_set_main_stack (&main_stack_context);
+}
+
+//------------------------------------------------------------------------------
+static unsigned long __stdcall grt_stack_loop(void* pv_myStack)
+{
+ Stack_Type myStack= (Stack_Type)pv_myStack;
+
+ INFO("grt_stack_loop\n");
+
+ INFO(" myStack=0x%08x\n", myStack);
+
+ // block until event becomes set again.
+ // this happens when this stack is enabled for the first time
+ WaitForSingleObject(myStack->mutex, INFINITE);
+
+ // run stack's function in endless loop
+ while(1)
+ { INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg);
+ myStack->Func(myStack->Arg);
+ }
+
+ // we never get here...
+ return 0;
+}
+
+//------------------------------------------------------------------------------
+Stack_Type grt_stack_create(void* Func, void* Arg)
+// Create a new stack, which on first execution will call FUNC with
+// an argument ARG.
+// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type;
+{ Stack_Type newStack;
+ DWORD m_IDThread; // Thread's ID (dummy)
+
+ INFO("grt_stack_create\n");
+ INFO(" call 0x%08x with 0x%08x\n", Func, Arg);
+
+ newStack= malloc(sizeof(Stack_Type_t));
+
+ // init function and argument
+ newStack->Func= Func;
+ newStack->Arg= Arg;
+
+ // create event. reset event, so that thread will blocked in grt_stack_loop
+ newStack->mutex= CreateEvent(NULL, // lpsa
+ FALSE, // fManualReset
+ FALSE, // fInitialState
+ NULL); // lpszEventName
+
+ INFO(" newStack=0x%08x\n", newStack);
+
+ // create thread, which executes grt_stack_loop
+ newStack->thread= CreateThread(NULL, // lpsa
+ 0, // cbStack
+ grt_stack_loop, // lpStartAddr
+ newStack, // lpvThreadParm
+ 0, // fdwCreate
+ &m_IDThread); // lpIDThread
+
+ return newStack;
+}
+
+//------------------------------------------------------------------------------
+void grt_stack_switch(Stack_Type To, Stack_Type From)
+// Resume stack TO and save the current context to the stack pointed by
+// CUR.
+// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type);
+{ INFO("grt_stack_switch\n");
+ INFO(" from 0x%08x to 0x%08x\n", From, To);
+
+ // set 'To' event. this will make the other thread either
+ // - start for first time in grt_stack_loop
+ // - resume at WaitForSingleObject below
+ SetEvent(To->mutex);
+
+ // block until 'From' event becomes set again
+ // as we are running, our event is reset and we block here
+ // when stacks are switched, with above SetEvent, we may proceed
+ WaitForSingleObject(From->mutex, INFINITE);
+}
+
+//------------------------------------------------------------------------------
+void grt_stack_delete(Stack_Type Stack)
+// Delete stack STACK, which must not be currently executed.
+// => procedure Stack_Delete (Stack : Stack_Type);
+{ INFO("grt_stack_delete\n");
+}
+
+//----------------------------------------------------------------------------
+#ifndef WITH_GNAT_RUN_TIME
+void __gnat_raise_storage_error(void)
+{
+ abort ();
+}
+
+void __gnat_raise_program_error(void)
+{
+ abort ();
+}
+#endif
+
+//----------------------------------------------------------------------------
+// end of file
+
diff --git a/src/translate/grt/ghdl_main.adb b/src/translate/grt/ghdl_main.adb
new file mode 100644
index 000000000..ce5b67d7e
--- /dev/null
+++ b/src/translate/grt/ghdl_main.adb
@@ -0,0 +1,61 @@
+-- GHDL Run Time (GRT) entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Grt.Options; use Grt.Options;
+with Grt.Main;
+with Grt.Types; use Grt.Types;
+
+-- Some files are only referenced from compiled code. With it here so that
+-- they get compiled during build (and elaborated).
+pragma Warnings (Off);
+with Grt.Rtis_Binding;
+with Grt.Std_Logic_1164;
+pragma Warnings (On);
+
+
+function Ghdl_Main (Argc : Integer; Argv : System.Address)
+ return Integer
+is
+ -- Grt_Init corresponds to the 'adainit' subprogram for grt.
+ procedure Grt_Init;
+ pragma Import (C, Grt_Init, "grt_init");
+
+ function To_Argv_Type is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Grt.Options.Argv_Type);
+
+ Default_Progname : constant String := "ghdl_design" & NUL;
+begin
+ if Argc > 0 then
+ Grt.Options.Progname := To_Argv_Type (Argv)(0);
+ else
+ Grt.Options.Progname := To_Ghdl_C_String (Default_Progname'Address);
+ end if;
+ Grt.Options.Argc := Argc;
+ Grt.Options.Argv := To_Argv_Type (Argv);
+
+ Grt_Init;
+ Grt.Main.Run;
+ return 0;
+end Ghdl_Main;
diff --git a/src/translate/grt/ghdl_main.ads b/src/translate/grt/ghdl_main.ads
new file mode 100644
index 000000000..88d181a0a
--- /dev/null
+++ b/src/translate/grt/ghdl_main.ads
@@ -0,0 +1,33 @@
+-- GHDL Run Time (GRT) entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+
+-- 'main' function for grt.
+-- Contrary to the C main function, ARGC can be 0 (in this case a fake argv[0]
+-- is used).
+function Ghdl_Main (Argc : Integer; Argv : System.Address)
+ return Integer;
+pragma Export (C, Ghdl_Main, "ghdl_main");
+
diff --git a/src/translate/grt/ghwdump.c b/src/translate/grt/ghwdump.c
new file mode 100644
index 000000000..4affc2b5c
--- /dev/null
+++ b/src/translate/grt/ghwdump.c
@@ -0,0 +1,195 @@
+/* Display a GHDL Wavefile for debugging.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+#include <stdio.h>
+#include <stdint.h>
+#include <string.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+#include "ghwlib.h"
+
+static const char *progname;
+void
+usage (void)
+{
+ printf ("usage: %s [OPTIONS] FILEs...\n", progname);
+ printf ("Options are:\n"
+ " -t display types\n"
+ " -h display hierarchy\n"
+ " -T display time\n"
+ " -s display signals (and time)\n"
+ " -l display list of sections\n"
+ " -v verbose\n");
+}
+
+int
+main (int argc, char **argv)
+{
+ int i;
+ int flag_disp_types;
+ int flag_disp_hierarchy;
+ int flag_disp_time;
+ int flag_disp_signals;
+ int flag_list;
+ int flag_verbose;
+ int eof;
+ enum ghw_sm_type sm;
+
+ progname = argv[0];
+ flag_disp_types = 0;
+ flag_disp_hierarchy = 0;
+ flag_disp_time = 0;
+ flag_disp_signals = 0;
+ flag_list = 0;
+ flag_verbose = 0;
+
+ while (1)
+ {
+ int c;
+
+ c = getopt (argc, argv, "thTslv");
+ if (c == -1)
+ break;
+ switch (c)
+ {
+ case 't':
+ flag_disp_types = 1;
+ break;
+ case 'h':
+ flag_disp_hierarchy = 1;
+ break;
+ case 'T':
+ flag_disp_time = 1;
+ break;
+ case 's':
+ flag_disp_signals = 1;
+ flag_disp_time = 1;
+ break;
+ case 'l':
+ flag_list = 1;
+ break;
+ case 'v':
+ flag_verbose++;
+ break;
+ default:
+ usage ();
+ exit (2);
+ }
+ }
+
+ if (optind >= argc)
+ {
+ usage ();
+ return 1;
+ }
+
+ for (i = optind; i < argc; i++)
+ {
+ struct ghw_handler h;
+ struct ghw_handler *hp = &h;
+
+ hp->flag_verbose = flag_verbose;
+
+ if (ghw_open (hp, argv[i]) != 0)
+ {
+ fprintf (stderr, "cannot open ghw file %s\n", argv[i]);
+ return 1;
+ }
+ if (flag_list)
+ {
+ while (1)
+ {
+ int section;
+
+ section = ghw_read_section (hp);
+ if (section == -2)
+ {
+ printf ("eof of file\n");
+ break;
+ }
+ else if (section < 0)
+ {
+ printf ("Error in file\n");
+ break;
+ }
+ else if (section == 0)
+ {
+ printf ("Unknown section\n");
+ break;
+ }
+ printf ("Section %s\n", ghw_sections[section].name);
+ if ((*ghw_sections[section].handler)(hp) < 0)
+ break;
+ }
+ }
+ else
+ {
+ if (ghw_read_base (hp) < 0)
+ {
+ fprintf (stderr, "cannot read ghw file\n");
+ return 2;
+ }
+ if (0)
+ {
+ int i;
+ printf ("String table:\n");
+
+ for (i = 1; i < hp->nbr_str; i++)
+ printf (" %s\n", hp->str_table[i]);
+ }
+ if (flag_disp_types)
+ ghw_disp_types (hp);
+ if (flag_disp_hierarchy)
+ ghw_disp_hie (hp, hp->hie);
+
+#if 1
+ sm = ghw_sm_init;
+ eof = 0;
+ while (!eof)
+ {
+ switch (ghw_read_sm (hp, &sm))
+ {
+ case ghw_res_snapshot:
+ case ghw_res_cycle:
+ if (flag_disp_time)
+ printf ("Time is %lld fs\n", hp->snap_time);
+ if (flag_disp_signals)
+ ghw_disp_values (hp);
+ break;
+ case ghw_res_eof:
+ eof = 1;
+ break;
+ default:
+ abort ();
+ }
+ }
+
+#else
+ if (ghw_read_dump (hp) < 0)
+ {
+ fprintf (stderr, "error in ghw dump\n");
+ return 3;
+ }
+#endif
+ }
+ ghw_close (&h);
+ }
+ return 0;
+}
diff --git a/src/translate/grt/ghwlib.c b/src/translate/grt/ghwlib.c
new file mode 100644
index 000000000..2db63d9c9
--- /dev/null
+++ b/src/translate/grt/ghwlib.c
@@ -0,0 +1,1746 @@
+/* GHDL Wavefile reader library.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+#include "ghwlib.h"
+
+int
+ghw_open (struct ghw_handler *h, const char *filename)
+{
+ char hdr[16];
+
+ h->stream = fopen (filename, "rb");
+ if (h->stream == NULL)
+ return -1;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+ /* Check magic. */
+ if (memcmp (hdr, "GHDLwave\n", 9) != 0)
+ return -2;
+ /* Check version. */
+ if (hdr[9] != 16
+ || hdr[10] != 0)
+ return -2;
+ h->version = hdr[11];
+ if (h->version > 1)
+ return -3;
+ if (hdr[12] == 1)
+ h->word_be = 0;
+ else if (hdr[12] == 2)
+ h->word_be = 1;
+ else
+ return -4;
+#if 0
+ /* Endianness. */
+ {
+ int endian;
+ union { unsigned char b[4]; uint32_t i;} v;
+ v.i = 0x11223344;
+ if (v.b[0] == 0x11)
+ endian = 2;
+ else if (v.b[0] == 0x44)
+ endian = 1;
+ else
+ return -3;
+
+ if (hdr[12] != 1 && hdr[12] != 2)
+ return -3;
+ if (hdr[12] != endian)
+ h->swap_word = 1;
+ else
+ h->swap_word = 0;
+ }
+#endif
+ h->word_len = hdr[13];
+ h->off_len = hdr[14];
+
+ if (hdr[15] != 0)
+ return -5;
+
+ h->hie = NULL;
+ return 0;
+}
+
+int32_t
+ghw_get_i32 (struct ghw_handler *h, unsigned char *b)
+{
+ if (h->word_be)
+ return (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0);
+ else
+ return (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0);
+}
+
+int64_t
+ghw_get_i64 (struct ghw_handler *ghw_h, unsigned char *b)
+{
+ int l, h;
+
+ if (ghw_h->word_be)
+ {
+ h = (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0);
+ l = (b[4] << 24) | (b[5] << 16) | (b[6] << 8) | (b[7] << 0);
+ }
+ else
+ {
+ l = (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0);
+ h = (b[7] << 24) | (b[6] << 16) | (b[5] << 8) | (b[4] << 0);
+ }
+ return (((int64_t)h) << 32) | l;
+}
+
+int
+ghw_read_byte (struct ghw_handler *h, unsigned char *res)
+{
+ int v;
+
+ v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ *res = v;
+ return 0;
+}
+
+int
+ghw_read_uleb128 (struct ghw_handler *h, uint32_t *res)
+{
+ unsigned int r = 0;
+ unsigned int off = 0;
+
+ while (1)
+ {
+ int v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ r |= (v & 0x7f) << off;
+ if ((v & 0x80) == 0)
+ break;
+ off += 7;
+ }
+ *res = r;
+ return 0;
+}
+
+int
+ghw_read_sleb128 (struct ghw_handler *h, int32_t *res)
+{
+ int32_t r = 0;
+ unsigned int off = 0;
+
+ while (1)
+ {
+ int v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ r |= ((int32_t)(v & 0x7f)) << off;
+ off += 7;
+ if ((v & 0x80) == 0)
+ {
+ if ((v & 0x40) && off < 32)
+ r |= -1 << off;
+ break;
+ }
+ }
+ *res = r;
+ return 0;
+}
+
+int
+ghw_read_lsleb128 (struct ghw_handler *h, int64_t *res)
+{
+ static const int64_t r_mask = -1;
+ int64_t r = 0;
+ unsigned int off = 0;
+
+ while (1)
+ {
+ int v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ r |= ((int64_t)(v & 0x7f)) << off;
+ off += 7;
+ if ((v & 0x80) == 0)
+ {
+ if ((v & 0x40) && off < 64)
+ r |= r_mask << off;
+ break;
+ }
+ }
+ *res = r;
+ return 0;
+}
+
+int
+ghw_read_f64 (struct ghw_handler *h, double *res)
+{
+ /* FIXME: handle byte order. */
+ if (fread (res, sizeof (*res), 1, h->stream) != 1)
+ return -1;
+ return 0;
+}
+
+const char *
+ghw_read_strid (struct ghw_handler *h)
+{
+ unsigned int id;
+ if (ghw_read_uleb128 (h, &id) != 0)
+ return NULL;
+ return h->str_table[id];
+}
+
+union ghw_type *
+ghw_read_typeid (struct ghw_handler *h)
+{
+ unsigned int id;
+ if (ghw_read_uleb128 (h, &id) != 0)
+ return NULL;
+ return h->types[id - 1];
+}
+
+union ghw_range *
+ghw_read_range (struct ghw_handler *h)
+{
+ int t = fgetc (h->stream);
+ if (t == EOF)
+ return NULL;
+ switch (t & 0x7f)
+ {
+ case ghdl_rtik_type_b2:
+ {
+ struct ghw_range_b2 *r;
+ r = malloc (sizeof (struct ghw_range_b2));
+ r->kind = t & 0x7f;
+ r->dir = (t & 0x80) != 0;
+ if (ghw_read_byte (h, &r->left) != 0)
+ return NULL;
+ if (ghw_read_byte (h, &r->right) != 0)
+ return NULL;
+ return (union ghw_range *)r;
+ }
+ case ghdl_rtik_type_e8:
+ {
+ struct ghw_range_e8 *r;
+ r = malloc (sizeof (struct ghw_range_e8));
+ r->kind = t & 0x7f;
+ r->dir = (t & 0x80) != 0;
+ if (ghw_read_byte (h, &r->left) != 0)
+ return NULL;
+ if (ghw_read_byte (h, &r->right) != 0)
+ return NULL;
+ return (union ghw_range *)r;
+ }
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_p32:
+ {
+ struct ghw_range_i32 *r;
+ r = malloc (sizeof (struct ghw_range_i32));
+ r->kind = t & 0x7f;
+ r->dir = (t & 0x80) != 0;
+ if (ghw_read_sleb128 (h, &r->left) != 0)
+ return NULL;
+ if (ghw_read_sleb128 (h, &r->right) != 0)
+ return NULL;
+ return (union ghw_range *)r;
+ }
+ case ghdl_rtik_type_i64:
+ case ghdl_rtik_type_p64:
+ {
+ struct ghw_range_i64 *r;
+ r = malloc (sizeof (struct ghw_range_i64));
+ r->kind = t & 0x7f;
+ r->dir = (t & 0x80) != 0;
+ if (ghw_read_lsleb128 (h, &r->left) != 0)
+ return NULL;
+ if (ghw_read_lsleb128 (h, &r->right) != 0)
+ return NULL;
+ return (union ghw_range *)r;
+ }
+ case ghdl_rtik_type_f64:
+ {
+ struct ghw_range_f64 *r;
+ r = malloc (sizeof (struct ghw_range_f64));
+ r->kind = t & 0x7f;
+ r->dir = (t & 0x80) != 0;
+ if (ghw_read_f64 (h, &r->left) != 0)
+ return NULL;
+ if (ghw_read_f64 (h, &r->right) != 0)
+ return NULL;
+ return (union ghw_range *)r;
+ }
+ default:
+ fprintf (stderr, "ghw_read_range: type %d unhandled\n", t & 0x7f);
+ return NULL;
+ }
+}
+
+int
+ghw_read_str (struct ghw_handler *h)
+{
+ unsigned char hdr[12];
+ int i;
+ char *p;
+ int prev_len;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0)
+ return -1;
+ h->nbr_str = ghw_get_i32 (h, &hdr[4]);
+ h->nbr_str++;
+ h->str_size = ghw_get_i32 (h, &hdr[8]);
+ h->str_table = (char **)malloc ((h->nbr_str + 1) * sizeof (char *));
+ h->str_content = (char *)malloc (h->str_size + h->nbr_str + 1);
+
+ if (h->flag_verbose)
+ {
+ printf ("Number of strings: %d\n", h->nbr_str - 1);
+ printf ("String table size: %d\n", h->str_size);
+ }
+
+ h->str_table[0] = "<anon>";
+ p = h->str_content;
+ prev_len = 0;
+ for (i = 1; i < h->nbr_str; i++)
+ {
+ int j;
+ int c;
+ char *prev;
+ int sh;
+
+ h->str_table[i] = p;
+ prev = h->str_table[i - 1];
+ for (j = 0; j < prev_len; j++)
+ *p++ = prev[j];
+
+ while (1)
+ {
+ c = fgetc (h->stream);
+ if (c == EOF)
+ return -1;
+ if ((c >= 0 && c <= 31)
+ || (c >= 128 && c <= 159))
+ break;
+ *p++ = c;
+ }
+ *p++ = 0;
+
+ if (h->flag_verbose > 1)
+ printf (" string %d (pl=%d): %s\n", i, prev_len, h->str_table[i]);
+
+ prev_len = c & 0x1f;
+ sh = 5;
+ while (c >= 128)
+ {
+ c = fgetc (h->stream);
+ if (c == EOF)
+ return -1;
+ prev_len |= (c & 0x1f) << sh;
+ sh += 5;
+ }
+ }
+ if (fread (hdr, 4, 1, h->stream) != 1)
+ return -1;
+ if (memcmp (hdr, "EOS", 4) != 0)
+ return -1;
+ return 0;
+}
+
+union ghw_type *
+ghw_get_base_type (union ghw_type *t)
+{
+ switch (t->kind)
+ {
+ case ghdl_rtik_type_b2:
+ case ghdl_rtik_type_e8:
+ case ghdl_rtik_type_e32:
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_i64:
+ case ghdl_rtik_type_f64:
+ case ghdl_rtik_type_p32:
+ case ghdl_rtik_type_p64:
+ return t;
+ case ghdl_rtik_subtype_scalar:
+ return t->ss.base;
+ case ghdl_rtik_subtype_array:
+ return (union ghw_type*)(t->sa.base);
+ default:
+ fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind);
+ abort ();
+ }
+}
+
+int
+get_nbr_elements (union ghw_type *t)
+{
+ switch (t->kind)
+ {
+ case ghdl_rtik_type_b2:
+ case ghdl_rtik_type_e8:
+ case ghdl_rtik_type_e32:
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_i64:
+ case ghdl_rtik_type_f64:
+ case ghdl_rtik_type_p32:
+ case ghdl_rtik_type_p64:
+ case ghdl_rtik_subtype_scalar:
+ return 1;
+ case ghdl_rtik_subtype_array:
+ case ghdl_rtik_subtype_array_ptr:
+ return t->sa.nbr_el;
+ case ghdl_rtik_type_record:
+ return t->rec.nbr_el;
+ default:
+ fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind);
+ abort ();
+ }
+}
+
+int
+get_range_length (union ghw_range *rng)
+{
+ switch (rng->kind)
+ {
+ case ghdl_rtik_type_i32:
+ if (rng->i32.dir)
+ return (rng->i32.left - rng->i32.right + 1);
+ else
+ return (rng->i32.right - rng->i32.left + 1);
+ default:
+ fprintf (stderr, "get_range_length: unhandled kind %d\n", rng->kind);
+ abort ();
+ }
+}
+
+int
+ghw_read_type (struct ghw_handler *h)
+{
+ unsigned char hdr[8];
+ int i;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0)
+ return -1;
+ h->nbr_types = ghw_get_i32 (h, &hdr[4]);
+ h->types = (union ghw_type **)
+ malloc (h->nbr_types * sizeof (union ghw_type *));
+
+ for (i = 0; i < h->nbr_types; i++)
+ {
+ int t;
+
+ t = fgetc (h->stream);
+ if (t == EOF)
+ return -1;
+ /* printf ("type[%d]= %d\n", i, t); */
+ switch (t)
+ {
+ case ghdl_rtik_type_b2:
+ case ghdl_rtik_type_e8:
+ {
+ struct ghw_type_enum *e;
+ int j;
+
+ e = malloc (sizeof (struct ghw_type_enum));
+ e->kind = t;
+ e->wkt = ghw_wkt_unknown;
+ e->name = ghw_read_strid (h);
+ if (ghw_read_uleb128 (h, &e->nbr) != 0)
+ return -1;
+ e->lits = (const char **) malloc (e->nbr * sizeof (char *));
+ if (h->flag_verbose > 1)
+ printf ("enum %s:", e->name);
+ for (j = 0; j < e->nbr; j++)
+ {
+ e->lits[j] = ghw_read_strid (h);
+ if (h->flag_verbose > 1)
+ printf (" %s", e->lits[j]);
+ }
+ if (h->flag_verbose > 1)
+ printf ("\n");
+ h->types[i] = (union ghw_type *)e;
+ }
+ break;
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_i64:
+ case ghdl_rtik_type_f64:
+ {
+ struct ghw_type_scalar *sc;
+
+ sc = malloc (sizeof (struct ghw_type_scalar));
+ sc->kind = t;
+ sc->name = ghw_read_strid (h);
+ if (h->flag_verbose > 1)
+ printf ("scalar: %s\n", sc->name);
+ h->types[i] = (union ghw_type *)sc;
+ }
+ break;
+ case ghdl_rtik_type_p32:
+ case ghdl_rtik_type_p64:
+ {
+ struct ghw_type_physical *ph;
+
+ ph = malloc (sizeof (struct ghw_type_physical));
+ ph->kind = t;
+ ph->name = ghw_read_strid (h);
+ if (h->version == 0)
+ ph->nbr_units = 0;
+ else
+ {
+ int i;
+
+ if (ghw_read_uleb128 (h, &ph->nbr_units) != 0)
+ return -1;
+ ph->units = malloc (ph->nbr_units * sizeof (struct ghw_unit));
+ for (i = 0; i < ph->nbr_units; i++)
+ {
+ ph->units[i].name = ghw_read_strid (h);
+ if (ghw_read_lsleb128 (h, &ph->units[i].val) < 0)
+ return -1;
+ }
+ }
+ if (h->flag_verbose > 1)
+ printf ("physical: %s\n", ph->name);
+ h->types[i] = (union ghw_type *)ph;
+ }
+ break;
+ case ghdl_rtik_subtype_scalar:
+ {
+ struct ghw_subtype_scalar *ss;
+
+ ss = malloc (sizeof (struct ghw_subtype_scalar));
+ ss->kind = t;
+ ss->name = ghw_read_strid (h);
+ ss->base = ghw_read_typeid (h);
+ ss->rng = ghw_read_range (h);
+ if (h->flag_verbose > 1)
+ printf ("subtype scalar: %s\n", ss->name);
+ h->types[i] = (union ghw_type *)ss;
+ }
+ break;
+ case ghdl_rtik_type_array:
+ {
+ struct ghw_type_array *arr;
+ int j;
+
+ arr = malloc (sizeof (struct ghw_type_array));
+ arr->kind = t;
+ arr->name = ghw_read_strid (h);
+ arr->el = ghw_read_typeid (h);
+ if (ghw_read_uleb128 (h, &arr->nbr_dim) != 0)
+ return -1;
+ arr->dims = (union ghw_type **)
+ malloc (arr->nbr_dim * sizeof (union ghw_type *));
+ for (j = 0; j < arr->nbr_dim; j++)
+ arr->dims[j] = ghw_read_typeid (h);
+ if (h->flag_verbose > 1)
+ printf ("array: %s\n", arr->name);
+ h->types[i] = (union ghw_type *)arr;
+ }
+ break;
+ case ghdl_rtik_subtype_array:
+ case ghdl_rtik_subtype_array_ptr:
+ {
+ struct ghw_subtype_array *sa;
+ int j;
+ int nbr_el;
+
+ sa = malloc (sizeof (struct ghw_subtype_array));
+ sa->kind = t;
+ sa->name = ghw_read_strid (h);
+ sa->base = (struct ghw_type_array *)ghw_read_typeid (h);
+ nbr_el = get_nbr_elements (sa->base->el);
+ sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *));
+ for (j = 0; j < sa->base->nbr_dim; j++)
+ {
+ sa->rngs[j] = ghw_read_range (h);
+ nbr_el *= get_range_length (sa->rngs[j]);
+ }
+ sa->nbr_el = nbr_el;
+ if (h->flag_verbose > 1)
+ printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el);
+ h->types[i] = (union ghw_type *)sa;
+ }
+ break;
+ case ghdl_rtik_type_record:
+ {
+ struct ghw_type_record *rec;
+ int j;
+ int nbr_el;
+
+ rec = malloc (sizeof (struct ghw_type_record));
+ rec->kind = t;
+ rec->name = ghw_read_strid (h);
+ if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0)
+ return -1;
+ rec->el = malloc
+ (rec->nbr_fields * sizeof (struct ghw_record_element));
+ nbr_el = 0;
+ for (j = 0; j < rec->nbr_fields; j++)
+ {
+ rec->el[j].name = ghw_read_strid (h);
+ rec->el[j].type = ghw_read_typeid (h);
+ nbr_el += get_nbr_elements (rec->el[j].type);
+ }
+ rec->nbr_el = nbr_el;
+ if (h->flag_verbose > 1)
+ printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el);
+ h->types[i] = (union ghw_type *)rec;
+ }
+ break;
+ default:
+ fprintf (stderr, "ghw_read_type: unknown type %d\n", t);
+ return -1;
+ }
+ }
+ if (fgetc (h->stream) != 0)
+ return -1;
+ return 0;
+}
+
+int
+ghw_read_wk_types (struct ghw_handler *h)
+{
+ char hdr[4];
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0)
+ return -1;
+
+ while (1)
+ {
+ int t;
+ union ghw_type *tid;
+
+ t = fgetc (h->stream);
+ if (t == EOF)
+ return -1;
+ else if (t == 0)
+ break;
+
+ tid = ghw_read_typeid (h);
+ if (tid->kind == ghdl_rtik_type_b2
+ || tid->kind == ghdl_rtik_type_e8)
+ {
+ if (h->flag_verbose > 0)
+ printf ("%s: wkt=%d\n", tid->en.name, t);
+ tid->en.wkt = t;
+ }
+ }
+ return 0;
+}
+
+void
+ghw_disp_typename (struct ghw_handler *h, union ghw_type *t)
+{
+ printf ("%s", t->common.name);
+}
+
+/* Read a signal composed of severals elements. */
+int
+ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t)
+{
+ switch (t->kind)
+ {
+ case ghdl_rtik_type_b2:
+ case ghdl_rtik_type_e8:
+ case ghdl_rtik_type_e32:
+ case ghdl_rtik_subtype_scalar:
+ {
+ unsigned int sig_el;
+
+ if (ghw_read_uleb128 (h, &sig_el) < 0)
+ return -1;
+ *sigs = sig_el;
+ if (sig_el >= h->nbr_sigs)
+ abort ();
+ if (h->sigs[sig_el].type == NULL)
+ h->sigs[sig_el].type = ghw_get_base_type (t);
+ }
+ return 0;
+ case ghdl_rtik_subtype_array:
+ case ghdl_rtik_subtype_array_ptr:
+ {
+ int i;
+ int stride;
+ int len;
+
+ len = t->sa.nbr_el;
+ stride = get_nbr_elements (t->sa.base->el);
+
+ for (i = 0; i < len; i += stride)
+ if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0)
+ return -1;
+ }
+ return 0;
+ case ghdl_rtik_type_record:
+ {
+ int i;
+ int off;
+
+ off = 0;
+ for (i = 0; i < t->rec.nbr_fields; i++)
+ {
+ if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0)
+ return -1;
+ off += get_nbr_elements (t->rec.el[i].type);
+ }
+ }
+ return 0;
+ default:
+ fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind);
+ abort ();
+ }
+}
+
+
+int
+ghw_read_value (struct ghw_handler *h,
+ union ghw_val *val, union ghw_type *type)
+{
+ switch (ghw_get_base_type (type)->kind)
+ {
+ case ghdl_rtik_type_b2:
+ {
+ int v;
+ v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ val->b2 = v;
+ }
+ break;
+ case ghdl_rtik_type_e8:
+ {
+ int v;
+ v = fgetc (h->stream);
+ if (v == EOF)
+ return -1;
+ val->e8 = v;
+ }
+ break;
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_p32:
+ {
+ int32_t v;
+ if (ghw_read_sleb128 (h, &v) < 0)
+ return -1;
+ val->i32 = v;
+ }
+ break;
+ case ghdl_rtik_type_f64:
+ {
+ double v;
+ if (ghw_read_f64 (h, &v) < 0)
+ return -1;
+ val->f64 = v;
+ }
+ break;
+ case ghdl_rtik_type_p64:
+ {
+ int64_t v;
+ if (ghw_read_lsleb128 (h, &v) < 0)
+ return -1;
+ val->i64 = v;
+ }
+ break;
+ default:
+ fprintf (stderr, "read_value: cannot handle format %d\n", type->kind);
+ abort ();
+ }
+ return 0;
+}
+
+int
+ghw_read_hie (struct ghw_handler *h)
+{
+ unsigned char hdr[16];
+ int nbr_scopes;
+ int nbr_sigs;
+ int i;
+ struct ghw_hie *blk;
+ struct ghw_hie **last;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0)
+ return -1;
+ nbr_scopes = ghw_get_i32 (h, &hdr[4]);
+ /* Number of declared signals (which may be composite). */
+ nbr_sigs = ghw_get_i32 (h, &hdr[8]);
+ /* Number of basic signals. */
+ h->nbr_sigs = ghw_get_i32 (h, &hdr[12]);
+
+ if (h->flag_verbose)
+ printf ("%d scopes, %d signals, %d signal elements\n",
+ nbr_scopes, nbr_sigs, h->nbr_sigs);
+
+ blk = (struct ghw_hie *)malloc (sizeof (struct ghw_hie));
+ blk->kind = ghw_hie_design;
+ blk->name = NULL;
+ blk->parent = NULL;
+ blk->brother = NULL;
+ blk->u.blk.child = NULL;
+
+ last = &blk->u.blk.child;
+ h->hie = blk;
+
+ h->nbr_sigs++;
+ h->sigs = (struct ghw_sig *) malloc (h->nbr_sigs * sizeof (struct ghw_sig));
+ memset (h->sigs, 0, h->nbr_sigs * sizeof (struct ghw_sig));
+
+ while (1)
+ {
+ int t;
+ struct ghw_hie *el;
+ unsigned int str;
+
+ t = fgetc (h->stream);
+ if (t == EOF)
+ return -1;
+ if (t == 0)
+ break;
+
+ if (t == ghw_hie_eos)
+ {
+ blk = blk->parent;
+ if (blk->u.blk.child == NULL)
+ last = &blk->u.blk.child;
+ else
+ {
+ struct ghw_hie *l = blk->u.blk.child;
+ while (l->brother != NULL)
+ l = l->brother;
+ last = &l->brother;
+ }
+
+ continue;
+ }
+
+ el = (struct ghw_hie *) malloc (sizeof (struct ghw_hie));
+ el->kind = t;
+ el->parent = blk;
+ el->brother = NULL;
+
+ /* Link. */
+ *last = el;
+ last = &el->brother;
+
+ /* Read name. */
+ if (ghw_read_uleb128 (h, &str) != 0)
+ return -1;
+ el->name = h->str_table[str];
+
+ switch (t)
+ {
+ case ghw_hie_eoh:
+ case ghw_hie_design:
+ case ghw_hie_eos:
+ /* Should not be here. */
+ abort ();
+ case ghw_hie_process:
+ break;
+ case ghw_hie_block:
+ case ghw_hie_generate_if:
+ case ghw_hie_generate_for:
+ case ghw_hie_instance:
+ case ghw_hie_generic:
+ case ghw_hie_package:
+ /* Create a block. */
+ el->u.blk.child = NULL;
+
+ if (t == ghw_hie_generate_for)
+ {
+ el->u.blk.iter_type = ghw_read_typeid (h);
+ el->u.blk.iter_value = malloc (sizeof (union ghw_val));
+ if (ghw_read_value (h, el->u.blk.iter_value,
+ el->u.blk.iter_type) < 0)
+ return -1;
+ }
+ blk = el;
+ last = &el->u.blk.child;
+ break;
+ case ghw_hie_signal:
+ case ghw_hie_port_in:
+ case ghw_hie_port_out:
+ case ghw_hie_port_inout:
+ case ghw_hie_port_buffer:
+ case ghw_hie_port_linkage:
+ /* For a signal, read type. */
+ {
+ int nbr_el;
+ unsigned int *sigs;
+
+ el->u.sig.type = ghw_read_typeid (h);
+ nbr_el = get_nbr_elements (el->u.sig.type);
+ sigs = (unsigned int *) malloc
+ ((nbr_el + 1) * sizeof (unsigned int));
+ el->u.sig.sigs = sigs;
+ /* Last element is NULL. */
+ sigs[nbr_el] = 0;
+
+ if (h->flag_verbose > 1)
+ printf ("signal %s: %d el [", el->name, nbr_el);
+ if (ghw_read_signal (h, sigs, el->u.sig.type) < 0)
+ return -1;
+ if (h->flag_verbose > 1)
+ {
+ int i;
+ for (i = 0; i < nbr_el; i++)
+ printf (" #%u", sigs[i]);
+ printf ("]\n");
+ }
+ }
+ break;
+ default:
+ fprintf (stderr, "ghw_read_hie: unhandled kind %d\n", t);
+ abort ();
+ }
+ }
+
+ /* Allocate values. */
+ for (i = 0; i < h->nbr_sigs; i++)
+ if (h->sigs[i].type != NULL)
+ h->sigs[i].val = (union ghw_val *) malloc (sizeof (union ghw_val));
+ return 0;
+}
+
+const char *
+ghw_get_hie_name (struct ghw_hie *h)
+{
+ switch (h->kind)
+ {
+ case ghw_hie_eoh:
+ return "eoh";
+ case ghw_hie_design:
+ return "design";
+ case ghw_hie_block:
+ return "block";
+ case ghw_hie_generate_if:
+ return "generate-if";
+ case ghw_hie_generate_for:
+ return "generate-for";
+ case ghw_hie_instance:
+ return "instance";
+ case ghw_hie_package:
+ return "package";
+ case ghw_hie_process:
+ return "process";
+ case ghw_hie_generic:
+ return "generic";
+ case ghw_hie_eos:
+ return "eos";
+ case ghw_hie_signal:
+ return "signal";
+ case ghw_hie_port_in:
+ return "port-in";
+ case ghw_hie_port_out:
+ return "port-out";
+ case ghw_hie_port_inout:
+ return "port-inout";
+ case ghw_hie_port_buffer:
+ return "port-buffer";
+ case ghw_hie_port_linkage:
+ return "port-linkage";
+ default:
+ return "??";
+ }
+}
+
+void
+ghw_disp_value (union ghw_val *val, union ghw_type *type);
+
+void
+ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top)
+{
+ int i;
+ int indent;
+ struct ghw_hie *hie;
+ struct ghw_hie *n;
+
+ hie = top;
+ indent = 0;
+
+ while (1)
+ {
+ for (i = 0; i < indent; i++)
+ fputc (' ', stdout);
+ printf ("%s", ghw_get_hie_name (hie));
+
+ switch (hie->kind)
+ {
+ case ghw_hie_design:
+ case ghw_hie_block:
+ case ghw_hie_generate_if:
+ case ghw_hie_generate_for:
+ case ghw_hie_instance:
+ case ghw_hie_process:
+ case ghw_hie_package:
+ if (hie->name)
+ printf (" %s", hie->name);
+ if (hie->kind == ghw_hie_generate_for)
+ {
+ printf ("(");
+ ghw_disp_value (hie->u.blk.iter_value, hie->u.blk.iter_type);
+ printf (")");
+ }
+ n = hie->u.blk.child;
+ if (n == NULL)
+ n = hie->brother;
+ else
+ indent++;
+ break;
+ case ghw_hie_generic:
+ case ghw_hie_eos:
+ abort ();
+ case ghw_hie_signal:
+ case ghw_hie_port_in:
+ case ghw_hie_port_out:
+ case ghw_hie_port_inout:
+ case ghw_hie_port_buffer:
+ case ghw_hie_port_linkage:
+ {
+ unsigned int *sigs;
+
+ printf (" %s: ", hie->name);
+ ghw_disp_typename (h, hie->u.sig.type);
+ for (sigs = hie->u.sig.sigs; *sigs != 0; sigs++)
+ printf (" #%u", *sigs);
+ n = hie->brother;
+ }
+ break;
+ default:
+ abort ();
+ }
+ printf ("\n");
+
+ while (n == NULL)
+ {
+ if (hie->parent == NULL)
+ return;
+ hie = hie->parent;
+ indent--;
+ n = hie->brother;
+ }
+ hie = n;
+ }
+}
+
+int
+ghw_read_eoh (struct ghw_handler *h)
+{
+ return 0;
+}
+
+
+int
+ghw_read_base (struct ghw_handler *h)
+{
+ unsigned char hdr[4];
+ int res;
+
+ while (1)
+ {
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+ if (memcmp (hdr, "STR", 4) == 0)
+ res = ghw_read_str (h);
+ else if (memcmp (hdr, "HIE", 4) == 0)
+ res = ghw_read_hie (h);
+ else if (memcmp (hdr, "TYP", 4) == 0)
+ res = ghw_read_type (h);
+ else if (memcmp (hdr, "WKT", 4) == 0)
+ res = ghw_read_wk_types (h);
+ else if (memcmp (hdr, "EOH", 4) == 0)
+ return 0;
+ else
+ {
+ fprintf (stderr, "ghw_read_base: unknown GHW section %c%c%c%c\n",
+ hdr[0], hdr[1], hdr[2], hdr[3]);
+ return -1;
+ }
+ if (res != 0)
+ {
+ fprintf (stderr, "ghw_read_base: error in section %s\n", hdr);
+ return res;
+ }
+ }
+}
+
+int
+ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s)
+{
+ return ghw_read_value (h, s->val, s->type);
+}
+
+int
+ghw_read_snapshot (struct ghw_handler *h)
+{
+ unsigned char hdr[12];
+ int i;
+ struct ghw_sig *s;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0)
+ return -1;
+ h->snap_time = ghw_get_i64 (h, &hdr[4]);
+ if (h->flag_verbose > 1)
+ printf ("Time is %lld fs\n", h->snap_time);
+
+ for (i = 0; i < h->nbr_sigs; i++)
+ {
+ s = &h->sigs[i];
+ if (s->type != NULL)
+ {
+ if (h->flag_verbose > 1)
+ printf ("read type %d for sig %d\n", s->type->kind, i);
+ if (ghw_read_signal_value (h, s) < 0)
+ return -1;
+ }
+ }
+ if (fread (hdr, 4, 1, h->stream) != 1)
+ return -1;
+
+ if (memcmp (hdr, "ESN", 4))
+ return -1;
+
+ return 0;
+}
+
+void ghw_disp_values (struct ghw_handler *h);
+
+int
+ghw_read_cycle_start (struct ghw_handler *h)
+{
+ unsigned char hdr[8];
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ h->snap_time = ghw_get_i64 (h, hdr);
+ return 0;
+}
+
+int
+ghw_read_cycle_cont (struct ghw_handler *h, int *list)
+{
+ int i;
+ int *list_p;
+
+ i = 0;
+ list_p = list;
+ while (1)
+ {
+ uint32_t d;
+
+ /* Read delta to next signal. */
+ if (ghw_read_uleb128 (h, &d) < 0)
+ return -1;
+ if (d == 0)
+ {
+ /* Last signal reached. */
+ break;
+ }
+
+ /* Find next signal. */
+ while (d > 0)
+ {
+ i++;
+ if (h->sigs[i].type != NULL)
+ d--;
+ }
+
+ if (ghw_read_signal_value (h, &h->sigs[i]) < 0)
+ return -1;
+ if (list_p)
+ *list_p++ = i;
+ }
+
+ if (list_p)
+ *list_p = 0;
+ return 0;
+}
+
+int
+ghw_read_cycle_next (struct ghw_handler *h)
+{
+ int64_t d_time;
+
+ if (ghw_read_lsleb128 (h, &d_time) < 0)
+ return -1;
+ if (d_time == -1)
+ return 0;
+ h->snap_time += d_time;
+ return 1;
+}
+
+
+int
+ghw_read_cycle_end (struct ghw_handler *h)
+{
+ char hdr[4];
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+ if (memcmp (hdr, "ECY", 4))
+ return -1;
+
+ return 0;
+}
+
+static const char *
+ghw_get_lit (union ghw_type *type, int e)
+{
+ if (e >= type->en.nbr || e < 0)
+ return "??";
+ else
+ return type->en.lits[e];
+}
+
+static void
+ghw_disp_lit (union ghw_type *type, int e)
+{
+ printf ("%s (%d)", ghw_get_lit (type, e), e);
+}
+
+void
+ghw_disp_value (union ghw_val *val, union ghw_type *type)
+{
+ switch (ghw_get_base_type (type)->kind)
+ {
+ case ghdl_rtik_type_b2:
+ ghw_disp_lit (type, val->b2);
+ break;
+ case ghdl_rtik_type_e8:
+ ghw_disp_lit (type, val->e8);
+ break;
+ case ghdl_rtik_type_i32:
+ printf ("%d", val->i32);
+ break;
+ case ghdl_rtik_type_p64:
+ printf ("%lld", val->i64);
+ break;
+ case ghdl_rtik_type_f64:
+ printf ("%g", val->f64);
+ break;
+ default:
+ fprintf (stderr, "ghw_disp_value: cannot handle type %d\n",
+ type->kind);
+ abort ();
+ }
+}
+
+/* Put the ASCII representation of VAL into BUF, whose size if LEN.
+ A NUL is always written to BUF.
+*/
+void
+ghw_get_value (char *buf, int len, union ghw_val *val, union ghw_type *type)
+{
+ switch (ghw_get_base_type (type)->kind)
+ {
+ case ghdl_rtik_type_b2:
+ if (val->b2 <= 1)
+ {
+ strncpy (buf, type->en.lits[val->b2], len - 1);
+ buf[len - 1] = 0;
+ }
+ else
+ {
+ snprintf (buf, len, "?%d", val->b2);
+ }
+ break;
+ case ghdl_rtik_type_e8:
+ if (val->b2 <= type->en.nbr)
+ {
+ strncpy (buf, type->en.lits[val->e8], len - 1);
+ buf[len - 1] = 0;
+ }
+ else
+ {
+ snprintf (buf, len, "?%d", val->e8);
+ }
+ break;
+ case ghdl_rtik_type_i32:
+ snprintf (buf, len, "%d", val->i32);
+ break;
+ case ghdl_rtik_type_p64:
+ snprintf (buf, len, "%lld", val->i64);
+ break;
+ case ghdl_rtik_type_f64:
+ snprintf (buf, len, "%g", val->f64);
+ break;
+ default:
+ snprintf (buf, len, "?bad type %d?", type->kind);
+ }
+}
+
+void
+ghw_disp_values (struct ghw_handler *h)
+{
+ int i;
+
+ for (i = 0; i < h->nbr_sigs; i++)
+ {
+ struct ghw_sig *s = &h->sigs[i];
+ if (s->type != NULL)
+ {
+ printf ("#%d: ", i);
+ ghw_disp_value (s->val, s->type);
+ printf ("\n");
+ }
+ }
+}
+
+int
+ghw_read_directory (struct ghw_handler *h)
+{
+ unsigned char hdr[8];
+ int nbr_entries;
+ int i;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ nbr_entries = ghw_get_i32 (h, &hdr[4]);
+
+ if (h->flag_verbose)
+ printf ("Directory (%d entries):\n", nbr_entries);
+
+ for (i = 0; i < nbr_entries; i++)
+ {
+ unsigned char ent[8];
+ int pos;
+
+ if (fread (ent, sizeof (ent), 1, h->stream) != 1)
+ return -1;
+
+ pos = ghw_get_i32 (h, &ent[4]);
+ if (h->flag_verbose)
+ printf (" %s at %d\n", ent, pos);
+ }
+
+ if (fread (hdr, 4, 1, h->stream) != 1)
+ return -1;
+ if (memcmp (hdr, "EOD", 4))
+ return -1;
+ return 0;
+}
+
+int
+ghw_read_tailer (struct ghw_handler *h)
+{
+ unsigned char hdr[8];
+ int pos;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ return -1;
+
+ pos = ghw_get_i32 (h, &hdr[4]);
+
+ if (h->flag_verbose)
+ printf ("Tailer: directory at %d\n", pos);
+ return 0;
+}
+
+enum ghw_res
+ghw_read_sm_hdr (struct ghw_handler *h, int *list)
+{
+ unsigned char hdr[4];
+ int res;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ {
+ if (feof (h->stream))
+ return ghw_res_eof;
+ else
+ return ghw_res_error;
+ }
+ if (memcmp (hdr, "SNP", 4) == 0)
+ {
+ res = ghw_read_snapshot (h);
+ if (res < 0)
+ return res;
+ return ghw_res_snapshot;
+ }
+ else if (memcmp (hdr, "CYC", 4) == 0)
+ {
+ res = ghw_read_cycle_start (h);
+ if (res < 0)
+ return res;
+ res = ghw_read_cycle_cont (h, list);
+ if (res < 0)
+ return res;
+
+ return ghw_res_cycle;
+ }
+ else if (memcmp (hdr, "DIR", 4) == 0)
+ {
+ res = ghw_read_directory (h);
+ }
+ else if (memcmp (hdr, "TAI", 4) == 0)
+ {
+ res = ghw_read_tailer (h);
+ }
+ else
+ {
+ fprintf (stderr, "unknown GHW section %c%c%c%c\n",
+ hdr[0], hdr[1], hdr[2], hdr[3]);
+ return -1;
+ }
+ if (res != 0)
+ return res;
+ return ghw_res_other;
+}
+
+int
+ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm)
+{
+ int res;
+
+ while (1)
+ {
+ /* printf ("sm: state = %d\n", *sm); */
+ switch (*sm)
+ {
+ case ghw_sm_init:
+ case ghw_sm_sect:
+ res = ghw_read_sm_hdr (h, NULL);
+ switch (res)
+ {
+ case ghw_res_other:
+ break;
+ case ghw_res_snapshot:
+ *sm = ghw_sm_sect;
+ return res;
+ case ghw_res_cycle:
+ *sm = ghw_sm_cycle;
+ return res;
+ default:
+ return res;
+ }
+ break;
+ case ghw_sm_cycle:
+ if (0)
+ printf ("Time is %lld fs\n", h->snap_time);
+ if (0)
+ ghw_disp_values (h);
+
+ res = ghw_read_cycle_next (h);
+ if (res < 0)
+ return res;
+ if (res == 1)
+ {
+ res = ghw_read_cycle_cont (h, NULL);
+ if (res < 0)
+ return res;
+ return ghw_res_cycle;
+ }
+ res = ghw_read_cycle_end (h);
+ if (res < 0)
+ return res;
+ *sm = ghw_sm_sect;
+ break;
+ }
+ }
+}
+
+int
+ghw_read_cycle (struct ghw_handler *h)
+{
+ int res;
+
+ res = ghw_read_cycle_start (h);
+ if (res < 0)
+ return res;
+ while (1)
+ {
+ res = ghw_read_cycle_cont (h, NULL);
+ if (res < 0)
+ return res;
+
+ if (0)
+ printf ("Time is %lld fs\n", h->snap_time);
+ if (0)
+ ghw_disp_values (h);
+
+
+ res = ghw_read_cycle_next (h);
+ if (res < 0)
+ return res;
+ if (res == 0)
+ break;
+ }
+ res = ghw_read_cycle_end (h);
+ return res;
+}
+
+int
+ghw_read_dump (struct ghw_handler *h)
+{
+ unsigned char hdr[4];
+ int res;
+
+ while (1)
+ {
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ {
+ if (feof (h->stream))
+ return 0;
+ else
+ return -1;
+ }
+ if (memcmp (hdr, "SNP", 4) == 0)
+ {
+ res = ghw_read_snapshot (h);
+ if (0 && res >= 0)
+ ghw_disp_values (h);
+ }
+ else if (memcmp (hdr, "CYC", 4) == 0)
+ {
+ res = ghw_read_cycle (h);
+ }
+ else if (memcmp (hdr, "DIR", 4) == 0)
+ {
+ res = ghw_read_directory (h);
+ }
+ else if (memcmp (hdr, "TAI", 4) == 0)
+ {
+ res = ghw_read_tailer (h);
+ }
+ else
+ {
+ fprintf (stderr, "unknown GHW section %c%c%c%c\n",
+ hdr[0], hdr[1], hdr[2], hdr[3]);
+ return -1;
+ }
+ if (res != 0)
+ return res;
+ }
+}
+
+struct ghw_section ghw_sections[] = {
+ { "\0\0\0", NULL },
+ { "STR", ghw_read_str },
+ { "HIE", ghw_read_hie },
+ { "TYP", ghw_read_type },
+ { "WKT", ghw_read_wk_types },
+ { "EOH", ghw_read_eoh },
+ { "SNP", ghw_read_snapshot },
+ { "CYC", ghw_read_cycle },
+ { "DIR", ghw_read_directory },
+ { "TAI", ghw_read_tailer }
+};
+
+int
+ghw_read_section (struct ghw_handler *h)
+{
+ unsigned char hdr[4];
+ int i;
+
+ if (fread (hdr, sizeof (hdr), 1, h->stream) != 1)
+ {
+ if (feof (h->stream))
+ return -2;
+ else
+ return -1;
+ }
+
+ for (i = 1; i < sizeof (ghw_sections) / sizeof (*ghw_sections); i++)
+ if (memcmp (hdr, ghw_sections[i].name, 4) == 0)
+ return i;
+
+ fprintf (stderr, "ghw_read_section: unknown GHW section %c%c%c%c\n",
+ hdr[0], hdr[1], hdr[2], hdr[3]);
+ return 0;
+}
+
+void
+ghw_close (struct ghw_handler *h)
+{
+ if (h->stream)
+ {
+ fclose (h->stream);
+ h->stream = NULL;
+ }
+}
+
+const char *
+ghw_get_dir (int is_downto)
+{
+ return is_downto ? "downto" : "to";
+}
+
+void
+ghw_disp_range (union ghw_type *type, union ghw_range *rng)
+{
+ switch (rng->kind)
+ {
+ case ghdl_rtik_type_e8:
+ printf ("%s %s %s", ghw_get_lit (type, rng->e8.left),
+ ghw_get_dir (rng->e8.dir), ghw_get_lit (type, rng->e8.right));
+ break;
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_p32:
+ printf ("%d %s %d",
+ rng->i32.left, ghw_get_dir (rng->i32.dir), rng->i32.right);
+ break;
+ case ghdl_rtik_type_i64:
+ case ghdl_rtik_type_p64:
+ printf ("%lld %s %lld",
+ rng->i64.left, ghw_get_dir (rng->i64.dir), rng->i64.right);
+ break;
+ case ghdl_rtik_type_f64:
+ printf ("%g %s %g",
+ rng->f64.left, ghw_get_dir (rng->f64.dir), rng->f64.right);
+ break;
+ default:
+ printf ("?(%d)", rng->kind);
+ }
+}
+
+void
+ghw_disp_type (struct ghw_handler *h, union ghw_type *t)
+{
+ switch (t->kind)
+ {
+ case ghdl_rtik_type_b2:
+ case ghdl_rtik_type_e8:
+ {
+ struct ghw_type_enum *e = &t->en;
+ int i;
+
+ printf ("type %s is (", e->name);
+ for (i = 0; i < e->nbr; i++)
+ {
+ if (i != 0)
+ printf (", ");
+ printf ("%s", e->lits[i]);
+ }
+ printf (");");
+ if (e->wkt != ghw_wkt_unknown)
+ printf (" -- WKT:%d", e->wkt);
+ printf ("\n");
+ }
+ break;
+ case ghdl_rtik_type_i32:
+ case ghdl_rtik_type_f64:
+ {
+ struct ghw_type_scalar *s = &t->sc;
+ printf ("type %s is range <>;\n", s->name);
+ }
+ break;
+ case ghdl_rtik_type_p32:
+ case ghdl_rtik_type_p64:
+ {
+ int i;
+
+ struct ghw_type_physical *p = &t->ph;
+ printf ("type %s is range <> units\n", p->name);
+ for (i = 0; i < p->nbr_units; i++)
+ {
+ struct ghw_unit *u = &p->units[i];
+ printf (" %s = %lld %s;\n", u->name, u->val, p->units[0].name);
+ }
+ printf ("end units\n");
+ }
+ break;
+ case ghdl_rtik_subtype_scalar:
+ {
+ struct ghw_subtype_scalar *s = &t->ss;
+ printf ("subtype %s is ", s->name);
+ ghw_disp_typename (h, s->base);
+ printf (" range ");
+ ghw_disp_range (s->base, s->rng);
+ printf (";\n");
+ }
+ break;
+ case ghdl_rtik_type_array:
+ {
+ struct ghw_type_array *a = &t->ar;
+ int i;
+
+ printf ("type %s is array (", a->name);
+ for (i = 0; i < a->nbr_dim; i++)
+ {
+ if (i != 0)
+ printf (", ");
+ ghw_disp_typename (h, a->dims[i]);
+ printf (" range <>");
+ }
+ printf (") of ");
+ ghw_disp_typename (h, a->el);
+ printf (";\n");
+ }
+ break;
+ case ghdl_rtik_subtype_array:
+ case ghdl_rtik_subtype_array_ptr:
+ {
+ struct ghw_subtype_array *a = &t->sa;
+ int i;
+
+ printf ("subtype %s is ", a->name);
+ ghw_disp_typename (h, (union ghw_type *)a->base);
+ printf (" (");
+ for (i = 0; i < a->base->nbr_dim; i++)
+ {
+ if (i != 0)
+ printf (", ");
+ ghw_disp_range ((union ghw_type *)a->base, a->rngs[i]);
+ }
+ printf (");\n");
+ }
+ break;
+ case ghdl_rtik_type_record:
+ {
+ struct ghw_type_record *r = &t->rec;
+ int i;
+
+ printf ("type %s is record\n", r->name);
+ for (i = 0; i < r->nbr_fields; i++)
+ {
+ printf (" %s: ", r->el[i].name);
+ ghw_disp_typename (h, r->el[i].type);
+ printf ("\n");
+ }
+ printf ("end record;\n");
+ }
+ break;
+ default:
+ printf ("ghw_disp_type: unhandled type kind %d\n", t->kind);
+ }
+}
+
+void
+ghw_disp_types (struct ghw_handler *h)
+{
+ int i;
+
+ for (i = 0; i < h->nbr_types; i++)
+ ghw_disp_type (h, h->types[i]);
+}
diff --git a/src/translate/grt/ghwlib.h b/src/translate/grt/ghwlib.h
new file mode 100644
index 000000000..0138267ed
--- /dev/null
+++ b/src/translate/grt/ghwlib.h
@@ -0,0 +1,399 @@
+/* GHDL Wavefile reader library.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+
+#ifndef _GHWLIB_H_
+#define _GHWLIB_H_
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef __GNUC__
+#include <stdint.h>
+#endif
+
+enum ghdl_rtik {
+ ghdl_rtik_top, /* 0 */
+ ghdl_rtik_library,
+ ghdl_rtik_package,
+ ghdl_rtik_package_body,
+ ghdl_rtik_entity,
+ ghdl_rtik_architecture, /* 5 */
+ ghdl_rtik_process,
+ ghdl_rtik_block,
+ ghdl_rtik_if_generate,
+ ghdl_rtik_for_generate,
+ ghdl_rtik_instance,
+ ghdl_rtik_constant,
+ ghdl_rtik_iterator,
+ ghdl_rtik_variable,
+ ghdl_rtik_signal,
+ ghdl_rtik_file,
+ ghdl_rtik_port,
+ ghdl_rtik_generic,
+ ghdl_rtik_alias,
+ ghdl_rtik_guard,
+ ghdl_rtik_component,
+ ghdl_rtik_attribute,
+ ghdl_rtik_type_b2, /* 22 */
+ ghdl_rtik_type_e8,
+ ghdl_rtik_type_e32,
+ ghdl_rtik_type_i32, /* 25 */
+ ghdl_rtik_type_i64,
+ ghdl_rtik_type_f64,
+ ghdl_rtik_type_p32,
+ ghdl_rtik_type_p64,
+ ghdl_rtik_type_access, /* 30 */
+ ghdl_rtik_type_array,
+ ghdl_rtik_type_record,
+ ghdl_rtik_type_file,
+ ghdl_rtik_subtype_scalar,
+ ghdl_rtik_subtype_array, /* 35 */
+ ghdl_rtik_subtype_array_ptr,
+ ghdl_rtik_subtype_unconstrained_array,
+ ghdl_rtik_subtype_record,
+ ghdl_rtik_subtype_access,
+ ghdl_rtik_type_protected,
+ ghdl_rtik_element,
+ ghdl_rtik_unit,
+ ghdl_rtik_attribute_transaction,
+ ghdl_rtik_attribute_quiet,
+ ghdl_rtik_attribute_stable,
+ ghdl_rtik_error
+};
+
+/* Well-known types. */
+enum ghw_wkt_type {
+ ghw_wkt_unknown,
+ ghw_wkt_boolean,
+ ghw_wkt_bit,
+ ghw_wkt_std_ulogic
+};
+
+struct ghw_range_b2
+{
+ enum ghdl_rtik kind : 8;
+ int dir : 8; /* 0: to, !0: downto. */
+ unsigned char left;
+ unsigned char right;
+};
+
+struct ghw_range_e8
+{
+ enum ghdl_rtik kind : 8;
+ int dir : 8; /* 0: to, !0: downto. */
+ unsigned char left;
+ unsigned char right;
+};
+
+struct ghw_range_i32
+{
+ enum ghdl_rtik kind : 8;
+ int dir : 8; /* 0: to, !0: downto. */
+ int32_t left;
+ int32_t right;
+};
+
+struct ghw_range_i64
+{
+ enum ghdl_rtik kind : 8;
+ int dir : 8;
+ int64_t left;
+ int64_t right;
+};
+
+struct ghw_range_f64
+{
+ enum ghdl_rtik kind : 8;
+ int dir : 8;
+ double left;
+ double right;
+};
+
+union ghw_range
+{
+ enum ghdl_rtik kind : 8;
+ struct ghw_range_e8 e8;
+ struct ghw_range_i32 i32;
+ struct ghw_range_i64 i64;
+ struct ghw_range_f64 f64;
+};
+
+/* Note: the first two fields must be kind and name. */
+union ghw_type;
+
+struct ghw_type_common
+{
+ enum ghdl_rtik kind;
+ const char *name;
+};
+
+struct ghw_type_enum
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ enum ghw_wkt_type wkt;
+ unsigned int nbr;
+ const char **lits;
+};
+
+struct ghw_type_scalar
+{
+ enum ghdl_rtik kind;
+ const char *name;
+};
+
+struct ghw_unit
+{
+ const char *name;
+ int64_t val;
+};
+
+struct ghw_type_physical
+{
+ enum ghdl_rtik kind;
+ const char *name;
+ uint32_t nbr_units;
+ struct ghw_unit *units;
+};
+
+struct ghw_type_array
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ unsigned int nbr_dim;
+ union ghw_type *el;
+ union ghw_type **dims;
+};
+
+struct ghw_subtype_array
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ struct ghw_type_array *base;
+ int nbr_el;
+ union ghw_range **rngs;
+};
+
+struct ghw_subtype_scalar
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ union ghw_type *base;
+ union ghw_range *rng;
+};
+
+struct ghw_record_element
+{
+ const char *name;
+ union ghw_type *type;
+};
+
+struct ghw_type_record
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ unsigned int nbr_fields;
+ int nbr_el; /* Number of scalar signals. */
+ struct ghw_record_element *el;
+};
+
+union ghw_type
+{
+ enum ghdl_rtik kind;
+ struct ghw_type_common common;
+ struct ghw_type_enum en;
+ struct ghw_type_scalar sc;
+ struct ghw_type_physical ph;
+ struct ghw_subtype_scalar ss;
+ struct ghw_subtype_array sa;
+ struct ghw_type_array ar;
+ struct ghw_type_record rec;
+};
+
+union ghw_val
+{
+ unsigned char b2;
+ unsigned char e8;
+ int32_t i32;
+ int64_t i64;
+ double f64;
+};
+
+/* A non-composite signal. */
+struct ghw_sig
+{
+ union ghw_type *type;
+ union ghw_val *val;
+};
+
+enum ghw_hie_kind {
+ ghw_hie_eoh = 0,
+ ghw_hie_design = 1,
+ ghw_hie_block = 3,
+ ghw_hie_generate_if = 4,
+ ghw_hie_generate_for = 5,
+ ghw_hie_instance = 6,
+ ghw_hie_package = 7,
+ ghw_hie_process = 13,
+ ghw_hie_generic = 14,
+ ghw_hie_eos = 15,
+ ghw_hie_signal = 16,
+ ghw_hie_port_in = 17,
+ ghw_hie_port_out = 18,
+ ghw_hie_port_inout = 19,
+ ghw_hie_port_buffer = 20,
+ ghw_hie_port_linkage = 21
+};
+
+struct ghw_hie
+{
+ enum ghw_hie_kind kind;
+ struct ghw_hie *parent;
+ const char *name;
+ struct ghw_hie *brother;
+ union
+ {
+ struct
+ {
+ struct ghw_hie *child;
+ union ghw_type *iter_type;
+ union ghw_val *iter_value;
+ } blk;
+ struct
+ {
+ union ghw_type *type;
+ /* Array of signal elements.
+ Last element is 0. */
+ unsigned int *sigs;
+ } sig;
+ } u;
+};
+
+struct ghw_handler
+{
+ FILE *stream;
+ /* True if words are big-endian. */
+ int word_be;
+ int word_len;
+ int off_len;
+ /* Minor version. */
+ int version;
+
+ /* Set by user. */
+ int flag_verbose;
+
+ /* String table. */
+ /* Number of strings. */
+ int nbr_str;
+ /* Size of the strings (without nul). */
+ int str_size;
+ /* String table. */
+ char **str_table;
+ /* Array containing strings. */
+ char *str_content;
+
+ /* Type table. */
+ int nbr_types;
+ union ghw_type **types;
+
+ /* Non-composite (or basic) signals. */
+ int nbr_sigs;
+ struct ghw_sig *sigs;
+
+ /* Hierarchy. */
+ struct ghw_hie *hie;
+
+ /* Time of the next cycle. */
+ int64_t snap_time;
+};
+
+/* Open a GHW file with H.
+ Return < 0 in case of error. */
+int ghw_open (struct ghw_handler *h, const char *filename);
+
+union ghw_type *ghw_get_base_type (union ghw_type *t);
+
+/* Put the ASCII representation of VAL into BUF, whose size if LEN.
+ A NUL is always written to BUF. */
+void ghw_get_value (char *buf, int len,
+ union ghw_val *val, union ghw_type *type);
+
+const char *ghw_get_hie_name (struct ghw_hie *h);
+
+void ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top);
+
+int ghw_read_base (struct ghw_handler *h);
+
+void ghw_disp_values (struct ghw_handler *h);
+
+int ghw_read_cycle_start (struct ghw_handler *h);
+
+int ghw_read_cycle_cont (struct ghw_handler *h, int *list);
+
+int ghw_read_cycle_next (struct ghw_handler *h);
+
+int ghw_read_cycle_end (struct ghw_handler *h);
+
+enum ghw_sm_type {
+ /* At init;
+ Read section name. */
+ ghw_sm_init = 0,
+ ghw_sm_sect = 1,
+ ghw_sm_cycle = 2
+};
+
+enum ghw_res {
+ ghw_res_error = -1,
+ ghw_res_eof = -2,
+ ghw_res_ok = 0,
+ ghw_res_snapshot = 1,
+ ghw_res_cycle = 2,
+ ghw_res_other = 3
+};
+
+int ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm);
+
+int ghw_read_dump (struct ghw_handler *h);
+
+struct ghw_section {
+ const char name[4];
+ int (*handler)(struct ghw_handler *h);
+};
+
+extern struct ghw_section ghw_sections[];
+
+int ghw_read_section (struct ghw_handler *h);
+
+void ghw_close (struct ghw_handler *h);
+
+const char *ghw_get_dir (int is_downto);
+
+/* Note: TYPE must be a base type (used only to display literals). */
+void ghw_disp_range (union ghw_type *type, union ghw_range *rng);
+
+void ghw_disp_type (struct ghw_handler *h, union ghw_type *t);
+
+void ghw_disp_types (struct ghw_handler *h);
+#endif /* _GHWLIB_H_ */
diff --git a/src/translate/grt/grt-arch.ads b/src/translate/grt/grt-arch.ads
new file mode 100644
index 000000000..5f5aa0e4c
--- /dev/null
+++ b/src/translate/grt/grt-arch.ads
@@ -0,0 +1,2 @@
+With Grt.Arch_None;
+Package Grt.Arch renames Grt.Arch_None;
diff --git a/src/translate/grt/grt-arch_none.adb b/src/translate/grt/grt-arch_none.adb
new file mode 100644
index 000000000..14db1c7d5
--- /dev/null
+++ b/src/translate/grt/grt-arch_none.adb
@@ -0,0 +1,7 @@
+package body Grt.Arch_None is
+ function Get_Time_Stamp return Ghdl_U64 is
+ begin
+ return 0;
+ end Get_Time_Stamp;
+end Grt.Arch_None;
+
diff --git a/src/translate/grt/grt-arch_none.ads b/src/translate/grt/grt-arch_none.ads
new file mode 100644
index 000000000..f8ae437d6
--- /dev/null
+++ b/src/translate/grt/grt-arch_none.ads
@@ -0,0 +1,6 @@
+with Grt.Types; use Grt.Types;
+
+package Grt.Arch_None is
+ function Get_Time_Stamp return Ghdl_U64;
+ pragma Inline (Get_Time_Stamp);
+end Grt.Arch_None;
diff --git a/src/translate/grt/grt-astdio.adb b/src/translate/grt/grt-astdio.adb
new file mode 100644
index 000000000..456d024ac
--- /dev/null
+++ b/src/translate/grt/grt-astdio.adb
@@ -0,0 +1,231 @@
+-- GHDL Run Time (GRT) stdio subprograms for GRT types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.C; use Grt.C;
+
+package body Grt.Astdio is
+ procedure Put (Stream : FILEs; Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, Stream);
+ end Put;
+
+ procedure Put (Stream : FILEs; C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Stream);
+ end Put;
+
+ procedure Put (Stream : FILEs; Str : Ghdl_C_String)
+ is
+ Len : Natural;
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ Len := strlen (Str);
+ S := fwrite (Str (1)'Address, size_t (Len), 1, Stream);
+ end Put;
+
+ procedure New_Line (Stream : FILEs) is
+ begin
+ Put (Stream, Nl);
+ end New_Line;
+
+ procedure Put (Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, stdout);
+ end Put;
+
+ procedure Put (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), stdout);
+ end Put;
+
+ procedure Put (Str : Ghdl_C_String)
+ is
+ Len : Natural;
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ Len := strlen (Str);
+ S := fwrite (Str (1)'Address, size_t (Len), 1, stdout);
+ end Put;
+
+ procedure New_Line is
+ begin
+ Put (Nl);
+ end New_Line;
+
+ procedure Put_Line (Str : String)
+ is
+ begin
+ Put (Str);
+ New_Line;
+ end Put_Line;
+
+ procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type)
+ is
+ S : String (1 .. 3);
+ begin
+ if Str.Str = null then
+ S (1) := ''';
+ S (2) := Character'Val (Str.Len);
+ S (3) := ''';
+ Put (Stream, S);
+ else
+ Put (Stream, Str.Str (1 .. Str.Len));
+ end if;
+ end Put_Str_Len;
+
+ generic
+ type Ntype is range <>;
+ Max_Len : Natural;
+ procedure Put_Ntype (Stream : FILEs; N : Ntype);
+
+ procedure Put_Ntype (Stream : FILEs; N : Ntype)
+ is
+ Str : String (1 .. Max_Len);
+ P : Natural := Str'Last;
+ V : Ntype;
+ begin
+ -- V is negativ.
+ if N > 0 then
+ V := -N;
+ else
+ V := N;
+ end if;
+ loop
+ Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0.
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ if N < 0 then
+ P := P - 1;
+ Str (P) := '-';
+ end if;
+ Put (Stream, Str (P .. Max_Len));
+ end Put_Ntype;
+
+ generic
+ type Utype is mod <>;
+ Max_Len : Natural;
+ procedure Put_Utype (Stream : FILEs; N : Utype);
+
+ procedure Put_Utype (Stream : FILEs; N : Utype)
+ is
+ Str : String (1 .. Max_Len);
+ P : Natural := Str'Last;
+ V : Utype := N;
+ begin
+ loop
+ Str (P) := Character'Val (48 + (V rem 10));
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ Put (Stream, Str (P .. Max_Len));
+ end Put_Utype;
+
+ procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11);
+ procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1;
+
+ procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11);
+ procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1;
+
+ procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20);
+ procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1;
+
+ procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20);
+ procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1;
+
+ procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64)
+ is
+ procedure Fprintf_G (Stream : FILEs;
+ Arg : Ghdl_F64);
+ pragma Import (C, Fprintf_G, "__ghdl_fprintf_g");
+ begin
+ Fprintf_G (Stream, F64);
+ end Put_F64;
+
+ Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+
+ procedure Put (Stream : FILEs; Addr : System.Address)
+ is
+ Res : String (1 .. System.Word_Size / 4);
+ Val : Integer_Address := To_Integer (Addr);
+ begin
+ for I in reverse Res'Range loop
+ Res (I) := Hex_Map (Natural (Val and 15));
+ Val := Val / 16;
+ end loop;
+ Put (Stream, Res);
+ end Put;
+
+ procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type) is
+ begin
+ case Dir is
+ when Dir_To =>
+ Put (Stream, " to ");
+ when Dir_Downto =>
+ Put (Stream, " downto ");
+ end case;
+ end Put_Dir;
+
+ procedure Put_Time (Stream : FILEs; Time : Std_Time) is
+ begin
+ if Time = Std_Time'First then
+ Put (Stream, "-Inf");
+ else
+ -- Do not bother with sec, min, and hr.
+ if (Time mod 1_000_000_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000_000));
+ Put (Stream, "ms");
+ elsif (Time mod 1_000_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000));
+ Put (Stream, "us");
+ elsif (Time mod 1_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000));
+ Put (Stream, "ns");
+ elsif (Time mod 1_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000));
+ Put (Stream, "ps");
+ else
+ Put_I64 (Stream, Ghdl_I64 (Time));
+ Put (Stream, "fs");
+ end if;
+ end if;
+ end Put_Time;
+
+end Grt.Astdio;
diff --git a/src/translate/grt/grt-astdio.ads b/src/translate/grt/grt-astdio.ads
new file mode 100644
index 000000000..8e8b739cc
--- /dev/null
+++ b/src/translate/grt/grt-astdio.ads
@@ -0,0 +1,60 @@
+-- GHDL Run Time (GRT) stdio subprograms for GRT types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Types; use Grt.Types;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Astdio is
+ pragma Preelaborate (Grt.Astdio);
+
+ -- Procedures to disp on STREAM.
+ procedure Put (Stream : FILEs; Str : String);
+ procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32);
+ procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32);
+ procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64);
+ procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64);
+ procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64);
+ procedure Put (Stream : FILEs; Addr : System.Address);
+ procedure Put (Stream : FILEs; Str : Ghdl_C_String);
+ procedure Put (Stream : FILEs; C : Character);
+ procedure New_Line (Stream : FILEs);
+
+ -- Display time with unit, without space.
+ -- Eg: 10ns, 100ms, 97ps...
+ procedure Put_Time (Stream : FILEs; Time : Std_Time);
+
+ -- And on stdout.
+ procedure Put (Str : String);
+ procedure Put (C : Character);
+ procedure New_Line;
+ procedure Put_Line (Str : String);
+ procedure Put (Str : Ghdl_C_String);
+
+ -- Put STR using put procedures.
+ procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type);
+
+ -- Put " to " or " downto ".
+ procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type);
+end Grt.Astdio;
diff --git a/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb
new file mode 100644
index 000000000..b935fd9a3
--- /dev/null
+++ b/src/translate/grt/grt-avhpi.adb
@@ -0,0 +1,1142 @@
+-- GHDL Run Time (GRT) - VHPI implementation for Ada.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+
+package body Grt.Avhpi is
+ procedure Get_Root_Inst (Res : out VhpiHandleT)
+ is
+ begin
+ Res := (Kind => VhpiRootInstK,
+ Ctxt => Get_Top_Context);
+ end Get_Root_Inst;
+
+ procedure Get_Package_Inst (Res : out VhpiHandleT) is
+ begin
+ Res := (Kind => VhpiIteratorK,
+ Ctxt => (Base => Null_Address,
+ Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)),
+ Rel => VhpiPackInsts,
+ It_Cur => 0,
+ It2 => 0,
+ Max2 => 0);
+ end Get_Package_Inst;
+
+ -- Number of elements in an array.
+ function Ranges_To_Length (Rngs : Ghdl_Range_Array;
+ Indexes : Ghdl_Rti_Arr_Acc)
+ return Ghdl_Index_Type
+ is
+ Res : Ghdl_Index_Type;
+ begin
+ Res := 1;
+ for I in Rngs'Range loop
+ Res := Res * Range_To_Length
+ (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First)));
+ end loop;
+ return Res;
+ end Ranges_To_Length;
+
+ procedure Vhpi_Iterator (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default value in case of success.
+ Res := (Kind => VhpiIteratorK,
+ Ctxt => Ref.Ctxt,
+ Rel => Rel,
+ It_Cur => 0,
+ It2 => 0,
+ Max2 => 0);
+ Error := AvhpiErrorOk;
+
+ case Rel is
+ when VhpiInternalRegions =>
+ case Ref.Kind is
+ when VhpiRootInstK
+ | VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK =>
+ return;
+ when VhpiForGenerateK =>
+ Res.It2 := 1;
+ return;
+ when VhpiCompInstStmtK =>
+ Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
+ return;
+ when others =>
+ null;
+ end case;
+ when VhpiDecls =>
+ case Ref.Kind is
+ when VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK =>
+ return;
+ when VhpiRootInstK
+ | VhpiPackInstK =>
+ Res.It2 := 1;
+ return;
+ when VhpiCompInstStmtK =>
+ Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
+ Res.It2 := 1;
+ return;
+ when others =>
+ null;
+ end case;
+ when VhpiIndexedNames =>
+ case Ref.Kind is
+ when VhpiGenericDeclK =>
+ Res := (Kind => AvhpiNameIteratorK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Avhpi_Get_Address (Ref),
+ N_Type => Ref.Obj.Obj_Type,
+ N_Idx => 0,
+ N_Obj => Ref.Obj);
+ when VhpiIndexedNameK =>
+ Res := (Kind => AvhpiNameIteratorK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Ref.N_Addr,
+ N_Type => Ref.N_Type,
+ N_Idx => 0,
+ N_Obj => Ref.N_Obj);
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ return;
+ end case;
+ case Res.N_Type.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt),
+ Bt, Rngs);
+ Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes);
+ end;
+ when others =>
+ Error := AvhpiErrorBadRel;
+ end case;
+ return;
+ when others =>
+ null;
+ end case;
+ -- Failure.
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end Vhpi_Iterator;
+
+ -- OBJ_RTI is the RTI for the base name.
+ function Add_Index (Ctxt : Rti_Context;
+ Obj_Base : Address;
+ Obj_Rti : Ghdl_Rtin_Object_Acc;
+ El_Type : Ghdl_Rti_Access;
+ Off : Ghdl_Index_Type) return Address
+ is
+ pragma Unreferenced (Ctxt);
+ Is_Sig : Boolean;
+ El_Size : Ghdl_Index_Type;
+ El_Type1 : Ghdl_Rti_Access;
+ begin
+ case Obj_Rti.Common.Kind is
+ when Ghdl_Rtik_Generic =>
+ Is_Sig := False;
+ when others =>
+ Internal_Error ("add_index");
+ end case;
+
+ if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then
+ El_Type1 := Get_Base_Type (El_Type);
+ else
+ El_Type1 := El_Type;
+ end if;
+
+ case El_Type1.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ if Is_Sig then
+ El_Size := Address'Size / Storage_Unit;
+ else
+ El_Size := Ghdl_I64'Size / Storage_Unit;
+ end if;
+ when Ghdl_Rtik_Subtype_Array =>
+ if Is_Sig then
+ El_Size := Ghdl_Index_Type
+ (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize);
+ else
+ El_Size := Ghdl_Index_Type
+ (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize);
+ end if;
+ when others =>
+ Internal_Error ("add_index");
+ end case;
+ return Obj_Base + Off * El_Size;
+ end Add_Index;
+
+ procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ El_Type : Ghdl_Rti_Access;
+ begin
+ if Iterator.N_Idx = 0 then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ El_Type := To_Ghdl_Rtin_Type_Array_Acc
+ (Get_Base_Type (Iterator.N_Type)).Element;
+
+ Res := (Kind => VhpiIndexedNameK,
+ Ctxt => Iterator.Ctxt,
+ N_Addr => Iterator.N_Addr,
+ N_Type => El_Type,
+ N_Idx => 0,
+ N_Obj => Iterator.N_Obj);
+
+ -- Increment Address.
+ Iterator.N_Addr := Add_Index
+ (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1);
+
+ Iterator.N_Idx := Iterator.N_Idx - 1;
+ Error := AvhpiErrorOk;
+ end Vhpi_Scan_Indexed_Name;
+
+ procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ch : Ghdl_Rti_Access;
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ if Blk = null then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ loop
+ << Again >> null;
+ if Iterator.It_Cur >= Blk.Nbr_Child then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ Ch := Blk.Children (Iterator.It_Cur);
+ Nblk := To_Ghdl_Rtin_Block_Acc (Ch);
+
+ if Iterator.Max2 /= 0 then
+ -- A for generate.
+ Iterator.It2 := Iterator.It2 + 1;
+ if Iterator.It2 >= Iterator.Max2 then
+ -- End of loop.
+ Iterator.Max2 := 0;
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+ goto Again;
+ else
+ declare
+ Base : Address;
+ begin
+ Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all;
+ Base := Base + Iterator.It2 * Nblk.Size;
+ Res := (Kind => VhpiForGenerateK,
+ Ctxt => (Base => Base,
+ Block => Ch));
+
+ Error := AvhpiErrorOk;
+ return;
+ end;
+ end if;
+ end if;
+
+
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+
+ case Ch.Kind is
+ when Ghdl_Rtik_Process =>
+ Res := (Kind => VhpiProcessStmtK,
+ Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc,
+ Block => Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when Ghdl_Rtik_Block =>
+ Res := (Kind => VhpiBlockStmtK,
+ Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc,
+ Block => Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when Ghdl_Rtik_If_Generate =>
+ Res := (Kind => VhpiIfGenerateK,
+ Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base
+ + Nblk.Loc).all,
+ Block => Ch));
+ -- Return only if the condition is true.
+ if Res.Ctxt.Base /= Null_Address then
+ Error := AvhpiErrorOk;
+ return;
+ end if;
+ when Ghdl_Rtik_For_Generate =>
+ Res := (Kind => VhpiForGenerateK,
+ Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base
+ + Nblk.Loc).all,
+ Block => Ch));
+ Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt);
+ Iterator.It2 := 0;
+ if Iterator.Max2 > 0 then
+ Iterator.It_Cur := Iterator.It_Cur - 1;
+ Error := AvhpiErrorOk;
+ return;
+ end if;
+ -- If the iterator range is nul, then continue to scan.
+ when Ghdl_Rtik_Instance =>
+ Res := (Kind => VhpiCompInstStmtK,
+ Ctxt => Iterator.Ctxt,
+ Inst => To_Ghdl_Rtin_Instance_Acc (Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when others =>
+ -- Next one.
+ null;
+ end case;
+ end loop;
+ end Vhpi_Scan_Internal_Regions;
+
+ procedure Rti_To_Handle (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Res : out VhpiHandleT)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Signal =>
+ Res := (Kind => VhpiSigDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Port =>
+ Res := (Kind => VhpiPortDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Generic =>
+ Res := (Kind => VhpiGenericDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Atype : Ghdl_Rtin_Subtype_Array_Acc;
+ Bt : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt := Atype.Basetype;
+ if Atype.Name = Bt.Name then
+ Res := (Kind => VhpiArrayTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ else
+ Res := (Kind => VhpiSubtypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ end if;
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ Res := (Kind => VhpiArrayTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Res := (Kind => VhpiEnumTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ Res := (Kind => VhpiPhysTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Res := (Kind => VhpiSubtypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when others =>
+ Res := (Kind => VhpiUndefined,
+ Ctxt => Ctxt);
+ end case;
+ end Rti_To_Handle;
+
+ procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ch : Ghdl_Rti_Access;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+
+ -- If there is no context, returns now.
+ -- This may happen for a unbound compinststmt.
+ if Blk = null then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ if Iterator.It2 = 1 then
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ -- Iterate on the entity.
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ when Ghdl_Rtik_Package_Body =>
+ -- Iterate on the package.
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ when Ghdl_Rtik_Package =>
+ -- Only for std.standard.
+ Iterator.It2 := 0;
+ when others =>
+ Internal_Error ("vhpi_scan_decls");
+ end case;
+ end if;
+ loop
+ loop
+ exit when Iterator.It_Cur >= Blk.Nbr_Child;
+
+ Ch := Blk.Children (Iterator.It_Cur);
+
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+
+ case Ch.Kind is
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Generic
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Subtype_Array
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Subtype_Scalar =>
+ Rti_To_Handle (Ch, Iterator.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ return;
+ else
+ Internal_Error ("vhpi_scan_decls");
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ case Iterator.It2 is
+ when 1 =>
+ -- Iterate on the architecture/package decl.
+ Iterator.It2 := 0;
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ Iterator.It_Cur := 0;
+ when others =>
+ exit;
+ end case;
+ end loop;
+ Error := AvhpiErrorIteratorEnd;
+ end Vhpi_Scan_Decls;
+
+ procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ if Iterator.Kind = AvhpiNameIteratorK then
+ case Iterator.N_Type.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Vhpi_Scan_Indexed_Name (Iterator, Res, Error);
+ when others =>
+ Error := AvhpiErrorHandle;
+ Res := Null_Handle;
+ end case;
+ return;
+ elsif Iterator.Kind /= VhpiIteratorK then
+ Error := AvhpiErrorHandle;
+ Res := Null_Handle;
+ return;
+ end if;
+
+ case Iterator.Rel is
+ when VhpiPackInsts =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ if Iterator.It_Cur >= Blk.Nbr_Child then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+ Res := (Kind => VhpiPackInstK,
+ Ctxt => (Base => Null_Address,
+ Block => Blk.Children (Iterator.It_Cur)));
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+ Error := AvhpiErrorOk;
+ end;
+ when VhpiInternalRegions =>
+ Vhpi_Scan_Internal_Regions (Iterator, Res, Error);
+ when VhpiDecls =>
+ Vhpi_Scan_Decls (Iterator, Res, Error);
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Scan;
+
+ function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String
+ is
+ begin
+ case Obj.Kind is
+ when VhpiEnumTypeDeclK =>
+ return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name;
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK
+ | VhpiProcessStmtK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK =>
+ return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name;
+ when VhpiRootInstK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ return Blk.Name;
+ end;
+ when VhpiCompInstStmtK =>
+ return Obj.Inst.Name;
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK =>
+ return Obj.Obj.Name;
+ when VhpiSubtypeDeclK =>
+ return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name;
+ when others =>
+ return null;
+ end case;
+ end Avhpi_Get_Base_Name;
+
+ procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+ Obj : VhpiHandleT;
+ Res : out String;
+ Len : out Natural)
+ is
+ subtype R_Type is String (1 .. Res'Length);
+ R : R_Type renames Res;
+
+ procedure Add (C : Character) is
+ begin
+ Len := Len + 1;
+ if Len <= R_Type'Last then
+ R (Len) := C;
+ end if;
+ end Add;
+
+ procedure Add (Str : String) is
+ begin
+ for I in Str'Range loop
+ Add (Str (I));
+ end loop;
+ end Add;
+
+ procedure Add (Str : Ghdl_C_String) is
+ begin
+ for I in Str'Range loop
+ exit when Str (I) = NUL;
+ Add (Str (I));
+ end loop;
+ end Add;
+ begin
+ Len := 0;
+
+ case Property is
+ when VhpiNameP =>
+ case Obj.Kind is
+ when VhpiEnumTypeDeclK =>
+ Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name);
+ when VhpiSubtypeDeclK =>
+ Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name);
+ when VhpiArrayTypeDeclK =>
+ Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name);
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK
+ | VhpiProcessStmtK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK =>
+ Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name);
+ when VhpiRootInstK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ Add (Blk.Name);
+ end;
+ when VhpiCompInstStmtK =>
+ Add (Obj.Inst.Name);
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK =>
+ Add (Obj.Obj.Name);
+ when VhpiForGenerateK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Iter : Ghdl_Rtin_Object_Acc;
+ Iter_Type : Ghdl_Rti_Access;
+ Vptr : Ghdl_Value_Ptr;
+ Buf : String (1 .. 12);
+ Buf_Len : Natural;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Vptr := To_Ghdl_Value_Ptr
+ (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt));
+ Add (Blk.Name);
+ Add ('(');
+ Iter_Type := Iter.Obj_Type;
+ if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc
+ (Iter_Type).Basetype;
+ end if;
+ case Iter_Type.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ To_String (Buf, Buf_Len, Vptr.I32);
+ Add (Buf (Buf_Len .. Buf'Last));
+-- when Ghdl_Rtik_Type_E8 =>
+-- Disp_Enum_Value
+-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
+-- when Ghdl_Rtik_Type_E32 =>
+-- Disp_Enum_Value
+-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32));
+-- when Ghdl_Rtik_Type_B1 =>
+-- Disp_Enum_Value
+-- (Stream, Rti,
+-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1)));
+ when others =>
+ Add ('?');
+ end case;
+ --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+ Add (')');
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiCompNameP =>
+ case Obj.Kind is
+ when VhpiCompInstStmtK =>
+ declare
+ Comp : Ghdl_Rtin_Component_Acc;
+ begin
+ Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance);
+ if Comp.Common.Kind = Ghdl_Rtik_Component then
+ Add (Comp.Name);
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiLibLogicalNameP =>
+ case Obj.Kind is
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Lib : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ if Blk.Common.Kind = Ghdl_Rtik_Package_Body then
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ end if;
+ Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+ if Lib.Common.Kind /= Ghdl_Rtik_Library then
+ Internal_Error ("VhpiLibLogicalNameP");
+ end if;
+ Add (Lib.Name);
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiFullNameP =>
+ declare
+ Rstr : Rstring;
+ Nctxt : Rti_Context;
+ begin
+ if Obj.Kind = VhpiCompInstStmtK then
+ Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt);
+ Get_Path_Name (Rstr, Nctxt, ':', False);
+ else
+ Get_Path_Name (Rstr, Obj.Ctxt, ':', False);
+ end if;
+ Copy (Rstr, R, Len);
+ Free (Rstr);
+ case Obj.Kind is
+ when VhpiCompInstStmtK =>
+ null;
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Add (':');
+ Add (Obj.Obj.Name);
+ when others =>
+ null;
+ end case;
+ end;
+ when others =>
+ null;
+ end case;
+ end Vhpi_Get_Str;
+
+ procedure Vhpi_Handle (Rel : VhpiOneToOneT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default error.
+ Error := AvhpiErrorNotImplemented;
+
+ case Rel is
+ when VhpiDesignUnit =>
+ case Ref.Kind is
+ when VhpiRootInstK =>
+ case Ref.Ctxt.Block.Kind is
+ when Ghdl_Rtik_Architecture =>
+ Res := (Kind => VhpiArchBodyK,
+ Ctxt => Ref.Ctxt);
+ Error := AvhpiErrorOk;
+ return;
+ when others =>
+ return;
+ end case;
+ when others =>
+ return;
+ end case;
+ when VhpiPrimaryUnit =>
+ case Ref.Kind is
+ when VhpiArchBodyK =>
+ declare
+ Rti : Ghdl_Rti_Access;
+ Ent : Ghdl_Rtin_Block_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent;
+ Ent := To_Ghdl_Rtin_Block_Acc (Rti);
+ Res := (Kind => VhpiEntityDeclK,
+ Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc,
+ Block => Rti));
+ Error := AvhpiErrorOk;
+ end;
+ when others =>
+ return;
+ end case;
+ when VhpiIterScheme =>
+ case Ref.Kind is
+ when VhpiForGenerateK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Iter : Ghdl_Rtin_Object_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Res := (Kind => VhpiConstDeclK,
+ Ctxt => Ref.Ctxt,
+ Obj => Iter);
+ Error := AvhpiErrorOk;
+ end;
+ when others =>
+ return;
+ end case;
+ when VhpiSubtype =>
+ case Ref.Kind is
+ when VhpiPortDeclK
+ | VhpiSigDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ Res := (Kind => VhpiSubtypeIndicK,
+ Ctxt => Ref.Ctxt,
+ Atype => Ref.Obj.Obj_Type);
+ Error := AvhpiErrorOk;
+ when others =>
+ return;
+ end case;
+ when VhpiTypeMark =>
+ case Ref.Kind is
+ when VhpiSubtypeIndicK =>
+ -- FIXME: if the subtype is anonymous, return the base type.
+ Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ return;
+ when others =>
+ return;
+ end case;
+ when VhpiBaseType =>
+ declare
+ Atype : Ghdl_Rti_Access;
+ begin
+ case Ref.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK =>
+ Atype := Ref.Atype;
+ when VhpiGenericDeclK =>
+ Atype := Ref.Obj.Obj_Type;
+ when VhpiIndexedNameK =>
+ Atype := Ref.N_Type;
+ when others =>
+ return;
+ end case;
+ case Atype.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Rti_To_Handle
+ (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc
+ (Atype).Basetype),
+ Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Rti_To_Handle
+ (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype,
+ Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ when Ghdl_Rtik_Type_Array =>
+ Res := Ref;
+ Error := AvhpiErrorOk;
+ when others =>
+ return;
+ end case;
+ end;
+ when VhpiElemSubtype =>
+ declare
+ Base_Type : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ case Ref.Atype.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Base_Type :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype;
+ when Ghdl_Rtik_Type_Array =>
+ Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype);
+ when others =>
+ return;
+ end case;
+ Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ end;
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Handle;
+
+ procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Index : Natural;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default error.
+ Error := AvhpiErrorNotImplemented;
+
+ case Rel is
+ when VhpiConstraints =>
+ case Ref.Kind is
+ when VhpiSubtypeIndicK =>
+ if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then
+ declare
+ Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype);
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc :=
+ Arr_Subtype.Basetype;
+ Idx : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (Index);
+ Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1);
+ Range_Basetype : Ghdl_Rti_Access;
+ begin
+ if Idx not in 1 .. Basetype.Nbr_Dim then
+ Res := Null_Handle;
+ Error := AvhpiErrorBadIndex;
+ return;
+ end if;
+ -- constraint type is basetype.indexes (idx - 1)
+ Bound_To_Range
+ (Loc_To_Addr (Arr_Subtype.Common.Depth,
+ Arr_Subtype.Bounds, Ref.Ctxt),
+ Basetype, Bounds);
+ Res := (Kind => VhpiIntRangeK,
+ Ctxt => Ref.Ctxt,
+ Rng_Type => Basetype.Indexes (Idx - 1),
+ Rng_Addr => Bounds (Idx - 1));
+ Range_Basetype := Get_Base_Type (Res.Rng_Type);
+ case Range_Basetype.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ null;
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Res := (Kind => VhpiEnumRangeK,
+ Ctxt => Ref.Ctxt,
+ Rng_Type => Res.Rng_Type,
+ Rng_Addr => Res.Rng_Addr);
+ when others =>
+ Internal_Error
+ ("vhpi_handle_by_index/constraint");
+ end case;
+ Error := AvhpiErrorOk;
+ end;
+ end if;
+ when others =>
+ return;
+ end case;
+ when VhpiIndexedNames =>
+ declare
+ Base_Type, El_Type : VhpiHandleT;
+ begin
+ Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ Res := (Kind => VhpiIndexedNameK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Avhpi_Get_Address (Ref),
+ N_Type => El_Type.Atype,
+ N_Idx => Ghdl_Index_Type (Index),
+ N_Obj => Ref.Obj);
+ if Res.N_Addr = Null_Address then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Res.N_Addr := Add_Index
+ (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type,
+ Ghdl_Index_Type (Index));
+ end;
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Handle_By_Index;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out VhpiIntT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ case Property is
+ when VhpiLeftBoundP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Res := 0;
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Left;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when VhpiRightBoundP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Right;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Get;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out Boolean;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ case Property is
+ when VhpiIsUpP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Res := False;
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Dir = Dir_To;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Get;
+
+ function Vhpi_Get_EntityClass (Obj : VhpiHandleT)
+ return VhpiEntityClassT
+ is
+ begin
+ case Obj.Kind is
+ when VhpiArchBodyK =>
+ return VhpiArchitectureEC;
+ when others =>
+ return VhpiErrorEC;
+ end case;
+ end Vhpi_Get_EntityClass;
+
+ function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is
+ begin
+ return Obj.Kind;
+ end Vhpi_Get_Kind;
+
+ function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is
+ begin
+ case Obj.Kind is
+ when VhpiPortDeclK =>
+ case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is
+ when Ghdl_Rti_Signal_Mode_In =>
+ return VhpiInMode;
+ when Ghdl_Rti_Signal_Mode_Out =>
+ return VhpiOutMode;
+ when Ghdl_Rti_Signal_Mode_Inout =>
+ return VhpiInoutMode;
+ when Ghdl_Rti_Signal_Mode_Buffer =>
+ return VhpiBufferMode;
+ when Ghdl_Rti_Signal_Mode_Linkage =>
+ return VhpiLinkageMode;
+ when others =>
+ return VhpiErrorMode;
+ end case;
+ when others =>
+ return VhpiErrorMode;
+ end case;
+ end Vhpi_Get_Mode;
+
+ function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is
+ begin
+ case Obj.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiEnumTypeDeclK =>
+ return Obj.Atype;
+ when VhpiSigDeclK
+ | VhpiPortDeclK =>
+ return To_Ghdl_Rti_Access (Obj.Obj);
+ when others =>
+ return null;
+ end case;
+ end Avhpi_Get_Rti;
+
+ function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is
+ begin
+ case Obj.Kind is
+ when VhpiPortDeclK
+ | VhpiSigDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ return Loc_To_Addr (Obj.Ctxt.Block.Depth,
+ Obj.Obj.Loc,
+ Obj.Ctxt);
+ when others =>
+ return Null_Address;
+ end case;
+ end Avhpi_Get_Address;
+
+ function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is
+ begin
+ return Obj.Ctxt;
+ end Avhpi_Get_Context;
+
+ function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT)
+ return Boolean
+ is
+ begin
+ if Hdl1.Kind /= Hdl2.Kind then
+ return False;
+ end if;
+ case Hdl1.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK
+ | VhpiPhysTypeDeclK =>
+ return Hdl1.Atype = Hdl2.Atype;
+ when others =>
+ -- FIXME: todo
+ Internal_Error ("vhpi_compare_handles");
+ end case;
+ end Vhpi_Compare_Handles;
+
+ function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64)
+ return AvhpiErrorT
+ is
+ Vptr : Ghdl_Value_Ptr;
+ Atype : Ghdl_Rti_Access;
+ begin
+ case Obj.Kind is
+ when VhpiIndexedNameK =>
+ Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr);
+ Atype := Obj.N_Type;
+ when others =>
+ return AvhpiErrorNotImplemented;
+ end case;
+ case Get_Base_Type (Atype).Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ null;
+ when others =>
+ return AvhpiErrorHandle;
+ end case;
+ Vptr.I64 := Val;
+ return AvhpiErrorOk;
+ end Vhpi_Put_Value;
+end Grt.Avhpi;
+
+
diff --git a/src/translate/grt/grt-avhpi.ads b/src/translate/grt/grt-avhpi.ads
new file mode 100644
index 000000000..1eff5a8a3
--- /dev/null
+++ b/src/translate/grt/grt-avhpi.ads
@@ -0,0 +1,561 @@
+-- GHDL Run Time (GRT) - VHPI implementation for Ada.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- Ada oriented implementation of VHPI.
+-- This doesn't follow exactly what VHPI defined, but:
+-- * it should be easy to write a VHPI interface from this implementation.
+-- * this implementation is thread-safe (no global storage).
+-- * this implementation never allocates memory.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+
+package Grt.Avhpi is
+ -- Object Kinds.
+ type VhpiClassKindT is
+ (
+ VhpiUndefined,
+ VhpiAccessTypeDeclK,
+ VhpiAggregateK,
+ VhpiAliasDeclK,
+ VhpiAllLiteralK,
+ VhpiAllocatorK,
+ VhpiAnyCollectionK,
+ VhpiArchBodyK,
+ VhpiArgvK,
+ VhpiArrayTypeDeclK,
+ VhpiAssertStmtK,
+ VhpiAssocElemK,
+ VhpiAttrDeclK,
+ VhpiAttrSpecK,
+ VhpiBinaryExprK,
+ VhpiBitStringLiteralK,
+ VhpiBlockConfigK,
+ VhpiBlockStmtK,
+ VhpiBranchK,
+ VhpiCallbackK,
+ VhpiCaseStmtK,
+ VhpiCharLiteralK,
+ VhpiCompConfigK,
+ VhpiCompDeclK,
+ VhpiCompInstStmtK,
+ VhpiCondSigAssignStmtK,
+ VhpiCondWaveformK,
+ VhpiConfigDeclK,
+ VhpiConstDeclK,
+ VhpiConstParamDeclK,
+ VhpiConvFuncK,
+ VhpiDeRefObjK,
+ VhpiDisconnectSpecK,
+ VhpiDriverK,
+ VhpiDriverCollectionK,
+ VhpiElemAssocK,
+ VhpiElemDeclK,
+ VhpiEntityClassEntryK,
+ VhpiEntityDeclK,
+ VhpiEnumLiteralK,
+ VhpiEnumRangeK,
+ VhpiEnumTypeDeclK,
+ VhpiExitStmtK,
+ VhpiFileDeclK,
+ VhpiFileParamDeclK,
+ VhpiFileTypeDeclK,
+ VhpiFloatRangeK,
+ VhpiFloatTypeDeclK,
+ VhpiForGenerateK,
+ VhpiForLoopK,
+ VhpiForeignfK,
+ VhpiFuncCallK,
+ VhpiFuncDeclK,
+ VhpiGenericDeclK,
+ VhpiGroupDeclK,
+ VhpiGroupTempDeclK,
+ VhpiIfGenerateK,
+ VhpiIfStmtK,
+ VhpiInPortK,
+ VhpiIndexedNameK,
+ VhpiIntLiteralK,
+ VhpiIntRangeK,
+ VhpiIntTypeDeclK,
+ VhpiIteratorK,
+ VhpiLibraryDeclK,
+ VhpiLoopStmtK,
+ VhpiNextStmtK,
+ VhpiNullLiteralK,
+ VhpiNullStmtK,
+ VhpiOperatorK,
+ VhpiOthersLiteralK,
+ VhpiOutPortK,
+ VhpiPackBodyK,
+ VhpiPackDeclK,
+ VhpiPackInstK,
+ VhpiParamAttrNameK,
+ VhpiPhysLiteralK,
+ VhpiPhysRangeK,
+ VhpiPhysTypeDeclK,
+ VhpiPortDeclK,
+ VhpiProcCallStmtK,
+ VhpiProcDeclK,
+ VhpiProcessStmtK,
+ VhpiProtectedTypeK,
+ VhpiProtectedTypeBodyK,
+ VhpiProtectedTypeDeclK,
+ VhpiRealLiteralK,
+ VhpiRecordTypeDeclK,
+ VhpiReportStmtK,
+ VhpiReturnStmtK,
+ VhpiRootInstK,
+ VhpiSelectSigAssignStmtK,
+ VhpiSelectWaveformK,
+ VhpiSelectedNameK,
+ VhpiSigDeclK,
+ VhpiSigParamDeclK,
+ VhpiSimpAttrNameK,
+ VhpiSimpleSigAssignStmtK,
+ VhpiSliceNameK,
+ VhpiStringLiteralK,
+ VhpiSubpBodyK,
+ VhpiSubtypeDeclK,
+ VhpiSubtypeIndicK,
+ VhpiToolK,
+ VhpiTransactionK,
+ VhpiTypeConvK,
+ VhpiUnaryExprK,
+ VhpiUnitDeclK,
+ VhpiUserAttrNameK,
+ VhpiVarAssignStmtK,
+ VhpiVarDeclK,
+ VhpiVarParamDeclK,
+ VhpiWaitStmtK,
+ VhpiWaveformElemK,
+ VhpiWhileLoopK,
+
+ -- Iterator, but on a name.
+ AvhpiNameIteratorK
+ );
+
+ type VhpiOneToOneT is
+ (
+ VhpiAbstractLiteral,
+ VhpiActual,
+ VhpiAllLiteral,
+ VhpiAttrDecl,
+ VhpiAttrSpec,
+ VhpiBaseType,
+ VhpiBaseUnit,
+ VhpiBasicSignal,
+ VhpiBlockConfig,
+ VhpiCaseExpr,
+ VhpiCondExpr,
+ VhpiConfigDecl,
+ VhpiConfigSpec,
+ VhpiConstraint,
+ VhpiContributor,
+ VhpiCurCallback,
+ VhpiCurEqProcess,
+ VhpiCurStackFrame,
+ VhpiDeRefObj,
+ VhpiDecl,
+ VhpiDesignUnit,
+ VhpiDownStack,
+ VhpiElemSubtype,
+ VhpiEntityAspect,
+ VhpiEntityDecl,
+ VhpiEqProcessStmt,
+ VhpiExpr,
+ VhpiFormal,
+ VhpiFuncDecl,
+ VhpiGroupTempDecl,
+ VhpiGuardExpr,
+ VhpiGuardSig,
+ VhpiImmRegion,
+ VhpiInPort,
+ VhpiInitExpr,
+ VhpiIterScheme,
+ VhpiLeftExpr,
+ VhpiLexicalScope,
+ VhpiLhsExpr,
+ VhpiLocal,
+ VhpiLogicalExpr,
+ VhpiName,
+ VhpiOperator,
+ VhpiOthersLiteral,
+ VhpiOutPort,
+ VhpiParamDecl,
+ VhpiParamExpr,
+ VhpiParent,
+ VhpiPhysLiteral,
+ VhpiPrefix,
+ VhpiPrimaryUnit,
+ VhpiProtectedTypeBody,
+ VhpiProtectedTypeDecl,
+ VhpiRejectTime,
+ VhpiReportExpr,
+ VhpiResolFunc,
+ VhpiReturnExpr,
+ VhpiReturnTypeMark,
+ VhpiRhsExpr,
+ VhpiRightExpr,
+ VhpiRootInst,
+ VhpiSelectExpr,
+ VhpiSeverityExpr,
+ VhpiSimpleName,
+ VhpiSubpBody,
+ VhpiSubpDecl,
+ VhpiSubtype,
+ VhpiSuffix,
+ VhpiTimeExpr,
+ VhpiTimeOutExpr,
+ VhpiTool,
+ VhpiTypeMark,
+ VhpiUnitDecl,
+ VhpiUpStack,
+ VhpiUpperRegion,
+ VhpiValExpr,
+ VhpiValSubtype
+ );
+
+ -- Methods used to traverse 1 to many relationships.
+ type VhpiOneToManyT is
+ (
+ VhpiAliasDecls,
+ VhpiArgvs,
+ VhpiAttrDecls,
+ VhpiAttrSpecs,
+ VhpiBasicSignals,
+ VhpiBlockStmts,
+ VhpiBranchs,
+ VhpiCallbacks,
+ VhpiChoices,
+ VhpiCompInstStmts,
+ VhpiCondExprs,
+ VhpiCondWaveforms,
+ VhpiConfigItems,
+ VhpiConfigSpecs,
+ VhpiConstDecls,
+ VhpiConstraints,
+ VhpiContributors,
+ VhpiCurRegions,
+ VhpiDecls,
+ VhpiDepUnits,
+ VhpiDesignUnits,
+ VhpiDrivenSigs,
+ VhpiDrivers,
+ VhpiElemAssocs,
+ VhpiEntityClassEntrys,
+ VhpiEntityDesignators,
+ VhpiEnumLiterals,
+ VhpiForeignfs,
+ VhpiGenericAssocs,
+ VhpiGenericDecls,
+ VhpiIndexExprs,
+ VhpiIndexedNames,
+ VhpiInternalRegions,
+ VhpiMembers,
+ VhpiPackInsts,
+ VhpiParamAssocs,
+ VhpiParamDecls,
+ VhpiPortAssocs,
+ VhpiPortDecls,
+ VhpiRecordElems,
+ VhpiSelectWaveforms,
+ VhpiSelectedNames,
+ VhpiSensitivitys,
+ VhpiSeqStmts,
+ VhpiSigAttrs,
+ VhpiSigDecls,
+ VhpiSigNames,
+ VhpiSignals,
+ VhpiSpecNames,
+ VhpiSpecs,
+ VhpiStmts,
+ VhpiTransactions,
+ VhpiTypeMarks,
+ VhpiUnitDecls,
+ VhpiUses,
+ VhpiVarDecls,
+ VhpiWaveformElems,
+ VhpiLibraryDecls
+ );
+
+ type VhpiIntPropertyT is
+ (
+ VhpiAccessP,
+ VhpiArgcP,
+ VhpiAttrKindP,
+ VhpiBaseIndexP,
+ VhpiBeginLineNoP,
+ VhpiEndLineNoP,
+ VhpiEntityClassP,
+ VhpiForeignKindP,
+ VhpiFrameLevelP,
+ VhpiGenerateIndexP,
+ VhpiIntValP,
+ VhpiIsAnonymousP,
+ VhpiIsBasicP,
+ VhpiIsCompositeP,
+ VhpiIsDefaultP,
+ VhpiIsDeferredP,
+ VhpiIsDiscreteP,
+ VhpiIsForcedP,
+ VhpiIsForeignP,
+ VhpiIsGuardedP,
+ VhpiIsImplicitDeclP,
+ VhpiIsInvalidP_DEPRECATED,
+ VhpiIsLocalP,
+ VhpiIsNamedP,
+ VhpiIsNullP,
+ VhpiIsOpenP,
+ VhpiIsPLIP,
+ VhpiIsPassiveP,
+ VhpiIsPostponedP,
+ VhpiIsProtectedTypeP,
+ VhpiIsPureP,
+ VhpiIsResolvedP,
+ VhpiIsScalarP,
+ VhpiIsSeqStmtP,
+ VhpiIsSharedP,
+ VhpiIsTransportP,
+ VhpiIsUnaffectedP,
+ VhpiIsUnconstrainedP,
+ VhpiIsUninstantiatedP,
+ VhpiIsUpP,
+ VhpiIsVitalP,
+ VhpiIteratorTypeP,
+ VhpiKindP,
+ VhpiLeftBoundP,
+ VhpiLevelP_DEPRECATED,
+ VhpiLineNoP,
+ VhpiLineOffsetP,
+ VhpiLoopIndexP,
+ VhpiModeP,
+ VhpiNumDimensionsP,
+ VhpiNumFieldsP_DEPRECATED,
+ VhpiNumGensP,
+ VhpiNumLiteralsP,
+ VhpiNumMembersP,
+ VhpiNumParamsP,
+ VhpiNumPortsP,
+ VhpiOpenModeP,
+ VhpiPhaseP,
+ VhpiPositionP,
+ VhpiPredefAttrP,
+ VhpiReasonP,
+ VhpiRightBoundP,
+ VhpiSigKindP,
+ VhpiSizeP,
+ VhpiStartLineNoP,
+ VhpiStateP,
+ VhpiStaticnessP,
+ VhpiVHDLversionP,
+ VhpiIdP,
+ VhpiCapabilitiesP
+ );
+
+ -- String properties.
+ type VhpiStrPropertyT is
+ (
+ VhpiCaseNameP,
+ VhpiCompNameP,
+ VhpiDefNameP,
+ VhpiFileNameP,
+ VhpiFullCaseNameP,
+ VhpiFullNameP,
+ VhpiKindStrP,
+ VhpiLabelNameP,
+ VhpiLibLogicalNameP,
+ VhpiLibPhysicalNameP,
+ VhpiLogicalNameP,
+ VhpiLoopLabelNameP,
+ VhpiNameP,
+ VhpiOpNameP,
+ VhpiStrValP,
+ VhpiToolVersionP,
+ VhpiUnitNameP
+ );
+
+ -- Possible Errors.
+ type AvhpiErrorT is
+ (
+ AvhpiErrorOk,
+ AvhpiErrorBadRel,
+ AvhpiErrorHandle,
+ AvhpiErrorNotImplemented,
+ AvhpiErrorIteratorEnd,
+ AvhpiErrorBadIndex
+ );
+
+ type VhpiHandleT is private;
+
+ -- A null handle.
+ Null_Handle : constant VhpiHandleT;
+
+ -- Get the root instance.
+ procedure Get_Root_Inst (Res : out VhpiHandleT);
+
+ -- Get the instanciated packages.
+ procedure Get_Package_Inst (Res : out VhpiHandleT);
+
+ procedure Vhpi_Handle (Rel : VhpiOneToOneT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Index : Natural;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Iterator (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+ procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+ Obj : VhpiHandleT;
+ Res : out String;
+ Len : out Natural);
+
+ subtype VhpiIntT is Ghdl_I32;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out VhpiIntT;
+ Error : out AvhpiErrorT);
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out Boolean;
+ Error : out AvhpiErrorT);
+
+ -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not
+ -- indexes for generate stmt.
+ function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String;
+
+ -- Return TRUE iff HDL1 and HDL2 are equivalent.
+ function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT)
+ return Boolean;
+
+-- procedure Vhpi_Handle_By_Simple_Name (Ref : VhpiHandleT;
+-- Res : out VhpiHandleT;
+-- Error : out AvhpiErrorT);
+
+ type VhpiEntityClassT is
+ (
+ VhpiErrorEC,
+ VhpiEntityEC,
+ VhpiArchitectureEC,
+ VhpiConfigurationEC,
+ VhpiProcedureEC,
+ VhpiFunctionEC,
+ VhpiPackageEC,
+ VhpiTypeEC,
+ VhpiSubtypeEC,
+ VhpiConstantEC,
+ VhpiSignalEC,
+ VhpiVariableEC,
+ VhpiComponentEC,
+ VhpiLabelEC,
+ VhpiLiteralEC,
+ VhpiUnitsEC,
+ VhpiFileEC,
+ VhpiGroupEC
+ );
+
+ function Vhpi_Get_EntityClass (Obj : VhpiHandleT)
+ return VhpiEntityClassT;
+
+ type VhpiModeT is
+ (
+ VhpiErrorMode,
+ VhpiInMode,
+ VhpiOutMode,
+ VhpiInoutMode,
+ VhpiBufferMode,
+ VhpiLinkageMode
+ );
+ function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT;
+
+ function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access;
+
+ function Avhpi_Get_Address (Obj : VhpiHandleT) return Address;
+
+ function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context;
+
+ function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT;
+
+ function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64)
+ return AvhpiErrorT;
+private
+ type VhpiHandleT (Kind : VhpiClassKindT := VhpiUndefined) is record
+ -- Context.
+ Ctxt : Rti_Context;
+
+ case Kind is
+ when VhpiIteratorK =>
+ Rel : VhpiOneToManyT;
+ It_Cur : Ghdl_Index_Type;
+ It2 : Ghdl_Index_Type;
+ Max2 : Ghdl_Index_Type;
+ when AvhpiNameIteratorK
+ | VhpiIndexedNameK =>
+ N_Addr : Address;
+ N_Type : Ghdl_Rti_Access;
+ N_Idx : Ghdl_Index_Type;
+ N_Obj : Ghdl_Rtin_Object_Acc;
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ Obj : Ghdl_Rtin_Object_Acc;
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK
+ | VhpiEnumTypeDeclK
+ | VhpiPhysTypeDeclK =>
+ Atype : Ghdl_Rti_Access;
+ when VhpiCompInstStmtK =>
+ Inst : Ghdl_Rtin_Instance_Acc;
+ when VhpiIntRangeK
+ | VhpiEnumRangeK
+ | VhpiFloatRangeK
+ | VhpiPhysRangeK =>
+ Rng_Type : Ghdl_Rti_Access;
+ Rng_Addr : Ghdl_Range_Ptr;
+ when others =>
+ null;
+ end case;
+ -- Current Object.
+ --Obj : Ghdl_Rti_Access;
+ end record;
+
+ Null_Handle : constant VhpiHandleT := (Kind => VhpiUndefined,
+ Ctxt => (Base => Null_Address,
+ Block => null));
+end Grt.Avhpi;
diff --git a/src/translate/grt/grt-avls.adb b/src/translate/grt/grt-avls.adb
new file mode 100644
index 000000000..7f13ed39a
--- /dev/null
+++ b/src/translate/grt/grt-avls.adb
@@ -0,0 +1,249 @@
+-- GHDL Run Time (GRT) - binary balanced tree.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Avls is
+ function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is
+ begin
+ if N = AVL_Nil then
+ return 0;
+ else
+ return Tree (N).Height;
+ end if;
+ end Get_Height;
+
+ procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid)
+ is
+ L, R : AVL_Nid;
+ Lh, Rh : Ghdl_I32;
+ H : Ghdl_I32;
+ begin
+ if N = AVL_Nil then
+ return;
+ end if;
+ L := Tree (N).Left;
+ R := Tree (N).Right;
+ H := Get_Height (Tree, N);
+ if L = AVL_Nil and R = AVL_Nil then
+ if Get_Height (Tree, N) /= 1 then
+ Internal_Error ("check_AVL(1)");
+ end if;
+ return;
+ elsif L = AVL_Nil then
+ Check_AVL (Tree, R);
+ if H /= Get_Height (Tree, R) + 1 or H > 2 then
+ Internal_Error ("check_AVL(2)");
+ end if;
+ elsif R = AVL_Nil then
+ Check_AVL (Tree, L);
+ if H /= Get_Height (Tree, L) + 1 or H > 2 then
+ Internal_Error ("check_AVL(3)");
+ end if;
+ else
+ Check_AVL (Tree, L);
+ Check_AVL (Tree, R);
+ Lh := Get_Height (Tree, L);
+ Rh := Get_Height (Tree, R);
+ if Ghdl_I32'Max (Lh, Rh) + 1 /= H then
+ Internal_Error ("check_AVL(4)");
+ end if;
+ if Rh - Lh > 1 or Rh - Lh < -1 then
+ Internal_Error ("check_AVL(5)");
+ end if;
+ end if;
+ end Check_AVL;
+
+ procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ begin
+ Tree (N).Height :=
+ Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left),
+ Get_Height (Tree, Tree (N).Right)) + 1;
+ end Compute_Height;
+
+ procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ R : AVL_Nid;
+ V : AVL_Value;
+ begin
+ -- Rotate nodes.
+ R := Tree (N).Right;
+ Tree (N).Right := Tree (R).Right;
+ Tree (R).Right := Tree (R).Left;
+ Tree (R).Left := Tree (N).Left;
+ Tree (N).Left := R;
+ -- Swap vals.
+ V := Tree (N).Val;
+ Tree (N).Val := Tree (R).Val;
+ Tree (R).Val := V;
+ -- Adjust bal.
+ Compute_Height (Tree, R);
+ Compute_Height (Tree, N);
+ end Simple_Rotate_Right;
+
+ procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ L : AVL_Nid;
+ V : AVL_Value;
+ begin
+ L := Tree (N).Left;
+ Tree (N).Left := Tree (L).Left;
+ Tree (L).Left := Tree (L).Right;
+ Tree (L).Right := Tree (N).Right;
+ Tree (N).Right := L;
+ V := Tree (N).Val;
+ Tree (N).Val := Tree (L).Val;
+ Tree (L).Val := V;
+ Compute_Height (Tree, L);
+ Compute_Height (Tree, N);
+ end Simple_Rotate_Left;
+
+ procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ R : AVL_Nid;
+ begin
+ R := Tree (N).Right;
+ Simple_Rotate_Left (Tree, R);
+ Simple_Rotate_Right (Tree, N);
+ end Double_Rotate_Right;
+
+ procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ L : AVL_Nid;
+ begin
+ L := Tree (N).Left;
+ Simple_Rotate_Right (Tree, L);
+ Simple_Rotate_Left (Tree, N);
+ end Double_Rotate_Left;
+
+ procedure Insert (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Nid;
+ N : AVL_Nid;
+ Res : out AVL_Nid)
+ is
+ Diff : Integer;
+ Op_Ch, Ch : AVL_Nid;
+ begin
+ Diff := Cmp.all (Tree (Val).Val, Tree (N).Val);
+ if Diff = 0 then
+ Res := N;
+ return;
+ end if;
+ if Diff < 0 then
+ if Tree (N).Left = AVL_Nil then
+ Tree (N).Left := Val;
+ Compute_Height (Tree, N);
+ -- N is balanced.
+ Res := Val;
+ else
+ Ch := Tree (N).Left;
+ Op_Ch := Tree (N).Right;
+ Insert (Tree, Cmp, Val, Ch, Res);
+ if Res /= Val then
+ return;
+ end if;
+ if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+ -- Rotate
+ if Get_Height (Tree, Tree (Ch).Left)
+ > Get_Height (Tree, Tree (Ch).Right)
+ then
+ Simple_Rotate_Left (Tree, N);
+ else
+ Double_Rotate_Left (Tree, N);
+ end if;
+ else
+ Compute_Height (Tree, N);
+ end if;
+ end if;
+ else
+ if Tree (N).Right = AVL_Nil then
+ Tree (N).Right := Val;
+ Compute_Height (Tree, N);
+ -- N is balanced.
+ Res := Val;
+ else
+ Ch := Tree (N).Right;
+ Op_Ch := Tree (N).Left;
+ Insert (Tree, Cmp, Val, Ch, Res);
+ if Res /= Val then
+ return;
+ end if;
+ if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+ -- Rotate
+ if Get_Height (Tree, Tree (Ch).Right)
+ > Get_Height (Tree, Tree (Ch).Left)
+ then
+ Simple_Rotate_Right (Tree, N);
+ else
+ Double_Rotate_Right (Tree, N);
+ end if;
+ else
+ Compute_Height (Tree, N);
+ end if;
+ end if;
+ end if;
+ end Insert;
+
+ procedure Get_Node (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ N : AVL_Nid;
+ Res : out AVL_Nid)
+ is
+ begin
+ if Tree'First /= AVL_Root or N /= Tree'Last then
+ Internal_Error ("avls.get_node");
+ end if;
+ Insert (Tree, Cmp, N, AVL_Root, Res);
+ Check_AVL (Tree, AVL_Root);
+ end Get_Node;
+
+ function Find_Node (Tree : AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Value) return AVL_Nid
+ is
+ N : AVL_Nid;
+ Diff : Integer;
+ begin
+ N := AVL_Root;
+ if Tree'Last < AVL_Root then
+ return AVL_Nil;
+ end if;
+ loop
+ Diff := Cmp.all (Val, Tree (N).Val);
+ if Diff = 0 then
+ return N;
+ end if;
+ if Diff < 0 then
+ N := Tree (N).Left;
+ else
+ N := Tree (N).Right;
+ end if;
+ if N = AVL_Nil then
+ return AVL_Nil;
+ end if;
+ end loop;
+ end Find_Node;
+end Grt.Avls;
diff --git a/src/translate/grt/grt-avls.ads b/src/translate/grt/grt-avls.ads
new file mode 100644
index 000000000..790053c6f
--- /dev/null
+++ b/src/translate/grt/grt-avls.ads
@@ -0,0 +1,84 @@
+-- GHDL Run Time (GRT) - binary balanced tree.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+
+package Grt.Avls is
+ -- Implementation of a binary balanced tree.
+ -- This package is very generic, and provides only the algorithm.
+ -- The user must provide the storage of the tree.
+ -- The basic types of this implementation ares:
+ -- * AVL_Value: the value stored in the tree. This is an integer on 32
+ -- bits. However, they may either really represent integers or an index
+ -- into another table. To compare two values, a user function is always
+ -- provided.
+ -- * AVL_Nid: a node id or an index into the tree.
+ -- * AVL_Node: a node, indexed by AVL_Nid.
+ -- * AVL_Tree: an array of AVL_Node, indexed by AVL_Nid. This represents
+ -- the tree. The root of the tree is always AVL_Root, which is the
+ -- first element of the array.
+ --
+ -- As a choice, this package never allocate nodes. So, to insert a value
+ -- in the tree, the user must allocate an (empty) node, set the value of
+ -- the node and try to insert this node into the tree. If the value is
+ -- already in the tree, Get_Node will returns the node id which contains
+ -- the value. Otherwise, Get_Node returns the node just created by the
+ -- user.
+
+ -- The value in an AVL tree.
+ -- This is fixed.
+ type AVL_Value is new Ghdl_I32;
+
+ -- An AVL node id.
+ type AVL_Nid is new Ghdl_I32;
+ AVL_Nil : constant AVL_Nid := 0;
+ AVL_Root : constant AVL_Nid := 1;
+
+ type AVL_Node is record
+ Val : AVL_Value;
+ Left : AVL_Nid;
+ Right : AVL_Nid;
+ Height : Ghdl_I32;
+ end record;
+
+ type AVL_Tree is array (AVL_Nid range <>) of AVL_Node;
+
+ -- Compare two values.
+ -- Returns < 0 if L < R, 0 if L = R, > 0 if L > R.
+ type AVL_Compare_Func is access function (L, R : AVL_Value) return Integer;
+
+ -- Try to insert node N into TREE.
+ -- Returns either N or the node id of a node containing already the value.
+ procedure Get_Node (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ N : AVL_Nid;
+ Res : out AVL_Nid);
+
+ function Find_Node (Tree : AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Value) return AVL_Nid;
+
+end Grt.Avls;
+
+
diff --git a/src/translate/grt/grt-c.ads b/src/translate/grt/grt-c.ads
new file mode 100644
index 000000000..24003cf4a
--- /dev/null
+++ b/src/translate/grt/grt-c.ads
@@ -0,0 +1,54 @@
+-- GHDL Run Time (GRT) - C interface.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- This package declares C types.
+-- It is a really stripped down version of interfaces.C!
+with System;
+
+package Grt.C is
+ pragma Preelaborate (Grt.C);
+
+ -- Type void * and char *.
+ subtype voids is System.Address;
+ subtype chars is System.Address;
+ subtype long is Long_Integer;
+
+ -- Type size_t.
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ -- Type int. It is an alias on Integer for simplicity.
+ subtype int is Integer;
+
+ -- Low level memory management.
+ procedure Free (Addr : System.Address);
+ function Malloc (Size : size_t) return System.Address;
+ function Realloc (Ptr : System.Address; Size : size_t)
+ return System.Address;
+
+private
+ pragma Import (C, Free);
+ pragma Import (C, Malloc);
+ pragma Import (C, Realloc);
+end Grt.C;
diff --git a/src/translate/grt/grt-cbinding.c b/src/translate/grt/grt-cbinding.c
new file mode 100644
index 000000000..b95c0f0a9
--- /dev/null
+++ b/src/translate/grt/grt-cbinding.c
@@ -0,0 +1,99 @@
+/* GRT C bindings.
+ Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+FILE *
+__ghdl_get_stdout (void)
+{
+ return stdout;
+}
+
+FILE *
+__ghdl_get_stdin (void)
+{
+ return stdin;
+}
+
+FILE *
+__ghdl_get_stderr (void)
+{
+ return stderr;
+}
+
+int
+__ghdl_snprintf_g (char *buf, unsigned int len, double val)
+{
+ snprintf (buf, len, "%g", val);
+ return strlen (buf);
+}
+
+void
+__ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val)
+{
+ snprintf (buf, len, "%.*f", ndigits, val);
+}
+
+void
+__ghdl_snprintf_fmtf (char *buf, unsigned int len,
+ const char *format, double v)
+{
+ snprintf (buf, len, format, v);
+}
+
+void
+__ghdl_fprintf_g (FILE *stream, double val)
+{
+ fprintf (stream, "%g", val);
+}
+
+void
+__ghdl_fprintf_clock (FILE *stream, int a, int b)
+{
+ fprintf (stream, "%3d.%03d", a, b);
+}
+
+#ifndef WITH_GNAT_RUN_TIME
+void
+__gnat_last_chance_handler (void)
+{
+ abort ();
+}
+
+void *
+__gnat_malloc (size_t size)
+{
+ void *res;
+ res = malloc (size);
+ return res;
+}
+
+void
+__gnat_free (void *ptr)
+{
+ free (ptr);
+}
+
+void *
+__gnat_realloc (void *ptr, size_t size)
+{
+ return realloc (ptr, size);
+}
+#endif
diff --git a/src/translate/grt/grt-cvpi.c b/src/translate/grt/grt-cvpi.c
new file mode 100644
index 000000000..51edd678f
--- /dev/null
+++ b/src/translate/grt/grt-cvpi.c
@@ -0,0 +1,277 @@
+/* GRT VPI C helpers.
+ Copyright (C) 2003, 2004, 2005 Tristan Gingold & Felix Bertram
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Description: VPI interface for GRT runtime, "C" helpers
+// the main purpose of this code is to interface with the
+// Icarus Verilog Interactive (IVI) simulator GUI
+//-----------------------------------------------------------------------------
+
+#include <stdio.h>
+#include <stdlib.h>
+
+//-----------------------------------------------------------------------------
+// VPI callback functions
+typedef void *vpiHandle, *p_vpi_time, *p_vpi_value;
+typedef struct t_cb_data {
+ int reason;
+ int (*cb_rtn)(struct t_cb_data*cb);
+ vpiHandle obj;
+ p_vpi_time time;
+ p_vpi_value value;
+ int index;
+ char*user_data;
+} s_cb_data, *p_cb_data;
+
+//-----------------------------------------------------------------------------
+// vpi thunking a la Icarus Verilog
+#include <stdarg.h>
+typedef void *s_vpi_time, *p_vpi_vlog_info, *p_vpi_error_info;
+#define VPI_THUNK_MAGIC (0x87836BA5)
+struct t_vpi_systf_data;
+void vpi_register_systf (const struct t_vpi_systf_data*ss);
+void vpi_vprintf (const char*fmt, va_list ap);
+unsigned int vpi_mcd_close (unsigned int mcd);
+char * vpi_mcd_name (unsigned int mcd);
+unsigned int vpi_mcd_open (char *name);
+unsigned int vpi_mcd_open_x (char *name, char *mode);
+int vpi_mcd_vprintf (unsigned int mcd, const char*fmt, va_list ap);
+int vpi_mcd_fputc (unsigned int mcd, unsigned char x);
+int vpi_mcd_fgetc (unsigned int mcd);
+vpiHandle vpi_register_cb (p_cb_data data);
+int vpi_remove_cb (vpiHandle ref);
+void vpi_sim_vcontrol (int operation, va_list ap);
+vpiHandle vpi_handle (int type, vpiHandle ref);
+vpiHandle vpi_iterate (int type, vpiHandle ref);
+vpiHandle vpi_scan (vpiHandle iter);
+vpiHandle vpi_handle_by_index (vpiHandle ref, int index);
+void vpi_get_time (vpiHandle obj, s_vpi_time*t);
+int vpi_get (int property, vpiHandle ref);
+char* vpi_get_str (int property, vpiHandle ref);
+void vpi_get_value (vpiHandle expr, p_vpi_value value);
+vpiHandle vpi_put_value (vpiHandle obj, p_vpi_value value,
+ p_vpi_time when, int flags);
+int vpi_free_object (vpiHandle ref);
+int vpi_get_vlog_info (p_vpi_vlog_info vlog_info_p);
+int vpi_chk_error (p_vpi_error_info info);
+vpiHandle vpi_handle_by_name (char *name, vpiHandle scope);
+
+typedef struct {
+ int magic;
+ void (*vpi_register_systf) (const struct t_vpi_systf_data*ss);
+ void (*vpi_vprintf) (const char*fmt, va_list ap);
+ unsigned int (*vpi_mcd_close) (unsigned int mcd);
+ char* (*vpi_mcd_name) (unsigned int mcd);
+ unsigned int (*vpi_mcd_open) (char *name);
+ unsigned int (*vpi_mcd_open_x) (char *name, char *mode);
+ int (*vpi_mcd_vprintf) (unsigned int mcd, const char*fmt, va_list ap);
+ int (*vpi_mcd_fputc) (unsigned int mcd, unsigned char x);
+ int (*vpi_mcd_fgetc) (unsigned int mcd);
+ vpiHandle (*vpi_register_cb) (p_cb_data data);
+ int (*vpi_remove_cb) (vpiHandle ref);
+ void (*vpi_sim_vcontrol) (int operation, va_list ap);
+ vpiHandle (*vpi_handle) (int type, vpiHandle ref);
+ vpiHandle (*vpi_iterate) (int type, vpiHandle ref);
+ vpiHandle (*vpi_scan) (vpiHandle iter);
+ vpiHandle (*vpi_handle_by_index)(vpiHandle ref, int index);
+ void (*vpi_get_time) (vpiHandle obj, s_vpi_time*t);
+ int (*vpi_get) (int property, vpiHandle ref);
+ char* (*vpi_get_str) (int property, vpiHandle ref);
+ void (*vpi_get_value) (vpiHandle expr, p_vpi_value value);
+ vpiHandle (*vpi_put_value) (vpiHandle obj, p_vpi_value value,
+ p_vpi_time when, int flags);
+ int (*vpi_free_object) (vpiHandle ref);
+ int (*vpi_get_vlog_info) (p_vpi_vlog_info vlog_info_p);
+ int (*vpi_chk_error) (p_vpi_error_info info);
+ vpiHandle (*vpi_handle_by_name) (char *name, vpiHandle scope);
+} vpi_thunk, *p_vpi_thunk;
+
+int vpi_register_sim(p_vpi_thunk tp);
+
+static vpi_thunk thunkTable =
+{ VPI_THUNK_MAGIC,
+ vpi_register_systf,
+ vpi_vprintf,
+ vpi_mcd_close,
+ vpi_mcd_name,
+ vpi_mcd_open,
+ 0, //vpi_mcd_open_x,
+ 0, //vpi_mcd_vprintf,
+ 0, //vpi_mcd_fputc,
+ 0, //vpi_mcd_fgetc,
+ vpi_register_cb,
+ vpi_remove_cb,
+ 0, //vpi_sim_vcontrol,
+ vpi_handle,
+ vpi_iterate,
+ vpi_scan,
+ vpi_handle_by_index,
+ vpi_get_time,
+ vpi_get,
+ vpi_get_str,
+ vpi_get_value,
+ vpi_put_value,
+ vpi_free_object,
+ vpi_get_vlog_info,
+ 0, //vpi_chk_error,
+ 0 //vpi_handle_by_name
+};
+
+//-----------------------------------------------------------------------------
+// VPI module load & startup
+static void * module_open (const char *path);
+static void * module_symbol (void *handle, const char *symbol);
+static const char *module_error (void);
+
+#if defined(__WIN32__)
+#include <windows.h>
+static void *
+module_open (const char *path)
+{
+ return (void *)LoadLibrary (path);
+}
+
+static void *
+module_symbol (void *handle, const char *symbol)
+{
+ return (void *)GetProcAddress ((HMODULE)handle, symbol);
+}
+
+static const char *
+module_error (void)
+{
+ static char msg[256];
+
+ FormatMessage
+ (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
+ NULL,
+ GetLastError (),
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ (LPTSTR) &msg,
+ sizeof (msg) - 1,
+ NULL);
+ return msg;
+}
+#else
+#include <dlfcn.h>
+static void *
+module_open (const char *path)
+{
+ return dlopen (path, RTLD_LAZY);
+}
+
+static void *
+module_symbol (void *handle, const char *symbol)
+{
+ return dlsym (handle, symbol);
+}
+
+static const char *
+module_error (void)
+{
+ return dlerror ();
+}
+#endif
+
+int
+loadVpiModule (const char* modulename)
+{
+ static const char * const vpitablenames[] =
+ {
+ "_vlog_startup_routines", // with leading underscore: MacOSX
+ "vlog_startup_routines" // w/o leading underscore: Linux
+ };
+ static const char * const vpithunknames[] =
+ {
+ "_vpi_register_sim", // with leading underscore: MacOSX
+ "vpi_register_sim" // w/o leading underscore: Linux
+ };
+
+ int i;
+ void* vpimod;
+
+ fprintf (stderr, "loading VPI module '%s'\n", modulename);
+
+ vpimod = module_open (modulename);
+
+ if (vpimod == NULL)
+ {
+ const char *msg;
+
+ msg = module_error ();
+
+ fprintf (stderr, "%s\n", msg == NULL ? "unknown dlopen error" : msg);
+ return -1;
+ }
+
+ for (i = 0; i < 2; i++) // try with and w/o leading underscores
+ {
+ void* vpithunk;
+ void* vpitable;
+
+ vpitable = module_symbol (vpimod, vpitablenames[i]);
+ vpithunk = module_symbol (vpimod, vpithunknames[i]);
+
+ if (vpithunk)
+ {
+ typedef int (*funT)(p_vpi_thunk tp);
+ funT regsim;
+
+ regsim = (funT)vpithunk;
+ regsim (&thunkTable);
+ }
+ else
+ {
+ // this is not an error, as the register-mechanism
+ // is not standardized
+ }
+
+ if (vpitable)
+ {
+ unsigned int tmp;
+ //extern void (*vlog_startup_routines[])();
+ typedef void (*vlog_startup_routines_t)(void);
+ vlog_startup_routines_t *vpifuns;
+
+ vpifuns = (vlog_startup_routines_t*)vpitable;
+ for (tmp = 0; vpifuns[tmp]; tmp++)
+ {
+ vpifuns[tmp]();
+ }
+
+ fprintf (stderr, "VPI module loaded!\n");
+ return 0; // successfully registered VPI module
+ }
+ }
+ fprintf (stderr, "vlog_startup_routines not found\n");
+ return -1; // failed to register VPI module
+}
+
+void
+vpi_printf (const char *fmt, ...)
+{
+ va_list params;
+
+ va_start (params, fmt);
+ vprintf (fmt, params);
+ va_end (params);
+}
+
+//-----------------------------------------------------------------------------
+// end of file
+
diff --git a/src/translate/grt/grt-disp.adb b/src/translate/grt/grt-disp.adb
new file mode 100644
index 000000000..e68b1168b
--- /dev/null
+++ b/src/translate/grt/grt-disp.adb
@@ -0,0 +1,227 @@
+-- GHDL Run Time (GRT) - Common display subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Stdio; use Grt.Stdio;
+--with Grt.Errors; use Grt.Errors;
+
+package body Grt.Disp is
+
+-- procedure Put_Trim (Stream : FILEs; Str : String)
+-- is
+-- Start : Natural;
+-- begin
+-- Start := Str'First;
+-- while Start <= Str'Last and then Str (Start) = ' ' loop
+-- Start := Start + 1;
+-- end loop;
+-- Put (Stream, Str (Start .. Str'Last));
+-- end Put_Trim;
+
+-- procedure Put_E8 (Stream : FILEs; E8 : Ghdl_E8; Type_Desc : Ghdl_Desc_Ptr)
+-- is
+-- begin
+-- Put_Str_Len (Stream, Type_Desc.E8.Values (Natural (E8)));
+-- end Put_E8;
+
+ --procedure Put_E32
+ -- (Stream : FILEs; E32 : Ghdl_E32; Type_Desc : Ghdl_Desc_Ptr)
+ --is
+ --begin
+ -- Put_Str_Len (Stream, Type_Desc.E32.Values (Natural (E32)));
+ --end Put_E32;
+
+ procedure Put_Sig_Index (Sig : Sig_Table_Index)
+ is
+ begin
+ Put_I32 (stdout, Ghdl_I32 (Sig));
+ end Put_Sig_Index;
+
+ procedure Put_Sig_Range (Sig : Sig_Table_Range)
+ is
+ begin
+ Put_Sig_Index (Sig.First);
+ if Sig.Last /= Sig.First then
+ Put ("-");
+ Put_Sig_Index (Sig.Last);
+ end if;
+ end Put_Sig_Range;
+
+ procedure Disp_Now
+ is
+ begin
+ Put ("Now is ");
+ Put_Time (stdout, Current_Time);
+ Put (" +");
+ Put_I32 (stdout, Ghdl_I32 (Current_Delta));
+ New_Line;
+ end Disp_Now;
+
+ procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type)
+ is
+ begin
+ case Kind is
+ when Drv_One_Driver =>
+ Put ("Drv (1 drv) ");
+ when Eff_One_Driver =>
+ Put ("Eff (1 drv) ");
+ when Drv_One_Port =>
+ Put ("Drv (1 prt) ");
+ when Eff_One_Port =>
+ Put ("Eff (1 prt) ");
+ when Imp_Forward =>
+ Put ("Forward ");
+ when Imp_Forward_Build =>
+ Put ("Forward_Build ");
+ when Imp_Guard =>
+ Put ("Guard ");
+ when Imp_Stable =>
+ Put ("Stable ");
+ when Imp_Quiet =>
+ Put ("Quiet ");
+ when Imp_Transaction =>
+ Put ("Transaction ");
+ when Imp_Delayed =>
+ Put ("Delayed ");
+ when Eff_Actual =>
+ Put ("Eff Actual ");
+ when Eff_Multiple =>
+ Put ("Eff multiple ");
+ when Drv_One_Resolved =>
+ Put ("Drv 1 resolved ");
+ when Eff_One_Resolved =>
+ Put ("Eff 1 resolved ");
+ when In_Conversion =>
+ Put ("In conv ");
+ when Out_Conversion =>
+ Put ("Out conv ");
+ when Drv_Error =>
+ Put ("Drv error ");
+ when Drv_Multiple =>
+ Put ("Drv multiple ");
+ when Prop_End =>
+ Put ("end ");
+ end case;
+ end Disp_Propagation_Kind;
+
+ procedure Disp_Signals_Order is
+ begin
+ for I in Propagation.First .. Propagation.Last loop
+ Put_I32 (stdout, Ghdl_I32 (I));
+ Put (": ");
+ Disp_Propagation_Kind (Propagation.Table (I).Kind);
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver
+ | Drv_One_Port
+ | Eff_One_Port
+ | Drv_One_Resolved
+ | Eff_One_Resolved
+ | Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Delayed
+ | Eff_Actual =>
+ Put_Sig_Index (Signal_Ptr_To_Index (Propagation.Table (I).Sig));
+ New_Line;
+ when Imp_Forward =>
+ Put_I32 (stdout, Ghdl_I32 (Propagation.Table (I).Sig.Net));
+ New_Line;
+ when Imp_Forward_Build =>
+ declare
+ Forward : Forward_Build_Acc;
+ begin
+ Forward := Propagation.Table (I).Forward;
+ Put_Sig_Index (Signal_Ptr_To_Index (Forward.Src));
+ Put (" -> ");
+ Put_Sig_Index (Signal_Ptr_To_Index (Forward.Targ));
+ New_Line;
+ end;
+ when Eff_Multiple
+ | Drv_Multiple =>
+ Put_Sig_Range (Propagation.Table (I).Resolv.Sig_Range);
+ New_Line;
+ when In_Conversion
+ | Out_Conversion =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Propagation.Table (I).Conv;
+ Put_Sig_Range (Conv.Src);
+ Put (" -> ");
+ Put_Sig_Range (Conv.Dest);
+ New_Line;
+ end;
+ when Prop_End =>
+ New_Line;
+ when Drv_Error =>
+ null;
+ end case;
+ end loop;
+ end Disp_Signals_Order;
+
+ procedure Disp_Mode (Mode : Mode_Type)
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Put (" b1");
+ when Mode_E8 =>
+ Put (" e8");
+ when Mode_E32 =>
+ Put ("e32");
+ when Mode_I32 =>
+ Put ("i32");
+ when Mode_I64 =>
+ Put ("i64");
+ when Mode_F64 =>
+ Put ("f64");
+ end case;
+ end Disp_Mode;
+
+ procedure Disp_Value (Value : Value_Union; Mode : Mode_Type) is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ if Value.B1 then
+ Put ("T");
+ else
+ Put ("F");
+ end if;
+ when Mode_E8 =>
+ Put_I32 (stdout, Ghdl_I32 (Value.E8));
+ when Mode_E32 =>
+ Put_I32 (stdout, Ghdl_I32 (Value.E32));
+ when Mode_I32 =>
+ Put_I32 (stdout, Value.I32);
+ when Mode_I64 =>
+ Put_I64 (stdout, Value.I64);
+ when Mode_F64 =>
+ Put_F64 (stdout, Value.F64);
+ end case;
+ end Disp_Value;
+end Grt.Disp;
diff --git a/src/translate/grt/grt-disp.ads b/src/translate/grt/grt-disp.ads
new file mode 100644
index 000000000..6c15b37c9
--- /dev/null
+++ b/src/translate/grt/grt-disp.ads
@@ -0,0 +1,46 @@
+-- GHDL Run Time (GRT) - Common display subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Signals; use Grt.Signals;
+with Grt.Types; use Grt.Types;
+
+package Grt.Disp is
+ -- Display SIG number.
+ procedure Put_Sig_Index (Sig : Sig_Table_Index);
+
+ -- Disp current time and current delta.
+ procedure Disp_Now;
+
+ procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type);
+
+ -- Disp signals propagation order.
+ procedure Disp_Signals_Order;
+
+ -- Disp mode.
+ procedure Disp_Mode (Mode : Mode_Type);
+
+ -- Disp value (numeric).
+ procedure Disp_Value (Value : Value_Union; Mode : Mode_Type);
+
+end Grt.Disp;
diff --git a/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb
new file mode 100644
index 000000000..08d27dacb
--- /dev/null
+++ b/src/translate/grt/grt-disp_rti.adb
@@ -0,0 +1,1080 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+
+package body Grt.Disp_Rti is
+ procedure Disp_Kind (Kind : Ghdl_Rtik);
+
+ procedure Disp_Name (Name : Ghdl_C_String) is
+ begin
+ if Name = null then
+ Put (stdout, "<anonymous>");
+ else
+ Put (stdout, Name);
+ end if;
+ end Disp_Name;
+
+ -- Disp value stored at ADDR and whose type is described by RTI.
+ procedure Disp_Enum_Value
+ (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Put (Stream, Enum_Rti.Names (Val));
+ end Disp_Enum_Value;
+
+ procedure Disp_Scalar_Value
+ (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Addr : in out Address;
+ Is_Sig : Boolean)
+ is
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Addr := Addr + (S / Storage_Unit);
+ end Update;
+
+ Vptr : Ghdl_Value_Ptr;
+ begin
+ if Is_Sig then
+ Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all);
+ Update (Address'Size);
+ else
+ Vptr := To_Ghdl_Value_Ptr (Addr);
+ end if;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Put_I32 (Stream, Vptr.I32);
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when Ghdl_Rtik_Type_E8 =>
+ Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
+ if not Is_Sig then
+ Update (8);
+ end if;
+ when Ghdl_Rtik_Type_E32 =>
+ Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32));
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when Ghdl_Rtik_Type_B1 =>
+ Disp_Enum_Value (Stream, Rti,
+ Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1)));
+ if not Is_Sig then
+ Update (8);
+ end if;
+ when Ghdl_Rtik_Type_F64 =>
+ Put_F64 (Stream, Vptr.F64);
+ if not Is_Sig then
+ Update (64);
+ end if;
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64 (Stream, Vptr.I64);
+ Put (Stream, " ");
+ Put (Stream,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (64);
+ end if;
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32 (Stream, Vptr.I32);
+ Put (Stream, " ");
+ Put (Stream,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when others =>
+ Internal_Error ("disp_rti.disp_scalar_value");
+ end case;
+ end Disp_Scalar_Value;
+
+-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik
+-- is
+-- Ndef : Ghdl_Rti_Access;
+-- begin
+-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
+-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
+-- else
+-- Ndef := Rti;
+-- end if;
+-- case Ndef.Kind is
+-- when Ghdl_Rtik_Type_I32 =>
+-- return Ndef.Kind;
+-- when others =>
+-- return Ghdl_Rtik_Error;
+-- end case;
+-- end Get_Scalar_Type_Kind;
+
+ procedure Disp_Array_Value_1 (Stream : FILEs;
+ El_Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Rngs : Ghdl_Range_Array;
+ Rtis : Ghdl_Rti_Arr_Acc;
+ Index : Ghdl_Index_Type;
+ Obj : in out Address;
+ Is_Sig : Boolean)
+ is
+ Length : Ghdl_Index_Type;
+ begin
+ Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index)));
+ Put (Stream, "(");
+ for I in 1 .. Length loop
+ if I /= 1 then
+ Put (Stream, ", ");
+ end if;
+ if Index = Rngs'Last then
+ Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig);
+ else
+ Disp_Array_Value_1
+ (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig);
+ end if;
+ end loop;
+ Put (Stream, ")");
+ end Disp_Array_Value_1;
+
+ procedure Disp_Array_Value (Stream : FILEs;
+ Rti : Ghdl_Rtin_Type_Array_Acc;
+ Ctxt : Rti_Context;
+ Vals : Ghdl_Uc_Array_Acc;
+ Is_Sig : Boolean)
+ is
+ Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim;
+ Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
+ Obj : Address;
+ begin
+ Bound_To_Range (Vals.Bounds, Rti, Rngs);
+ Obj := Vals.Base;
+ Disp_Array_Value_1
+ (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig);
+ end Disp_Array_Value;
+
+ procedure Disp_Record_Value (Stream : FILEs;
+ Rti : Ghdl_Rtin_Type_Record_Acc;
+ Ctxt : Rti_Context;
+ Obj : Address;
+ Is_Sig : Boolean)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ El_Addr : Address;
+ begin
+ Put (Stream, "(");
+ for I in 1 .. Rti.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Put (Stream, El.Name);
+ Put (" => ");
+ if Is_Sig then
+ El_Addr := Obj + El.Sig_Off;
+ else
+ El_Addr := Obj + El.Val_Off;
+ end if;
+ if Rti_Complex_Type (El.Eltype) then
+ El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all;
+ end if;
+ Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig);
+ end loop;
+ Put (")");
+ -- FIXME: update ADDR.
+ end Disp_Record_Value;
+
+ procedure Disp_Value
+ (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Obj : in out Address;
+ Is_Sig : Boolean)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Disp_Scalar_Value
+ (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype,
+ Obj, Is_Sig);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig);
+ when Ghdl_Rtik_Type_Array =>
+ Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt,
+ To_Ghdl_Uc_Array_Acc (Obj), Is_Sig);
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ B : Address;
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+ B := Obj;
+ Disp_Array_Value_1
+ (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
+ end;
+ when Ghdl_Rtik_Type_File =>
+ declare
+ Vptr : Ghdl_Value_Ptr;
+ begin
+ Vptr := To_Ghdl_Value_Ptr (Obj);
+ Put (Stream, "File#");
+ Put_I32 (Stream, Vptr.I32);
+ -- FIXME: update OBJ (not very useful since never in a
+ -- composite type).
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Record_Value
+ (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig);
+ when Ghdl_Rtik_Type_Protected =>
+ Put (Stream, "Unhandled protected type");
+ when others =>
+ Put (Stream, "Unknown Rti Kind : ");
+ Disp_Kind(Rti.Kind);
+ end case;
+ -- Put_Line(":");
+ end Disp_Value;
+
+ procedure Disp_Kind (Kind : Ghdl_Rtik) is
+ begin
+ case Kind is
+ when Ghdl_Rtik_Top =>
+ Put ("ghdl_rtik_top");
+ when Ghdl_Rtik_Package =>
+ Put ("ghdl_rtik_package");
+ when Ghdl_Rtik_Package_Body =>
+ Put ("ghdl_rtik_package_body");
+ when Ghdl_Rtik_Entity =>
+ Put ("ghdl_rtik_entity");
+ when Ghdl_Rtik_Architecture =>
+ Put ("ghdl_rtik_architecture");
+
+ when Ghdl_Rtik_Port =>
+ Put ("ghdl_rtik_port");
+ when Ghdl_Rtik_Generic =>
+ Put ("ghdl_rtik_generic");
+ when Ghdl_Rtik_Process =>
+ Put ("ghdl_rtik_process");
+ when Ghdl_Rtik_Component =>
+ Put ("ghdl_rtik_component");
+ when Ghdl_Rtik_Attribute =>
+ Put ("ghdl_rtik_attribute");
+
+ when Ghdl_Rtik_Attribute_Quiet =>
+ Put ("ghdl_rtik_attribute_quiet");
+ when Ghdl_Rtik_Attribute_Stable =>
+ Put ("ghdl_rtik_attribute_stable");
+ when Ghdl_Rtik_Attribute_Transaction =>
+ Put ("ghdl_rtik_attribute_transaction");
+
+ when Ghdl_Rtik_Constant =>
+ Put ("ghdl_rtik_constant");
+ when Ghdl_Rtik_Iterator =>
+ Put ("ghdl_rtik_iterator");
+ when Ghdl_Rtik_Signal =>
+ Put ("ghdl_rtik_signal");
+ when Ghdl_Rtik_Variable =>
+ Put ("ghdl_rtik_variable");
+ when Ghdl_Rtik_Guard =>
+ Put ("ghdl_rtik_guard");
+ when Ghdl_Rtik_File =>
+ Put ("ghdl_rtik_file");
+
+ when Ghdl_Rtik_Instance =>
+ Put ("ghdl_rtik_instance");
+ when Ghdl_Rtik_Block =>
+ Put ("ghdl_rtik_block");
+ when Ghdl_Rtik_If_Generate =>
+ Put ("ghdl_rtik_if_generate");
+ when Ghdl_Rtik_For_Generate =>
+ Put ("ghdl_rtik_for_generate");
+
+ when Ghdl_Rtik_Type_B1 =>
+ Put ("ghdl_rtik_type_b1");
+ when Ghdl_Rtik_Type_E8 =>
+ Put ("ghdl_rtik_type_e8");
+ when Ghdl_Rtik_Type_E32 =>
+ Put ("ghdl_rtik_type_e32");
+ when Ghdl_Rtik_Type_P64 =>
+ Put ("ghdl_rtik_type_p64");
+ when Ghdl_Rtik_Type_I32 =>
+ Put ("ghdl_rtik_type_i32");
+
+ when Ghdl_Rtik_Type_Array =>
+ Put ("ghdl_rtik_type_array");
+ when Ghdl_Rtik_Subtype_Array =>
+ Put ("ghdl_rtik_subtype_array");
+ when Ghdl_Rtik_Type_Record =>
+ Put ("ghdl_rtik_type_record");
+
+ when Ghdl_Rtik_Type_Access =>
+ Put ("ghdl_rtik_type_access");
+ when Ghdl_Rtik_Type_File =>
+ Put ("ghdl_rtik_type_file");
+ when Ghdl_Rtik_Type_Protected =>
+ Put ("ghdl_rtik_type_protected");
+
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Put ("ghdl_rtik_subtype_scalar");
+
+ when Ghdl_Rtik_Element =>
+ Put ("ghdl_rtik_element");
+ when Ghdl_Rtik_Unit64 =>
+ Put ("ghdl_rtik_unit64");
+ when Ghdl_Rtik_Unitptr =>
+ Put ("ghdl_rtik_unitptr");
+
+ when others =>
+ Put ("ghdl_rtik_#");
+ Put_I32 (stdout, Ghdl_Rtik'Pos (Kind));
+ end case;
+ end Disp_Kind;
+
+ procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is
+ begin
+ Put (", D=");
+ Put_I32 (stdout, Ghdl_I32 (Depth));
+ end Disp_Depth;
+
+ procedure Disp_Indent (Indent : Natural) is
+ begin
+ for I in 1 .. Indent loop
+ Put (' ');
+ end loop;
+ end Disp_Indent;
+
+ -- Disp a subtype_indication.
+ -- OBJ may be necessary when the subtype is an unconstrained array type,
+ -- whose bounds are stored with the object.
+ procedure Disp_Subtype_Indication
+ (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address);
+
+ procedure Disp_Range
+ (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr)
+ is
+ begin
+ case Kind is
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_P32 =>
+ Put_I32 (Stream, Rng.I32.Left);
+ Put_Dir (Stream, Rng.I32.Dir);
+ Put_I32 (Stream, Rng.I32.Right);
+ when Ghdl_Rtik_Type_F64 =>
+ Put_F64 (Stream, Rng.F64.Left);
+ Put_Dir (Stream, Rng.F64.Dir);
+ Put_F64 (Stream, Rng.F64.Right);
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64 (Stream, Rng.P64.Left);
+ Put_Dir (Stream, Rng.P64.Dir);
+ Put_I64 (Stream, Rng.P64.Right);
+ when others =>
+ Put ("?Scal");
+ end case;
+ end Disp_Range;
+
+ procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is
+ begin
+ case Def.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+ if Rti.Name /= null then
+ Disp_Name (Rti.Name);
+ else
+ Disp_Scalar_Type_Name (Rti.Basetype);
+ end if;
+ end;
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when others =>
+ Put ("#disp_scalar_type_name#");
+ end case;
+ end Disp_Scalar_Type_Name;
+
+ procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc;
+ Bounds_Ptr : Address)
+ is
+ Bounds : Address;
+
+ procedure Align (A : Ghdl_Index_Type) is
+ begin
+ Bounds := Align (Bounds, Ghdl_Rti_Loc (A));
+ end Align;
+
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Bounds := Bounds + (S / Storage_Unit);
+ end Update;
+
+ procedure Disp_Bounds (Def : Ghdl_Rti_Access)
+ is
+ Ndef : Ghdl_Rti_Access;
+ begin
+ if Bounds = Null_Address then
+ Put ("?");
+ else
+ if Def.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype;
+ else
+ Ndef := Def;
+ end if;
+ case Ndef.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Align (Ghdl_Range_I32'Alignment);
+ Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds));
+ Update (Ghdl_Range_I32'Size);
+ when others =>
+ Disp_Kind (Ndef.Kind);
+ -- Bounds are not known anymore.
+ Bounds := Null_Address;
+ end case;
+ end if;
+ end Disp_Bounds;
+ begin
+ Disp_Name (Def.Name);
+ if Bounds_Ptr = Null_Address then
+ return;
+ end if;
+ Put (" (");
+ Bounds := Bounds_Ptr;
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Scalar_Type_Name (Def.Indexes (I));
+ Put (" range ");
+ Disp_Bounds (Def.Indexes (I));
+ end loop;
+ Put (")");
+ end Disp_Type_Array_Name;
+
+ procedure Disp_Subtype_Scalar_Range
+ (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context)
+ is
+ Range_Addr : Address;
+ Rng : Ghdl_Range_Ptr;
+ begin
+ Range_Addr := Loc_To_Addr (Def.Common.Depth,
+ Def.Range_Loc, Ctxt);
+ Rng := To_Ghdl_Range_Ptr (Range_Addr);
+ Disp_Range (Stream, Def.Basetype.Kind, Rng);
+ end Disp_Subtype_Scalar_Range;
+
+ procedure Disp_Subtype_Indication
+ (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address)
+ is
+ begin
+ case Def.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+ if Rti.Name /= null then
+ Disp_Name (Rti.Name);
+ else
+ Disp_Subtype_Indication
+ (Rti.Basetype, Null_Context, Null_Address);
+ Put (" range ");
+ Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt);
+ end if;
+ end;
+ --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def),
+ -- Base);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when Ghdl_Rtik_Type_File
+ | Ghdl_Rtik_Type_Access =>
+ Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name);
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name);
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Bounds : Address;
+ begin
+ if Obj = Null_Address then
+ Bounds := Null_Address;
+ else
+ Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds;
+ end if;
+ Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def),
+ Bounds);
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Sdef : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def);
+ if Sdef.Name /= null then
+ Disp_Name (Sdef.Name);
+ else
+ Disp_Type_Array_Name
+ (Sdef.Basetype,
+ Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt));
+ end if;
+ end;
+ when Ghdl_Rtik_Type_Protected =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when others =>
+ Disp_Kind (Def.Kind);
+ Put (' ');
+ end case;
+ end Disp_Subtype_Indication;
+
+
+ procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Indent : Natural);
+
+ procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type;
+ Arr : Ghdl_Rti_Arr_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ for I in 1 .. Nbr loop
+ Disp_Rti (Arr (I - 1), Ctxt, Indent);
+ end loop;
+ end Disp_Rti_Arr;
+
+ procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Nctxt : Rti_Context;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Blk.Common.Kind);
+ Disp_Depth (Blk.Common.Depth);
+ Put (": ");
+ Disp_Name (Blk.Name);
+ New_Line;
+ if Blk.Parent /= null then
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ -- Disp entity.
+ Disp_Rti (Blk.Parent, Ctxt, Indent + 1);
+ when others =>
+ null;
+ end case;
+ end if;
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Package_Body
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_Process =>
+ Nctxt := (Base => Ctxt.Base + Blk.Loc,
+ Block => To_Ghdl_Rti_Access (Blk));
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Length : Ghdl_Index_Type;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all,
+ Block => To_Ghdl_Rti_Access (Blk));
+ Length := Get_For_Generate_Length (Blk, Ctxt);
+ for I in 1 .. Length loop
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ Nctxt.Base := Nctxt.Base + Blk.Size;
+ end loop;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all,
+ Block => To_Ghdl_Rti_Access (Blk));
+ if Nctxt.Base /= Null_Address then
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ end if;
+ when others =>
+ Internal_Error ("disp_block");
+ end case;
+ end Disp_Block;
+
+ procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc;
+ Is_Sig : Boolean;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Addr : Address;
+ Obj_Type : Ghdl_Rti_Access;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Obj.Common.Kind);
+ Disp_Depth (Obj.Common.Depth);
+ Put ("; ");
+ Disp_Name (Obj.Name);
+ Put (": ");
+ Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt);
+ Obj_Type := Obj.Obj_Type;
+ Disp_Subtype_Indication (Obj_Type, Ctxt, Addr);
+ Put (" := ");
+
+ -- FIXME: put this into a function.
+ if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array
+ or Obj_Type.Kind = Ghdl_Rtik_Type_Record)
+ and then Rti_Complex_Type (Obj_Type)
+ then
+ Addr := To_Addr_Acc (Addr).all;
+ end if;
+ Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig);
+ New_Line;
+ end Disp_Object;
+
+ procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Obj.Common.Kind);
+ Disp_Depth (Obj.Common.Depth);
+ Put ("; ");
+ Disp_Name (Obj.Name);
+ Put (": ");
+ Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Attribute;
+
+ procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Comp.Common.Kind);
+ Disp_Depth (Comp.Common.Depth);
+ Put (": ");
+ Disp_Name (Comp.Name);
+ New_Line;
+ --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1);
+ end Disp_Component;
+
+ procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Inst_Addr : Address;
+ Inst_Base : Address;
+ Inst_Rti : Ghdl_Rti_Access;
+ Nindent : Natural;
+ Nctxt : Rti_Context;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Inst.Common.Kind);
+ Put (": ");
+ Disp_Name (Inst.Name);
+ New_Line;
+
+ Inst_Addr := Ctxt.Base + Inst.Loc;
+ -- Read sub instance.
+ Inst_Base := To_Addr_Acc (Inst_Addr).all;
+
+ Nindent := Indent + 1;
+
+ case Inst.Instance.Kind is
+ when Ghdl_Rtik_Component =>
+ declare
+ Comp : Ghdl_Rtin_Component_Acc;
+ begin
+ Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+ Disp_Indent (Nindent);
+ Disp_Kind (Comp.Common.Kind);
+ Put (": ");
+ Disp_Name (Comp.Name);
+ New_Line;
+ -- Disp components generics and ports.
+ -- FIXME: the data to disp are at COMP_BASE.
+ Nctxt := (Base => Inst_Addr,
+ Block => Inst.Instance);
+ Nindent := Nindent + 1;
+ Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent);
+ Nindent := Nindent + 1;
+ end;
+ when Ghdl_Rtik_Entity =>
+ null;
+ when others =>
+ null;
+ end case;
+
+ -- Read instance RTI.
+ if Inst_Base /= Null_Address then
+ Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all;
+ Nctxt := (Base => Inst_Base,
+ Block => Inst_Rti);
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti),
+ Nctxt, Nindent);
+ end if;
+ end Disp_Instance;
+
+ procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Enum.Common.Kind);
+ Put (": ");
+ Disp_Name (Enum.Name);
+ Put (" is (");
+ Disp_Name (Enum.Names (0));
+ for I in 1 .. Enum.Nbr - 1 loop
+ Put (", ");
+ Disp_Name (Enum.Names (I));
+ end loop;
+ Put (")");
+ New_Line;
+ end Disp_Type_Enum_Decl;
+
+ procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Bt : Ghdl_Rti_Access;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Disp_Depth (Def.Common.Depth);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Bt := Def.Basetype;
+ case Bt.Kind is
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Bdef : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt);
+ if Bdef.Name /= Def.Name then
+ Disp_Name (Bdef.Name);
+ Put (" range ");
+ end if;
+ -- This is the type definition.
+ Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+ end;
+ when Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_P32 =>
+ declare
+ Bdef : Ghdl_Rtin_Type_Physical_Acc;
+ Unit : Ghdl_Rti_Access;
+ begin
+ Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt);
+ if Bdef.Name /= Def.Name then
+ Disp_Name (Bdef.Name);
+ Put (" range ");
+ end if;
+ -- This is the type definition.
+ Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+ if Bdef.Name = Def.Name then
+ for I in 0 .. Bdef.Nbr - 1 loop
+ Unit := Bdef.Units (I);
+ New_Line;
+ Disp_Indent (Indent + 1);
+ Disp_Kind (Unit.Kind);
+ Put (": ");
+ Disp_Name (Get_Physical_Unit_Name (Unit));
+ Put (" = ");
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Put_I64 (stdout,
+ To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Bt.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ end case;
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ end case;
+ end loop;
+ end if;
+ end;
+ when others =>
+ Disp_Subtype_Indication
+ (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address);
+ end case;
+ New_Line;
+ end Disp_Subtype_Scalar_Decl;
+
+ procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is array (");
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address);
+ Put (" range <>");
+ end loop;
+ Put (") of ");
+ Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Type_Array_Decl;
+
+ procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Disp_Type_Array_Name
+ (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt));
+ if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then
+ Put (" of ");
+ Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address);
+ end if;
+ New_Line;
+ end Disp_Subtype_Array_Decl;
+
+ procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ case Def.Common.Kind is
+ when Ghdl_Rtik_Type_Access =>
+ Put ("access ");
+ when Ghdl_Rtik_Type_File =>
+ Put ("file ");
+ when others =>
+ Put ("?? ");
+ end case;
+ Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Type_File_Or_Access;
+
+ procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is record");
+ New_Line;
+ for I in 1 .. Def.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1));
+ Disp_Indent (Indent + 1);
+ Disp_Kind (El.Common.Kind);
+ Put (": ");
+ Disp_Name (El.Name);
+ Put (": ");
+ Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address);
+ New_Line;
+ end loop;
+ end Disp_Type_Record;
+
+ procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ pragma Unreferenced (Ctxt);
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is protected");
+ New_Line;
+ end Disp_Type_Protected;
+
+ procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ if Rti = null then
+ return;
+ end if;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Package
+ | Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate
+ | Ghdl_Rtik_For_Generate =>
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Package_Body =>
+ Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent);
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent);
+ when Ghdl_Rtik_Generic
+ | Ghdl_Rtik_Constant
+ | Ghdl_Rtik_Variable
+ | Ghdl_Rtik_Iterator
+ | Ghdl_Rtik_File =>
+ Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent);
+ when Ghdl_Rtik_Component =>
+ Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent);
+ when Ghdl_Rtik_Attribute =>
+ Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Instance =>
+ Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent);
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti),
+ Ctxt, Indent);
+ when Ghdl_Rtik_Type_Array =>
+ Disp_Type_Array_Decl
+ (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Subtype_Array =>
+ Disp_Subtype_Array_Decl
+ (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Access
+ | Ghdl_Rtik_Type_File =>
+ Disp_Type_File_Or_Access
+ (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Type_Record
+ (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Protected =>
+ Disp_Type_Protected
+ (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent);
+ when others =>
+ Disp_Indent (Indent);
+ Disp_Kind (Rti.Kind);
+ Put_Line (" ? ");
+ end case;
+ end Disp_Rti;
+
+ Disp_Rti_Flag : Boolean := False;
+
+ procedure Disp_All
+ is
+ Ctxt : Rti_Context;
+ begin
+ if not Disp_Rti_Flag then
+ return;
+ end if;
+
+ Put ("DISP_RTI.Disp_All: ");
+ Disp_Kind (Ghdl_Rti_Top.Common.Kind);
+ New_Line;
+ Ctxt := (Base => Ghdl_Rti_Top_Instance,
+ Block => Ghdl_Rti_Top.Parent);
+ Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child,
+ Ghdl_Rti_Top.Children,
+ Ctxt, 0);
+ Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0);
+
+ --Disp_Hierarchy;
+ end Disp_All;
+
+ function Disp_Rti_Option (Opt : String) return Boolean
+ is
+ begin
+ if Opt = "--dump-rti" then
+ Disp_Rti_Flag := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Rti_Option;
+
+ procedure Disp_Rti_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --dump-rti dump Run Time Information");
+ end Disp_Rti_Help;
+
+ Disp_Rti_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Rti_Option'Access,
+ Help => Disp_Rti_Help'Access,
+ Init => null,
+ Start => Disp_All'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Rti_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Rti;
diff --git a/src/translate/grt/grt-disp_rti.ads b/src/translate/grt/grt-disp_rti.ads
new file mode 100644
index 000000000..6033d2011
--- /dev/null
+++ b/src/translate/grt/grt-disp_rti.ads
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+
+package Grt.Disp_Rti is
+ -- Disp NAME. If NAME is null, then disp <anonymous>.
+ procedure Disp_Name (Name : Ghdl_C_String);
+
+ -- Disp a value.
+ procedure Disp_Value (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Obj : in out Address;
+ Is_Sig : Boolean);
+
+ procedure Register;
+end Grt.Disp_Rti;
diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb
new file mode 100644
index 000000000..424d20dcf
--- /dev/null
+++ b/src/translate/grt/grt-disp_signals.adb
@@ -0,0 +1,524 @@
+-- GHDL Run Time (GRT) - Display subprograms for signals.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Conversion;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+pragma Elaborate_All (Grt.Rtis_Utils);
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Options;
+with Grt.Processes;
+with Grt.Disp; use Grt.Disp;
+
+package body Grt.Disp_Signals is
+ procedure Foreach_Scalar_Signal
+ (Process : access procedure (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object))
+ is
+ procedure Call_Process (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object) is
+ begin
+ Process.all (Val_Addr, Val_Name, Val_Type, Param);
+ end Call_Process;
+
+ pragma Inline (Call_Process);
+
+ procedure Foreach_Scalar_Signal_Signal is new
+ Foreach_Scalar (Param_Type => Rti_Object,
+ Process => Call_Process);
+
+ function Foreach_Scalar_Signal_Object
+ (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access)
+ return Traverse_Result
+ is
+ Sig : Ghdl_Rtin_Object_Acc;
+ begin
+ case Obj.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+ Foreach_Scalar_Signal_Signal
+ (Ctxt, Sig.Obj_Type,
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True,
+ Rti_Object'(Obj, Ctxt));
+ when others =>
+ null;
+ end case;
+ return Traverse_Ok;
+ end Foreach_Scalar_Signal_Object;
+
+ function Foreach_Scalar_Signal_Traverse is
+ new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object);
+
+ Res : Traverse_Result;
+ pragma Unreferenced (Res);
+ begin
+ Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context);
+ end Foreach_Scalar_Signal;
+
+ procedure Disp_Context (Ctxt : Rti_Context)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Nctxt : Rti_Context;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Block
+ | Ghdl_Rtik_Process =>
+ Nctxt := Get_Parent_Context (Ctxt);
+ Disp_Context (Nctxt);
+ Put ('.');
+ Put (Blk.Name);
+ when Ghdl_Rtik_Entity =>
+ Put (Blk.Name);
+ when Ghdl_Rtik_Architecture =>
+ Nctxt := Get_Parent_Context (Ctxt);
+ Disp_Context (Nctxt);
+ Put ('(');
+ Put (Blk.Name);
+ Put (')');
+ when others =>
+ Internal_Error ("disp_context");
+ end case;
+ end Disp_Context;
+
+ -- This is a debugging procedure.
+ pragma Unreferenced (Disp_Context);
+
+ -- Option --trace-signals.
+
+ -- Disp transaction TRANS from signal SIG.
+ procedure Disp_Transaction (Trans : Transaction_Acc;
+ Sig_Type : Ghdl_Rti_Access;
+ Mode : Mode_Type)
+ is
+ T : Transaction_Acc;
+ begin
+ T := Trans;
+ loop
+ case T.Kind is
+ when Trans_Value =>
+ if Sig_Type /= null then
+ Disp_Value (stdout, T.Val, Sig_Type);
+ else
+ Disp_Value (T.Val, Mode);
+ end if;
+ when Trans_Direct =>
+ if Sig_Type /= null then
+ Disp_Value (stdout, T.Val_Ptr.all, Sig_Type);
+ else
+ Disp_Value (T.Val_Ptr.all, Mode);
+ end if;
+ when Trans_Null =>
+ Put ("NULL");
+ when Trans_Error =>
+ Put ("ERROR");
+ end case;
+ if T.Kind = Trans_Direct then
+ -- The Time field is not updated for direct transaction.
+ Put ("[DIRECT]");
+ else
+ Put ("@");
+ Put_Time (stdout, T.Time);
+ end if;
+ T := T.Next;
+ exit when T = null;
+ Put (", ");
+ end loop;
+ end Disp_Transaction;
+
+ procedure Disp_Simple_Signal
+ (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean)
+ is
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Resolved_Signal_Acc, Target => Address);
+ begin
+ Put (' ');
+ Put (stdout, Sig.all'Address);
+ Put (' ');
+ Disp_Mode (Sig.Mode);
+ Put (' ');
+ if Sig.Active then
+ Put ('A');
+ else
+ Put ('-');
+ end if;
+ if Sig.Event then
+ Put ('E');
+ else
+ Put ('-');
+ end if;
+ if Sig.Has_Active then
+ Put ('a');
+ else
+ Put ('-');
+ end if;
+ if Sig.S.Effective /= null then
+ Put ('e');
+ else
+ Put ('-');
+ end if;
+ if Boolean'(True) then
+ Put (" last_event=");
+ Put_Time (stdout, Sig.Last_Event);
+ Put (" last_active=");
+ Put_Time (stdout, Sig.Last_Active);
+ end if;
+ Put (" val=");
+ if Sig_Type /= null then
+ Disp_Value (stdout, Sig.Value, Sig_Type);
+ else
+ Disp_Value (Sig.Value, Sig.Mode);
+ end if;
+ Put ("; drv=");
+ if Sig_Type /= null then
+ Disp_Value (stdout, Sig.Driving_Value, Sig_Type);
+ else
+ Disp_Value (Sig.Driving_Value, Sig.Mode);
+ end if;
+ if Sources then
+ if Sig.Nbr_Ports > 0 then
+ Put (';');
+ Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+ Put (" ports");
+ end if;
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Resolv /= null then
+ Put (stdout, " res func ");
+ Put (stdout, To_Address(Sig.S.Resolv));
+ end if;
+ if Sig.S.Nbr_Drivers = 0 then
+ Put ("; no driver");
+ elsif Sig.S.Nbr_Drivers = 1 then
+ Put ("; trans=");
+ Disp_Transaction
+ (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode);
+ else
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ New_Line;
+ Put (" ");
+ Disp_Transaction
+ (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode);
+ end loop;
+ end if;
+ end if;
+ end if;
+ New_Line;
+ end Disp_Simple_Signal;
+
+ procedure Disp_Signal_Name (Stream : FILEs;
+ Ctxt : Rti_Context;
+ Sig : Ghdl_Rtin_Object_Acc) is
+ begin
+ case Sig.Common.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, Sig.Name);
+ when Ghdl_Rtik_Attribute_Quiet =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'quiet");
+ when Ghdl_Rtik_Attribute_Stable =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'stable");
+ when Ghdl_Rtik_Attribute_Transaction =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'transaction");
+ when others =>
+ null;
+ end case;
+ end Disp_Signal_Name;
+
+ procedure Disp_Scalar_Signal (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ begin
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
+ Val_Type, Options.Disp_Sources);
+ end Disp_Scalar_Signal;
+
+
+ procedure Disp_All_Signals is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Signal'access);
+ end Disp_All_Signals;
+
+ -- Option disp-sensitivity
+
+ procedure Disp_Scalar_Sensitivity (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ pragma Unreferenced (Val_Type);
+ Sig : Ghdl_Signal_Ptr;
+
+ Action : Action_List_Acc;
+ begin
+ Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ if Sig.Flags.Seen then
+ return;
+ else
+ Sig.Flags.Seen := True;
+ end if;
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ New_Line (stdout);
+
+ Action := Sig.Event_List;
+ while Action /= null loop
+ Put (stdout, " wakeup ");
+ Grt.Processes.Disp_Process_Name (stdout, Action.Proc);
+ New_Line (stdout);
+ Action := Action.Next;
+ end loop;
+
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ Put (stdout, " driven ");
+ Grt.Processes.Disp_Process_Name
+ (stdout, Sig.S.Drivers (I - 1).Proc);
+ New_Line (stdout);
+ end loop;
+ end if;
+ end Disp_Scalar_Sensitivity;
+
+ procedure Disp_All_Sensitivity is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access);
+ end Disp_All_Sensitivity;
+
+
+ -- Option disp-signals-map
+
+ procedure Disp_Signals_Map_Scalar (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ pragma Unreferenced (Val_Type);
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Signal_Ptr);
+
+ S : Ghdl_Signal_Ptr;
+ begin
+ Disp_Signal_Name (stdout,
+ Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ Put (": ");
+ S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ Put (stdout, S.all'Address);
+ Put (" net: ");
+ Put_I32 (stdout, Ghdl_I32 (S.Net));
+ if S.Has_Active then
+ Put (" +A");
+ end if;
+ New_Line;
+ end Disp_Signals_Map_Scalar;
+
+ procedure Disp_Signals_Map is
+ begin
+ Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access);
+ end Disp_Signals_Map;
+
+ -- Option --disp-signals-table
+ procedure Disp_Mode_Signal (Mode : Mode_Signal_Type)
+ is
+ begin
+ case Mode is
+ when Mode_Signal =>
+ Put ("signal");
+ when Mode_Linkage =>
+ Put ("linkage");
+ when Mode_Buffer =>
+ Put ("buffer");
+ when Mode_Out =>
+ Put ("out");
+ when Mode_Inout =>
+ Put ("inout");
+ when Mode_In =>
+ Put ("in");
+ when Mode_Stable =>
+ Put ("stable");
+ when Mode_Quiet =>
+ Put ("quiet");
+ when Mode_Transaction =>
+ Put ("transaction");
+ when Mode_Delayed =>
+ Put ("delayed");
+ when Mode_Guard =>
+ Put ("guard");
+ when Mode_Conv_In =>
+ Put ("conv_in");
+ when Mode_Conv_Out =>
+ Put ("conv_out");
+ when Mode_End =>
+ Put ("end");
+ end case;
+ end Disp_Mode_Signal;
+
+ procedure Disp_Signals_Table
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+ Put_Sig_Index (I);
+ Put (": ");
+ Put (stdout, Sig.all'Address);
+ if Sig.Has_Active then
+ Put (" +A");
+ end if;
+ Put (" net: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.Net));
+ Put (" smode: ");
+ Disp_Mode_Signal (Sig.S.Mode_Sig);
+ Put (" #prt: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ Put (" #drv: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers));
+ if Sig.S.Effective /= null then
+ Put (" eff: ");
+ Put (stdout, Sig.S.Effective.all'Address);
+ end if;
+ if Sig.S.Resolv /= null then
+ Put (" resolved");
+ end if;
+ end if;
+ if Boolean'(False) then
+ Put (" link: ");
+ Put (stdout, Sig.Link.all'Address);
+ end if;
+ New_Line;
+ if Sig.Nbr_Ports /= 0 then
+ for J in 1 .. Sig.Nbr_Ports loop
+ Put (" ");
+ Put (stdout, Sig.Ports (J - 1).all'Address);
+ end loop;
+ New_Line;
+ end if;
+ end loop;
+ Grt.Stdio.fflush (stdout);
+ end Disp_Signals_Table;
+
+ procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Disp_Simple_Signal (Sig, null, True);
+ end Disp_A_Signal;
+
+ procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr)
+ is
+ Found : Boolean := False;
+ Cur_Ctxt : Rti_Context;
+ Cur_Sig : Ghdl_Rtin_Object_Acc;
+
+ procedure Process_Scalar (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Boolean)
+ is
+ pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param);
+ Sig1 : Ghdl_Signal_Ptr;
+ begin
+ -- Read the signal.
+ Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ if Sig1 = Sig and not Found then
+ Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig);
+ Put (Stream, Val_Name);
+ Found := True;
+ end if;
+ end Process_Scalar;
+
+ procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar
+ (Param_Type => Boolean, Process => Process_Scalar);
+
+ function Process_Block (Ctxt : Rti_Context;
+ Obj : Ghdl_Rti_Access)
+ return Traverse_Result
+ is
+ begin
+ case Obj.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Cur_Ctxt := Ctxt;
+ Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+ Foreach_Scalar
+ (Ctxt, Cur_Sig.Obj_Type,
+ Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt),
+ True, True);
+ if Found then
+ return Traverse_Stop;
+ end if;
+ when others =>
+ null;
+ end case;
+ return Traverse_Ok;
+ end Process_Block;
+
+ function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks
+ (Process_Block);
+
+ Res_Status : Traverse_Result;
+ pragma Unreferenced (Res_Status);
+ begin
+ Res_Status := Foreach_Block (Get_Top_Context);
+ if not Found then
+ Put (Stream, "(unknown signal)");
+ end if;
+ end Put_Signal_Name;
+
+end Grt.Disp_Signals;
diff --git a/src/translate/grt/grt-disp_signals.ads b/src/translate/grt/grt-disp_signals.ads
new file mode 100644
index 000000000..73bd60d06
--- /dev/null
+++ b/src/translate/grt/grt-disp_signals.ads
@@ -0,0 +1,48 @@
+-- GHDL Run Time (GRT) - Display subprograms for signals.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Signals; use Grt.Signals;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Disp_Signals is
+ procedure Disp_All_Signals;
+
+ procedure Disp_Signals_Map;
+
+ procedure Disp_Signals_Table;
+
+ procedure Disp_All_Sensitivity;
+
+ procedure Disp_Mode_Signal (Mode : Mode_Signal_Type);
+
+ -- Disp informations on signal SIG.
+ -- To be used inside the debugger.
+ procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr);
+
+ -- Put the full name of signal SIG.
+ -- This operation is really expensive, since the whole hierarchy is
+ -- traversed.
+ procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr);
+end Grt.Disp_Signals;
diff --git a/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb
new file mode 100644
index 000000000..7d5811960
--- /dev/null
+++ b/src/translate/grt/grt-disp_tree.adb
@@ -0,0 +1,461 @@
+-- GHDL Run Time (GRT) - Tree displayer.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Disp_Rti; use Grt.Disp_Rti;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Types; use Grt.Types;
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Disp_Tree is
+ -- Set by --disp-tree, to display the design hierarchy.
+ type Disp_Tree_Kind is
+ (
+ Disp_Tree_None, -- Do not disp tree.
+ Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components.
+ Disp_Tree_Proc, -- As above plus processes
+ Disp_Tree_Port -- As above plus ports and signals.
+ );
+ Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None;
+
+
+ -- Get next interesting child.
+ procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
+ Index : in out Ghdl_Index_Type;
+ Child : out Ghdl_Rti_Access)
+ is
+ begin
+ -- Exit if no more children.
+ while Index < Parent.Nbr_Child loop
+ Child := Parent.Children (Index);
+ Index := Index + 1;
+ case Child.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate
+ | Ghdl_Rtik_Instance =>
+ return;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard =>
+ if Disp_Tree_Flag >= Disp_Tree_Port then
+ return;
+ end if;
+ when Ghdl_Rtik_Process =>
+ if Disp_Tree_Flag >= Disp_Tree_Proc then
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ Child := null;
+ end Get_Tree_Child;
+
+ procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Process
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate =>
+ declare
+ Blk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Rti);
+ begin
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_Package_Body
+ | Ghdl_Rtik_Package =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Lib : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Rti);
+ if Rti.Kind = Ghdl_Rtik_Package_Body then
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ end if;
+ Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+ Disp_Name (Lib.Name);
+ Put ('.');
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Blk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Rti);
+ Iter : Ghdl_Rtin_Object_Acc;
+ Addr : Address;
+ begin
+ Disp_Name (Blk.Name);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+ Put ('(');
+ Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+ Put (')');
+ end;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Iterator =>
+ Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
+ when Ghdl_Rtik_Instance =>
+ Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
+ when others =>
+ null;
+ end case;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Package_Body =>
+ Put (" [package]");
+ when Ghdl_Rtik_Entity =>
+ Put (" [entity]");
+ when Ghdl_Rtik_Architecture =>
+ Put (" [arch]");
+ when Ghdl_Rtik_Process =>
+ Put (" [process]");
+ when Ghdl_Rtik_Block =>
+ Put (" [block]");
+ when Ghdl_Rtik_For_Generate =>
+ Put (" [for-generate]");
+ when Ghdl_Rtik_If_Generate =>
+ Put (" [if-generate ");
+ if Ctxt.Base = Null_Address then
+ Put ("false]");
+ else
+ Put ("true]");
+ end if;
+ when Ghdl_Rtik_Signal =>
+ Put (" [signal]");
+ when Ghdl_Rtik_Port =>
+ Put (" [port ");
+ case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
+ when Ghdl_Rti_Signal_Mode_In =>
+ Put ("in");
+ when Ghdl_Rti_Signal_Mode_Out =>
+ Put ("out");
+ when Ghdl_Rti_Signal_Mode_Inout =>
+ Put ("inout");
+ when Ghdl_Rti_Signal_Mode_Buffer =>
+ Put ("buffer");
+ when Ghdl_Rti_Signal_Mode_Linkage =>
+ Put ("linkage");
+ when others =>
+ Put ("?");
+ end case;
+ Put ("]");
+ when Ghdl_Rtik_Guard =>
+ Put (" [guard]");
+ when Ghdl_Rtik_Iterator =>
+ Put (" [iterator]");
+ when Ghdl_Rtik_Instance =>
+ Put (" [instance]");
+ when others =>
+ null;
+ end case;
+ end Disp_Tree_Child;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
+
+ procedure Disp_Tree_Block1
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ Child : Ghdl_Rti_Access;
+ Child2 : Ghdl_Rti_Access;
+ Index : Ghdl_Index_Type;
+
+ procedure Disp_Header (Nctxt : Rti_Context;
+ Force_Cont : Boolean := False)
+ is
+ begin
+ Put (Pfx);
+
+ if Blk.Common.Kind /= Ghdl_Rtik_Entity
+ and Child2 = null
+ and Force_Cont = False
+ then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+
+ Disp_Tree_Child (Child, Nctxt);
+ New_Line;
+ end Disp_Header;
+
+ procedure Disp_Sub_Block
+ (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
+ is
+ Npfx : String (1 .. Pfx'Length + 2);
+ begin
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 2) := ' ';
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
+ end Disp_Sub_Block;
+
+ begin
+ Index := 0;
+ Get_Tree_Child (Blk, Index, Child);
+ while Child /= null loop
+ Get_Tree_Child (Blk, Index, Child2);
+
+ case Child.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => Ctxt.Base + Nblk.Loc,
+ Block => Child);
+ Disp_Header (Nctxt, False);
+ Disp_Sub_Block (Nblk, Nctxt);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ Length : Ghdl_Index_Type;
+ Old_Child2 : Ghdl_Rti_Access;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Length := Get_For_Generate_Length (Nblk, Ctxt);
+ Disp_Header (Nctxt, Length > 1);
+ Old_Child2 := Child2;
+ if Length > 1 then
+ Child2 := Child;
+ end if;
+ for I in 1 .. Length loop
+ Disp_Sub_Block (Nblk, Nctxt);
+ if I /= Length then
+ Nctxt.Base := Nctxt.Base + Nblk.Size;
+ if I = Length - 1 then
+ Child2 := Old_Child2;
+ end if;
+ Disp_Header (Nctxt);
+ end if;
+ end loop;
+ Child2 := Old_Child2;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Disp_Header (Nctxt);
+ if Nctxt.Base /= Null_Address then
+ Disp_Sub_Block (Nblk, Nctxt);
+ end if;
+ end;
+ when Ghdl_Rtik_Instance =>
+ declare
+ Inst : Ghdl_Rtin_Instance_Acc;
+ Sub_Ctxt : Rti_Context;
+ Sub_Blk : Ghdl_Rtin_Block_Acc;
+ Npfx : String (1 .. Pfx'Length + 4);
+ Comp : Ghdl_Rtin_Component_Acc;
+ Ch : Ghdl_Rti_Access;
+ begin
+ Disp_Header (Ctxt);
+ Inst := To_Ghdl_Rtin_Instance_Acc (Child);
+ Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
+ Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
+ if Inst.Instance.Kind = Ghdl_Rtik_Component
+ and then Disp_Tree_Flag >= Disp_Tree_Port
+ then
+ -- Disp generics and ports of the component.
+ Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+ for I in 1 .. Comp.Nbr_Child loop
+ Ch := Comp.Children (I - 1);
+ if Ch.Kind = Ghdl_Rtik_Port then
+ -- Disp only port (and not generics).
+ Put (Pfx);
+ if Child2 = null then
+ Put (" ");
+ else
+ Put ("| ");
+ end if;
+ if I = Comp.Nbr_Child and then Sub_Blk = null then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+ Disp_Tree_Child (Ch, Sub_Ctxt);
+ New_Line;
+ end if;
+ end loop;
+ end if;
+ if Sub_Blk /= null then
+ Npfx (1 .. Pfx'Length) := Pfx;
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Npfx (Pfx'Length + 2) := ' ';
+ Npfx (Pfx'Length + 3) := '`';
+ Npfx (Pfx'Length + 4) := '-';
+ Put (Npfx);
+ Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
+ New_Line;
+ Npfx (Pfx'Length + 3) := ' ';
+ Npfx (Pfx'Length + 4) := ' ';
+ Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
+ end if;
+ end;
+ when others =>
+ Disp_Header (Ctxt);
+ end case;
+
+ Child := Child2;
+ end loop;
+ end Disp_Tree_Block1;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ begin
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ declare
+ Npfx : String (1 .. Pfx'Length + 2);
+ Nctxt : Rti_Context;
+ begin
+ -- The entity.
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
+ -- Then the architecture.
+ Put (Pfx);
+ Put ("`-");
+ Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
+ New_Line;
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 1) := ' ';
+ Npfx (Pfx'Length + 2) := ' ';
+ Disp_Tree_Block1 (Blk, Ctxt, Npfx);
+ end;
+ when Ghdl_Rtik_Package_Body =>
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
+ when others =>
+ Disp_Tree_Block1 (Blk, Ctxt, Pfx);
+ end case;
+ end Disp_Tree_Block;
+
+ procedure Disp_Hierarchy
+ is
+ Ctxt : Rti_Context;
+ Parent : Ghdl_Rtin_Block_Acc;
+ Child : Ghdl_Rti_Access;
+ begin
+ if Disp_Tree_Flag = Disp_Tree_None then
+ return;
+ end if;
+
+ Ctxt := Get_Top_Context;
+ Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+
+ Disp_Tree_Child (Parent.Parent, Ctxt);
+ New_Line;
+ Disp_Tree_Block (Parent, Ctxt, "");
+
+ for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop
+ Child := Ghdl_Rti_Top.Children (I - 1);
+ Ctxt := (Base => Null_Address,
+ Block => Child);
+ Disp_Tree_Child (Child, Ctxt);
+ New_Line;
+ Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
+ end loop;
+ end Disp_Hierarchy;
+
+ function Disp_Tree_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then
+ if Opt'Length = 11 then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=port" then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=proc" then
+ Disp_Tree_Flag := Disp_Tree_Proc;
+ elsif Opt (12 .. Opt'Last) = "=inst" then
+ Disp_Tree_Flag := Disp_Tree_Inst;
+ elsif Opt (12 .. Opt'Last) = "=none" then
+ Disp_Tree_Flag := Disp_Tree_None;
+ else
+ Error ("bad argument for --disp-tree option, try --help");
+ end if;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Tree_Option;
+
+ procedure Disp_Tree_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --disp-tree[=KIND] disp the design hierarchy after elaboration");
+ P (" KIND is inst, proc, port (default)");
+ end Disp_Tree_Help;
+
+ Disp_Tree_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Tree_Option'Access,
+ Help => Disp_Tree_Help'Access,
+ Init => null,
+ Start => Disp_Hierarchy'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Tree_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Tree;
diff --git a/src/translate/grt/grt-disp_tree.ads b/src/translate/grt/grt-disp_tree.ads
new file mode 100644
index 000000000..e3bc983a7
--- /dev/null
+++ b/src/translate/grt/grt-disp_tree.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Disp_Tree is
+ procedure Register;
+end Grt.Disp_Tree;
diff --git a/src/translate/grt/grt-errors.adb b/src/translate/grt/grt-errors.adb
new file mode 100644
index 000000000..eddea38c1
--- /dev/null
+++ b/src/translate/grt/grt-errors.adb
@@ -0,0 +1,253 @@
+-- GHDL Run Time (GRT) - Error handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Options; use Grt.Options;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Errors is
+ -- Called in case of premature exit.
+ -- CODE is 0 for success, 1 for failure.
+ procedure Ghdl_Exit (Code : Integer);
+ pragma No_Return (Ghdl_Exit);
+
+ procedure Ghdl_Exit (Code : Integer)
+ is
+ procedure C_Exit (Status : Integer);
+ pragma Import (C, C_Exit, "exit");
+ pragma No_Return (C_Exit);
+ begin
+ C_Exit (Code);
+ end Ghdl_Exit;
+
+ procedure Maybe_Return_Via_Longjump (Val : Integer);
+ pragma Import (C, Maybe_Return_Via_Longjump,
+ "__ghdl_maybe_return_via_longjump");
+
+ procedure Exit_Simulation is
+ begin
+ Maybe_Return_Via_Longjump (-2);
+ Internal_Error ("exit_simulation");
+ end Exit_Simulation;
+
+ procedure Fatal_Error is
+ begin
+ if Error_Hook /= null then
+ -- Call the hook, but avoid infinite loop by reseting it.
+ declare
+ Current_Hook : constant Proc_Hook_Type := Error_Hook;
+ begin
+ Error_Hook := null;
+ Current_Hook.all;
+ end;
+ end if;
+ Maybe_Return_Via_Longjump (-1);
+ if Expect_Failure then
+ Ghdl_Exit (0);
+ else
+ Ghdl_Exit (1);
+ end if;
+ end Fatal_Error;
+
+ procedure Put_Err (Str : String) is
+ begin
+ Put (stderr, Str);
+ end Put_Err;
+
+ procedure Put_Err (Str : Ghdl_C_String) is
+ begin
+ Put (stderr, Str);
+ end Put_Err;
+
+ procedure Put_Err (N : Integer) is
+ begin
+ Put_I32 (stderr, Ghdl_I32 (N));
+ end Put_Err;
+
+ procedure Newline_Err is
+ begin
+ New_Line (stderr);
+ end Newline_Err;
+
+-- procedure Put_Err (Str : Ghdl_Str_Len_Type)
+-- is
+-- S : String (1 .. 3);
+-- begin
+-- if Str.Str = null then
+-- S (1) := ''';
+-- S (2) := Character'Val (Str.Len);
+-- S (3) := ''';
+-- Put_Err (S);
+-- else
+-- Put_Err (Str.Str (1 .. Str.Len));
+-- end if;
+-- end Put_Err;
+
+ procedure Report_H (Str : String := "") is
+ begin
+ Put_Err (Str);
+ end Report_H;
+
+ procedure Report_C (Str : String) is
+ begin
+ Put_Err (Str);
+ end Report_C;
+
+ procedure Report_C (Str : Ghdl_C_String)
+ is
+ Len : constant Natural := strlen (Str);
+ begin
+ Put_Err (Str (1 .. Len));
+ end Report_C;
+
+ procedure Report_C (N : Integer)
+ renames Put_Err;
+
+ procedure Report_Now_C is
+ begin
+ Put_Time (stderr, Grt.Types.Current_Time);
+ end Report_Now_C;
+
+ procedure Report_E (Str : String) is
+ begin
+ Put_Err (Str);
+ Newline_Err;
+ end Report_E;
+
+ procedure Report_E (Str : Std_String_Ptr)
+ is
+ subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length));
+ begin
+ if Ada_Str'Length > 0 then
+ Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)));
+ end if;
+ Newline_Err;
+ end Report_E;
+
+ procedure Error_H is
+ begin
+ Put_Err (Progname);
+ Put_Err (":error: ");
+ end Error_H;
+
+ Cont : Boolean := False;
+
+ procedure Error_C (Str : String) is
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (Str);
+ end Error_C;
+
+ procedure Error_C (Str : Ghdl_C_String)
+ is
+ Len : constant Natural := strlen (Str);
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (Str (1 .. Len));
+ end Error_C;
+
+ procedure Error_C (N : Integer) is
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (N);
+ end Error_C;
+
+-- procedure Error_C (Inst : Ghdl_Instance_Name_Acc)
+-- is
+-- begin
+-- if not Cont then
+-- Error_H;
+-- Cont := True;
+-- end if;
+-- if Inst.Parent /= null then
+-- Error_C (Inst.Parent);
+-- Put_Err (".");
+-- end if;
+-- case Inst.Kind is
+-- when Ghdl_Name_Architecture =>
+-- Put_Err ("(");
+-- Put_Err (Inst.Name.all);
+-- Put_Err (")");
+-- when others =>
+-- if Inst.Name /= null then
+-- Put_Err (Inst.Name.all);
+-- end if;
+-- end case;
+-- end Error_C;
+
+ procedure Error_E (Str : String := "") is
+ begin
+ Put_Err (Str);
+ Newline_Err;
+ Cont := False;
+ Fatal_Error;
+ end Error_E;
+
+ procedure Error_C_Std (Str : Std_String_Uncons)
+ is
+ subtype Str_Subtype is String (1 .. Str'Length);
+ begin
+ Error_C (Str_Subtype (Str));
+ end Error_C_Std;
+
+ procedure Error (Str : String) is
+ begin
+ Error_H;
+ Put_Err (Str);
+ Newline_Err;
+ Fatal_Error;
+ end Error;
+
+ procedure Info (Str : String) is
+ begin
+ Put_Err (Progname);
+ Put_Err (":info: ");
+ Put_Err (Str);
+ Newline_Err;
+ end Info;
+
+ procedure Internal_Error (Msg : String) is
+ begin
+ Put_Err (Progname);
+ Put_Err (":internal error: ");
+ Put_Err (Msg);
+ Newline_Err;
+ Fatal_Error;
+ end Internal_Error;
+
+ procedure Grt_Overflow_Error is
+ begin
+ Error ("overflow detected");
+ end Grt_Overflow_Error;
+end Grt.Errors;
diff --git a/src/translate/grt/grt-errors.ads b/src/translate/grt/grt-errors.ads
new file mode 100644
index 000000000..c797a71bd
--- /dev/null
+++ b/src/translate/grt/grt-errors.ads
@@ -0,0 +1,84 @@
+-- GHDL Run Time (GRT) - Error handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Hooks;
+
+package Grt.Errors is
+ pragma Preelaborate (Grt.Errors);
+
+ -- Multi-call error procedure.
+ -- Start and continue with Error_C, finish by an Error_E.
+ procedure Error_C (Str : String);
+ procedure Error_C (N : Integer);
+ procedure Error_C (Str : Ghdl_C_String);
+ procedure Error_C_Std (Str : Std_String_Uncons);
+ --procedure Error_C (Inst : Ghdl_Instance_Name_Acc);
+ procedure Error_E (Str : String := "");
+ -- procedure Error_E_Std (Str : Std_String_Uncons);
+ pragma No_Return (Error_E);
+
+ -- Multi-call report procedure. Do not exit at end.
+ procedure Report_H (Str : String := "");
+ procedure Report_C (Str : Ghdl_C_String);
+ procedure Report_C (Str : String);
+ procedure Report_C (N : Integer);
+ procedure Report_Now_C;
+ procedure Report_E (Str : String);
+ procedure Report_E (Str : Std_String_Ptr);
+
+ -- Complete error message.
+ procedure Error (Str : String);
+
+ -- Internal error. The message must contain the subprogram name which
+ -- has called this procedure.
+ procedure Internal_Error (Msg : String);
+ pragma No_Return (Internal_Error);
+
+ -- Display a message which is not an error.
+ procedure Info (Str : String);
+
+ -- Display an error message for an overflow.
+ procedure Grt_Overflow_Error;
+
+ -- Called at end of error message. Central point for failures.
+ procedure Fatal_Error;
+ pragma No_Return (Fatal_Error);
+ pragma Export (C, Fatal_Error, "__ghdl_fatal");
+
+ Exit_Status : Integer := 0;
+ procedure Exit_Simulation;
+
+ -- Hook called in case of error.
+ Error_Hook : Grt.Hooks.Proc_Hook_Type := null;
+
+ -- If true, an error is expected and the exit status is inverted.
+ Expect_Failure : Boolean := False;
+
+private
+ pragma Export (C, Grt_Overflow_Error, "grt_overflow_error");
+
+ pragma No_Return (Error);
+end Grt.Errors;
+
diff --git a/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb
new file mode 100644
index 000000000..30d51cf43
--- /dev/null
+++ b/src/translate/grt/grt-files.adb
@@ -0,0 +1,452 @@
+-- GHDL Run Time (GRT) - VHDL files subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Table;
+with System; use System;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Files is
+ subtype C_Files is Grt.Stdio.FILEs;
+
+ Auto_Flush : constant Boolean := False;
+
+ type File_Entry_Type is record
+ Stream : C_Files;
+ Signature : Ghdl_C_String;
+ Is_Text : Boolean;
+ Is_Alive : Boolean;
+ end record;
+
+ package Files_Table is new Grt.Table
+ (Table_Component_Type => File_Entry_Type,
+ Table_Index_Type => Ghdl_File_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => 2);
+
+ function Get_File (Index : Ghdl_File_Index) return C_Files
+ is
+ begin
+ if Index not in Files_Table.First .. Files_Table.Last then
+ Internal_Error ("get_file: bad file index");
+ end if;
+ return Files_Table.Table (Index).Stream;
+ end Get_File;
+
+ procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean)
+ is
+ begin
+ if Files_Table.Table (Index).Is_Text /= Is_Text then
+ Internal_Error ("check_file_mode: bad file mode");
+ end if;
+ end Check_File_Mode;
+
+ function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String)
+ return Ghdl_File_Index is
+ begin
+ Files_Table.Append ((Stream => NULL_Stream,
+ Signature => Sig,
+ Is_Text => Is_Text,
+ Is_Alive => True));
+ return Files_Table.Last;
+ end Create_File;
+
+ procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is
+ begin
+ if Get_File (Index) /= NULL_Stream then
+ Internal_Error ("destroy_file");
+ end if;
+ Check_File_Mode (Index, Is_Text);
+ Files_Table.Table (Index).Is_Alive := False;
+ if Index = Files_Table.Last then
+ while Files_Table.Last >= Files_Table.First
+ and then Files_Table.Table (Files_Table.Last).Is_Alive = False
+ loop
+ Files_Table.Decrement_Last;
+ end loop;
+ end if;
+ end Destroy_File;
+
+ procedure File_Error (File : Ghdl_File_Index)
+ is
+ pragma Unreferenced (File);
+ begin
+ Internal_Error ("file: IO error");
+ end File_Error;
+
+ function Ghdl_Text_File_Elaborate return Ghdl_File_Index is
+ begin
+ return Create_File (True, null);
+ end Ghdl_Text_File_Elaborate;
+
+ function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index
+ is
+ begin
+ return Create_File (False, Sig);
+ end Ghdl_File_Elaborate;
+
+ procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is
+ begin
+ Destroy_File (True, File);
+ end Ghdl_Text_File_Finalize;
+
+ procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is
+ begin
+ Destroy_File (False, File);
+ end Ghdl_File_Finalize;
+
+ function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean
+ is
+ Stream : C_Files;
+ C : int;
+ begin
+ Stream := Get_File (File);
+ if feof (Stream) /= 0 then
+ return True;
+ end if;
+ C := fgetc (Stream);
+ if C < 0 then
+ return True;
+ end if;
+ if ungetc (C, Stream) /= C then
+ Error ("internal error: ungetc");
+ end if;
+ return False;
+ end Ghdl_File_Endfile;
+
+ Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl;
+
+ function File_Open (File : Ghdl_File_Index;
+ Mode : Ghdl_I32;
+ Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1);
+ Str_Mode : String (1 .. 3);
+ F : C_Files;
+ Sig : Ghdl_C_String;
+ Sig_Len : Natural;
+ begin
+ F := Get_File (File);
+
+ if F /= NULL_Stream then
+ -- File was already open.
+ return Status_Error;
+ end if;
+
+ -- Copy file name and convert it to a C string (NUL terminated).
+ for I in 1 .. Str.Bounds.Dim_1.Length loop
+ Name (Natural (I)) := Str.Base (I - 1);
+ end loop;
+ Name (Name'Last) := NUL;
+
+ if Name = "STD_INPUT" & NUL then
+ if Mode /= Read_Mode then
+ return Mode_Error;
+ end if;
+ F := stdin;
+ elsif Name = "STD_OUTPUT" & NUL then
+ if Mode /= Write_Mode then
+ return Mode_Error;
+ end if;
+ F := stdout;
+ else
+ case Mode is
+ when Read_Mode =>
+ Str_Mode (1) := 'r';
+ when Write_Mode =>
+ Str_Mode (1) := 'w';
+ when Append_Mode =>
+ Str_Mode (1) := 'a';
+ when others =>
+ -- Bad mode, cannot happen.
+ Internal_Error ("file_open: bad open mode");
+ end case;
+ if Files_Table.Table (File).Is_Text then
+ Str_Mode (2) := NUL;
+ else
+ Str_Mode (2) := 'b';
+ Str_Mode (3) := NUL;
+ end if;
+ F := fopen (Name'Address, Str_Mode'Address);
+ if F = NULL_Stream then
+ return Name_Error;
+ end if;
+ end if;
+ Sig := Files_Table.Table (File).Signature;
+ if Sig /= null then
+ Sig_Len := strlen (Sig);
+ case Mode is
+ when Write_Mode =>
+ if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F)
+ /= Sig_Header'Length
+ then
+ File_Error (File);
+ end if;
+ if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F)
+ /= size_t (Sig_Len)
+ then
+ File_Error (File);
+ end if;
+ when Read_Mode =>
+ declare
+ Hdr : String (1 .. Sig_Header'Length);
+ Sig_Buf : String (1 .. Sig_Len);
+ begin
+ if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then
+ File_Error (File);
+ end if;
+ if Hdr /= Sig_Header then
+ File_Error (File);
+ end if;
+ if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F)
+ /= Sig_Buf'Length
+ then
+ File_Error (File);
+ end if;
+ if Sig_Buf /= Sig (1 .. Sig_Len) then
+ File_Error (File);
+ end if;
+ end;
+ when Append_Mode =>
+ null;
+ when others =>
+ null;
+ end case;
+ end if;
+ Files_Table.Table (File).Stream := F;
+ return Open_Ok;
+ end File_Open;
+
+ procedure Ghdl_Text_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ is
+ Res : Ghdl_I32;
+ begin
+ Check_File_Mode (File, True);
+
+ Res := File_Open (File, Mode, Str);
+
+ if Res /= Open_Ok then
+ Error_C ("open: cannot open text file ");
+ Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1));
+ Error_E;
+ end if;
+ end Ghdl_Text_File_Open;
+
+ procedure Ghdl_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ is
+ Res : Ghdl_I32;
+ begin
+ Check_File_Mode (File, False);
+
+ Res := File_Open (File, Mode, Str);
+
+ if Res /= Open_Ok then
+ Error_C ("open: cannot open file ");
+ Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1));
+ Error_E;
+ end if;
+ end Ghdl_File_Open;
+
+ function Ghdl_Text_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ begin
+ Check_File_Mode (File, True);
+ return File_Open (File, Mode, Str);
+ end Ghdl_Text_File_Open_Status;
+
+ function Ghdl_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ begin
+ Check_File_Mode (File, False);
+ return File_Open (File, Mode, Str);
+ end Ghdl_File_Open_Status;
+
+ procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr)
+ is
+ Res : C_Files;
+ R : size_t;
+ R1 : int;
+ pragma Unreferenced (R, R1);
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, True);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fwrite (Str.Base (0)'Address,
+ size_t (Str.Bounds.Dim_1.Length), 1, Res);
+ -- FIXME: check r
+ -- Write '\n'.
+ R1 := fputc (Character'Pos (Nl), Res);
+ if Auto_Flush then
+ fflush (Res);
+ end if;
+ end Ghdl_Text_Write;
+
+ procedure Ghdl_Write_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type)
+ is
+ Res : C_Files;
+ R : size_t;
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, False);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fwrite (System.Address (Ptr), size_t (Length), 1, Res);
+ if R /= 1 then
+ Error ("write_scalar failed");
+ end if;
+ if Auto_Flush then
+ fflush (Res);
+ end if;
+ end Ghdl_Write_Scalar;
+
+ procedure Ghdl_Read_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type)
+ is
+ Res : C_Files;
+ R : size_t;
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, False);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fread (System.Address (Ptr), size_t (Length), 1, Res);
+ if R /= 1 then
+ Error ("read_scalar failed");
+ end if;
+ end Ghdl_Read_Scalar;
+
+ function Ghdl_Text_Read_Length (File : Ghdl_File_Index;
+ Str : Std_String_Ptr)
+ return Std_Integer
+ is
+ Stream : C_Files;
+ C : int;
+ Len : Ghdl_Index_Type;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, True);
+ Len := Str.Bounds.Dim_1.Length;
+ -- Read until EOL (or EOF).
+ -- Store as much as possible.
+ for I in Ghdl_Index_Type loop
+ C := fgetc (Stream);
+ if C < 0 then
+ Error ("read: end of file reached");
+ return Std_Integer (I);
+ end if;
+ if I < Len then
+ Str.Base (I) := Character'Val (C);
+ end if;
+ -- End of line is '\n' or LF or character # 10.
+ if C = 10 then
+ return Std_Integer (I + 1);
+ end if;
+ end loop;
+ return 0;
+ end Ghdl_Text_Read_Length;
+
+ procedure Ghdl_Untruncated_Text_Read
+ (Res : Ghdl_Untruncated_Text_Read_Result_Acc;
+ File : Ghdl_File_Index;
+ Str : Std_String_Ptr)
+ is
+ Stream : C_Files;
+ Len : int;
+ Idx : Ghdl_Index_Type;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, True);
+ Len := int (Str.Bounds.Dim_1.Length);
+ if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then
+ Internal_Error ("ghdl_untruncated_text_read: end of file");
+ end if;
+ -- Compute the length.
+ for I in Ghdl_Index_Type loop
+ if Str.Base (I) = NUL then
+ Idx := I;
+ exit;
+ end if;
+ end loop;
+ Res.Len := Std_Integer (Idx);
+ end Ghdl_Untruncated_Text_Read;
+
+ procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean)
+ is
+ Stream : C_Files;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, Is_Text);
+ -- LRM 3.4.1 File Operations
+ -- If F is not associated with an external file, then FILE_CLOSE has
+ -- no effect.
+ if Stream = NULL_Stream then
+ return;
+ end if;
+ if fclose (Stream) /= 0 then
+ Internal_Error ("file_close: fclose error");
+ end if;
+ Files_Table.Table (File).Stream := NULL_Stream;
+ end File_Close;
+
+ procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is
+ begin
+ File_Close (File, True);
+ end Ghdl_Text_File_Close;
+
+ procedure Ghdl_File_Close (File : Ghdl_File_Index) is
+ begin
+ File_Close (File, False);
+ end Ghdl_File_Close;
+
+ procedure Ghdl_File_Flush (File : Ghdl_File_Index)
+ is
+ Stream : C_Files;
+ begin
+ Stream := Get_File (File);
+ if Stream = NULL_Stream then
+ return;
+ end if;
+ fflush (Stream);
+ end Ghdl_File_Flush;
+end Grt.Files;
+
diff --git a/src/translate/grt/grt-files.ads b/src/translate/grt/grt-files.ads
new file mode 100644
index 000000000..14f998468
--- /dev/null
+++ b/src/translate/grt/grt-files.ads
@@ -0,0 +1,123 @@
+-- GHDL Run Time (GRT) - VHDL files subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Interfaces;
+
+package Grt.Files is
+ type Ghdl_File_Index is new Interfaces.Integer_32;
+
+ -- File open mode.
+ Read_Mode : constant Ghdl_I32 := 0;
+ Write_Mode : constant Ghdl_I32 := 1;
+ Append_Mode : constant Ghdl_I32 := 2;
+
+ -- file_open_status.
+ Open_Ok : constant Ghdl_I32 := 0;
+ Status_Error : constant Ghdl_I32 := 1;
+ Name_Error : constant Ghdl_I32 := 2;
+ Mode_Error : constant Ghdl_I32 := 3;
+
+ -- General files.
+ function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean;
+
+ -- Elaboration.
+ function Ghdl_Text_File_Elaborate return Ghdl_File_Index;
+ function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index;
+
+ -- Finalization.
+ procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index);
+ procedure Ghdl_File_Finalize (File : Ghdl_File_Index);
+
+ -- Subprograms.
+ procedure Ghdl_Text_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr);
+ function Ghdl_Text_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32;
+
+ procedure Ghdl_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr);
+ function Ghdl_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32;
+
+ procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr);
+ procedure Ghdl_Write_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type);
+
+ procedure Ghdl_Read_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type);
+
+ function Ghdl_Text_Read_Length
+ (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer;
+
+ type Ghdl_Untruncated_Text_Read_Result is record
+ Len : Std_Integer;
+ end record;
+
+ type Ghdl_Untruncated_Text_Read_Result_Acc is
+ access Ghdl_Untruncated_Text_Read_Result;
+
+ procedure Ghdl_Untruncated_Text_Read
+ (Res : Ghdl_Untruncated_Text_Read_Result_Acc;
+ File : Ghdl_File_Index;
+ Str : Std_String_Ptr);
+
+ procedure Ghdl_Text_File_Close (File : Ghdl_File_Index);
+ procedure Ghdl_File_Close (File : Ghdl_File_Index);
+
+ procedure Ghdl_File_Flush (File : Ghdl_File_Index);
+private
+ pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile");
+
+ pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate");
+ pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate");
+
+ pragma Export (C, Ghdl_Text_File_Finalize, "__ghdl_text_file_finalize");
+ pragma Export (C, Ghdl_File_Finalize, "__ghdl_file_finalize");
+
+ pragma Export (C, Ghdl_Text_File_Open, "__ghdl_text_file_open");
+ pragma Export (C, Ghdl_Text_File_Open_Status,
+ "__ghdl_text_file_open_status");
+
+ pragma Export (C, Ghdl_File_Open, "__ghdl_file_open");
+ pragma Export (C, Ghdl_File_Open_Status, "__ghdl_file_open_status");
+
+ pragma Export (C, Ghdl_Text_Write, "__ghdl_text_write");
+ pragma Export (C, Ghdl_Write_Scalar, "__ghdl_write_scalar");
+
+ pragma Export (C, Ghdl_Read_Scalar, "__ghdl_read_scalar");
+
+ pragma Export (C, Ghdl_Text_Read_Length, "__ghdl_text_read_length");
+ pragma Export (C, Ghdl_Untruncated_Text_Read,
+ "std__textio__untruncated_text_read");
+
+ pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close");
+ pragma Export (C, Ghdl_File_Close, "__ghdl_file_close");
+
+ pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush");
+end Grt.Files;
diff --git a/src/translate/grt/grt-hooks.adb b/src/translate/grt/grt-hooks.adb
new file mode 100644
index 000000000..6a77aaf01
--- /dev/null
+++ b/src/translate/grt/grt-hooks.adb
@@ -0,0 +1,161 @@
+-- GHDL Run Time (GRT) - Hooks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Hooks is
+ type Hooks_Cell;
+ type Hooks_Cell_Acc is access Hooks_Cell;
+ type Hooks_Cell is record
+ Hooks : Hooks_Acc;
+ Next : Hooks_Cell_Acc;
+ end record;
+
+ First_Hooks : Hooks_Cell_Acc := null;
+ Last_Hooks : Hooks_Cell_Acc := null;
+
+ procedure Register_Hooks (Hooks : Hooks_Acc)
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := new Hooks_Cell'(Hooks => Hooks,
+ Next => null);
+ if Last_Hooks = null then
+ First_Hooks := Cell;
+ else
+ Last_Hooks.Next := Cell;
+ end if;
+ Last_Hooks := Cell;
+ end Register_Hooks;
+
+ type Hook_Cell;
+ type Hook_Cell_Acc is access Hook_Cell;
+ type Hook_Cell is record
+ Hook : Proc_Hook_Type;
+ Next : Hook_Cell_Acc;
+ end record;
+
+ -- Chain of cycle hooks.
+ Cycle_Hook : Hook_Cell_Acc := null;
+ Last_Cycle_Hook : Hook_Cell_Acc := null;
+
+ procedure Register_Cycle_Hook (Proc : Proc_Hook_Type)
+ is
+ Cell : Hook_Cell_Acc;
+ begin
+ Cell := new Hook_Cell'(Hook => Proc,
+ Next => null);
+ if Cycle_Hook = null then
+ Cycle_Hook := Cell;
+ else
+ Last_Cycle_Hook.Next := Cell;
+ end if;
+ Last_Cycle_Hook := Cell;
+ end Register_Cycle_Hook;
+
+ procedure Call_Cycle_Hooks
+ is
+ Cell : Hook_Cell_Acc;
+ begin
+ Cell := Cycle_Hook;
+ while Cell /= null loop
+ Cell.Hook.all;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Cycle_Hooks;
+
+ function Call_Option_Hooks (Opt : String) return Boolean
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Option /= null
+ and then Cell.Hooks.Option.all (Opt)
+ then
+ return True;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ return False;
+ end Call_Option_Hooks;
+
+ procedure Call_Help_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Help /= null then
+ Cell.Hooks.Help.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Help_Hooks;
+
+ procedure Call_Init_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Init /= null then
+ Cell.Hooks.Init.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Init_Hooks;
+
+ procedure Call_Start_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Start /= null then
+ Cell.Hooks.Start.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Start_Hooks;
+
+ procedure Call_Finish_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Finish /= null then
+ Cell.Hooks.Finish.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Finish_Hooks;
+
+ procedure Proc_Hook_Nil is
+ begin
+ null;
+ end Proc_Hook_Nil;
+end Grt.Hooks;
+
+
diff --git a/src/translate/grt/grt-hooks.ads b/src/translate/grt/grt-hooks.ads
new file mode 100644
index 000000000..20846c7f8
--- /dev/null
+++ b/src/translate/grt/grt-hooks.ads
@@ -0,0 +1,70 @@
+-- GHDL Run Time (GRT) - Hooks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Hooks is
+ pragma Preelaborate (Grt.Hooks);
+
+ type Option_Hook_Type is access function (Opt : String) return Boolean;
+ type Proc_Hook_Type is access procedure;
+
+ type Hooks_Type is record
+ -- Called for every unknown command line argument.
+ -- Return TRUE if handled.
+ Option : Option_Hook_Type;
+
+ -- Display command line help.
+ Help : Proc_Hook_Type;
+
+ -- Called at initialization (after decoding options).
+ Init : Proc_Hook_Type;
+
+ -- Called just after elaboration.
+ Start : Proc_Hook_Type;
+
+ -- Called at the end of execution.
+ Finish : Proc_Hook_Type;
+ end record;
+
+ type Hooks_Acc is access constant Hooks_Type;
+
+ -- Registers hook.
+ procedure Register_Hooks (Hooks : Hooks_Acc);
+
+ -- Register an hook which will call PROC after every non-delta cycles.
+ procedure Register_Cycle_Hook (Proc : Proc_Hook_Type);
+
+ -- Call hooks.
+ function Call_Option_Hooks (Opt : String) return Boolean;
+ procedure Call_Help_Hooks;
+ procedure Call_Init_Hooks;
+ procedure Call_Start_Hooks;
+ procedure Call_Finish_Hooks;
+
+ -- Call non-delta cycles hooks.
+ procedure Call_Cycle_Hooks;
+ pragma Inline_Always (Call_Cycle_Hooks);
+
+ -- Nil procedure.
+ procedure Proc_Hook_Nil;
+end Grt.Hooks;
diff --git a/src/translate/grt/grt-images.adb b/src/translate/grt/grt-images.adb
new file mode 100644
index 000000000..342c98f2a
--- /dev/null
+++ b/src/translate/grt/grt-images.adb
@@ -0,0 +1,387 @@
+-- GHDL Run Time (GRT) - 'image subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Conversion;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Processes; use Grt.Processes;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Images is
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Basep);
+
+ function To_Std_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Boundp);
+
+ procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type)
+ is
+ begin
+ Res.Bounds := To_Std_String_Boundp
+ (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit));
+ Res.Bounds.Dim_1 := (Left => 1,
+ Right => Std_Integer (Len),
+ Dir => Dir_To,
+ Length => Len);
+ end Set_String_Bounds;
+
+ procedure Return_String (Res : Std_String_Ptr; Str : String)
+ is
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length));
+ for I in 0 .. Str'Length - 1 loop
+ Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I);
+ end loop;
+ Set_String_Bounds (Res, Str'Length);
+ end Return_String;
+
+ procedure Return_Enum
+ (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ Str : Ghdl_C_String;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str := Enum_Rti.Names (Index);
+ Return_String (Res, Str (1 .. strlen (Str)));
+ end Return_Enum;
+
+ procedure Ghdl_Image_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_B1'Pos (Val));
+ end Ghdl_Image_B1;
+
+ procedure Ghdl_Image_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_E8'Pos (Val));
+ end Ghdl_Image_E8;
+
+ procedure Ghdl_Image_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_E32'Pos (Val));
+ end Ghdl_Image_E32;
+
+ procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ begin
+ To_String (Str, First, Val);
+ Return_String (Res, Str (First .. Str'Last));
+ end Ghdl_Image_I32;
+
+ procedure Ghdl_Image_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access)
+ is
+ Str : String (1 .. 21);
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ To_String (Str, First, Val);
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (0));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Image_P64;
+
+ procedure Ghdl_Image_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ To_String (Str, First, Val);
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (0));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Image_P32;
+
+ procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+ is
+ Str : String (1 .. 24);
+ P : Natural;
+ begin
+ To_String (Str, P, Val);
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_Image_F64;
+
+ procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32)
+ renames Ghdl_Image_I32;
+ procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+ renames Ghdl_Image_F64;
+
+ procedure Ghdl_To_String_F64_Digits
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32)
+ is
+ Str : String_Real_Digits;
+ P : Natural;
+ begin
+ To_String (Str, P, Val, Nbr_Digits);
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_To_String_F64_Digits;
+
+ procedure Ghdl_To_String_F64_Format
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr)
+ is
+ C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1));
+ Str : Grt.Vstrings.String_Real_Format;
+ P : Natural;
+ begin
+ for I in 1 .. C_Format'Last - 1 loop
+ C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1));
+ end loop;
+ C_Format (C_Format'Last) := NUL;
+
+ To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address));
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_To_String_F64_Format;
+
+ subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4;
+ Hex_Chars : constant array (Natural range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
+
+ procedure Ghdl_BV_To_String (Res : Std_String_Ptr;
+ Val : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type;
+ Log_Base : Log_Base_Type)
+ is
+ Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base;
+ Pos : Ghdl_Index_Type;
+ V : Natural;
+ Sh : Natural range 0 .. 4;
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len));
+ V := 0;
+ Sh := 0;
+ Pos := Res_Len - 1;
+ for I in reverse 1 .. Len loop
+ V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh);
+ Sh := Sh + 1;
+ if Sh = Natural (Log_Base) or else I = 1 then
+ Res.Base (Pos) := Hex_Chars (V);
+ Pos := Pos - 1;
+ Sh := 0;
+ V := 0;
+ end if;
+ end loop;
+ Set_String_Bounds (Res, Res_Len);
+ end Ghdl_BV_To_String;
+
+ procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type) is
+ begin
+ Ghdl_BV_To_String (Res, Base, Len, 3);
+ end Ghdl_BV_To_Ostring;
+
+ procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type) is
+ begin
+ Ghdl_BV_To_String (Res, Base, Len, 4);
+ end Ghdl_BV_To_Hstring;
+
+ procedure To_String_Enum
+ (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ Str : Ghdl_C_String;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str := Enum_Rti.Names (Index);
+ if Str (1) = ''' then
+ Return_String (Res, Str (2 .. 2));
+ else
+ Return_String (Res, Str (1 .. strlen (Str)));
+ end if;
+ end To_String_Enum;
+
+ procedure Ghdl_To_String_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val));
+ end Ghdl_To_String_B1;
+
+ procedure Ghdl_To_String_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val));
+ end Ghdl_To_String_E8;
+
+ procedure Ghdl_To_String_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val));
+ end Ghdl_To_String_E32;
+
+ procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is
+ begin
+ Return_String (Res, (1 => Val));
+ end Ghdl_To_String_Char;
+
+ procedure Ghdl_To_String_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access)
+ renames Ghdl_Image_P32;
+
+ procedure Ghdl_To_String_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access)
+ renames Ghdl_Image_P64;
+
+ procedure Ghdl_Time_To_String_Unit
+ (Res : Std_String_Ptr;
+ Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access)
+ is
+ Str : Grt.Vstrings.String_Time_Unit;
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ Unit_Name := null;
+ for I in 1 .. Phys.Nbr loop
+ if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit)
+ then
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1));
+ exit;
+ end if;
+ end loop;
+ if Unit_Name = null then
+ Error ("no unit for to_string");
+ end if;
+ Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Time_To_String_Unit;
+
+ procedure Ghdl_Array_Char_To_String_B1
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_B1;
+
+ procedure Ghdl_Array_Char_To_String_E8
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_E8;
+
+ procedure Ghdl_Array_Char_To_String_E32
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_E32_Array_Base_Ptr :=
+ To_Ghdl_E32_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_E32;
+
+-- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+-- is
+-- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1)
+-- -- + exp_digits (4) -> 24.
+-- Str : String (1 .. 25);
+
+-- procedure Snprintf_G (Str : System.Address;
+-- Size : Integer;
+-- Arg : Ghdl_F64);
+-- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");
+
+-- function strlen (Str : System.Address) return Integer;
+-- pragma Import (C, strlen);
+-- begin
+-- Snprintf_G (Str'Address, Str'Length, Val);
+-- Return_String (Res, Str (1 .. strlen (Str'Address)));
+-- end Ghdl_Image_F64;
+
+end Grt.Images;
diff --git a/src/translate/grt/grt-images.ads b/src/translate/grt/grt-images.ads
new file mode 100644
index 000000000..cd8911091
--- /dev/null
+++ b/src/translate/grt/grt-images.ads
@@ -0,0 +1,110 @@
+-- GHDL Run Time (GRT) - 'image subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Images is
+ -- For all images procedures, the result is allocated on the secondary
+ -- stack.
+
+ procedure Ghdl_Image_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_Image_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access);
+
+ procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_To_String_F64_Digits
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32);
+ procedure Ghdl_To_String_F64_Format
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr);
+ procedure Ghdl_To_String_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_Char
+ (Res : Std_String_Ptr; Val : Std_Character);
+ procedure Ghdl_To_String_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Time_To_String_Unit
+ (Res : Std_String_Ptr;
+ Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_B1
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_E8
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_E32
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+
+ procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type);
+ procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type);
+private
+ pragma Export (Ada, Ghdl_Image_B1, "__ghdl_image_b1");
+ pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8");
+ pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32");
+ pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32");
+ pragma Export (C, Ghdl_Image_F64, "__ghdl_image_f64");
+ pragma Export (C, Ghdl_Image_P64, "__ghdl_image_p64");
+ pragma Export (C, Ghdl_Image_P32, "__ghdl_image_p32");
+
+ pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32");
+ pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64");
+ pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits");
+ pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format");
+ pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1");
+ pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8");
+ pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32");
+ pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char");
+ pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32");
+ pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64");
+ pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit");
+ pragma Export (C, Ghdl_Array_Char_To_String_B1,
+ "__ghdl_array_char_to_string_b1");
+ pragma Export (C, Ghdl_Array_Char_To_String_E8,
+ "__ghdl_array_char_to_string_e8");
+ pragma Export (C, Ghdl_Array_Char_To_String_E32,
+ "__ghdl_array_char_to_string_e32");
+ pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring");
+ pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring");
+end Grt.Images;
diff --git a/src/translate/grt/grt-lib.adb b/src/translate/grt/grt-lib.adb
new file mode 100644
index 000000000..d2b095c67
--- /dev/null
+++ b/src/translate/grt/grt-lib.adb
@@ -0,0 +1,298 @@
+-- GHDL Run Time (GRT) - misc subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Options;
+
+package body Grt.Lib is
+ --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T);
+ --pragma Import (C, Memcpy);
+
+ procedure Ghdl_Memcpy
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type)
+ is
+ procedure Memmove
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type);
+ pragma Import (C, Memmove);
+ begin
+ Memmove (Dest, Src, Size);
+ end Ghdl_Memcpy;
+
+ procedure Do_Report (Msg : String;
+ Str : Std_String_Ptr;
+ Default_Str : String;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr)
+ is
+ Level : constant Integer := Severity mod 256;
+ begin
+ Report_H;
+ Report_C (Loc.Filename);
+ Report_C (":");
+ Report_C (Loc.Line);
+ Report_C (":");
+ Report_C (Loc.Col);
+ Report_C (":@");
+ Report_Now_C;
+ Report_C (":(");
+ Report_C (Msg);
+ Report_C (" ");
+ case Level is
+ when Note_Severity =>
+ Report_C ("note");
+ when Warning_Severity =>
+ Report_C ("warning");
+ when Error_Severity =>
+ Report_C ("error");
+ when Failure_Severity =>
+ Report_C ("failure");
+ when others =>
+ Report_C ("???");
+ end case;
+ Report_C ("): ");
+ if Str /= null then
+ Report_E (Str);
+ else
+ Report_E (Default_Str);
+ end if;
+ if Level >= Grt.Options.Severity_Level then
+ Error_C (Msg);
+ Error_E (" failed");
+ end if;
+ end Do_Report;
+
+ procedure Ghdl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr)
+ is
+ begin
+ Do_Report ("assertion", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Assert_Failed;
+
+ procedure Ghdl_Ieee_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr)
+ is
+ use Grt.Options;
+ begin
+ if Ieee_Asserts = Disable_Asserts
+ or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0)
+ then
+ return;
+ else
+ Do_Report ("assertion", Str, "Assertion violation", Severity, Loc);
+ end if;
+ end Ghdl_Ieee_Assert_Failed;
+
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Psl_Assert_Failed;
+
+ procedure Ghdl_Psl_Cover
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl cover", Str, "sequence covered", Severity, Loc);
+ end Ghdl_Psl_Cover;
+
+ procedure Ghdl_Psl_Cover_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl cover failure",
+ Str, "sequence not covered", Severity, Loc);
+ end Ghdl_Psl_Cover_Failed;
+
+ procedure Ghdl_Report
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr)
+ is
+ begin
+ Do_Report ("report", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Report;
+
+ procedure Ghdl_Program_Error (Filename : Ghdl_C_String;
+ Line : Ghdl_I32;
+ Code : Ghdl_Index_Type)
+ is
+ begin
+ case Code is
+ when 1 =>
+ Error_C ("missing return in function");
+ when 2 =>
+ Error_C ("block already configured");
+ when 3 =>
+ Error_C ("bad configuration");
+ when others =>
+ Error_C ("unknown error code ");
+ Error_C (Integer (Code));
+ end case;
+ Error_C (" at ");
+ if Filename = null then
+ Error_C ("*unknown*");
+ else
+ Error_C (Filename);
+ end if;
+ Error_C (":");
+ Error_C (Integer(Line));
+ Error_E ("");
+ end Ghdl_Program_Error;
+
+ procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String;
+ Line: Ghdl_I32)
+ is
+ begin
+ Error_C ("bound check failure at ");
+ Error_C (Filename);
+ Error_C (":");
+ Error_C (Integer (Line));
+ Error_E ("");
+ end Ghdl_Bound_Check_Failed_L1;
+
+ function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
+ return Ghdl_I32
+ is
+ pragma Suppress (Overflow_Check);
+
+ R : Ghdl_I32;
+ Res : Ghdl_I32;
+ P : Ghdl_I32;
+ T : Ghdl_I64;
+ begin
+ if E < 0 then
+ Error ("negative exponent");
+ end if;
+ Res := 1;
+ P := V;
+ R := E;
+ loop
+ if R mod 2 = 1 then
+ T := Ghdl_I64 (Res) * Ghdl_I64 (P);
+ Res := Ghdl_I32 (T);
+ if Ghdl_I64 (Res) /= T then
+ Error ("overflow in exponentiation");
+ end if;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ return Res;
+ end Ghdl_Integer_Exp;
+
+ function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+ pragma Import (C, C_Malloc, "malloc");
+
+ function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr is
+ begin
+ return C_Malloc (Size);
+ end Ghdl_Malloc;
+
+ function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr
+ is
+ procedure Memset (Ptr : Ghdl_Ptr; C : Integer; Size : Ghdl_Index_Type);
+ pragma Import (C, Memset);
+
+ Res : Ghdl_Ptr;
+ begin
+ Res := C_Malloc (Size);
+ Memset (Res, 0, Size);
+ return Res;
+ end Ghdl_Malloc0;
+
+ procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr)
+ is
+ procedure C_Free (Ptr : Ghdl_Ptr);
+ pragma Import (C, C_Free, "free");
+ begin
+ C_Free (Ptr);
+ end Ghdl_Deallocate;
+
+ function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32)
+ return Ghdl_Real
+ is
+ R : Ghdl_I32;
+ Res : Ghdl_Real;
+ P : Ghdl_Real;
+ begin
+ Res := 1.0;
+ P := X;
+ R := Exp;
+ if R >= 0 then
+ loop
+ if R mod 2 = 1 then
+ Res := Res * P;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ return Res;
+ else
+ R := -R;
+ loop
+ if R mod 2 = 1 then
+ Res := Res * P;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ if Res = 0.0 then
+ Error ("division per 0.0");
+ return 0.0;
+ end if;
+ return 1.0 / Res;
+ end if;
+ end Ghdl_Real_Exp;
+
+ function Ghdl_Get_Resolution_Limit return Std_Time is
+ begin
+ return 1;
+ end Ghdl_Get_Resolution_Limit;
+
+ procedure Ghdl_Control_Simulation
+ (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is
+ begin
+ Report_H;
+ -- Report_C (Grt.Options.Progname);
+ Report_C ("simulation ");
+ if Stop then
+ Report_C ("stopped");
+ else
+ Report_C ("finished");
+ end if;
+ Report_C (" @");
+ Report_Now_C;
+ if Has_Status then
+ Report_C (" with status ");
+ Report_C (Integer (Status));
+ end if;
+ Report_E ("");
+ if Has_Status then
+ Exit_Status := Integer (Status);
+ end if;
+ Exit_Simulation;
+ end Ghdl_Control_Simulation;
+
+end Grt.Lib;
diff --git a/src/translate/grt/grt-lib.ads b/src/translate/grt/grt-lib.ads
new file mode 100644
index 000000000..4dac2c8d2
--- /dev/null
+++ b/src/translate/grt/grt-lib.ads
@@ -0,0 +1,127 @@
+-- GHDL Run Time (GRT) - misc subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Lib is
+ pragma Preelaborate (Grt.Lib);
+
+ procedure Ghdl_Memcpy
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type);
+
+ procedure Ghdl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+ procedure Ghdl_Ieee_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr);
+
+ -- Called when a sequence is covered (in a cover directive)
+ procedure Ghdl_Psl_Cover
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Psl_Cover_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Report
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ Note_Severity : constant Integer := 0;
+ Warning_Severity : constant Integer := 1;
+ Error_Severity : constant Integer := 2;
+ Failure_Severity : constant Integer := 3;
+
+ procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String;
+ Line: Ghdl_I32);
+
+ -- Program error has occured:
+ -- * configuration of an already configured block.
+ procedure Ghdl_Program_Error (Filename : Ghdl_C_String;
+ Line : Ghdl_I32;
+ Code : Ghdl_Index_Type);
+
+ function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
+ return Ghdl_I32;
+
+ function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+
+ -- Allocate and clear SIZE bytes.
+ function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+
+ procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr);
+
+ function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32)
+ return Ghdl_Real;
+
+ type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8)
+ of Ghdl_B1;
+
+ Ghdl_Std_Ulogic_To_Boolean_Array :
+ constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U
+ False, -- X
+ False, -- 0
+ True, -- 1
+ False, -- Z
+ False, -- W
+ False, -- L
+ True, -- H
+ False -- -
+ );
+
+ function Ghdl_Get_Resolution_Limit return Std_Time;
+ procedure Ghdl_Control_Simulation
+ (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer);
+private
+ pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy");
+
+ pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed");
+ pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed");
+ pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed");
+ pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover");
+ pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed");
+ pragma Export (C, Ghdl_Report, "__ghdl_report");
+
+ pragma Export (C, Ghdl_Bound_Check_Failed_L1,
+ "__ghdl_bound_check_failed_l1");
+ pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error");
+
+ pragma Export (C, Ghdl_Malloc, "__ghdl_malloc");
+ pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0");
+ pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate");
+
+ pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp");
+ pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp");
+
+ pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array,
+ "__ghdl_std_ulogic_to_boolean_array");
+
+ pragma Export (C, Ghdl_Get_Resolution_Limit,
+ "__ghdl_get_resolution_limit");
+ pragma Export (Ada, Ghdl_Control_Simulation,
+ "__ghdl_control_simulation");
+end Grt.Lib;
diff --git a/src/translate/grt/grt-main.adb b/src/translate/grt/grt-main.adb
new file mode 100644
index 000000000..116ea7b2e
--- /dev/null
+++ b/src/translate/grt/grt-main.adb
@@ -0,0 +1,190 @@
+-- GHDL Run Time (GRT) - entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Types; use Grt.Types;
+with Grt.Errors;
+with Grt.Stacks;
+with Grt.Processes;
+with Grt.Signals;
+with Grt.Options; use Grt.Options;
+with Grt.Stats;
+with Grt.Hooks;
+with Grt.Disp_Signals;
+with Grt.Disp;
+with Grt.Modules;
+
+-- The following packages are not referenced in this package.
+-- These are subprograms called only from GHDL generated code.
+-- They are with'ed in order to be present in the binary.
+pragma Warnings (Off);
+with Grt.Files;
+with Grt.Types;
+with Grt.Lib;
+with Grt.Shadow_Ieee;
+with Grt.Images;
+with Grt.Values;
+with Grt.Names;
+pragma Warnings (On);
+
+package body Grt.Main is
+ procedure Ghdl_Elaborate;
+ pragma Import (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ -- Wrapper around elaboration just to return 0.
+ function Ghdl_Elaborate_Wrapper return Integer is
+ begin
+ Ghdl_Elaborate;
+ return 0;
+ end Ghdl_Elaborate_Wrapper;
+
+ procedure Disp_Stats_Hook (Code : Integer);
+ pragma Convention (C, Disp_Stats_Hook);
+
+ procedure Disp_Stats_Hook (Code : Integer)
+ is
+ pragma Unreferenced (Code);
+ begin
+ Stats.End_Simulation;
+ Stats.Disp_Stats;
+ end Disp_Stats_Hook;
+
+ procedure Check_Flag_String
+ is
+ Err : Boolean;
+ begin
+ -- The conditions may be statically known.
+ pragma Warnings (Off);
+
+ Err := False;
+ if (Std_Integer'Size = 32 and Flag_String (3) /= 'i')
+ or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I')
+ then
+ Err := True;
+ end if;
+ if (Std_Time'Size = 32 and Flag_String (4) /= 't')
+ or else (Std_Time'Size = 64 and Flag_String (4) /= 'T')
+ then
+ Err := True;
+ end if;
+
+ pragma Warnings (On);
+
+ if Err then
+ Grt.Errors.Error
+ ("GRT is not consistent with the flags used for your design");
+ end if;
+ end Check_Flag_String;
+
+ procedure Run
+ is
+ use Grt.Errors;
+ Stop : Boolean;
+ Status : Integer;
+ begin
+ -- Register modules.
+ -- They may insert hooks.
+ Grt.Modules.Register_Modules;
+
+ -- If the time resolution is to be set by the user, select a default
+ -- resolution. Options may override it.
+ if Flag_String (5) = '?' then
+ Set_Time_Resolution ('n');
+ end if;
+
+ -- Decode options.
+ Grt.Options.Decode (Stop);
+
+ -- Check coherency between GRT and GHDL generated code.
+ Check_Flag_String;
+
+ -- Early stop (for options such as --help).
+ if Stop then
+ return;
+ end if;
+
+ -- Internal initializations.
+ Grt.Stacks.Stack_Init;
+
+ Grt.Hooks.Call_Init_Hooks;
+
+ Grt.Processes.Init;
+
+ Grt.Signals.Init;
+
+ if Flag_Stats then
+ Stats.Start_Elaboration;
+ end if;
+
+ -- Elaboration. Run through longjump to catch errors.
+ if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0
+ then
+ Grt.Errors.Error ("error during elaboration");
+ return;
+ end if;
+
+ if Flag_Stats then
+ Stats.Start_Order;
+ end if;
+
+ Grt.Hooks.Call_Start_Hooks;
+
+ if not Flag_No_Run then
+ Grt.Signals.Order_All_Signals;
+
+ if Grt.Options.Disp_Signals_Map then
+ Grt.Disp_Signals.Disp_Signals_Map;
+ end if;
+ if Grt.Options.Disp_Signals_Table then
+ Grt.Disp_Signals.Disp_Signals_Table;
+ end if;
+ if Disp_Signals_Order then
+ Grt.Disp.Disp_Signals_Order;
+ end if;
+ if Disp_Sensitivity then
+ Grt.Disp_Signals.Disp_All_Sensitivity;
+ end if;
+
+ -- Do the simulation.
+ Status := Grt.Processes.Simulation;
+ end if;
+
+ if Flag_Stats then
+ Disp_Stats_Hook (0);
+ end if;
+
+ if Expect_Failure then
+ if Status >= 0 then
+ Expect_Failure := False;
+ Error ("error expected, but none occured");
+ end if;
+ else
+ if Status < 0 then
+ Error ("simulation failed");
+ end if;
+ end if;
+ end Run;
+
+end Grt.Main;
diff --git a/src/translate/grt/grt-main.ads b/src/translate/grt/grt-main.ads
new file mode 100644
index 000000000..4f78477f2
--- /dev/null
+++ b/src/translate/grt/grt-main.ads
@@ -0,0 +1,29 @@
+-- GHDL Run Time (GRT) - entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Main is
+ -- Elaborate and simulate the design.
+ procedure Run;
+end Grt.Main;
diff --git a/src/translate/grt/grt-modules.adb b/src/translate/grt/grt-modules.adb
new file mode 100644
index 000000000..e5304f04d
--- /dev/null
+++ b/src/translate/grt/grt-modules.adb
@@ -0,0 +1,47 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Vcd;
+with Grt.Vcdz;
+with Grt.Vpi;
+with Grt.Waves;
+with Grt.Vital_Annotate;
+with Grt.Disp_Tree;
+with Grt.Disp_Rti;
+
+package body Grt.Modules is
+ procedure Register_Modules is
+ begin
+ -- List of modules to be registered.
+ Grt.Disp_Tree.Register;
+ Grt.Vcd.Register;
+ Grt.Vcdz.Register;
+ Grt.Waves.Register;
+ Grt.Vpi.Register;
+ Grt.Vital_Annotate.Register;
+ Grt.Disp_Rti.Register;
+ end Register_Modules;
+end Grt.Modules;
diff --git a/src/translate/grt/grt-modules.ads b/src/translate/grt/grt-modules.ads
new file mode 100644
index 000000000..23c7d6e7a
--- /dev/null
+++ b/src/translate/grt/grt-modules.ads
@@ -0,0 +1,29 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Modules is
+ -- Register optional modules.
+ procedure Register_Modules;
+end Grt.Modules;
diff --git a/src/translate/grt/grt-names.adb b/src/translate/grt/grt-names.adb
new file mode 100644
index 000000000..e7928f75c
--- /dev/null
+++ b/src/translate/grt/grt-names.adb
@@ -0,0 +1,105 @@
+-- GHDL Run Time (GRT) - 'name* subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+--with Grt.Errors; use Grt.Errors;
+with Ada.Unchecked_Conversion;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Processes; use Grt.Processes;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Vstrings; use Grt.Vstrings;
+
+package body Grt.Names is
+ function To_Str_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Boundp);
+
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => String_Ptr, Target => Std_String_Basep);
+
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Basep);
+
+ procedure Get_Name (Res : Std_String_Ptr;
+ Ctxt : Rti_Context;
+ Name : Ghdl_Str_Len_Ptr;
+ Is_Path : Boolean)
+ is
+ procedure Memcpy (Dst : Address; Src : Address; Len : Integer);
+ pragma Import (C, Memcpy);
+
+ Bounds : Std_String_Boundp;
+ Len : Natural;
+
+ Rstr : Rstring;
+ R_Len : Natural;
+ begin
+ if Ctxt.Block /= null then
+ Prepend (Rstr, ':');
+ Get_Path_Name (Rstr, Ctxt, ':', not Is_Path);
+ R_Len := Length (Rstr);
+ Len := R_Len + Name.Len;
+ else
+ Len := Name.Len;
+ end if;
+
+ Bounds := To_Str_String_Boundp
+ (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit));
+ Bounds.Dim_1.Left := 1;
+ Bounds.Dim_1.Right := Ghdl_I32 (Len);
+ Bounds.Dim_1.Dir := Dir_To;
+ Bounds.Dim_1.Length := Ghdl_Index_Type (Len);
+ Res.Bounds := Bounds;
+ if Ctxt.Block /= null then
+ Res.Base := To_Std_String_Basep
+ (Ghdl_Stack2_Allocate (Ghdl_Index_Type (Len)));
+ Memcpy (Res.Base (0)'Address, Get_Address (Rstr), R_Len);
+ Memcpy (Res.Base (Ghdl_Index_Type (R_Len))'Address,
+ Name.Str (1)'Address,
+ Name.Len);
+ Free (Rstr);
+ else
+ Res.Base := To_Std_String_Basep (Name.Str);
+ end if;
+ end Get_Name;
+
+ procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr)
+ is
+ begin
+ Get_Name (Res, (Base, Ctxt), Name, True);
+ end Ghdl_Get_Path_Name;
+
+ procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr)
+ is
+ begin
+ Get_Name (Res, (Base, Ctxt), Name, False);
+ end Ghdl_Get_Instance_Name;
+
+end Grt.Names;
diff --git a/src/translate/grt/grt-names.ads b/src/translate/grt/grt-names.ads
new file mode 100644
index 000000000..e0c284231
--- /dev/null
+++ b/src/translate/grt/grt-names.ads
@@ -0,0 +1,42 @@
+-- GHDL Run Time (GRT) - 'name* subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Names is
+ procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr);
+
+ procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr);
+private
+ pragma Export (C, Ghdl_Get_Path_Name, "__ghdl_get_path_name");
+ pragma Export (C, Ghdl_Get_Instance_Name, "__ghdl_get_instance_name");
+end Grt.Names;
diff --git a/src/translate/grt/grt-options.adb b/src/translate/grt/grt-options.adb
new file mode 100644
index 000000000..df1eb4ec8
--- /dev/null
+++ b/src/translate/grt/grt-options.adb
@@ -0,0 +1,507 @@
+-- GHDL Run Time (GRT) - command line options.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Interfaces; use Interfaces;
+with Grt.Errors; use Grt.Errors;
+with Grt.Astdio;
+with Grt.Hooks;
+
+package body Grt.Options is
+
+ Std_Standard_Time_Fs : Std_Time;
+ Std_Standard_Time_Ps : Std_Time;
+ Std_Standard_Time_Ns : Std_Time;
+ Std_Standard_Time_Us : Std_Time;
+ Std_Standard_Time_Ms : Std_Time;
+ Std_Standard_Time_Sec : Std_Time;
+ Std_Standard_Time_Min : Std_Time;
+ Std_Standard_Time_Hr : Std_Time;
+ pragma Export (C, Std_Standard_Time_Fs, "std__standard__time__BT__fs");
+ pragma Weak_External (Std_Standard_Time_Fs);
+ pragma Export (C, Std_Standard_Time_Ps, "std__standard__time__BT__ps");
+ pragma Weak_External (Std_Standard_Time_Ps);
+ pragma Export (C, Std_Standard_Time_Ns, "std__standard__time__BT__ns");
+ pragma Weak_External (Std_Standard_Time_Ns);
+ pragma Export (C, Std_Standard_Time_Us, "std__standard__time__BT__us");
+ pragma Weak_External (Std_Standard_Time_Us);
+ pragma Export (C, Std_Standard_Time_Ms, "std__standard__time__BT__ms");
+ pragma Weak_External (Std_Standard_Time_Ms);
+ pragma Export (C, Std_Standard_Time_Sec, "std__standard__time__BT__sec");
+ pragma Weak_External (Std_Standard_Time_Sec);
+ pragma Export (C, Std_Standard_Time_Min, "std__standard__time__BT__min");
+ pragma Weak_External (Std_Standard_Time_Min);
+ pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr");
+ pragma Weak_External (Std_Standard_Time_Hr);
+
+ procedure Set_Time_Resolution (Res : Character)
+ is
+ begin
+ Std_Standard_Time_Hr := 0;
+ case Res is
+ when 'f' =>
+ Std_Standard_Time_Fs := 1;
+ Std_Standard_Time_Ps := 1000;
+ Std_Standard_Time_Ns := 1000_000;
+ Std_Standard_Time_Us := 1000_000_000;
+ Std_Standard_Time_Ms := Std_Time'Last;
+ Std_Standard_Time_Sec := Std_Time'Last;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'p' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 1;
+ Std_Standard_Time_Ns := 1000;
+ Std_Standard_Time_Us := 1000_000;
+ Std_Standard_Time_Ms := 1000_000_000;
+ Std_Standard_Time_Sec := Std_Time'Last;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'n' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 1;
+ Std_Standard_Time_Us := 1000;
+ Std_Standard_Time_Ms := 1000_000;
+ Std_Standard_Time_Sec := 1000_000_000;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'u' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 1;
+ Std_Standard_Time_Ms := 1000;
+ Std_Standard_Time_Sec := 1000_000;
+ Std_Standard_Time_Min := 60_000_000;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'm' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 1;
+ Std_Standard_Time_Sec := 1000;
+ Std_Standard_Time_Min := 60_000;
+ Std_Standard_Time_Hr := 3600_000;
+ when 's' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 1;
+ Std_Standard_Time_Min := 60;
+ Std_Standard_Time_Hr := 3600;
+ when 'M' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 0;
+ Std_Standard_Time_Min := 1;
+ Std_Standard_Time_Hr := 60;
+ when 'h' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 0;
+ Std_Standard_Time_Min := 0;
+ Std_Standard_Time_Hr := 1;
+ when others =>
+ Error ("bad time resolution");
+ end case;
+ end Set_Time_Resolution;
+
+ procedure Help
+ is
+ use Grt.Astdio;
+ procedure P (Str : String) renames Put_Line;
+ Prog_Name : Ghdl_C_String;
+ begin
+ if Argc > 0 then
+ Prog_Name := Argv (0);
+ Put ("Usage: ");
+ Put (Prog_Name (1 .. strlen (Prog_Name)));
+ Put (" [OPTIONS]");
+ New_Line;
+ end if;
+
+ P ("Options are:");
+ P (" --help, -h disp this help");
+ P (" --assert-level=LEVEL stop simulation if assert at LEVEL");
+ P (" LEVEL is note,warning,error,failure,none");
+ P (" --ieee-asserts=POLICY enable or disable asserts from IEEE");
+ P (" POLICY is enable,disable,disable-at-0");
+ P (" --stop-time=X stop the simulation at time X");
+ P (" X is expressed as a time value, without spaces: 1ns, ps...");
+ P (" --stop-delta=X stop the simulation cycle after X delta");
+ P (" --expect-failure invert exit status");
+ P (" --stack-size=X set the stack size of non-sensitized processes");
+ P (" --stack-max-size=X set the maximum stack size");
+ P (" --no-run do not simulate, only elaborate");
+ -- P (" --threads=N use N threads for simulation");
+ Grt.Hooks.Call_Help_Hooks;
+ P ("trace options:");
+ P (" --disp-time disp time as simulation advances");
+ P (" --trace-signals disp signals after each cycle");
+ P (" --trace-processes disp process name before each cycle");
+ P (" --stats display run-time statistics");
+ P ("debug options:");
+ P (" --disp-order disp signals order");
+ P (" --disp-sources disp sources while displaying signals");
+ P (" --disp-sig-types disp signal types");
+ P (" --disp-signals-map disp map bw declared sigs and internal sigs");
+ P (" --disp-signals-table disp internal signals");
+ P (" --checks do internal checks after each process run");
+ P (" --activity=LEVEL watch activity of LEVEL signals");
+ P (" LEVEL is all, min (default) or none (unsafe)");
+ end Help;
+
+ -- Extract from STR a number.
+ -- First, all leading blanks are skipped.
+ -- Then, all next digits are eaten.
+ -- The position of the first non digit or one past the upper bound is
+ -- returned into POS.
+ -- If there is no digits, OK is set to false, else to true.
+ procedure Extract_Integer
+ (Str : String;
+ Ok : out Boolean;
+ Result : out Integer_64;
+ Pos : out Natural)
+ is
+ begin
+ Pos := Str'First;
+ -- Skip blanks.
+ while Pos <= Str'Last and then Str (Pos) = ' ' loop
+ Pos := Pos + 1;
+ end loop;
+ Ok := False;
+ Result := 0;
+ loop
+ exit when Pos > Str'Last or else Str (Pos) not in '0' .. '9';
+ Ok := True;
+ Result := Result * 10
+ + (Character'Pos (Str (Pos)) - Character'Pos ('0'));
+ Pos := Pos + 1;
+ end loop;
+ end Extract_Integer;
+
+ function Extract_Size (Str : String; Option_Name : String) return Natural
+ is
+ Ok : Boolean;
+ Val : Integer_64;
+ Pos : Natural;
+ begin
+ Extract_Integer (Str, Ok, Val, Pos);
+ if not Ok then
+ Val := 1;
+ end if;
+ if Pos > Str'Last then
+ -- No suffix.
+ if Val > Integer_64(Natural'Last) then
+ Error_C ("Size exceeds limit for option ");
+ Error_E (Option_Name);
+ else
+ return Natural (Val);
+ end if;
+ end if;
+ if Pos = Str'Last
+ or else (Pos + 1 = Str'Last
+ and then (Str (Pos + 1) = 'b' or Str (Pos + 1) = 'o'))
+ then
+ if Str (Pos) = 'k' or Str (Pos) = 'K' then
+ return Natural (Val) * 1024;
+ elsif Str (Pos) = 'm' or Str (Pos) = 'M' then
+ return Natural (Val) * 1024 * 1024;
+ end if;
+ end if;
+ Error_C ("bad memory unit for option ");
+ Error_E (Option_Name);
+ end Extract_Size;
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ procedure Decode_Option
+ (Option : String; Status : out Decode_Option_Status)
+ is
+ pragma Assert (Option'First = 1);
+ Len : constant Natural := Option'Last;
+ begin
+ Status := Decode_Option_Ok;
+ if Option = "--" then
+ Status := Decode_Option_Last;
+ elsif Option = "--help" or else Option = "-h" then
+ Help;
+ Status := Decode_Option_Help;
+ elsif Option = "--disp-time" then
+ Disp_Time := True;
+ elsif Option = "--trace-signals" then
+ Trace_Signals := True;
+ Disp_Time := True;
+ elsif Option = "--trace-processes" then
+ Trace_Processes := True;
+ Disp_Time := True;
+ elsif Option = "--disp-order" then
+ Disp_Signals_Order := True;
+ elsif Option = "--checks" then
+ Checks := True;
+ elsif Option = "--disp-sources" then
+ Disp_Sources := True;
+ elsif Option = "--disp-sig-types" then
+ Disp_Sig_Types := True;
+ elsif Option = "--disp-signals-map" then
+ Disp_Signals_Map := True;
+ elsif Option = "--disp-signals-table" then
+ Disp_Signals_Table := True;
+ elsif Option = "--disp-sensitivity" then
+ Disp_Sensitivity := True;
+ elsif Option = "--stats" then
+ Flag_Stats := True;
+ elsif Option = "--no-run" then
+ Flag_No_Run := True;
+ elsif Len > 18 and then Option (1 .. 18) = "--time-resolution=" then
+ declare
+ Res : Character;
+ Unit : String (1 .. 3);
+ begin
+ Res := '?';
+ if Len >= 20 then
+ Unit (1) := To_Lower (Option (19));
+ Unit (2) := To_Lower (Option (20));
+ if Len = 20 then
+ if Unit (1 .. 2) = "fs" then
+ Res := 'f';
+ elsif Unit (1 .. 2) = "ps" then
+ Res := 'p';
+ elsif Unit (1 .. 2) = "ns" then
+ Res := 'n';
+ elsif Unit (1 .. 2) = "us" then
+ Res := 'u';
+ elsif Unit (1 .. 2) = "ms" then
+ Res := 'm';
+ elsif Unit (1 .. 2) = "hr" then
+ Res := 'h';
+ end if;
+ elsif Len = 21 then
+ Unit (3) := To_Lower (Option (21));
+ if Unit = "min" then
+ Res := 'M';
+ elsif Unit = "sec" then
+ Res := 's';
+ end if;
+ end if;
+ end if;
+ if Res = '?' then
+ Error_C ("bad unit for '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ if Flag_String (5) = '-' then
+ Error ("time resolution is ignored");
+ elsif Flag_String (5) = '?' then
+ if Stop_Time /= Std_Time'Last then
+ Error ("time resolution must be set "
+ & "before --stop-time");
+ else
+ Set_Time_Resolution (Res);
+ end if;
+ elsif Flag_String (5) /= Res then
+ Error ("time resolution is fixed during analysis");
+ end if;
+ end if;
+ end;
+ elsif Len > 12 and then Option (1 .. 12) = "--stop-time=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Time : Integer_64;
+ Unit : String (1 .. 3);
+ begin
+ Extract_Integer (Option (13 .. Len), Ok, Time, Pos);
+ if not Ok then
+ Time := 1;
+ end if;
+ if (Len - Pos + 1) not in 2 .. 3 then
+ Error_C ("bad unit for '");
+ Error_C (Option);
+ Error_E ("'");
+ return;
+ end if;
+ Unit (1) := To_Lower (Option (Pos));
+ Unit (2) := To_Lower (Option (Pos + 1));
+ if Len = Pos + 2 then
+ Unit (3) := To_Lower (Option (Pos + 2));
+ else
+ Unit (3) := ' ';
+ end if;
+ if Unit = "fs " then
+ null;
+ elsif Unit = "ps " then
+ Time := Time * (10 ** 3);
+ elsif Unit = "ns " then
+ Time := Time * (10 ** 6);
+ elsif Unit = "us " then
+ Time := Time * (10 ** 9);
+ elsif Unit = "ms " then
+ Time := Time * (10 ** 12);
+ elsif Unit = "sec" then
+ Time := Time * (10 ** 15);
+ elsif Unit = "min" then
+ Time := Time * (10 ** 15) * 60;
+ elsif Unit = "hr " then
+ Time := Time * (10 ** 15) * 3600;
+ else
+ Error_C ("bad unit name for '");
+ Error_C (Option);
+ Error_E ("'");
+ end if;
+ Stop_Time := Std_Time (Time);
+ end;
+ elsif Len > 13 and then Option (1 .. 13) = "--stop-delta=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Time : Integer_64;
+ begin
+ Extract_Integer (Option (14 .. Len), Ok, Time, Pos);
+ if not Ok or else Pos <= Len then
+ Error_C ("bad value in '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ if Time > Integer_64 (Integer'Last) then
+ Stop_Delta := Integer'Last;
+ else
+ Stop_Delta := Integer (Time);
+ end if;
+ end if;
+ end;
+ elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then
+ if Option (16 .. Len) = "note" then
+ Severity_Level := Note_Severity;
+ elsif Option (16 .. Len) = "warning" then
+ Severity_Level := Warning_Severity;
+ elsif Option (16 .. Len) = "error" then
+ Severity_Level := Error_Severity;
+ elsif Option (16 .. Len) = "failure" then
+ Severity_Level := Failure_Severity;
+ elsif Option (16 .. Len) = "none" then
+ Severity_Level := 4;
+ else
+ Error ("bad argument for --assert-level option, try --help");
+ end if;
+ elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then
+ if Option (16 .. Len) = "disable" then
+ Ieee_Asserts := Disable_Asserts;
+ elsif Option (16 .. Len) = "enable" then
+ Ieee_Asserts := Enable_Asserts;
+ elsif Option (16 .. Len) = "disable-at-0" then
+ Ieee_Asserts := Disable_Asserts_At_Time_0;
+ else
+ Error ("bad argument for --ieee-asserts option, try --help");
+ end if;
+ elsif Option = "--expect-failure" then
+ Expect_Failure := True;
+ elsif Len >= 13 and then Option (1 .. 13) = "--stack-size=" then
+ Stack_Size := Extract_Size
+ (Option (14 .. Len), "--stack-size");
+ if Stack_Size > Stack_Max_Size then
+ Stack_Max_Size := Stack_Size;
+ end if;
+ elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then
+ Stack_Max_Size := Extract_Size
+ (Option (18 .. Len), "--stack-size");
+ if Stack_Size > Stack_Max_Size then
+ Stack_Size := Stack_Max_Size;
+ end if;
+ elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then
+ if Option (12 .. Len) = "none" then
+ Flag_Activity := Activity_None;
+ elsif Option (12 .. Len) = "min" then
+ Flag_Activity := Activity_Minimal;
+ elsif Option (12 .. Len) = "all" then
+ Flag_Activity := Activity_All;
+ else
+ Error ("bad argument for --activity, try --help");
+ end if;
+ elsif Len > 10 and then Option (1 .. 10) = "--threads=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Val : Integer_64;
+ begin
+ Extract_Integer (Option (11 .. Len), Ok, Val, Pos);
+ if not Ok or else Pos <= Len then
+ Error_C ("bad value in '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ Nbr_Threads := Integer (Val);
+ end if;
+ end;
+ elsif not Grt.Hooks.Call_Option_Hooks (Option) then
+ Error_C ("unknown option '");
+ Error_C (Option);
+ Error_E ("', try --help");
+ end if;
+ end Decode_Option;
+
+ procedure Decode (Stop : out Boolean)
+ is
+ Arg : Ghdl_C_String;
+ Len : Natural;
+ Status : Decode_Option_Status;
+ begin
+ Stop := False;
+ Last_Opt := Argc - 1;
+ for I in 1 .. Argc - 1 loop
+ Arg := Argv (I);
+ Len := strlen (Arg);
+ declare
+ Argument : constant String := Arg (1 .. Len);
+ begin
+ Decode_Option (Argument, Status);
+ case Status is
+ when Decode_Option_Last =>
+ Last_Opt := I;
+ exit;
+ when Decode_Option_Help =>
+ Stop := True;
+ when Decode_Option_Ok =>
+ null;
+ end case;
+ end;
+ end loop;
+ end Decode;
+end Grt.Options;
diff --git a/src/translate/grt/grt-options.ads b/src/translate/grt/grt-options.ads
new file mode 100644
index 000000000..88b1f5084
--- /dev/null
+++ b/src/translate/grt/grt-options.ads
@@ -0,0 +1,154 @@
+-- GHDL Run Time (GRT) - command line options.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Lib; use Grt.Lib;
+
+package Grt.Options is
+ pragma Preelaborate (Grt.Options);
+
+ -- Name of the program, set by argv[0].
+ -- Must be set before calling DECODE.
+ Progname : Ghdl_C_String;
+
+ -- Arguments.
+ -- This mimics argc/argv of 'main'.
+ -- These must be set before calling DECODE.
+ Argc : Integer;
+
+ type Argv_Array_Type is array (Natural) of Ghdl_C_String;
+ type Argv_Type is access Argv_Array_Type;
+
+ Argv : Argv_Type;
+
+ -- Last option decoded.
+ -- Following arguments are reserved for the program.
+ Last_Opt : Integer;
+
+ -- Consistent flags used for analysis.
+ -- Format is "VVitr", where:
+ -- 'VV' is the version (87, 93 or 08).
+ -- 'i' is the integer size ('i' for 32 bits, 'I' for 64 bits).
+ -- 't' is the time size ('t' for 32 bits, 'T' for 64 bits).
+ -- 'r' is the resolution ('?' for to be set by the user, '-' for any).
+ Flag_String : constant String (1 .. 5);
+ pragma Import (C, Flag_String, "__ghdl_flag_string");
+
+ -- Display options help.
+ -- Should not be called directly.
+ procedure Help;
+
+ -- Status from Decode_Option.
+ type Decode_Option_Status is
+ (
+ -- Last option, next arguments aren't options.
+ Decode_Option_Last,
+
+ -- --help option, program shouldn't run.
+ Decode_Option_Help,
+
+ -- Option was successfuly decoded.
+ Decode_Option_Ok);
+
+ -- Decode option Option and set Status.
+ procedure Decode_Option
+ (Option : String; Status : out Decode_Option_Status);
+
+ -- Decode command line options.
+ -- If STOP is true, there nothing must happen (set by --help).
+ procedure Decode (Stop : out Boolean);
+
+ -- Set by --disp-time (and --trace-signals, --trace-processes) to display
+ -- time and deltas.
+ Disp_Time : Boolean := False;
+
+ -- Set by --trace-signals, to display signals after each cycle.
+ Trace_Signals : Boolean := False;
+
+ -- Set by --trace-processes, to display process name before being run.
+ Trace_Processes : Boolean := False;
+
+ -- Set by --disp-sig-types, to display signals and they types.
+ Disp_Sig_Types : Boolean := False;
+
+ Disp_Sources : Boolean := False;
+ Disp_Signals_Map : Boolean := False;
+ Disp_Signals_Table : Boolean := False;
+ Disp_Sensitivity : Boolean := False;
+
+ -- Set by --disp-order to diplay evaluation order of signals.
+ Disp_Signals_Order : Boolean := False;
+
+ -- Set by --stats to display statistics.
+ Flag_Stats : Boolean := False;
+
+ -- Set by --checks to do internal checks.
+ Checks : Boolean := False;
+
+ -- Level at which an assert stop the simulation.
+ Severity_Level : Integer := Failure_Severity;
+
+ -- How assertions are handled.
+ type Assert_Handling is
+ (Enable_Asserts,
+ Disable_Asserts_At_Time_0,
+ Disable_Asserts);
+
+ -- Handling of assertions from IEEE library.
+ Ieee_Asserts : Assert_Handling := Enable_Asserts;
+
+ -- Set by --stop-time=XXX to stop the simulation at or just after XXX.
+ -- (unit is fs in fact).
+ Stop_Time : Std_Time := Std_Time'Last;
+
+ -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles.
+ Stop_Delta : Natural := 5000;
+
+ -- The default stack size for non-sensitized processes.
+ Stack_Size : Natural := 8 * 1024;
+
+ -- The maximum stack size for non-sensitized processes.
+ Stack_Max_Size : Natural := 128 * 1024;
+
+ -- Set by --no-run
+ -- If set, do not simulate, only elaborate.
+ Flag_No_Run : Boolean := False;
+
+ type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None);
+ Flag_Activity : Activity_Mode := Activity_Minimal;
+
+ -- Set by --thread=
+ -- Number of threads used to do the simulation.
+ -- 1 mean no additionnal threads, 0 means as many threads as number of
+ -- CPUs.
+ Nbr_Threads : Natural := 1;
+
+ -- Set the time resolution.
+ -- Only call this subprogram if you are allowed to set the time resolution.
+ procedure Set_Time_Resolution (Res : Character);
+private
+ pragma Export (C, Stack_Size);
+ pragma Export (C, Stack_Max_Size);
+ pragma Export (C, Nbr_Threads, "grt_nbr_threads");
+end Grt.Options;
diff --git a/src/translate/grt/grt-processes.adb b/src/translate/grt/grt-processes.adb
new file mode 100644
index 000000000..64db682e2
--- /dev/null
+++ b/src/translate/grt/grt-processes.adb
@@ -0,0 +1,1042 @@
+-- GHDL Run Time (GRT) - processes.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Table;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Disp;
+with Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+with Grt.Options;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils;
+with Grt.Hooks;
+with Grt.Disp_Signals;
+with Grt.Stats;
+with Grt.Threads; use Grt.Threads;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Processes is
+ Last_Time : constant Std_Time := Std_Time'Last;
+
+ -- Identifier for a process.
+ type Process_Id is new Integer;
+
+ -- Table of processes.
+ package Process_Table is new Grt.Table
+ (Table_Component_Type => Process_Acc,
+ Table_Index_Type => Process_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ type Finalizer_Type is record
+ -- Subprogram containing process code.
+ Subprg : Proc_Acc;
+
+ -- Instance (THIS parameter) for the subprogram.
+ This : Instance_Acc;
+ end record;
+
+ -- List of finalizer.
+ package Finalizer_Table is new Grt.Table
+ (Table_Component_Type => Finalizer_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 2);
+
+ -- List of processes to be resume at next cycle.
+ type Process_Acc_Array is array (Natural range <>) of Process_Acc;
+ type Process_Acc_Array_Acc is access Process_Acc_Array;
+
+ Resume_Process_Table : Process_Acc_Array_Acc;
+ Last_Resume_Process : Natural := 0;
+ Postponed_Resume_Process_Table : Process_Acc_Array_Acc;
+ Last_Postponed_Resume_Process : Natural := 0;
+
+ -- Number of postponed processes.
+ Nbr_Postponed_Processes : Natural := 0;
+ Nbr_Non_Postponed_Processes : Natural := 0;
+
+ -- Number of resumed processes.
+ Nbr_Resumed_Processes : Natural := 0;
+
+ -- Earliest time out within non-sensitized processes.
+ Process_First_Timeout : Std_Time := Last_Time;
+ Process_Timeout_Chain : Process_Acc := null;
+
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ function Get_Nbr_Processes return Natural is
+ begin
+ return Natural (Process_Table.Last);
+ end Get_Nbr_Processes;
+
+ function Get_Nbr_Sensitized_Processes return Natural
+ is
+ Res : Natural := 0;
+ begin
+ for I in Process_Table.First .. Process_Table.Last loop
+ if Process_Table.Table (I).State = State_Sensitized then
+ Res := Res + 1;
+ end if;
+ end loop;
+ return Res;
+ end Get_Nbr_Sensitized_Processes;
+
+ function Get_Nbr_Resumed_Processes return Natural is
+ begin
+ return Nbr_Resumed_Processes;
+ end Get_Nbr_Resumed_Processes;
+
+ procedure Process_Register (This : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Rti_Context;
+ State : Process_State;
+ Postponed : Boolean)
+ is
+ Stack : Stack_Type;
+ P : Process_Acc;
+ begin
+ if State /= State_Sensitized and then not One_Stack then
+ Stack := Stack_Create (Proc, This);
+ if Stack = Null_Stack then
+ Internal_Error ("cannot allocate stack: memory exhausted");
+ end if;
+ else
+ Stack := Null_Stack;
+ end if;
+ P := new Process_Type'(Subprg => Proc,
+ This => This,
+ Rti => Ctxt,
+ Sensitivity => null,
+ Resumed => False,
+ Postponed => Postponed,
+ State => State,
+ Timeout => Bad_Time,
+ Timeout_Chain_Next => null,
+ Timeout_Chain_Prev => null,
+ Stack => Stack);
+ Process_Table.Append (P);
+ -- Used to create drivers.
+ Set_Current_Process (P);
+ if Postponed then
+ Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1;
+ else
+ Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1;
+ end if;
+ end Process_Register;
+
+ procedure Ghdl_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, False);
+ end Ghdl_Process_Register;
+
+ procedure Ghdl_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False);
+ end Ghdl_Sensitized_Process_Register;
+
+ procedure Ghdl_Postponed_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, True);
+ end Ghdl_Postponed_Process_Register;
+
+ procedure Ghdl_Postponed_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True);
+ end Ghdl_Postponed_Sensitized_Process_Register;
+
+ procedure Verilog_Process_Register (This : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Rti_Context)
+ is
+ P : Process_Acc;
+ begin
+ P := new Process_Type'(Rti => Ctxt,
+ Sensitivity => null,
+ Resumed => False,
+ Postponed => False,
+ State => State_Sensitized,
+ Timeout => Bad_Time,
+ Timeout_Chain_Next => null,
+ Timeout_Chain_Prev => null,
+ Subprg => Proc,
+ This => This,
+ Stack => Null_Stack);
+ Process_Table.Append (P);
+ -- Used to create drivers.
+ Set_Current_Process (P);
+ end Verilog_Process_Register;
+
+ procedure Ghdl_Initial_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Verilog_Process_Register (Instance, Proc, Null_Context);
+ end Ghdl_Initial_Register;
+
+ procedure Ghdl_Always_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Verilog_Process_Register (Instance, Proc, Null_Context);
+ end Ghdl_Always_Register;
+
+ procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Resume_Process_If_Event
+ (Sig, Process_Table.Table (Process_Table.Last));
+ end Ghdl_Process_Add_Sensitivity;
+
+ procedure Ghdl_Finalize_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Finalizer_Table.Append (Finalizer_Type'(Proc, Instance));
+ end Ghdl_Finalize_Register;
+
+ procedure Call_Finalizers is
+ El : Finalizer_Type;
+ begin
+ for I in Finalizer_Table.First .. Finalizer_Table.Last loop
+ El := Finalizer_Table.Table (I);
+ El.Subprg.all (El.This);
+ end loop;
+ end Call_Finalizers;
+
+ procedure Resume_Process (Proc : Process_Acc)
+ is
+ begin
+ if not Proc.Resumed then
+ Proc.Resumed := True;
+ if Proc.Postponed then
+ Last_Postponed_Resume_Process := Last_Postponed_Resume_Process + 1;
+ Postponed_Resume_Process_Table (Last_Postponed_Resume_Process)
+ := Proc;
+ else
+ Last_Resume_Process := Last_Resume_Process + 1;
+ Resume_Process_Table (Last_Resume_Process) := Proc;
+ end if;
+ end if;
+ end Resume_Process;
+
+ function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
+ return System.Address
+ is
+ begin
+ return Grt.Stack2.Allocate (Get_Stack2, Size);
+ end Ghdl_Stack2_Allocate;
+
+ function Ghdl_Stack2_Mark return Mark_Id
+ is
+ St2 : Stack2_Ptr := Get_Stack2;
+ begin
+ if St2 = Null_Stack2_Ptr then
+ St2 := Grt.Stack2.Create;
+ Set_Stack2 (St2);
+ end if;
+ return Grt.Stack2.Mark (St2);
+ end Ghdl_Stack2_Mark;
+
+ procedure Ghdl_Stack2_Release (Mark : Mark_Id) is
+ begin
+ Grt.Stack2.Release (Get_Stack2, Mark);
+ end Ghdl_Stack2_Release;
+
+ procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ El : Action_List_Acc;
+ begin
+ El := new Action_List'(Dynamic => True,
+ Next => Sig.Event_List,
+ Proc => Proc,
+ Prev => null,
+ Sig => Sig,
+ Chain => Proc.Sensitivity);
+ if Sig.Event_List /= null and then Sig.Event_List.Dynamic then
+ Sig.Event_List.Prev := El;
+ end if;
+ Sig.Event_List := El;
+ Proc.Sensitivity := El;
+ end Ghdl_Process_Wait_Add_Sensitivity;
+
+ procedure Update_Process_First_Timeout (Proc : Process_Acc) is
+ begin
+ if Proc.Timeout < Process_First_Timeout then
+ Process_First_Timeout := Proc.Timeout;
+ end if;
+ Proc.Timeout_Chain_Next := Process_Timeout_Chain;
+ Proc.Timeout_Chain_Prev := null;
+ if Process_Timeout_Chain /= null then
+ Process_Timeout_Chain.Timeout_Chain_Prev := Proc;
+ end if;
+ Process_Timeout_Chain := Proc;
+ end Update_Process_First_Timeout;
+
+ procedure Remove_Process_From_Timeout_Chain (Proc : Process_Acc) is
+ begin
+ -- Remove Proc from the timeout list.
+ if Proc.Timeout_Chain_Prev /= null then
+ Proc.Timeout_Chain_Prev.Timeout_Chain_Next :=
+ Proc.Timeout_Chain_Next;
+ elsif Process_Timeout_Chain = Proc then
+ -- Only if Proc is in the chain.
+ Process_Timeout_Chain := Proc.Timeout_Chain_Next;
+ end if;
+ if Proc.Timeout_Chain_Next /= null then
+ Proc.Timeout_Chain_Next.Timeout_Chain_Prev :=
+ Proc.Timeout_Chain_Prev;
+ Proc.Timeout_Chain_Next := null;
+ end if;
+ -- Be sure a second call won't corrupt the chain.
+ Proc.Timeout_Chain_Prev := null;
+ end Remove_Process_From_Timeout_Chain;
+
+ procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Time < 0 then
+ -- LRM93 8.1
+ Error ("negative timeout clause");
+ end if;
+ Proc.Timeout := Current_Time + Time;
+ Update_Process_First_Timeout (Proc);
+ end Ghdl_Process_Wait_Set_Timeout;
+
+ function Ghdl_Process_Wait_Has_Timeout return Boolean
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ -- Note: in case of timeout, the timeout is removed when process is
+ -- woken up.
+ return Proc.State = State_Timeout;
+ end Ghdl_Process_Wait_Has_Timeout;
+
+ procedure Ghdl_Process_Wait_Wait
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ -- Suspend this process.
+ Proc.State := State_Wait;
+-- if Cur_Proc.Timeout = Bad_Time then
+-- Cur_Proc.Timeout := Std_Time'Last;
+-- end if;
+ end Ghdl_Process_Wait_Wait;
+
+ function Ghdl_Process_Wait_Suspend return Boolean
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ Ghdl_Process_Wait_Wait;
+ if One_Stack then
+ Internal_Error ("wait_suspend");
+ else
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ return Ghdl_Process_Wait_Has_Timeout;
+ end Ghdl_Process_Wait_Suspend;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Action_List, Action_List_Acc);
+
+ procedure Ghdl_Process_Wait_Close
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ El : Action_List_Acc;
+ N_El : Action_List_Acc;
+ begin
+ -- Remove the sensitivity.
+ El := Proc.Sensitivity;
+ Proc.Sensitivity := null;
+ while El /= null loop
+ pragma Assert (El.Proc = Get_Current_Process);
+ if El.Prev = null then
+ El.Sig.Event_List := El.Next;
+ else
+ pragma Assert (El.Prev.Dynamic);
+ El.Prev.Next := El.Next;
+ end if;
+ if El.Next /= null and then El.Next.Dynamic then
+ El.Next.Prev := El.Prev;
+ end if;
+ N_El := El.Chain;
+ Free (El);
+ El := N_El;
+ end loop;
+
+ -- Remove Proc from the timeout list.
+ Remove_Process_From_Timeout_Chain (Proc);
+
+ -- This is necessary when the process has been woken-up by an event
+ -- before the timeout triggers.
+ if Process_First_Timeout = Proc.Timeout then
+ -- Remove the timeout.
+ Proc.Timeout := Bad_Time;
+
+ declare
+ Next_Timeout : Std_Time;
+ P : Process_Acc;
+ begin
+ Next_Timeout := Last_Time;
+ P := Process_Timeout_Chain;
+ while P /= null loop
+ case P.State is
+ when State_Delayed
+ | State_Wait =>
+ if P.Timeout > 0
+ and then P.Timeout < Next_Timeout
+ then
+ Next_Timeout := P.Timeout;
+ end if;
+ when others =>
+ null;
+ end case;
+ P := P.Timeout_Chain_Next;
+ end loop;
+ Process_First_Timeout := Next_Timeout;
+ end;
+ else
+ -- Remove the timeout.
+ Proc.Timeout := Bad_Time;
+ end if;
+ Proc.State := State_Ready;
+ end Ghdl_Process_Wait_Close;
+
+ procedure Ghdl_Process_Wait_Exit
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ -- Mark this process as dead, in order to kill it.
+ -- It cannot be killed now, since this code is still in the process.
+ Proc.State := State_Dead;
+
+ -- Suspend this process.
+ if not One_Stack then
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ end Ghdl_Process_Wait_Exit;
+
+ procedure Ghdl_Process_Wait_Timeout (Time : Std_Time)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ if Time < 0 then
+ -- LRM93 8.1
+ Error ("negative timeout clause");
+ end if;
+ Proc.Timeout := Current_Time + Time;
+ Proc.State := State_Wait;
+ Update_Process_First_Timeout (Proc);
+ -- Suspend this process.
+ if One_Stack then
+ Internal_Error ("wait_timeout");
+ else
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ -- Clean-up.
+ Proc.Timeout := Bad_Time;
+ Remove_Process_From_Timeout_Chain (Proc);
+ Proc.State := State_Ready;
+ end Ghdl_Process_Wait_Timeout;
+
+ -- Verilog.
+ procedure Ghdl_Process_Delay (Del : Ghdl_U32)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ Proc.Timeout := Current_Time + Std_Time (Del);
+ Proc.State := State_Delayed;
+ Update_Process_First_Timeout (Proc);
+ end Ghdl_Process_Delay;
+
+ -- Protected object lock.
+ -- Note: there is no real locks, since the kernel is single threading.
+ -- Multi lock is allowed, and rules are just checked.
+ type Object_Lock is record
+ -- The owner of the lock.
+ -- Nul_Process_Id means the lock is free.
+ Process : Process_Acc;
+ -- Number of times the lock has been acquired.
+ Count : Natural;
+ end record;
+
+ type Object_Lock_Acc is access Object_Lock;
+ type Object_Lock_Acc_Acc is access Object_Lock_Acc;
+
+ function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Object_Lock_Acc_Acc);
+
+ procedure Ghdl_Protected_Enter (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
+ begin
+ if Lock.Process = null then
+ if Lock.Count /= 0 then
+ Internal_Error ("protected_enter");
+ end if;
+ Lock.Process := Get_Current_Process;
+ Lock.Count := 1;
+ else
+ if Lock.Process /= Get_Current_Process then
+ Internal_Error ("protected_enter(2)");
+ end if;
+ Lock.Count := Lock.Count + 1;
+ end if;
+ end Ghdl_Protected_Enter;
+
+ procedure Ghdl_Protected_Leave (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
+ begin
+ if Lock.Process /= Get_Current_Process then
+ Internal_Error ("protected_leave(1)");
+ end if;
+
+ if Lock.Count = 0 then
+ Internal_Error ("protected_leave(2)");
+ end if;
+ Lock.Count := Lock.Count - 1;
+ if Lock.Count = 0 then
+ Lock.Process := null;
+ end if;
+ end Ghdl_Protected_Leave;
+
+ procedure Ghdl_Protected_Init (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
+ begin
+ Lock.all := new Object_Lock'(Process => null, Count => 0);
+ end Ghdl_Protected_Init;
+
+ procedure Ghdl_Protected_Fini (Obj : System.Address)
+ is
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Object => Object_Lock, Name => Object_Lock_Acc);
+
+ Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
+ begin
+ if Lock.all.Count /= 0 or Lock.all.Process /= null then
+ Internal_Error ("protected_fini");
+ end if;
+ Deallocate (Lock.all);
+ end Ghdl_Protected_Fini;
+
+ function Compute_Next_Time return Std_Time
+ is
+ Res : Std_Time;
+ begin
+ -- f) The time of the next simulation cycle, Tn, is determined by
+ -- setting it to the earliest of
+ -- 1) TIME'HIGH
+ Res := Std_Time'Last;
+
+ -- 2) The next time at which a driver becomes active, or
+ Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time);
+
+ if Res = Current_Time then
+ return Res;
+ end if;
+
+ -- 3) The next time at which a process resumes.
+ if Process_First_Timeout < Res then
+ -- No signals to be updated.
+ Grt.Signals.Flush_Active_List;
+
+ Res := Process_First_Timeout;
+ end if;
+
+ return Res;
+ end Compute_Next_Time;
+
+ procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc)
+ is
+ begin
+ Grt.Rtis_Utils.Put (Stream, Proc.Rti);
+ end Disp_Process_Name;
+
+ procedure Disp_All_Processes
+ is
+ use Grt.Stdio;
+ use Grt.Astdio;
+ begin
+ for I in Process_Table.First .. Process_Table.Last loop
+ declare
+ Proc : constant Process_Acc := Process_Table.Table (I);
+ begin
+ Disp_Process_Name (stdout, Proc);
+ New_Line (stdout);
+ Put (stdout, " State: ");
+ case Proc.State is
+ when State_Sensitized =>
+ Put (stdout, "sensitized");
+ when State_Wait =>
+ Put (stdout, "wait");
+ if Proc.Timeout /= Bad_Time then
+ Put (stdout, " until ");
+ Put_Time (stdout, Proc.Timeout);
+ end if;
+ when State_Ready =>
+ Put (stdout, "ready");
+ when State_Timeout =>
+ Put (stdout, "timeout");
+ when State_Delayed =>
+ Put (stdout, "delayed");
+ when State_Dead =>
+ Put (stdout, "dead");
+ end case;
+-- Put (stdout, ": time: ");
+-- Put_U64 (stdout, Proc.Stats_Time);
+-- Put (stdout, ", runs: ");
+-- Put_U32 (stdout, Proc.Stats_Run);
+ New_Line (stdout);
+ end;
+ end loop;
+ end Disp_All_Processes;
+
+ pragma Unreferenced (Disp_All_Processes);
+
+ -- Run resumed processes.
+ -- If POSTPONED is true, resume postponed processes, else resume
+ -- non-posponed processes.
+ -- Returns one of these values:
+ -- No process has been run.
+ Run_None : constant Integer := 1;
+ -- At least one process was run.
+ Run_Resumed : constant Integer := 2;
+ -- Simulation is finished.
+ Run_Finished : constant Integer := 3;
+ -- Failure, simulation should stop.
+ Run_Failure : constant Integer := -1;
+
+ Mt_Last : Natural;
+ Mt_Table : Process_Acc_Array_Acc;
+ Mt_Index : aliased Natural;
+
+ procedure Run_Processes_Threads
+ is
+ Proc : Process_Acc;
+ Idx : Natural;
+ begin
+ loop
+ -- Atomically get a process to be executed
+ Idx := Grt.Threads.Atomic_Inc (Mt_Index'Access);
+ if Idx > Mt_Last then
+ return;
+ end if;
+ Proc := Mt_Table (Idx);
+
+ if Grt.Options.Trace_Processes then
+ Grt.Astdio.Put ("run process ");
+ Disp_Process_Name (Stdio.stdout, Proc);
+ Grt.Astdio.Put (" [");
+ Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
+ Grt.Astdio.Put ("]");
+ Grt.Astdio.New_Line;
+ end if;
+ if not Proc.Resumed then
+ Internal_Error ("run non-resumed process");
+ end if;
+ Proc.Resumed := False;
+ Set_Current_Process (Proc);
+ if Proc.State = State_Sensitized or else One_Stack then
+ Proc.Subprg.all (Proc.This);
+ else
+ Stack_Switch (Proc.Stack, Get_Main_Stack);
+ end if;
+ if Grt.Options.Checks then
+ Ghdl_Signal_Internal_Checks;
+ Grt.Stack2.Check_Empty (Get_Stack2);
+ end if;
+ end loop;
+ end Run_Processes_Threads;
+
+ function Run_Processes (Postponed : Boolean) return Integer
+ is
+ Table : Process_Acc_Array_Acc;
+ Last : Natural;
+ begin
+ if Options.Flag_Stats then
+ Stats.Start_Processes;
+ end if;
+
+ if Postponed then
+ Table := Postponed_Resume_Process_Table;
+ Last := Last_Postponed_Resume_Process;
+ Last_Postponed_Resume_Process := 0;
+ else
+ Table := Resume_Process_Table;
+ Last := Last_Resume_Process;
+ Last_Resume_Process := 0;
+ end if;
+ Nbr_Resumed_Processes := Nbr_Resumed_Processes + Last;
+
+ if Options.Nbr_Threads = 1 then
+ for I in 1 .. Last loop
+ declare
+ Proc : constant Process_Acc := Table (I);
+ begin
+ if not Proc.Resumed then
+ Internal_Error ("run non-resumed process");
+ end if;
+ if Grt.Options.Trace_Processes then
+ Grt.Astdio.Put ("run process ");
+ Disp_Process_Name (Stdio.stdout, Proc);
+ Grt.Astdio.Put (" [");
+ Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
+ Grt.Astdio.Put ("]");
+ Grt.Astdio.New_Line;
+ end if;
+
+ Proc.Resumed := False;
+ Set_Current_Process (Proc);
+ if Proc.State = State_Sensitized or else One_Stack then
+ Proc.Subprg.all (Proc.This);
+ else
+ Stack_Switch (Proc.Stack, Get_Main_Stack);
+ end if;
+ if Grt.Options.Checks then
+ Ghdl_Signal_Internal_Checks;
+ Grt.Stack2.Check_Empty (Get_Stack2);
+ end if;
+ end;
+ end loop;
+ else
+ Mt_Last := Last;
+ Mt_Table := Table;
+ Mt_Index := 1;
+ Threads.Run_Parallel (Run_Processes_Threads'Access);
+ end if;
+
+ if Last >= 1 then
+ return Run_Resumed;
+ else
+ return Run_None;
+ end if;
+ end Run_Processes;
+
+ function Initialization_Phase return Integer
+ is
+ Status : Integer;
+ begin
+ -- Allocate processes arrays.
+ Resume_Process_Table :=
+ new Process_Acc_Array (1 .. Nbr_Non_Postponed_Processes);
+ Postponed_Resume_Process_Table :=
+ new Process_Acc_Array (1 .. Nbr_Postponed_Processes);
+
+ -- LRM93 12.6.4
+ -- At the beginning of initialization, the current time, Tc, is assumed
+ -- to be 0 ns.
+ Current_Time := 0;
+
+ -- The initialization phase consists of the following steps:
+ -- - The driving value and the effective value of each explicitly
+ -- declared signal are computed, and the current value of the signal
+ -- is set to the effective value. This value is assumed to have been
+ -- the value of the signal for an infinite length of time prior to
+ -- the start of the simulation.
+ Init_Signals;
+
+ -- - The value of each implicit signal of the form S'Stable(T) or
+ -- S'Quiet(T) is set to true. The value of each implicit signal of
+ -- the form S'Delayed is set to the initial value of its prefix, S.
+ -- GHDL: already done when the signals are created.
+ null;
+
+ -- - The value of each implicit GUARD signal is set to the result of
+ -- evaluating the corresponding guard expression.
+ null;
+
+ for I in Process_Table.First .. Process_Table.Last loop
+ Resume_Process (Process_Table.Table (I));
+ end loop;
+
+ -- - Each nonpostponed process in the model is executed until it
+ -- suspends.
+ Status := Run_Processes (Postponed => False);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- - Each postponed process in the model is executed until it suspends.
+ Status := Run_Processes (Postponed => True);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- - The time of the next simulation cycle (which in this case is the
+ -- first simulation cycle), Tn, is calculated according to the rules
+ -- of step f of the simulation cycle, below.
+ Current_Time := Compute_Next_Time;
+
+ -- Clear current_delta, will be set by Simulation_Cycle.
+ Current_Delta := 0;
+
+ return Run_Resumed;
+ end Initialization_Phase;
+
+ -- Launch a simulation cycle.
+ -- Set FINISHED to true if this is the last cycle.
+ function Simulation_Cycle return Integer
+ is
+ Tn : Std_Time;
+ Status : Integer;
+ begin
+ -- LRM93 12.6.4
+ -- A simulation cycle consists of the following steps:
+ --
+ -- a) The current time, Tc is set equal to Tn. Simulation is complete
+ -- when Tn = TIME'HIGH and there are no active drivers or process
+ -- resumptions at Tn.
+ -- GHDL: this is done at the last step of the cycle.
+ null;
+
+ -- b) Each active explicit signal in the model is updated. (Events
+ -- may occur on signals as a result).
+ -- c) Each implicit signal in the model is updated. (Events may occur
+ -- on signals as a result.)
+ if Options.Flag_Stats then
+ Stats.Start_Update;
+ end if;
+ Update_Signals;
+ if Options.Flag_Stats then
+ Stats.Start_Resume;
+ end if;
+
+ -- d) For each process P, if P is currently sensitive to a signal S and
+ -- if an event has occured on S in this simulation cycle, then P
+ -- resumes.
+ if Current_Time = Process_First_Timeout then
+ Tn := Last_Time;
+ declare
+ Proc : Process_Acc;
+ begin
+ Proc := Process_Timeout_Chain;
+ while Proc /= null loop
+ case Proc.State is
+ when State_Sensitized =>
+ null;
+ when State_Delayed =>
+ if Proc.Timeout = Current_Time then
+ Proc.Timeout := Bad_Time;
+ Resume_Process (Proc);
+ Proc.State := State_Sensitized;
+ elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
+ Tn := Proc.Timeout;
+ end if;
+ when State_Wait =>
+ if Proc.Timeout = Current_Time then
+ Proc.Timeout := Bad_Time;
+ Resume_Process (Proc);
+ Proc.State := State_Timeout;
+ elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
+ Tn := Proc.Timeout;
+ end if;
+ when State_Timeout
+ | State_Ready =>
+ Internal_Error ("process in timeout");
+ when State_Dead =>
+ null;
+ end case;
+ Proc := Proc.Timeout_Chain_Next;
+ end loop;
+ end;
+ Process_First_Timeout := Tn;
+ end if;
+
+ -- e) Each nonpostponed that has resumed in the current simulation cycle
+ -- is executed until it suspends.
+ Status := Run_Processes (Postponed => False);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- f) The time of the next simulation cycle, Tn, is determined by
+ -- setting it to the earliest of
+ -- 1) TIME'HIGH
+ -- 2) The next time at which a driver becomes active, or
+ -- 3) The next time at which a process resumes.
+ -- If Tn = Tc, then the next simulation cycle (if any) will be a
+ -- delta cycle.
+ if Options.Flag_Stats then
+ Stats.Start_Next_Time;
+ end if;
+ Tn := Compute_Next_Time;
+
+ -- g) If the next simulation cycle will be a delta cycle, the remainder
+ -- of the step is skipped.
+ -- Otherwise, each postponed process that has resumed but has not
+ -- been executed since its last resumption is executed until it
+ -- suspends. Then Tn is recalculated according to the rules of
+ -- step f. It is an error if the execution of any postponed
+ -- process causes a delta cycle to occur immediatly after the
+ -- current simulation cycle.
+ if Tn = Current_Time then
+ if Current_Time = Last_Time and then Status = Run_None then
+ return Run_Finished;
+ else
+ Current_Delta := Current_Delta + 1;
+ return Run_Resumed;
+ end if;
+ else
+ Current_Delta := 0;
+ if Nbr_Postponed_Processes /= 0 then
+ Status := Run_Processes (Postponed => True);
+ end if;
+ if Status = Run_Resumed then
+ Flush_Active_List;
+ if Options.Flag_Stats then
+ Stats.Start_Next_Time;
+ end if;
+ Tn := Compute_Next_Time;
+ if Tn = Current_Time then
+ Error ("postponed process causes a delta cycle");
+ end if;
+ elsif Status = Run_Failure then
+ return Run_Failure;
+ end if;
+ Current_Time := Tn;
+ return Run_Resumed;
+ end if;
+ end Simulation_Cycle;
+
+ function Simulation return Integer
+ is
+ use Options;
+ Status : Integer;
+ begin
+ if Nbr_Threads /= 1 then
+ Threads.Init;
+ end if;
+
+-- if Disp_Sig_Types then
+-- Grt.Disp.Disp_Signals_Type;
+-- end if;
+
+ Status := Run_Through_Longjump (Initialization_Phase'Access);
+ if Status /= Run_Resumed then
+ return -1;
+ end if;
+
+ Nbr_Delta_Cycles := 0;
+ Nbr_Cycles := 0;
+ if Trace_Signals then
+ Grt.Disp_Signals.Disp_All_Signals;
+ end if;
+
+ if Current_Time /= 0 then
+ -- This is the end of a cycle. This can happen when the time is not
+ -- zero after initialization.
+ Cycle_Time := 0;
+ Grt.Hooks.Call_Cycle_Hooks;
+ end if;
+
+ loop
+ Cycle_Time := Current_Time;
+ if Disp_Time then
+ Grt.Disp.Disp_Now;
+ end if;
+ Status := Run_Through_Longjump (Simulation_Cycle'Access);
+ exit when Status < 0;
+ if Trace_Signals then
+ Grt.Disp_Signals.Disp_All_Signals;
+ end if;
+
+ -- Statistics.
+ if Current_Delta = 0 then
+ Nbr_Cycles := Nbr_Cycles + 1;
+ else
+ Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1;
+ end if;
+
+ exit when Status = Run_Finished;
+ if Current_Delta = 0 then
+ Grt.Hooks.Call_Cycle_Hooks;
+ end if;
+
+ if Current_Delta >= Stop_Delta then
+ Error ("simulation stopped by --stop-delta");
+ exit;
+ end if;
+ if Current_Time > Stop_Time then
+ if Current_Time /= Last_Time then
+ Info ("simulation stopped by --stop-time");
+ end if;
+ exit;
+ end if;
+ end loop;
+
+ if Nbr_Threads /= 1 then
+ Threads.Finish;
+ end if;
+
+ Call_Finalizers;
+
+ Grt.Hooks.Call_Finish_Hooks;
+
+ if Status = Run_Failure then
+ return -1;
+ else
+ return Exit_Status ;
+ end if;
+ end Simulation;
+
+end Grt.Processes;
diff --git a/src/translate/grt/grt-processes.ads b/src/translate/grt/grt-processes.ads
new file mode 100644
index 000000000..22326eb5e
--- /dev/null
+++ b/src/translate/grt/grt-processes.ads
@@ -0,0 +1,260 @@
+-- GHDL Run Time (GRT) - processes.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Stack2; use Grt.Stack2;
+with Grt.Types; use Grt.Types;
+with Grt.Signals; use Grt.Signals;
+with Grt.Stacks; use Grt.Stacks;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr;
+with Grt.Stdio;
+
+package Grt.Processes is
+ pragma Suppress (All_Checks);
+
+ -- Internal initialisations.
+ procedure Init;
+
+ -- Do the VHDL simulation.
+ -- Return 0 in case of success (end of time reached).
+ function Simulation return Integer;
+
+ -- Number of delta cycles.
+ Nbr_Delta_Cycles : Integer;
+ -- Number of non-delta cycles.
+ Nbr_Cycles : Integer;
+
+ -- If true, the simulation should be stopped.
+ Break_Simulation : Boolean;
+
+ -- If true, there is one stack for all processes. Non-sensitized
+ -- processes must save their state.
+ One_Stack : Boolean := False;
+
+ type Process_Type is private;
+ -- type Process_Acc is access all Process_Type;
+
+ -- Return the identifier of the current process.
+ -- During the elaboration, this is the identifier of the last process
+ -- being elaborated. So, this function can be used to create signal
+ -- drivers.
+
+ -- Return the total number of processes and number of sensitized processes.
+ -- Used for statistics.
+ function Get_Nbr_Processes return Natural;
+ function Get_Nbr_Sensitized_Processes return Natural;
+
+ -- Total number of resumed processes.
+ function Get_Nbr_Resumed_Processes return Natural;
+
+ -- Disp the name of process PROC.
+ procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc);
+
+ -- Register a process during elaboration.
+ -- This procedure is called by vhdl elaboration code.
+ procedure Ghdl_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Sensitized_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Postponed_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Postponed_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+
+ -- For verilog processes.
+ procedure Ghdl_Finalize_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+
+ procedure Ghdl_Initial_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+ procedure Ghdl_Always_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+
+ -- Add a simple signal in the sensitivity of the last registered
+ -- (sensitized) process.
+ procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr);
+
+ -- Resume a process.
+ procedure Resume_Process (Proc : Process_Acc);
+
+ -- Wait without timeout or sensitivity: wait;
+ procedure Ghdl_Process_Wait_Exit;
+ -- Wait for a timeout (without sensitivity): wait for X;
+ procedure Ghdl_Process_Wait_Timeout (Time : Std_Time);
+
+ -- Full wait statement:
+ -- 1. Call Ghdl_Process_Wait_Set_Timeout (if there is a timeout)
+ -- 2. Call Ghdl_Process_Wait_Add_Sensitivity (for each signal)
+ -- 3. Call Ghdl_Process_Wait_Suspend, go to 4 if it returns true (timeout)
+ -- Evaluate the condition and go to 4 if true
+ -- Else, restart 3
+ -- 4. Call Ghdl_Process_Wait_Close
+
+ -- Add a timeout for a wait.
+ procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time);
+ -- Add a sensitivity for a wait.
+ procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr);
+ -- Wait until timeout or sensitivity.
+ -- Return TRUE in case of timeout.
+ function Ghdl_Process_Wait_Suspend return Boolean;
+ -- Finish a wait statement.
+ procedure Ghdl_Process_Wait_Close;
+
+ -- For one stack setups, wait_suspend is decomposed into the suspension
+ -- procedure and the function to get resume status.
+ procedure Ghdl_Process_Wait_Wait;
+ function Ghdl_Process_Wait_Has_Timeout return Boolean;
+
+ -- Verilog.
+ procedure Ghdl_Process_Delay (Del : Ghdl_U32);
+
+ -- Secondary stack.
+ function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
+ return System.Address;
+ function Ghdl_Stack2_Mark return Mark_Id;
+ procedure Ghdl_Stack2_Release (Mark : Mark_Id);
+
+ -- Protected variables.
+ procedure Ghdl_Protected_Enter (Obj : System.Address);
+ procedure Ghdl_Protected_Leave (Obj : System.Address);
+ procedure Ghdl_Protected_Init (Obj : System.Address);
+ procedure Ghdl_Protected_Fini (Obj : System.Address);
+
+ type Run_Handler is access function return Integer;
+
+ -- Run HAND through a wrapper that catch some errors (in particular on
+ -- windows). Returns < 0 in case of error.
+ function Run_Through_Longjump (Hand : Run_Handler) return Integer;
+ pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump");
+
+private
+ -- State of a process.
+ type Process_State is
+ (
+ -- Sensitized process. Its state cannot change.
+ State_Sensitized,
+
+ -- Non-sensitized process, ready to run.
+ State_Ready,
+
+ -- Verilog process, being suspended.
+ State_Delayed,
+
+ -- Non-sensitized process being suspended.
+ State_Wait,
+
+ -- Non-sensitized process being awaked by a wait timeout. This state
+ -- is transcient.
+ -- This is necessary so that the process will exit immediately from the
+ -- wait statements without checking if the wait condition is true.
+ State_Timeout,
+
+ -- Non-sensitized process waiting until end.
+ State_Dead);
+
+ type Process_Type is record
+ -- Stack for the process.
+ -- This must be the first field of the record (and this is the only
+ -- part visible).
+ -- Must be NULL_STACK for sensitized processes.
+ Stack : Stacks.Stack_Type;
+
+ -- Subprogram containing process code.
+ Subprg : Proc_Acc;
+
+ -- Instance (THIS parameter) for the subprogram.
+ This : Instance_Acc;
+
+ -- Name of the process.
+ Rti : Rtis_Addr.Rti_Context;
+
+ -- True if the process is resumed and will be run at next cycle.
+ Resumed : Boolean;
+
+ -- True if the process is postponed.
+ Postponed : Boolean;
+
+ State : Process_State;
+
+ -- Timeout value for wait.
+ Timeout : Std_Time;
+
+ -- Sensitivity list while the (non-sensitized) process is waiting.
+ Sensitivity : Action_List_Acc;
+
+ Timeout_Chain_Next : Process_Acc;
+ Timeout_Chain_Prev : Process_Acc;
+ end record;
+
+ pragma Export (C, Ghdl_Process_Register,
+ "__ghdl_process_register");
+ pragma Export (C, Ghdl_Sensitized_Process_Register,
+ "__ghdl_sensitized_process_register");
+ pragma Export (C, Ghdl_Postponed_Process_Register,
+ "__ghdl_postponed_process_register");
+ pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register,
+ "__ghdl_postponed_sensitized_process_register");
+
+ pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register");
+
+ pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register");
+ pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register");
+
+ pragma Export (C, Ghdl_Process_Add_Sensitivity,
+ "__ghdl_process_add_sensitivity");
+
+ pragma Export (C, Ghdl_Process_Wait_Exit,
+ "__ghdl_process_wait_exit");
+ pragma Export (C, Ghdl_Process_Wait_Timeout,
+ "__ghdl_process_wait_timeout");
+ pragma Export (C, Ghdl_Process_Wait_Add_Sensitivity,
+ "__ghdl_process_wait_add_sensitivity");
+ pragma Export (C, Ghdl_Process_Wait_Set_Timeout,
+ "__ghdl_process_wait_set_timeout");
+ pragma Export (Ada, Ghdl_Process_Wait_Suspend,
+ "__ghdl_process_wait_suspend");
+ pragma Export (C, Ghdl_Process_Wait_Close,
+ "__ghdl_process_wait_close");
+
+ pragma Export (C, Ghdl_Process_Delay, "__ghdl_process_delay");
+
+ pragma Export (C, Ghdl_Stack2_Allocate, "__ghdl_stack2_allocate");
+ pragma Export (C, Ghdl_Stack2_Mark, "__ghdl_stack2_mark");
+ pragma Export (C, Ghdl_Stack2_Release, "__ghdl_stack2_release");
+
+ pragma Export (C, Ghdl_Protected_Enter, "__ghdl_protected_enter");
+ pragma Export (C, Ghdl_Protected_Leave, "__ghdl_protected_leave");
+ pragma Export (C, Ghdl_Protected_Init, "__ghdl_protected_init");
+ pragma Export (C, Ghdl_Protected_Fini, "__ghdl_protected_fini");
+end Grt.Processes;
diff --git a/src/translate/grt/grt-readline.ads b/src/translate/grt/grt-readline.ads
new file mode 100644
index 000000000..1a3083981
--- /dev/null
+++ b/src/translate/grt/grt-readline.ads
@@ -0,0 +1,30 @@
+-- Although being part of GRT, the readline binding should be independent of
+-- it (for easier reuse).
+
+with System; use System;
+
+package Grt.Readline is
+ subtype Fat_String is String (Positive);
+ type Char_Ptr is access Fat_String;
+ pragma Convention (C, Char_Ptr);
+ -- A C string (which is NUL terminated) is represented as a (thin) access
+ -- to a fat string (a string whose range is 1 .. integer'Last).
+ -- The use of an access to a constrained array allows a representation
+ -- compatible with C. Indexing of object of that type is safe only for
+ -- indexes until the NUL character.
+
+ function Readline (Prompt : Char_Ptr) return Char_Ptr;
+ function Readline (Prompt : Address) return Char_Ptr;
+ pragma Import (C, Readline);
+
+ procedure Free (Buf : Char_Ptr);
+ pragma Import (C, Free);
+
+ procedure Add_History (Line : Char_Ptr);
+ pragma Import (C, Add_History);
+
+ function Strlen (Str : Char_Ptr) return Natural;
+ pragma Import (C, Strlen);
+
+ pragma Linker_Options ("-lreadline");
+end Grt.Readline;
diff --git a/src/translate/grt/grt-rtis.adb b/src/translate/grt/grt-rtis.adb
new file mode 100644
index 000000000..26d976459
--- /dev/null
+++ b/src/translate/grt/grt-rtis.adb
@@ -0,0 +1,45 @@
+-- GHDL Run Time (GRT) - Run Time Informations.
+-- Copyright (C) 2013 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Rtis is
+ procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access) is
+ begin
+ Ghdl_Rti_Top.Children (Ghdl_Rti_Top.Nbr_Child) := Pkg;
+ Ghdl_Rti_Top.Nbr_Child := Ghdl_Rti_Top.Nbr_Child + 1;
+ end Ghdl_Rti_Add_Package;
+
+ procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type;
+ Pkgs : Ghdl_Rti_Arr_Acc;
+ Top : Ghdl_Rti_Access;
+ Instance : Address)
+ is
+ pragma Unreferenced (Max_Pkg);
+ begin
+ Ghdl_Rti_Top.Parent := Top;
+ Ghdl_Rti_Top.Children := Pkgs;
+ Ghdl_Rti_Top_Instance := Instance;
+ end Ghdl_Rti_Add_Top;
+
+end Grt.Rtis;
diff --git a/src/translate/grt/grt-rtis.ads b/src/translate/grt/grt-rtis.ads
new file mode 100644
index 000000000..6bb76597e
--- /dev/null
+++ b/src/translate/grt/grt-rtis.ads
@@ -0,0 +1,379 @@
+-- GHDL Run Time (GRT) - Run Time Informations.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Ada.Unchecked_Conversion;
+
+package Grt.Rtis is
+ pragma Preelaborate (Grt.Rtis);
+
+ type Ghdl_Rtik is
+ (Ghdl_Rtik_Top,
+ Ghdl_Rtik_Library, -- use scalar
+ Ghdl_Rtik_Package,
+ Ghdl_Rtik_Package_Body,
+ Ghdl_Rtik_Entity,
+ Ghdl_Rtik_Architecture,
+ Ghdl_Rtik_Process,
+ Ghdl_Rtik_Block,
+ Ghdl_Rtik_If_Generate,
+ Ghdl_Rtik_For_Generate,
+ Ghdl_Rtik_Instance, --10
+ Ghdl_Rtik_Constant,
+ Ghdl_Rtik_Iterator,
+ Ghdl_Rtik_Variable,
+ Ghdl_Rtik_Signal,
+ Ghdl_Rtik_File, -- 15
+ Ghdl_Rtik_Port,
+ Ghdl_Rtik_Generic,
+ Ghdl_Rtik_Alias,
+ Ghdl_Rtik_Guard,
+ Ghdl_Rtik_Component, -- 20
+ Ghdl_Rtik_Attribute,
+ Ghdl_Rtik_Type_B1, -- Enum
+ Ghdl_Rtik_Type_E8,
+ Ghdl_Rtik_Type_E32,
+ Ghdl_Rtik_Type_I32, -- 25 Scalar
+ Ghdl_Rtik_Type_I64,
+ Ghdl_Rtik_Type_F64,
+ Ghdl_Rtik_Type_P32,
+ Ghdl_Rtik_Type_P64,
+ Ghdl_Rtik_Type_Access,
+ Ghdl_Rtik_Type_Array,
+ Ghdl_Rtik_Type_Record,
+ Ghdl_Rtik_Type_File,
+ Ghdl_Rtik_Subtype_Scalar,
+ Ghdl_Rtik_Subtype_Array,
+ Ghdl_Rtik_Subtype_Unconstrained_Array,
+ Ghdl_Rtik_Subtype_Record,
+ Ghdl_Rtik_Subtype_Access,
+ Ghdl_Rtik_Type_Protected,
+ Ghdl_Rtik_Element,
+ Ghdl_Rtik_Unit64,
+ Ghdl_Rtik_Unitptr,
+ Ghdl_Rtik_Attribute_Transaction,
+ Ghdl_Rtik_Attribute_Quiet,
+ Ghdl_Rtik_Attribute_Stable,
+ Ghdl_Rtik_Error);
+ for Ghdl_Rtik'Size use 8;
+
+ type Ghdl_Rti_Depth is range 0 .. 255;
+ for Ghdl_Rti_Depth'Size use 8;
+
+ type Ghdl_Rti_U8 is mod 2 ** 8;
+ for Ghdl_Rti_U8'Size use 8;
+
+ -- This structure is common to all RTI nodes.
+ type Ghdl_Rti_Common is record
+ -- Kind of the RTI, list is above.
+ Kind : Ghdl_Rtik;
+
+ Depth : Ghdl_Rti_Depth;
+
+ -- * array types and subtypes, record types, protected types:
+ -- bit 0: set for complex type
+ -- bit 1: set for anonymous type definition
+ -- bit 2: set only for physical type with non-static units (time)
+ -- * signals:
+ -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in)
+ -- bit 4-5: kind (0 : none, 1 : register, 2 : bus)
+ -- bit 6: set if has 'active attributes
+ Mode : Ghdl_Rti_U8;
+
+ -- * Types and subtypes definition:
+ -- maximum depth of all RTIs referenced.
+ -- * Others:
+ -- 0
+ Max_Depth : Ghdl_Rti_Depth;
+ end record;
+
+ type Ghdl_Rti_Access is access all Ghdl_Rti_Common;
+
+ -- Fat array of rti accesses.
+ type Ghdl_Rti_Array is array (Ghdl_Index_Type) of Ghdl_Rti_Access;
+ type Ghdl_Rti_Arr_Acc is access Ghdl_Rti_Array;
+
+ subtype Ghdl_Rti_Loc is Integer_Address;
+ Null_Rti_Loc : constant Ghdl_Rti_Loc := 0;
+
+ type Ghdl_C_String_Array is array (Ghdl_Index_Type) of Ghdl_C_String;
+ type Ghdl_C_String_Array_Ptr is access Ghdl_C_String_Array;
+
+ type Ghdl_Rtin_Block is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Parent : Ghdl_Rti_Access;
+ Size : Ghdl_Index_Type;
+ Nbr_Child : Ghdl_Index_Type;
+ Children : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block;
+ function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Object is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Obj_Type : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object;
+ function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Object_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Instance is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Parent : Ghdl_Rti_Access;
+ Instance : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance;
+ function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc);
+
+ -- Must be kept in sync with grt.types.mode_signal_type.
+ Ghdl_Rti_Signal_Mode_Mask : constant Ghdl_Rti_U8 := 15;
+ Ghdl_Rti_Signal_Mode_None : constant Ghdl_Rti_U8 := 0;
+ Ghdl_Rti_Signal_Mode_Linkage : constant Ghdl_Rti_U8 := 1;
+ Ghdl_Rti_Signal_Mode_Buffer : constant Ghdl_Rti_U8 := 2;
+ Ghdl_Rti_Signal_Mode_Out : constant Ghdl_Rti_U8 := 3;
+ Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4;
+ Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5;
+
+ Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16;
+ Ghdl_Rti_Signal_Kind_Offset : constant Ghdl_Rti_U8 := 1 * 16;
+ Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16;
+ Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16;
+ Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16;
+
+ Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64;
+
+ type Ghdl_Rtin_Component is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr_Child : Ghdl_Index_Type;
+ Children : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component;
+ function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc);
+
+ type Ghdl_Rtin_Type_Enum is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr : Ghdl_Index_Type;
+ -- Characters are represented as 'X', identifiers are represented as is,
+ -- extended identifiers are represented as is too.
+ Names : Ghdl_C_String_Array_Ptr;
+ end record;
+ type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum;
+ function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc);
+
+ type Ghdl_Rtin_Type_Scalar is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ end record;
+ type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar;
+ function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc);
+
+ type Ghdl_Rtin_Subtype_Scalar is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Basetype : Ghdl_Rti_Access;
+ Range_Loc : Ghdl_Rti_Loc;
+ end record;
+ type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar;
+ function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access);
+
+ -- True if the type is complex, set in Mode field.
+ Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1;
+ Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1;
+
+ -- True if the type is anonymous
+ Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2;
+ Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2;
+
+ type Ghdl_Rtin_Type_Array is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Element : Ghdl_Rti_Access;
+ Nbr_Dim : Ghdl_Index_Type;
+ Indexes : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array;
+ function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Subtype_Array is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Basetype : Ghdl_Rtin_Type_Array_Acc;
+ Bounds : Ghdl_Rti_Loc;
+ Valsize : Ghdl_Rti_Loc;
+ Sigsize : Ghdl_Rti_Loc;
+ end record;
+ type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array;
+ function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Type_Fileacc is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Base : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc;
+ function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc);
+
+ type Ghdl_Rtin_Element is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Eltype : Ghdl_Rti_Access;
+ Val_Off : Ghdl_Index_Type;
+ Sig_Off : Ghdl_Index_Type;
+ end record;
+ type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element;
+ function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc);
+
+ type Ghdl_Rtin_Type_Record is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbrel : Ghdl_Index_Type;
+ Elements : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record;
+ function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc);
+
+ type Ghdl_Rtin_Unit64 is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Value : Ghdl_I64;
+ end record;
+ type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64;
+ function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc);
+
+ type Ghdl_Rtin_Unitptr is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Addr : Ghdl_Value_Ptr;
+ end record;
+ type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr;
+ function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc);
+
+ -- Mode field is set to 4 if units value is per address. Otherwise,
+ -- mode is 0.
+ type Ghdl_Rtin_Type_Physical is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr : Ghdl_Index_Type;
+ Units : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical;
+ function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc);
+
+ -- Instance linkage.
+
+ -- At the beginning of a component structure (or the object for a direct
+ -- instantiation), there is a Ghdl_Component_Link_Type record.
+ -- These record contains a pointer to the instance (down link),
+ -- and RTIS to the statement and its parent (up link).
+ type Ghdl_Component_Link_Type;
+ type Ghdl_Component_Link_Acc is access Ghdl_Component_Link_Type;
+
+ -- At the beginning of an entity structure, there is a Ghdl_Link_Type,
+ -- which contains the RTI for the architecture (down-link) and a pointer
+ -- to the instantiation object (up-link).
+ type Ghdl_Entity_Link_Type is record
+ Rti : Ghdl_Rti_Access;
+ Parent : Ghdl_Component_Link_Acc;
+ end record;
+
+ type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type;
+
+ function To_Ghdl_Entity_Link_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Entity_Link_Acc);
+
+ type Ghdl_Component_Link_Type is record
+ Instance : Ghdl_Entity_Link_Acc;
+ Stmt : Ghdl_Rti_Access;
+ end record;
+
+ function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Component_Link_Acc);
+
+ -- TOP rti.
+ Ghdl_Rti_Top : Ghdl_Rtin_Block :=
+ (Common => (Ghdl_Rtik_Top, 0, 0, 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Parent => null,
+ Size => 0,
+ Nbr_Child => 0,
+ Children => null);
+
+ -- Address of the top instance.
+ Ghdl_Rti_Top_Instance : Address;
+
+ -- Instances have a pointer to their RTI at offset 0.
+ type Ghdl_Rti_Acc_Acc is access Ghdl_Rti_Access;
+ function To_Ghdl_Rti_Acc_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Rti_Acc_Acc);
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Address);
+
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Rti_Access);
+
+ procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type;
+ Pkgs : Ghdl_Rti_Arr_Acc;
+ Top : Ghdl_Rti_Access;
+ Instance : Address);
+ pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top");
+
+ -- Register a package
+ procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access);
+ pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package");
+end Grt.Rtis;
diff --git a/src/translate/grt/grt-rtis_addr.adb b/src/translate/grt/grt-rtis_addr.adb
new file mode 100644
index 000000000..70a0e2118
--- /dev/null
+++ b/src/translate/grt/grt-rtis_addr.adb
@@ -0,0 +1,299 @@
+-- GHDL Run Time (GRT) - RTI address handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Rtis_Addr is
+ function "+" (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) + R);
+ end "+";
+
+ function "+" (L : Address; R : Ghdl_Index_Type) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) + Integer_Address (R));
+ end "+";
+
+ function "-" (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) - R);
+ end "-";
+
+ function Align (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ Nad : Integer_Address;
+ begin
+ Nad := To_Integer (L + (R - 1));
+ return To_Address (Nad - (Nad mod R));
+ end Align;
+
+ function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Ctxt.Block.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ return (Base => Ctxt.Base - Blk.Loc,
+ Block => Blk.Parent);
+ when Ghdl_Rtik_Architecture =>
+ if Blk.Loc /= Null_Rti_Loc then
+ Internal_Error ("get_parent_context(3)");
+ end if;
+ return (Base => Ctxt.Base + Blk.Loc,
+ Block => Blk.Parent);
+ when Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate =>
+ declare
+ Nbase : Address;
+ Parent : Ghdl_Rti_Access;
+ Blk1 : Ghdl_Rtin_Block_Acc;
+ begin
+ -- Read the pointer to the parent.
+ -- This is the first field.
+ Nbase := To_Addr_Acc (Ctxt.Base).all;
+ -- Since the parent may be a grant-parent, adjust
+ -- the base.
+ Parent := Blk.Parent;
+ loop
+ case Parent.Kind is
+ when Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate =>
+ exit;
+ when Ghdl_Rtik_Block =>
+ Blk1 := To_Ghdl_Rtin_Block_Acc (Parent);
+ Nbase := Nbase + Blk1.Loc;
+ Parent := Blk1.Parent;
+ when others =>
+ Internal_Error ("get_parent_context(2)");
+ end case;
+ end loop;
+ return (Base => Nbase,
+ Block => Blk.Parent);
+ end;
+ when others =>
+ Internal_Error ("get_parent_context(1)");
+ end case;
+ end Get_Parent_Context;
+
+ procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc;
+ Ctxt : out Rti_Context;
+ Stmt : out Ghdl_Rti_Access)
+ is
+ Obj : Ghdl_Rtin_Instance_Acc;
+ begin
+ if Link.Parent = null then
+ -- Top entity.
+ Stmt := null;
+ Ctxt := (Base => Null_Address, Block => null);
+ else
+ Stmt := Link.Parent.Stmt;
+ Obj := To_Ghdl_Rtin_Instance_Acc (Stmt);
+ Ctxt := (Base => Link.Parent.all'Address - Obj.Loc,
+ Block => Obj.Parent);
+ end if;
+ end Get_Instance_Link;
+
+ function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
+ Loc : Ghdl_Rti_Loc;
+ Ctxt : Rti_Context)
+ return Address
+ is
+ Cur_Ctxt : Rti_Context;
+ Nctxt : Rti_Context;
+ begin
+ if Depth = 0 then
+ return To_Address (Loc);
+ elsif Ctxt.Block.Depth = Depth then
+ --Addr := Base + Storage_Offset (Obj.Loc.Off);
+ return Ctxt.Base + Loc;
+ else
+ if Ctxt.Block.Depth < Depth then
+ Internal_Error ("loc_to_addr");
+ end if;
+ Cur_Ctxt := Ctxt;
+ loop
+ Nctxt := Get_Parent_Context (Cur_Ctxt);
+ if Nctxt.Block.Depth = Depth then
+ return Nctxt.Base + Loc;
+ end if;
+ Cur_Ctxt := Nctxt;
+ end loop;
+ end if;
+ end Loc_To_Addr;
+
+ function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access)
+ return Ghdl_Index_Type
+ is
+ begin
+ case Base_Type.Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ return Rng.B1.Len;
+ when Ghdl_Rtik_Type_E8 =>
+ return Rng.E8.Len;
+ when Ghdl_Rtik_Type_E32 =>
+ return Rng.E32.Len;
+ when Ghdl_Rtik_Type_I32 =>
+ return Rng.I32.Len;
+ when others =>
+ Internal_Error ("range_to_length");
+ end case;
+ end Range_To_Length;
+
+ function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context)
+ return Ghdl_Index_Type
+ is
+ Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc;
+ Rng : Ghdl_Range_Ptr;
+ begin
+ Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc
+ (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type);
+ if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then
+ Internal_Error ("get_for_generate_length(1)");
+ end if;
+ Rng := To_Ghdl_Range_Ptr
+ (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt));
+ return Range_To_Length (Rng, Iter_Type.Basetype);
+ end Get_For_Generate_Length;
+
+ procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Sub_Ctxt : out Rti_Context)
+ is
+ Inst_Addr : Address;
+ Inst_Base : Address;
+ begin
+ -- Address of the field containing the address of the instance.
+ Inst_Addr := Ctxt.Base + Inst.Loc;
+ -- Read sub instance address.
+ Inst_Base := To_Addr_Acc (Inst_Addr).all;
+ -- Read instance RTI.
+ if Inst_Base = Null_Address then
+ Sub_Ctxt := (Base => Null_Address, Block => null);
+ else
+ Sub_Ctxt := (Base => Inst_Base,
+ Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all);
+ end if;
+ end Get_Instance_Context;
+
+ procedure Bound_To_Range (Bounds_Addr : Address;
+ Def : Ghdl_Rtin_Type_Array_Acc;
+ Res : out Ghdl_Range_Array)
+ is
+ Bounds : Address;
+
+ procedure Align (A : Ghdl_Index_Type) is
+ begin
+ Bounds := Align (Bounds, Ghdl_Rti_Loc (A));
+ end Align;
+
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Bounds := Bounds + (S / Storage_Unit);
+ end Update;
+
+ Idx_Def : Ghdl_Rti_Access;
+ begin
+ if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then
+ Internal_Error ("disp_rti.bound_to_range");
+ end if;
+
+ Bounds := Bounds_Addr;
+
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ Idx_Def := Def.Indexes (I);
+
+ if Bounds = Null_Address then
+ Res (I) := null;
+ else
+ Idx_Def := Get_Base_Type (Idx_Def);
+ case Idx_Def.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Align (Ghdl_Range_I32'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_I32'Size);
+ when Ghdl_Rtik_Type_E8 =>
+ Align (Ghdl_Range_E8'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_E8'Size);
+ when Ghdl_Rtik_Type_E32 =>
+ Align (Ghdl_Range_E32'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_E32'Size);
+ when others =>
+ -- Bounds are not known anymore.
+ Bounds := Null_Address;
+ end case;
+ end if;
+ end loop;
+ end Bound_To_Range;
+
+ function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access
+ is
+ begin
+ case Atype.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype;
+ when Ghdl_Rtik_Subtype_Array =>
+ return To_Ghdl_Rti_Access
+ (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype);
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ return Atype;
+ when others =>
+ Internal_Error ("rtis_addr.get_base_type");
+ end case;
+ end Get_Base_Type;
+
+ function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean
+ is
+ begin
+ return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask)
+ = Ghdl_Rti_Type_Complex;
+ end Rti_Complex_Type;
+
+ function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean
+ is
+ begin
+ return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask)
+ = Ghdl_Rti_Type_Anonymous;
+ end Rti_Anonymous_Type;
+
+ function Get_Top_Context return Rti_Context
+ is
+ Ctxt : Rti_Context;
+ begin
+ Ctxt := (Base => Ghdl_Rti_Top_Instance,
+ Block => Ghdl_Rti_Top.Parent);
+ return Ctxt;
+ end Get_Top_Context;
+
+end Grt.Rtis_Addr;
diff --git a/src/translate/grt/grt-rtis_addr.ads b/src/translate/grt/grt-rtis_addr.ads
new file mode 100644
index 000000000..3fa2792af
--- /dev/null
+++ b/src/translate/grt/grt-rtis_addr.ads
@@ -0,0 +1,110 @@
+-- GHDL Run Time (GRT) - RTI address handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+-- Addresses handling.
+package Grt.Rtis_Addr is
+ function "+" (L : Address; R : Ghdl_Rti_Loc) return Address;
+ function "+" (L : Address; R : Ghdl_Index_Type) return Address;
+
+ function "-" (L : Address; R : Ghdl_Rti_Loc) return Address;
+
+ function Align (L : Address; R : Ghdl_Rti_Loc) return Address;
+
+ -- An RTI context contains a pointer (BASE) to or into an instance.
+ -- BLOCK describes data being pointed. If a reference is made to a field
+ -- described by a parent of BLOCK, BASE must be modified.
+ type Rti_Context is record
+ Base : Address;
+ Block : Ghdl_Rti_Access;
+ end record;
+
+ Null_Context : constant Rti_Context;
+
+ -- Access to an address.
+ type Addr_Acc is access Address;
+ function To_Addr_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Addr_Acc);
+
+ type Ghdl_Index_Acc is access Ghdl_Index_Type;
+ function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Index_Acc);
+
+ -- Get the parent context of CTXT.
+ -- The parent of an architecture is its entity.
+ function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context;
+
+ -- From an entity link, extract context and instantiation statement.
+ procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc;
+ Ctxt : out Rti_Context;
+ Stmt : out Ghdl_Rti_Access);
+
+ -- Convert a location to an address.
+ function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
+ Loc : Ghdl_Rti_Loc;
+ Ctxt : Rti_Context)
+ return Address;
+
+ -- Get the length of for_generate BLK.
+ function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context)
+ return Ghdl_Index_Type;
+
+ -- Get the context of instance INST.
+ procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Sub_Ctxt : out Rti_Context);
+
+ -- Extract range of every dimension from bounds.
+ procedure Bound_To_Range (Bounds_Addr : Address;
+ Def : Ghdl_Rtin_Type_Array_Acc;
+ Res : out Ghdl_Range_Array);
+
+ function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access)
+ return Ghdl_Index_Type;
+
+ -- Get the base type of ATYPE.
+ function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access;
+
+ -- Return true iff ATYPE is anonymous.
+ -- Valid only on type and subtype definitions.
+ function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean;
+ pragma Inline (Rti_Anonymous_Type);
+
+ -- Return true iff ATYPE is complex.
+ -- Valid only on type and subtype definitions.
+ function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean;
+ pragma Inline (Rti_Complex_Type);
+
+ -- Get the top context.
+ function Get_Top_Context return Rti_Context;
+
+private
+ Null_Context : constant Rti_Context := (Base => Null_Address,
+ Block => null);
+end Grt.Rtis_Addr;
diff --git a/src/translate/grt/grt-rtis_binding.ads b/src/translate/grt/grt-rtis_binding.ads
new file mode 100644
index 000000000..7e90eeafc
--- /dev/null
+++ b/src/translate/grt/grt-rtis_binding.ads
@@ -0,0 +1,67 @@
+-- GHDL Run Time (GRT) - Well known RTIs.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Rtis; use Grt.Rtis;
+
+-- Set RTI_ptr defined in grt.rtis_types.
+
+package Grt.Rtis_Binding is
+ pragma Preelaborate (Grt.Rtis_Binding);
+
+ -- Define and set bit and boolean RTIs.
+ Std_Standard_Bit_RTI : aliased Ghdl_Rti_Common;
+
+ Std_Standard_Boolean_RTI : aliased Ghdl_Rti_Common;
+
+ pragma Import (C, Std_Standard_Bit_RTI,
+ "std__standard__bit__RTI");
+
+ pragma Import (C, Std_Standard_Boolean_RTI,
+ "std__standard__boolean__RTI");
+
+ Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access
+ := Std_Standard_Bit_RTI'Access;
+
+ Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access
+ := Std_Standard_Boolean_RTI'Access;
+
+ pragma Export (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Export (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+
+
+ -- Define and set Resolved_Resolv_Ptr.
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV;
+ pragma Import (C, Ieee_Std_Logic_1164_Resolved_RESOLV,
+ "ieee__std_logic_1164__resolved_RESOLV");
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address :=
+ Ieee_Std_Logic_1164_Resolved_RESOLV'Address;
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+end Grt.Rtis_Binding;
diff --git a/src/translate/grt/grt-rtis_types.adb b/src/translate/grt/grt-rtis_types.adb
new file mode 100644
index 000000000..f22a309bc
--- /dev/null
+++ b/src/translate/grt/grt-rtis_types.adb
@@ -0,0 +1,118 @@
+-- GHDL Run Time (GRT) - Well known RTI types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Astdio;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package body Grt.Rtis_Types is
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ use Grt.Astdio;
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("grt.rtis_utils.Avhpi_Error!");
+ end Avhpi_Error;
+
+ -- Extract std_ulogic type.
+ procedure Search_Types (Pack : VhpiHandleT)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+
+ Error : AvhpiErrorT;
+ Name : String (1 .. 16);
+ Name_Len : Natural;
+ Rti : Ghdl_Rti_Access;
+ begin
+ Vhpi_Get_Str (VhpiLibLogicalNameP, Pack, Name, Name_Len);
+ if not (Name_Len = 4 and then Name (1 .. 4)= "ieee") then
+ return;
+ end if;
+
+ Vhpi_Iterator (VhpiDecls, Pack, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract packages.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ if Vhpi_Get_Kind (Decl) = VhpiEnumTypeDeclK then
+ Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len);
+ Rti := Avhpi_Get_Rti (Decl);
+ if Name_Len = 10 and then Name (1 .. 10) = "std_ulogic" then
+ Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr := Rti;
+ end if;
+ end if;
+ end loop;
+ end Search_Types;
+
+ procedure Search_Packages
+ is
+ Pack : VhpiHandleT;
+ Pack_It : VhpiHandleT;
+
+ Error : AvhpiErrorT;
+ Name : String (1 .. 16);
+ Name_Len : Natural;
+ begin
+ Get_Package_Inst (Pack_It);
+
+ -- Extract packages.
+ loop
+ Vhpi_Scan (Pack_It, Pack, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Vhpi_Get_Str (VhpiNameP, Pack, Name, Name_Len);
+ if Name_Len = 14 and then Name (1 .. 14) = "std_logic_1164" then
+ Search_Types (Pack);
+ end if;
+ end loop;
+ end Search_Packages;
+
+ Search_Types_RTI_Done : Boolean := False;
+
+ procedure Search_Types_RTI is
+ begin
+ if Search_Types_RTI_Done then
+ return;
+ else
+ Search_Types_RTI_Done := True;
+ end if;
+
+ Search_Packages;
+ end Search_Types_RTI;
+end Grt.Rtis_Types;
diff --git a/src/translate/grt/grt-rtis_types.ads b/src/translate/grt/grt-rtis_types.ads
new file mode 100644
index 000000000..f64b17324
--- /dev/null
+++ b/src/translate/grt/grt-rtis_types.ads
@@ -0,0 +1,55 @@
+-- GHDL Run Time (GRT) - Well known RTI types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Rtis; use Grt.Rtis;
+
+-- This package allow access to RTIs of some types.
+-- This is used to recognize some VHDL logic types.
+-- This is also used by grt.signals to set types of some implicit signals
+-- (such as 'stable or 'transation).
+
+package Grt.Rtis_Types is
+ -- RTIs for some logic types.
+ Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access;
+
+ Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access;
+
+ -- std_ulogic.
+ -- A VHDL may not contain ieee.std_logic_1164 package. So, this RTI
+ -- must be dynamicaly searched.
+ Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr : Ghdl_Rti_Access := null;
+
+ -- Search RTI for types.
+ -- If a type is not found, its RTI is set to null.
+ -- If this procedure has already been called, then this is a noop.
+ procedure Search_Types_RTI;
+private
+ -- These are set either by grt.rtis_binding or by ghdlrun.
+ -- This is not very clean...
+ pragma Import (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Import (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+end Grt.Rtis_Types;
diff --git a/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb
new file mode 100644
index 000000000..0d4328e7e
--- /dev/null
+++ b/src/translate/grt/grt-rtis_utils.adb
@@ -0,0 +1,660 @@
+-- GHDL Run Time (GRT) - RTI utilities.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+--with Grt.Disp; use Grt.Disp;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Rtis_Utils is
+
+ function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result
+ is
+ function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result;
+
+ function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+
+ Res : Traverse_Result;
+ Nctxt : Rti_Context;
+ Index : Ghdl_Index_Type;
+ Child : Ghdl_Rti_Access;
+ begin
+ Res := Process (Ctxt, Ctxt.Block);
+ if Res /= Traverse_Ok then
+ return Res;
+ end if;
+
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ Index := 0;
+ while Index < Blk.Nbr_Child loop
+ Child := Blk.Children (Index);
+ Index := Index + 1;
+ case Child.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt := (Base => Ctxt.Base + Nblk.Loc,
+ Block => Child);
+ Res := Traverse_Blocks_1 (Nctxt);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ Length : Ghdl_Index_Type;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt :=
+ (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Length := Get_For_Generate_Length (Nblk, Ctxt);
+ for I in 1 .. Length loop
+ Res := Traverse_Blocks_1 (Nctxt);
+ exit when Res = Traverse_Stop;
+ Nctxt.Base := Nctxt.Base + Nblk.Size;
+ end loop;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt :=
+ (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ if Nctxt.Base /= Null_Address then
+ Res := Traverse_Blocks_1 (Nctxt);
+ end if;
+ end;
+ when Ghdl_Rtik_Instance =>
+ Res := Process (Ctxt, Child);
+ if Res = Traverse_Ok then
+ declare
+ Obj : Ghdl_Rtin_Instance_Acc;
+ begin
+ Obj := To_Ghdl_Rtin_Instance_Acc (Child);
+
+ Get_Instance_Context (Obj, Ctxt, Nctxt);
+ if Nctxt /= Null_Context then
+ Res := Traverse_Instance (Nctxt);
+ end if;
+ end;
+ end if;
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture =>
+ Internal_Error ("traverse_blocks");
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Res := Process (Ctxt, Child);
+ when others =>
+ null;
+ end case;
+ exit when Res = Traverse_Stop;
+ end loop;
+
+ return Res;
+ end Traverse_Blocks_1;
+
+ function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+
+ Res : Traverse_Result;
+ Nctxt : Rti_Context;
+
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ -- The entity.
+ Res := Traverse_Blocks_1 (Nctxt);
+ if Res /= Traverse_Stop then
+ -- The architecture.
+ Res := Traverse_Blocks_1 (Ctxt);
+ end if;
+ when Ghdl_Rtik_Package_Body =>
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ Res := Traverse_Blocks_1 (Nctxt);
+ when others =>
+ Internal_Error ("traverse_blocks");
+ end case;
+ return Res;
+ end Traverse_Instance;
+ begin
+ return Traverse_Instance (Ctxt);
+ end Traverse_Blocks;
+
+ -- Disp value stored at ADDR and whose type is described by RTI.
+ procedure Get_Enum_Value
+ (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Append (Vstr, Enum_Rti.Names (Val));
+ end Get_Enum_Value;
+
+
+ procedure Foreach_Scalar (Ctxt : Rti_Context;
+ Obj_Type : Ghdl_Rti_Access;
+ Obj_Addr : Address;
+ Is_Sig : Boolean;
+ Param : Param_Type)
+ is
+ -- Current address.
+ Addr : Address;
+
+ Name : Vstring;
+
+ procedure Handle_Any (Rti : Ghdl_Rti_Access);
+
+ procedure Handle_Scalar (Rti : Ghdl_Rti_Access)
+ is
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Addr := Addr + (S / Storage_Unit);
+ end Update;
+ begin
+ Process (Addr, Name, Rti, Param);
+
+ if Is_Sig then
+ Update (Address'Size);
+ else
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Update (32);
+ when Ghdl_Rtik_Type_E8 =>
+ Update (8);
+ when Ghdl_Rtik_Type_E32 =>
+ Update (32);
+ when Ghdl_Rtik_Type_B1 =>
+ Update (8);
+ when Ghdl_Rtik_Type_F64 =>
+ Update (64);
+ when Ghdl_Rtik_Type_P64 =>
+ Update (64);
+ when others =>
+ Internal_Error ("handle_scalar");
+ end case;
+ end if;
+ end Handle_Scalar;
+
+ procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access;
+ Rng : Ghdl_Range_Ptr;
+ Pos : Ghdl_Index_Type;
+ Val : out Value_Union)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ case Rng.I32.Dir is
+ when Dir_To =>
+ Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos);
+ when Dir_Downto =>
+ Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_E8 =>
+ case Rng.E8.Dir is
+ when Dir_To =>
+ Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos);
+ when Dir_Downto =>
+ Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_E32 =>
+ case Rng.E32.Dir is
+ when Dir_To =>
+ Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos);
+ when Dir_Downto =>
+ Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_B1 =>
+ case Pos is
+ when 0 =>
+ Val.B1 := Rng.B1.Left;
+ when 1 =>
+ Val.B1 := Rng.B1.Right;
+ when others =>
+ Val.B1 := False;
+ end case;
+ when others =>
+ Internal_Error ("grt.rtis_utils.range_pos_to_val");
+ end case;
+ end Range_Pos_To_Val;
+
+ procedure Pos_To_Vstring
+ (Vstr : in out Vstring;
+ Rti : Ghdl_Rti_Access;
+ Rng : Ghdl_Range_Ptr;
+ Pos : Ghdl_Index_Type)
+ is
+ V : Value_Union;
+ begin
+ Range_Pos_To_Val (Rti, Rng, Pos, V);
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, V.I32);
+ Append (Vstr, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1));
+ when others =>
+ Append (Vstr, '?');
+ end case;
+ end Pos_To_Vstring;
+
+ procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access;
+ Rngs : Ghdl_Range_Array;
+ Rtis : Ghdl_Rti_Arr_Acc;
+ Index : Ghdl_Index_Type)
+ is
+ Len : Ghdl_Index_Type;
+ P : Natural;
+ Base_Type : Ghdl_Rti_Access;
+ begin
+ P := Length (Name);
+ if Index = 0 then
+ Append (Name, '(');
+ else
+ Append (Name, ',');
+ end if;
+
+ Base_Type := Get_Base_Type (Rtis (Index));
+ Len := Range_To_Length (Rngs (Index), Base_Type);
+
+ for I in 1 .. Len loop
+ Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1);
+ if Index = Rngs'Last then
+ Append (Name, ')');
+ Handle_Any (El_Rti);
+ else
+ Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1);
+ end if;
+ Truncate (Name, P + 1);
+ end loop;
+ Truncate (Name, P);
+ end Handle_Array_1;
+
+ procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc;
+ Vals : Ghdl_Uc_Array_Acc)
+ is
+ Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim;
+ Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
+ begin
+ Bound_To_Range (Vals.Bounds, Rti, Rngs);
+ Addr := Vals.Base;
+ Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0);
+ end Handle_Array;
+
+ procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ Obj_Addr : Address;
+ Last_Addr : Address;
+ P : Natural;
+ begin
+ P := Length (Name);
+ Obj_Addr := Addr;
+ Last_Addr := Addr;
+ for I in 1 .. Rti.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
+ if Is_Sig then
+ Addr := Obj_Addr + El.Sig_Off;
+ else
+ Addr := Obj_Addr + El.Val_Off;
+ end if;
+ if Rti_Complex_Type (El.Eltype) then
+ Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all;
+ end if;
+ Append (Name, '.');
+ Append (Name, El.Name);
+ Handle_Any (El.Eltype);
+ if Addr > Last_Addr then
+ Last_Addr := Addr;
+ end if;
+ Truncate (Name, P);
+ end loop;
+ Addr := Last_Addr;
+ end Handle_Record;
+
+ procedure Handle_Any (Rti : Ghdl_Rti_Access) is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ Handle_Scalar (Rti);
+ when Ghdl_Rtik_Type_Array =>
+ Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti),
+ To_Ghdl_Uc_Array_Acc (Addr));
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+ Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0);
+ end;
+-- when Ghdl_Rtik_Type_File =>
+-- declare
+-- Vptr : Ghdl_Value_Ptr;
+-- begin
+-- Vptr := To_Ghdl_Value_Ptr (Obj);
+-- Put (Stream, "File#");
+-- Put_I32 (Stream, Vptr.I32);
+-- -- FIXME: update OBJ (not very useful since never in a
+-- -- composite type).
+-- end;
+ when Ghdl_Rtik_Type_Record =>
+ Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
+ when others =>
+ Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
+ end case;
+ end Handle_Any;
+ begin
+ if Rti_Complex_Type (Obj_Type) then
+ Addr := To_Addr_Acc (Obj_Addr).all;
+ else
+ Addr := Obj_Addr;
+ end if;
+ Handle_Any (Obj_Type);
+ Free (Name);
+ end Foreach_Scalar;
+
+ procedure Get_Value (Str : in out Vstring;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ begin
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Append (Str, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value
+ (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
+ when Ghdl_Rtik_Type_F64 =>
+ declare
+ S : String (1 .. 32);
+ L : Integer;
+
+ function Snprintf_G (Cstr : Address;
+ Size : Natural;
+ Arg : Ghdl_F64)
+ return Integer;
+ pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");
+
+ begin
+ L := Snprintf_G (S'Address, S'Length, Value.F64);
+ if L < 0 then
+ -- FIXME.
+ Append (Str, "?");
+ else
+ Append (Str, S (1 .. L));
+ end if;
+ end;
+ when Ghdl_Rtik_Type_P32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Append (Str, S (F .. S'Last));
+ Append
+ (Str, Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
+ end;
+ when Ghdl_Rtik_Type_P64 =>
+ declare
+ S : String (1 .. 21);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I64);
+ Append (Str, S (F .. S'Last));
+ Append
+ (Str, Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
+ end;
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_value");
+ end case;
+ end Get_Value;
+
+ procedure Disp_Value (Stream : FILEs;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ Name : Vstring;
+ begin
+ Rtis_Utils.Get_Value (Name, Value, Type_Rti);
+ Put (Stream, Name);
+ Free (Name);
+ end Disp_Value;
+
+ function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
+ return Ghdl_C_String
+ is
+ begin
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ return To_Ghdl_Rtin_Unit64_Acc (Unit).Name;
+ when Ghdl_Rtik_Unitptr =>
+ return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name;
+ when others =>
+ Internal_Error ("rtis_utils.physical_unit_name");
+ end case;
+ end Get_Physical_Unit_Name;
+
+ function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
+ Type_Rti : Ghdl_Rti_Access)
+ return Ghdl_I64 is
+ begin
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ return To_Ghdl_Rtin_Unit64_Acc (Unit).Value;
+ when Ghdl_Rtik_Unitptr =>
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64;
+ when Ghdl_Rtik_Type_P32 =>
+ return Ghdl_I64
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
+ when others =>
+ Internal_Error ("get_physical_unit_value(1)");
+ end case;
+ when others =>
+ Internal_Error ("get_physical_unit_value(2)");
+ end case;
+ end Get_Physical_Unit_Value;
+
+ procedure Get_Enum_Value
+ (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Prepend (Rstr, Enum_Rti.Names (Val));
+ end Get_Enum_Value;
+
+
+ procedure Get_Value (Rstr : in out Rstring;
+ Addr : Address;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr);
+ begin
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Prepend (Rstr, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value
+ (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_value(rstr)");
+ end case;
+ end Get_Value;
+
+ procedure Get_Path_Name (Rstr : in out Rstring;
+ Last_Ctxt : Rti_Context;
+ Sep : Character;
+ Is_Instance : Boolean := True)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context;
+ begin
+ Ctxt := Last_Ctxt;
+ loop
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Ctxt.Block.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate =>
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, Sep);
+ Ctxt := Get_Parent_Context (Ctxt);
+ when Ghdl_Rtik_Entity =>
+ declare
+ Link : Ghdl_Entity_Link_Acc;
+ begin
+ Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base);
+ Ctxt := (Base => Ctxt.Base,
+ Block => Link.Rti);
+ if Ctxt.Block = null then
+ -- Process in an entity.
+ -- FIXME: check.
+ Prepend (Rstr, Blk.Name);
+ return;
+ end if;
+ end;
+ when Ghdl_Rtik_Architecture =>
+ declare
+ Entity_Ctxt: Rti_Context;
+ Link : Ghdl_Entity_Link_Acc;
+ Parent_Inst : Ghdl_Rti_Access;
+ begin
+ -- Architecture name.
+ if Is_Instance then
+ Prepend (Rstr, ')');
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, '(');
+ end if;
+
+ Entity_Ctxt := Get_Parent_Context (Ctxt);
+
+ -- Instance parent.
+ Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base);
+ Get_Instance_Link (Link, Ctxt, Parent_Inst);
+
+ -- Add entity name.
+ if Is_Instance or Parent_Inst = null then
+ Prepend (Rstr,
+ To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name);
+ end if;
+
+ if Parent_Inst = null then
+ -- Top reached.
+ Prepend (Rstr, Sep);
+ return;
+ else
+ -- Instantiation statement label.
+ if Is_Instance then
+ Prepend (Rstr, '@');
+ end if;
+ Prepend (Rstr,
+ To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name);
+ Prepend (Rstr, Sep);
+ end if;
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Iter : Ghdl_Rtin_Object_Acc;
+ Addr : Address;
+ begin
+ Prepend (Rstr, ')');
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+ Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
+ Prepend (Rstr, '(');
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, Sep);
+ Ctxt := Get_Parent_Context (Ctxt);
+ end;
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_path_name");
+ end case;
+ end loop;
+ end Get_Path_Name;
+
+ procedure Put (Stream : FILEs; Ctxt : Rti_Context)
+ is
+ Rstr : Rstring;
+ begin
+ Get_Path_Name (Rstr, Ctxt, '.');
+ Put (Stream, Rstr);
+ Free (Rstr);
+ end Put;
+
+end Grt.Rtis_Utils;
diff --git a/src/translate/grt/grt-rtis_utils.ads b/src/translate/grt/grt-rtis_utils.ads
new file mode 100644
index 000000000..10c1a0f28
--- /dev/null
+++ b/src/translate/grt/grt-rtis_utils.ads
@@ -0,0 +1,92 @@
+-- GHDL Run Time (GRT) - RTI utilities.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Rtis_Utils is
+ -- Action to perform after a node was handled by the user function:
+ -- Traverse_Ok: continue to process.
+ -- Traverse_Skip: do not traverse children.
+ -- Traverse_Stop: end of walk.
+ type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop);
+
+ -- An RTI object is a context and an RTI declaration.
+ type Rti_Object is record
+ Obj : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ end record;
+
+ -- Traverse all blocks (package, entities, architectures, block, generate,
+ -- processes).
+ generic
+ with function Process (Ctxt : Rti_Context;
+ Obj : Ghdl_Rti_Access)
+ return Traverse_Result;
+ function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result;
+
+ generic
+ type Param_Type is private;
+ with procedure Process (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Param_Type);
+ procedure Foreach_Scalar (Ctxt : Rti_Context;
+ Obj_Type : Ghdl_Rti_Access;
+ Obj_Addr : Address;
+ Is_Sig : Boolean;
+ Param : Param_Type);
+
+ procedure Get_Value (Str : in out Vstring;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access);
+
+ -- Get the name of a physical unit.
+ function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
+ return Ghdl_C_String;
+
+ -- Get the value of a physical unit.
+ function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
+ Type_Rti : Ghdl_Rti_Access)
+ return Ghdl_I64;
+
+ -- Disp a value.
+ procedure Disp_Value (Stream : FILEs;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access);
+
+ -- Get context as a path name.
+ -- If IS_INSTANCE is true, the architecture name of entities is added.
+ procedure Get_Path_Name (Rstr : in out Rstring;
+ Last_Ctxt : Rti_Context;
+ Sep : Character;
+ Is_Instance : Boolean := True);
+
+ -- Disp a context as a path.
+ procedure Put (Stream : FILEs; Ctxt : Rti_Context);
+end Grt.Rtis_Utils;
diff --git a/src/translate/grt/grt-sdf.adb b/src/translate/grt/grt-sdf.adb
new file mode 100644
index 000000000..73534e3eb
--- /dev/null
+++ b/src/translate/grt/grt-sdf.adb
@@ -0,0 +1,1389 @@
+-- GHDL Run Time (GRT) - SDF parser.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Errors; use Grt.Errors;
+with Ada.Characters.Latin_1;
+with Ada.Unchecked_Deallocation;
+with Grt.Vital_Annotate;
+
+package body Grt.Sdf is
+ EOT : constant Character := Character'Val (4);
+
+ type Sdf_Token_Type is
+ (
+ Tok_Oparen, -- (
+ Tok_Cparen, -- )
+ Tok_Qstring,
+ Tok_Identifier,
+ Tok_Rnumber,
+ Tok_Dnumber,
+ Tok_Div, -- /
+ Tok_Dot, -- .
+ Tok_Cln, -- :
+
+ Tok_Error,
+ Tok_Eof
+ );
+
+ type Sdf_Context_Acc is access Sdf_Context_Type;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => Sdf_Context_Acc, Object => Sdf_Context_Type);
+
+ Sdf_Context : Sdf_Context_Acc;
+
+ -- Current data read from the file.
+ Buf : String_Access (1 .. Buf_Size) := null;
+
+ -- Length of the buffer, including the EOT.
+ Buf_Len : Natural;
+ Pos : Natural;
+ Line_Start : Integer;
+
+ Sdf_Stream : FILEs := NULL_Stream;
+ Sdf_Filename : String_Access := null;
+ Sdf_Line : Natural;
+
+ function Open_Sdf (Filename : String) return Boolean
+ is
+ N_Filename : String (1 .. Filename'Length + 1);
+ Mode : constant String := "rt" & NUL;
+ begin
+ N_Filename (1 .. Filename'Length) := Filename;
+ N_Filename (N_Filename'Last) := NUL;
+ Sdf_Stream := fopen (N_Filename'Address, Mode'Address);
+ if Sdf_Stream = NULL_Stream then
+ Error_C ("cannot open SDF file '");
+ Error_C (Filename);
+ Error_E ("'");
+ return False;
+ end if;
+ Sdf_Context := new Sdf_Context_Type;
+
+ Sdf_Context.Version := Sdf_Version_Unknown;
+
+ -- Set the timescale to 1 ns.
+ Sdf_Context.Timescale := 1000;
+
+ Buf := new String (1 .. Buf_Size);
+ Buf_Len := 1;
+ Buf (1) := EOT;
+ Sdf_Line := 1;
+ Sdf_Filename := new String'(Filename);
+ Pos := 1;
+ Line_Start := 1;
+ return True;
+ end Open_Sdf;
+
+ procedure Close_Sdf
+ is
+ begin
+ fclose (Sdf_Stream);
+ Sdf_Stream := NULL_Stream;
+ Unchecked_Deallocation (Sdf_Context);
+ Unchecked_Deallocation (Buf);
+ end Close_Sdf;
+
+ procedure Read_Sdf
+ is
+ Res : size_t;
+ begin
+ Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream);
+ Line_Start := Line_Start - Buf_Len + Pos;
+ Buf_Len := Pos + Natural (Res);
+ Buf (Buf_Len) := EOT;
+ end Read_Sdf;
+
+
+ Ident_Start : Natural;
+ Ident_End : Natural;
+
+ procedure Read_Append
+ is
+ Len : Natural;
+ begin
+ Len := Pos - Ident_Start;
+ if Ident_Start = 1 or Len >= 1024 then
+ Error_C ("SDF line ");
+ Error_C (Sdf_Line);
+ Error_E (" is too long");
+ return;
+ end if;
+ Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1);
+ Pos := Len + 1;
+ Ident_Start := 1;
+ Read_Sdf;
+ end Read_Append;
+
+ procedure Error_Sdf_C is
+ begin
+ Error_C (Sdf_Filename.all);
+ Error_C (":");
+ Error_C (Sdf_Line);
+ Error_C (":");
+ Error_C (Pos - Line_Start);
+ Error_C (": ");
+ end Error_Sdf_C;
+
+ procedure Error_Sdf (Msg : String) is
+ begin
+ Error_Sdf_C;
+ Error_E (Msg);
+ end Error_Sdf;
+
+ procedure Error_Bad_Character is
+ begin
+ Error_Sdf ("bad character in SDF file");
+ end Error_Bad_Character;
+
+ procedure Scan_Identifier
+ is
+ begin
+ Ident_Start := Pos;
+ loop
+ Pos := Pos + 1;
+ case Buf (Pos) is
+ when 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '0' .. '9'
+ | '_' =>
+ null;
+ when '\' =>
+ Error_Sdf ("escape character not handled");
+ Ident_End := Pos - 1;
+ return;
+ when EOT =>
+ Read_Append;
+ Pos := Pos - 1;
+ when others =>
+ Ident_End := Pos - 1;
+ return;
+ end case;
+ end loop;
+ end Scan_Identifier;
+
+ function Ident_Length return Natural is
+ begin
+ return Ident_End - Ident_Start + 1;
+ end Ident_Length;
+
+ function Is_Ident (Str : String) return Boolean
+ is
+ begin
+ if Ident_Length /= Str'Length then
+ return False;
+ end if;
+ return Buf (Ident_Start .. Ident_End) = Str;
+ end Is_Ident;
+
+ procedure Scan_Qstring
+ is
+ begin
+ Ident_Start := Pos + 1;
+ loop
+ Pos := Pos + 1;
+ case Buf (Pos) is
+ when EOT =>
+ Read_Append;
+ when NUL .. Character'Val (3)
+ | Character'Val (5) .. Character'Val (31)
+ | Character'Val (127) .. Character'Val (255) =>
+ Error_Bad_Character;
+ when ' '
+ | '!'
+ | '#' .. '~' =>
+ null;
+ when '"' => -- "
+ Ident_End := Pos - 1;
+ Pos := Pos + 1;
+ exit;
+ end case;
+ end loop;
+ end Scan_Qstring;
+
+ Scan_Int : Integer;
+ Scan_Exp : Integer;
+
+ function Scan_Number return Sdf_Token_Type
+ is
+ Has_Dot : Boolean;
+ begin
+ Has_Dot := False;
+ Scan_Int := 0;
+ Scan_Exp := 0;
+ loop
+ case Buf (Pos) is
+ when '0' .. '9' =>
+ Scan_Int := Scan_Int * 10
+ + Character'Pos (Buf (Pos)) - Character'Pos ('0');
+ if Has_Dot then
+ Scan_Exp := Scan_Exp - 1;
+ end if;
+ Pos := Pos + 1;
+ when '.' =>
+ if Has_Dot then
+ Error_Bad_Character;
+ return Tok_Error;
+ else
+ Has_Dot := True;
+ end if;
+ Pos := Pos + 1;
+ when EOT =>
+ if Pos /= Buf_Len then
+ Error_Bad_Character;
+ return Tok_Error;
+ end if;
+ Pos := 1;
+ Read_Sdf;
+ exit when Buf_Len = 1;
+ when others =>
+ exit;
+ end case;
+ end loop;
+ if Has_Dot then
+ return Tok_Rnumber;
+ else
+ return Tok_Dnumber;
+ end if;
+ end Scan_Number;
+
+ procedure Refill_Buf is
+ begin
+ Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1);
+ Pos := Buf_Len - Pos + 1;
+ Read_Sdf;
+ Pos := 1;
+ end Refill_Buf;
+
+ procedure Skip_Spaces
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ -- Fast blanks skipping.
+ while Buf (Pos) = ' ' loop
+ Pos := Pos + 1;
+ end loop;
+
+ loop
+ -- Be sure there is at least 1 character.
+ if Pos + 1 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when EOT =>
+ if Pos /= Buf_Len then
+ return;
+ end if;
+ Pos := 1;
+ Read_Sdf;
+ if Buf_Len = 1 then
+ return;
+ end if;
+ when LF =>
+ Pos := Pos + 1;
+ if Buf (Pos) = CR then
+ Pos := Pos + 1;
+ end if;
+ Line_Start := Pos;
+ Sdf_Line := Sdf_Line + 1;
+ when CR =>
+ Pos := Pos + 1;
+ if Buf (Pos) = LF then
+ Pos := Pos + 1;
+ end if;
+ Line_Start := Pos;
+ Sdf_Line := Sdf_Line + 1;
+ when ' '
+ | HT =>
+ Pos := Pos + 1;
+ when '/' =>
+ if Buf (Pos + 1) = '/' then
+ Pos := Pos + 2;
+ -- Skip line comment.
+ loop
+ exit when Buf (Pos) = CR;
+ exit when Buf (Pos) = LF;
+ exit when Buf (Pos) = EOT;
+ Pos := Pos + 1;
+ if Pos >= Buf_Len then
+ Refill_Buf;
+ end if;
+ end loop;
+ else
+ return;
+ end if;
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Skip_Spaces;
+
+ function Get_Token return Sdf_Token_Type
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ Skip_Spaces;
+
+ -- Be sure there is at least 4 characters.
+ if Pos + 4 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when EOT =>
+ if Buf_Len = 1 then
+ return Tok_Eof;
+ else
+ Error_Bad_Character;
+ return Tok_Error;
+ end if;
+ when '"' => -- "
+ Scan_Qstring;
+ return Tok_Qstring;
+ when '/' =>
+ -- Skip_Spaces has already handled line comments.
+ Pos := Pos + 1;
+ return Tok_Div;
+ when '.' =>
+ Pos := Pos + 1;
+ return Tok_Dot;
+ when ':' =>
+ Pos := Pos + 1;
+ return Tok_Cln;
+ when '(' =>
+ Pos := Pos + 1;
+ return Tok_Oparen;
+ when ')' =>
+ Pos := Pos + 1;
+ return Tok_Cparen;
+ when 'a' .. 'z'
+ | 'A' .. 'Z' =>
+ Scan_Identifier;
+ return Tok_Identifier;
+ when '0' .. '9' =>
+ return Scan_Number;
+ when others =>
+ Error_Bad_Character;
+ return Tok_Error;
+ end case;
+ end Get_Token;
+
+ function Is_White_Space (C : Character) return Boolean
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ case C is
+ when ' '
+ | HT
+ | CR
+ | LF =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_White_Space;
+
+ function Get_Edge_Token return Edge_Type
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ Skip_Spaces;
+
+ -- Be sure there is at least 4 characters.
+ if Pos + 4 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when '0' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = 'z' then
+ Pos := Pos + 2;
+ return Edge_0z;
+ elsif Buf (Pos + 1) = '1' then
+ Pos := Pos + 2;
+ return Edge_01;
+ end if;
+ end if;
+ when '1' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = 'z' then
+ Pos := Pos + 2;
+ return Edge_1z;
+ elsif Buf (Pos + 1) = '0' then
+ Pos := Pos + 2;
+ return Edge_10;
+ end if;
+ end if;
+ when 'z' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = '0' then
+ Pos := Pos + 2;
+ return Edge_Z0;
+ elsif Buf (Pos + 1) = '1' then
+ Pos := Pos + 2;
+ return Edge_Z1;
+ end if;
+ end if;
+ when 'p' =>
+ Scan_Identifier;
+ if Is_Ident ("posedge") then
+ return Edge_Posedge;
+ end if;
+ when 'n' =>
+ Scan_Identifier;
+ if Is_Ident ("negedge") then
+ return Edge_Negedge;
+ end if;
+ when others =>
+ null;
+ end case;
+ Error_Sdf ("edge_identifier expected");
+ return Edge_Error;
+ end Get_Edge_Token;
+
+ procedure Error_Sdf (Tok : Sdf_Token_Type)
+ is
+ begin
+ case Tok is
+ when Tok_Qstring =>
+ Error_Sdf ("qstring expected");
+ when Tok_Oparen =>
+ Error_Sdf ("'(' expected");
+ when Tok_Identifier =>
+ Error_Sdf ("identifier expected");
+ when Tok_Cln =>
+ Error_Sdf ("':' (colon) expected");
+ when others =>
+ Error_Sdf ("parse error");
+ end case;
+ end Error_Sdf;
+
+ function Expect (Tok : Sdf_Token_Type) return Boolean
+ is
+ begin
+ if Get_Token = Tok then
+ return True;
+ end if;
+ Error_Sdf (Tok);
+ return False;
+ end Expect;
+
+ function Expect_Cp_Op_Ident (Tok : Sdf_Token_Type) return Boolean
+ is
+ begin
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ if not Expect (Tok_Oparen)
+ or else not Expect (Tok_Identifier)
+ then
+ return False;
+ end if;
+ return True;
+ end Expect_Cp_Op_Ident;
+
+ function Expect_Qstr_Cp_Op_Ident (Str : String) return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ begin
+ if not Is_Ident (Str) then
+ return True;
+ end if;
+
+ Tok := Get_Token;
+ if Tok = Tok_Qstring then
+ Tok := Get_Token;
+ end if;
+
+ return Expect_Cp_Op_Ident (Tok);
+ end Expect_Qstr_Cp_Op_Ident;
+
+ procedure Start_Generic_Name (Kind : Timing_Generic_Kind) is
+ begin
+ Sdf_Context.Kind := Kind;
+ Sdf_Context.Port_Num := 0;
+ Sdf_Context.Ports (1).L := Invalid_Dnumber;
+ Sdf_Context.Ports (2).L := Invalid_Dnumber;
+ Sdf_Context.Ports (1).Edge := Edge_None;
+ Sdf_Context.Ports (2).Edge := Edge_None;
+ end Start_Generic_Name;
+
+ -- Status of a parsing.
+ -- ERROR: parse error (syntax is not correct)
+ -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue).
+ -- OPTIONAL: the construct is absent.
+ -- FOUND: the construct is present.
+ -- SET: the construct is present and a value was extracted from.
+ type Parse_Status_Type is
+ (
+ Status_Error,
+ Status_Altern,
+ Status_Optional,
+ Status_Found,
+ Status_Set
+ );
+
+ function Num_To_Time return Ghdl_I64
+ is
+ Res : Ghdl_I64;
+ begin
+ Res := Ghdl_I64 (Scan_Int) * Ghdl_I64 (Sdf_Context.Timescale);
+ while Scan_Exp < 0 loop
+ Res := Res / 10;
+ Scan_Exp := Scan_Exp + 1;
+ end loop;
+ return Res;
+ end Num_To_Time;
+
+ -- Parse: REXPRESSION? ')'
+ procedure Parse_Rexpression
+ (Status : out Parse_Status_Type; Val : out Ghdl_I64)
+ is
+ Tok : Sdf_Token_Type;
+
+ procedure Pr_Rnumber (Mtm : Mtm_Type)
+ is
+ begin
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Mtm = Sdf_Mtm then
+ Val := Num_To_Time;
+ Status := Status_Set;
+ elsif Status /= Status_Set then
+ Status := Status_Found;
+ end if;
+ Tok := Get_Token;
+ end if;
+ end Pr_Rnumber;
+
+ function Pr_Colon return Boolean
+ is
+ begin
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ Status := Status_Error;
+ return False;
+ else
+ Tok := Get_Token;
+ return True;
+ end if;
+ end Pr_Colon;
+
+ begin
+ Val := 0;
+ Tok := Get_Token;
+ Status := Status_Error;
+ if Tok = Tok_Cparen then
+ Status := Status_Optional;
+ return;
+ end if;
+
+ Pr_Rnumber (Minimum);
+
+ if not Pr_Colon then
+ return;
+ end if;
+
+ Pr_Rnumber (Typical);
+
+ if not Pr_Colon then
+ return;
+ end if;
+
+ Pr_Rnumber (Maximum);
+
+ if Status = Status_Error then
+ Error_Sdf ("at least one number required in an rexpression");
+ return;
+ end if;
+
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ Status := Status_Error;
+ end if;
+ end Parse_Rexpression;
+
+ function Expect_Rexpr_Cp_Op_Ident return Boolean
+ is
+ Status : Parse_Status_Type;
+ Val : Ghdl_I64;
+ begin
+ Parse_Rexpression (Status, Val);
+ if Status = Status_Error then
+ return False;
+ end if;
+ if not Expect (Tok_Oparen)
+ or else not Expect (Tok_Identifier)
+ then
+ Error_Sdf (Tok_Identifier);
+ return False;
+ end if;
+ return True;
+ end Expect_Rexpr_Cp_Op_Ident;
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C >= 'A' and C <= 'Z' then
+ return Character'Val (Character'Pos (C)
+ - Character'Pos ('A') + Character'Pos ('a'));
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean
+ is
+ Port_Spec : Port_Spec_Type
+ renames Sdf_Context.Ports (Sdf_Context.Port_Num);
+ Len : Natural;
+ begin
+ if Tok /= Tok_Identifier then
+ Error_Sdf ("port path expected");
+ return False;
+ end if;
+ Len := 0;
+ for I in Ident_Start .. Ident_End loop
+ Len := Len + 1;
+ Port_Spec.Name (Len) := To_Lower (Buf (I));
+ end loop;
+ Port_Spec.Name_Len := Len;
+
+ -- Parse [ DNUMBER ]
+ -- | [ DNUMBER : DNUMBER ]
+ Skip_Spaces;
+ if Buf (Pos) = '[' then
+ Port_Spec.R := Invalid_Dnumber;
+ Pos := Pos + 1;
+ if Get_Token /= Tok_Dnumber then
+ Error_Sdf (Tok);
+ else
+ Port_Spec.L := Ghdl_I32 (Scan_Int);
+ end if;
+ Skip_Spaces;
+ if Buf (Pos) = ':' then
+ Pos := Pos + 1;
+ if Get_Token /= Tok_Dnumber then
+ Error_Sdf (Tok);
+ else
+ Port_Spec.R := Ghdl_I32 (Scan_Int);
+ end if;
+ Skip_Spaces;
+ end if;
+ if Buf (Pos) /= ']' then
+ Error_Sdf ("']' expected");
+ else
+ Pos := Pos + 1;
+ end if;
+ end if;
+
+ return True;
+ end Parse_Port_Path1;
+
+ function Parse_Port_Path return Boolean
+ is
+ begin
+ Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1;
+ return Parse_Port_Path1 (Get_Token);
+ end Parse_Port_Path;
+
+ function Parse_Port_Spec return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ Edge : Edge_Type;
+ begin
+ Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1;
+ Tok := Get_Token;
+ if Tok = Tok_Identifier then
+ return Parse_Port_Path1 (Tok);
+ elsif Tok /= Tok_Oparen then
+ Error_Sdf ("port spec expected");
+ return False;
+ end if;
+ Edge := Get_Edge_Token;
+ if Edge = Edge_Error then
+ return False;
+ end if;
+ Sdf_Context.Ports (Sdf_Context.Port_Num).Edge := Edge;
+ if not Parse_Port_Path1 (Get_Token) then
+ return False;
+ end if;
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ return True;
+ end Parse_Port_Spec;
+
+ function Parse_Port_Tchk return Boolean renames Parse_Port_Spec;
+
+ -- tc_rvalue ::= ( RNUMBER )
+ -- ||= ( rexpression )
+ -- Return status_optional for ( )
+ function Parse_Tc_Rvalue return Parse_Status_Type
+ is
+ Tok : Sdf_Token_Type;
+ Res : Parse_Status_Type;
+ begin
+ -- '('
+ if Get_Token /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return Status_Error;
+ end if;
+ Res := Status_Found;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Tok := Get_Token;
+ if Tok = Tok_Cparen then
+ -- This is a simple RNUMBER.
+ return Status_Altern;
+ end if;
+ if Sdf_Mtm = Minimum then
+ Res := Status_Set;
+ end if;
+ end if;
+ if Tok = Tok_Cparen then
+ return Status_Optional;
+ end if;
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ return Status_Error;
+ end if;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Sdf_Mtm = Typical then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Res := Status_Set;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ return Status_Error;
+ end if;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Sdf_Mtm = Maximum then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Res := Status_Set;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return Status_Error;
+ end if;
+ return Res;
+ end Parse_Tc_Rvalue;
+
+ function Parse_Simple_Tc_Rvalue return Boolean is
+ begin
+ Sdf_Context.Timing_Nbr := 0;
+
+ case Parse_Tc_Rvalue is
+ when Status_Error
+ | Status_Optional =>
+ return False;
+ when Status_Altern =>
+ null;
+ when Status_Found =>
+ Sdf_Context.Timing_Set (1) := False;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (1) := True;
+ end case;
+ return True;
+ end Parse_Simple_Tc_Rvalue;
+
+ -- rvalue ::= ( RNUMBER )
+ -- ||= rexp_list
+ -- Parse: rvalue )
+ function Parse_Rvalue return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ begin
+ Sdf_Context.Timing_Nbr := 0;
+ Sdf_Context.Timing_Set := (others => False);
+
+ case Parse_Tc_Rvalue is
+ when Status_Error =>
+ return False;
+ when Status_Altern =>
+ Sdf_Context.Timing_Nbr := 1;
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ end if;
+ return True;
+ when Status_Found
+ | Status_Optional =>
+ null;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (1) := True;
+ end case;
+
+ Sdf_Context.Timing_Nbr := 1;
+ loop
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return False;
+ end if;
+
+ Sdf_Context.Timing_Nbr := Sdf_Context.Timing_Nbr + 1;
+ declare
+ Status : Parse_Status_Type;
+ Val : Ghdl_I64;
+ begin
+ Parse_Rexpression (Status, Val);
+ case Status is
+ when Status_Error
+ | Status_Altern =>
+ return False;
+ when Status_Optional
+ | Status_Found =>
+ null;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (Sdf_Context.Timing_Nbr) := True;
+ Sdf_Context.Timing (Sdf_Context.Timing_Nbr) := Val;
+ end case;
+ end;
+ end loop;
+ if Boolean'(False) then
+ -- Do not expand here, since the most used is 01.
+ case Sdf_Context.Timing_Nbr is
+ when 1 =>
+ for I in 2 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (1);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1);
+ end loop;
+ when 2 =>
+ for I in 3 .. 4 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (1);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1);
+ end loop;
+ for I in 5 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (2);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (2);
+ end loop;
+ when 3 =>
+ for I in 4 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (I - 3);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (I - 3);
+ end loop;
+ when 6
+ | 12 =>
+ null;
+ when others =>
+ Error_Sdf ("bad number of rvalue");
+ return False;
+ end case;
+ end if;
+ return True;
+ end Parse_Rvalue;
+
+ function Handle_Generic return Boolean
+ is
+ Name : String (1 .. 1024);
+ Len : Natural;
+
+ procedure Start (Str : String) is
+ begin
+ Name (1 .. Str'Length) := Str;
+ Len := Str'Length;
+ end Start;
+
+ procedure Add (Str : String)
+ is
+ Nlen : Natural;
+ begin
+ Len := Len + 1;
+ Name (Len) := '_';
+ Nlen := Len + Str'Length;
+ Name (Len + 1 .. Nlen) := Str;
+ Len := Nlen;
+ end Add;
+
+ procedure Add_Edge (Edge : Edge_Type; Force : Boolean) is
+ begin
+ case Edge is
+ when Edge_Posedge =>
+ Add ("posedge");
+ when Edge_Negedge =>
+ Add ("negedge");
+ when Edge_01 =>
+ Add ("01");
+ when Edge_10 =>
+ Add ("10");
+ when Edge_0z =>
+ Add ("0z");
+ when Edge_Z1 =>
+ Add ("Z1");
+ when Edge_1z =>
+ Add ("1z");
+ when Edge_Z0 =>
+ Add ("ZO");
+ when Edge_None =>
+ if Force then
+ Add ("noedge");
+ end if;
+ when Edge_Error =>
+ Add ("?");
+ end case;
+ end Add_Edge;
+
+ Ok : Boolean;
+ begin
+ case Sdf_Context.Kind is
+ when Delay_Iopath =>
+ Start ("tpd");
+ when Delay_Port =>
+ Start ("tipd");
+ when Timingcheck_Setup =>
+ Start ("tsetup");
+ when Timingcheck_Hold =>
+ Start ("thold");
+ when Timingcheck_Setuphold =>
+ Start ("tsetup");
+ when Timingcheck_Recovery =>
+ Start ("trecovery");
+ when Timingcheck_Skew =>
+ Start ("tskew");
+ when Timingcheck_Width =>
+ Start ("tpw");
+ when Timingcheck_Period =>
+ Start ("tperiod");
+ when Timingcheck_Nochange =>
+ Start ("tncsetup");
+ end case;
+ for I in 1 .. Sdf_Context.Port_Num loop
+ Add (Sdf_Context.Ports (I).Name
+ (1 .. Sdf_Context.Ports (I).Name_Len));
+ end loop;
+ if Sdf_Context.Kind in Timing_Generic_Full_Condition then
+ Add_Edge (Sdf_Context.Ports (1).Edge, True);
+ Add_Edge (Sdf_Context.Ports (2).Edge, False);
+ elsif Sdf_Context.Kind in Timing_Generic_Simple_Condition then
+ Add_Edge (Sdf_Context.Ports (1).Edge, False);
+ end if;
+ Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok);
+ if not Ok then
+ Error_Sdf_C;
+ Error_C ("could not annotate generic ");
+ Error_E (Name (1 .. Len));
+ return False;
+ end if;
+ return True;
+ end Handle_Generic;
+
+ function Parse_Sdf return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ Ok : Boolean;
+ begin
+ if Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("DELAYFILE")
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("not an SDF file");
+ return False;
+ end if;
+
+ if Is_Ident ("SDFVERSION") then
+ Tok := Get_Token;
+ if Tok = Tok_Qstring then
+ Sdf_Context.Version := Sdf_Version_Bad;
+ if Ident_Length = 3 and then Buf (Ident_Start + 1) = '.' then
+ -- Version has the format '"X.Y"' (without simple quote).
+ if Buf (Ident_Start) = '2'
+ and then Buf (Ident_Start + 2) = '1'
+ then
+ Sdf_Context.Version := Sdf_2_1;
+ end if;
+ end if;
+ Tok := Get_Token;
+ end if;
+
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("DESIGN") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("DATE") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("VENDOR") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("PROGRAM") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("VERSION") then
+ return False;
+ end if;
+
+ if Is_Ident ("DIVIDER") then
+ Tok := Get_Token;
+ if Tok = Tok_Div or Tok = Tok_Dot then
+ Tok := Get_Token;
+ end if;
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ if Is_Ident ("VOLTAGE") then
+ if not Expect_Rexpr_Cp_Op_Ident then
+ return False;
+ end if;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("PROCESS") then
+ return False;
+ end if;
+
+ if Is_Ident ("TEMPERATURE") then
+ if not Expect_Rexpr_Cp_Op_Ident then
+ return False;
+ end if;
+ end if;
+
+ if Is_Ident ("TIMESCALE") then
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Scan_Exp = 0 and (Scan_Int = 1
+ or Scan_Int = 10
+ or Scan_Int = 100)
+ then
+ Sdf_Context.Timescale := Scan_Int;
+ else
+ Error_Sdf ("bad timescale value");
+ return False;
+ end if;
+ Tok := Get_Token;
+ if Tok /= Tok_Identifier then
+ Error_Sdf (Tok_Identifier);
+ end if;
+ if Is_Ident ("ps") then
+ null;
+ elsif Is_Ident ("ns") then
+ Sdf_Context.Timescale := Sdf_Context.Timescale * 1000;
+ elsif Is_Ident ("us") then
+ Sdf_Context.Timescale := Sdf_Context.Timescale * 1000_000;
+ else
+ Error_Sdf ("bad timescale unit");
+ return False;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ Vital_Annotate.Sdf_Header (Sdf_Context.all);
+
+ -- Parse cell+
+ loop
+ if not Is_Ident ("CELL") then
+ Error_Sdf ("CELL expected");
+ return False;
+ end if;
+ -- Parse celltype
+ if Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("CELLTYPE")
+ or else Get_Token /= Tok_Qstring
+ then
+ Error_Sdf ("CELLTYPE expected");
+ return False;
+ end if;
+ Sdf_Context.Celltype_Len := Ident_Length;
+ if Sdf_Context.Celltype_Len > Sdf_Context.Celltype'Length then
+ Error_Sdf ("CELLTYPE qstring is too long");
+ return False;
+ end if;
+ for I in Ident_Start .. Ident_End loop
+ Sdf_Context.Celltype (I - Ident_Start + 1) := To_Lower (Buf (I));
+ end loop;
+ Vital_Annotate.Sdf_Celltype (Sdf_Context.all);
+ if Get_Token /= Tok_Cparen
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("INSTANCE")
+ then
+ Error_Sdf ("INSTANCE expected");
+ return False;
+ end if;
+ -- Parse instance+
+ loop
+ exit when not Is_Ident ("INSTANCE");
+ Tok := Get_Token;
+ if Tok /= Tok_Cparen then
+ loop
+ if Tok /= Tok_Identifier then
+ Error_Sdf ("instance identifier expected");
+ return False;
+ end if;
+ for I in Ident_Start .. Ident_End loop
+ Buf (I) := To_Lower (Buf (I));
+ end loop;
+ Vital_Annotate.Sdf_Instance
+ (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok);
+ if not Ok then
+ Error_Sdf ("cannot find instance");
+ return False;
+ end if;
+ Tok := Get_Token;
+ exit when Tok /= Tok_Dot;
+ Tok := Get_Token;
+ end loop;
+ end if;
+ if Tok /= Tok_Cparen
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("instance or timing_spec expected");
+ return False;
+ end if;
+ end loop;
+ Vital_Annotate.Sdf_Instance_End (Sdf_Context.all, Ok);
+ if not Ok then
+ Error_Sdf ("bad instance or celltype mistmatch");
+ return False;
+ end if;
+
+ -- Parse timing_spec+
+ loop
+ if Is_Ident ("DELAY") then
+ -- Parse deltype+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("deltype expected");
+ return False;
+ end if;
+ if Is_Ident ("PATHPULSE")
+ or else Is_Ident ("GLOBALPATHPULSE")
+ then
+ Error_Sdf ("PATHPULSE and GLOBALPATHPULSE not allowed");
+ return False;
+ end if;
+ if Is_Ident ("ABSOLUTE") then
+ null;
+ elsif Is_Ident ("INCREMENT") then
+ null;
+ else
+ Error_Sdf ("ABSOLUTE or INCREMENT expected");
+ return False;
+ end if;
+ -- Parse absvals+ or incvals+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("absvals or incvals expected");
+ return False;
+ end if;
+ if Is_Ident ("IOPATH") then
+ Start_Generic_Name (Delay_Iopath);
+ if not Parse_Port_Spec
+ or else not Parse_Port_Path
+ or else not Parse_Rvalue
+ then
+ return False;
+ end if;
+ elsif Is_Ident ("PORT") then
+ Start_Generic_Name (Delay_Port);
+ if not Parse_Port_Path
+ or else not Parse_Rvalue
+ then
+ return False;
+ end if;
+ elsif Is_Ident ("COND")
+ or else Is_Ident ("INTERCONNECT")
+ or else Is_Ident ("DEVICE")
+ then
+ Error_Sdf
+ ("COND, INTERCONNECT, or DEVICE not handled");
+ return False;
+ elsif Is_Ident ("NETDELAY") then
+ Error_Sdf ("NETDELAY not allowed in VITAL SDF");
+ return False;
+ else
+ Error_Sdf ("absvals or incvals expected");
+ return False;
+ end if;
+
+ if not Handle_Generic then
+ return False;
+ end if;
+
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ elsif Is_Ident ("TIMINGCHECK") then
+ -- parse tc_def+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("tc_def expected");
+ return False;
+ end if;
+ if Is_Ident ("SETUP") then
+ Start_Generic_Name (Timingcheck_Setup);
+ elsif Is_Ident ("HOLD") then
+ Start_Generic_Name (Timingcheck_Hold);
+ elsif Is_Ident ("SETUPHOLD") then
+ Start_Generic_Name (Timingcheck_Setuphold);
+ elsif Is_Ident ("RECOVERY") then
+ Start_Generic_Name (Timingcheck_Recovery);
+ elsif Is_Ident ("SKEW") then
+ Start_Generic_Name (Timingcheck_Skew);
+ elsif Is_Ident ("WIDTH") then
+ Start_Generic_Name (Timingcheck_Width);
+ elsif Is_Ident ("PERIOD") then
+ Start_Generic_Name (Timingcheck_Period);
+ elsif Is_Ident ("NOCHANGE") then
+ Start_Generic_Name (Timingcheck_Nochange);
+ elsif Is_Ident ("PATHCONSTRAINT")
+ or else Is_Ident ("SUM")
+ or else Is_Ident ("DIFF")
+ or else Is_Ident ("SKEWCONSTRAINT")
+ then
+ Error_Sdf ("non-VITAL tc_def");
+ return False;
+ else
+ Error_Sdf ("bad tc_def");
+ return False;
+ end if;
+
+ case Sdf_Context.Kind is
+ when Timingcheck_Setup
+ | Timingcheck_Hold
+ | Timingcheck_Recovery
+ | Timingcheck_Skew
+ | Timingcheck_Setuphold
+ | Timingcheck_Nochange =>
+ if not Parse_Port_Tchk
+ or else not Parse_Port_Tchk
+ or else not Parse_Simple_Tc_Rvalue
+ then
+ return False;
+ end if;
+ when Timingcheck_Width
+ | Timingcheck_Period =>
+ if not Parse_Port_Tchk
+ or else not Parse_Simple_Tc_Rvalue
+ then
+ return False;
+ end if;
+ when others =>
+ Internal_Error ("sdf_parse");
+ end case;
+
+ if not Handle_Generic then
+ return False;
+ end if;
+
+ case Sdf_Context.Kind is
+ when Timingcheck_Setuphold
+ | Timingcheck_Nochange =>
+ if not Parse_Simple_Tc_Rvalue then
+ return False;
+ end if;
+ Error_Sdf ("setuphold and nochange not yet handled");
+ return False;
+ when others =>
+ null;
+ end case;
+
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ end if;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return False;
+ end if;
+ if Get_Token /= Tok_Identifier then
+ Error_Sdf (Tok_Identifier);
+ return False;
+ end if;
+ end loop;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf (Tok_Identifier);
+ end if;
+ end loop;
+ if Get_Token /= Tok_Eof then
+ Error_Sdf ("EOF expected");
+ return False;
+ end if;
+ return True;
+ end Parse_Sdf;
+
+ function Parse_Sdf_File (Filename : String) return Boolean
+ is
+ Res : Boolean;
+ begin
+ if not Open_Sdf (Filename) then
+ return False;
+ end if;
+ Res := Parse_Sdf;
+ Close_Sdf;
+ return Res;
+ end Parse_Sdf_File;
+
+end Grt.Sdf;
diff --git a/src/translate/grt/grt-sdf.ads b/src/translate/grt/grt-sdf.ads
new file mode 100644
index 000000000..fd05b9e20
--- /dev/null
+++ b/src/translate/grt/grt-sdf.ads
@@ -0,0 +1,131 @@
+-- GHDL Run Time (GRT) - SDF parser.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+
+package Grt.Sdf is
+ type Edge_Type is
+ (
+ Edge_Error,
+ Edge_None,
+ Edge_Posedge,
+ Edge_Negedge,
+ Edge_01,
+ Edge_10,
+ Edge_0z,
+ Edge_Z1,
+ Edge_1z,
+ Edge_Z0
+ );
+
+ type Timing_Generic_Kind is
+ (
+ Delay_Port,
+ --Delay_Interconnect,
+ --Delay_Device,
+
+ -- Simple condition
+ Delay_Iopath,
+ Timingcheck_Width,
+ Timingcheck_Period,
+
+ -- Full condition
+ Timingcheck_Setup,
+ Timingcheck_Hold,
+ Timingcheck_Recovery,
+ Timingcheck_Skew,
+ Timingcheck_Nochange,
+ Timingcheck_Setuphold
+ );
+
+ subtype Timing_Generic_Simple_Condition is Timing_Generic_Kind
+ range Delay_Iopath .. Timingcheck_Period;
+
+ subtype Timing_Generic_Full_Condition is Timing_Generic_Kind
+ range Timingcheck_Setup .. Timingcheck_Setuphold;
+
+ type Sdf_Version_Type is
+ (
+ Sdf_2_1,
+ Sdf_Version_Unknown,
+ Sdf_Version_Bad
+ );
+
+ Read_Size : constant Natural := 4096;
+ Buf_Size : constant Natural := Read_Size + 1024 + 1;
+
+ Invalid_Dnumber : constant Ghdl_I32 := -1;
+
+ type Port_Spec_Type is record
+ -- Port identifier.
+ Name : String (1 .. 128);
+ Name_Len : Natural;
+
+ -- Left and Right range.
+ -- If L = R = Invalid_Dnumber, this is a simple scalar port.
+ -- If R = Invalid_Dnumber, this is a scalar port (from a vector)
+ -- Otherwise, this is a bus port.
+ L, R : Ghdl_I32;
+
+ -- Cond : String (1 .. 1024);
+ -- Cond_Len : Natural;
+
+ Edge : Edge_Type;
+ end record;
+
+ type Port_Spec_Array_Type is array (Natural range <>) of Port_Spec_Type;
+
+ type Ghdl_I64_Array is array (1 .. 12) of Ghdl_I64;
+ type Boolean_Array is array (1 .. 12) of Boolean;
+
+ type Sdf_Context_Type is record
+ -- Version of the SDF file.
+ Version : Sdf_Version_Type;
+
+ -- Timescale; 1 corresponds to 1 ps.
+ -- Default is 1000 (1 ns).
+ Timescale : Natural;
+
+ Kind : Timing_Generic_Kind;
+
+ -- Cell type.
+ Celltype : String (1 .. 128);
+ Celltype_Len : Natural;
+
+ -- Current port.
+ Port_Num : Natural;
+ Ports : Port_Spec_Array_Type (1 .. 2);
+
+ -- timing spec.
+ Timing : Ghdl_I64_Array;
+ Timing_Set : Boolean_Array;
+ Timing_Nbr : Natural;
+ end record;
+
+ -- Which value is extracted.
+ type Mtm_Type is (Minimum, Typical, Maximum);
+ Sdf_Mtm : Mtm_Type := Typical;
+
+ function Parse_Sdf_File (Filename : String) return Boolean;
+end Grt.Sdf;
diff --git a/src/translate/grt/grt-shadow_ieee.adb b/src/translate/grt/grt-shadow_ieee.adb
new file mode 100644
index 000000000..32af4be5d
--- /dev/null
+++ b/src/translate/grt/grt-shadow_ieee.adb
@@ -0,0 +1,32 @@
+-- GHDL Run Time (GRT) - ghost declarations for ieee.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Shadow_Ieee is
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV is
+ begin
+ Internal_Error ("resolved_RESOLV from shadow ieee called");
+ end Ieee_Std_Logic_1164_Resolved_RESOLV;
+end Grt.Shadow_Ieee;
diff --git a/src/translate/grt/grt-shadow_ieee.ads b/src/translate/grt/grt-shadow_ieee.ads
new file mode 100644
index 000000000..f12b4792f
--- /dev/null
+++ b/src/translate/grt/grt-shadow_ieee.ads
@@ -0,0 +1,41 @@
+-- GHDL Run Time (GRT) - ghost declarations for ieee.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- This packages provides dummy declaration for main IEEE.STD_LOGIC_1164
+-- type descriptors.
+-- The package must not have elaboration code, since the actual type
+-- descriptors are not writable (they are constant). Making it preelaborated
+-- is not enough, the variables must be initialized. This current
+-- implementation provides bad values; this is not a problem since they are
+-- not read in grt.
+
+package Grt.Shadow_Ieee is
+ pragma Preelaborate (Grt.Shadow_Ieee);
+
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV;
+private
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_RESOLV,
+ "ieee__std_logic_1164__resolved_RESOLV");
+end Grt.Shadow_Ieee;
diff --git a/src/translate/grt/grt-signals.adb b/src/translate/grt/grt-signals.adb
new file mode 100644
index 000000000..9698d8178
--- /dev/null
+++ b/src/translate/grt/grt-signals.adb
@@ -0,0 +1,3400 @@
+-- GHDL Run Time (GRT) - signals management.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Deallocation;
+with Grt.Errors; use Grt.Errors;
+with Grt.Processes; use Grt.Processes;
+with Grt.Options; use Grt.Options;
+with Grt.Rtis_Types; use Grt.Rtis_Types;
+with Grt.Disp_Signals;
+with Grt.Astdio;
+with Grt.Stdio;
+with Grt.Threads; use Grt.Threads;
+
+package body Grt.Signals is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Transaction, Name => Transaction_Acc);
+
+ procedure Free_In (Trans : Transaction_Acc)
+ is
+ Ntrans : Transaction_Acc;
+ begin
+ Ntrans := Trans;
+ Free (Ntrans);
+ end Free_In;
+ pragma Inline (Free_In);
+
+ -- RTI for the current signal.
+ Sig_Rti : Ghdl_Rtin_Object_Acc;
+
+ -- Signal mode (and flags) for the current signal.
+ Sig_Mode : Mode_Signal_Type;
+ Sig_Has_Active : Boolean;
+ Sig_Kind : Kind_Signal_Type;
+
+ -- Last created implicit signal. This is used to add dependencies on
+ -- the prefix.
+ Last_Implicit_Signal : Ghdl_Signal_Ptr;
+
+ -- Current signal resolver.
+ Current_Resolv : Resolved_Signal_Acc := null;
+
+ function Get_Current_Mode_Signal return Mode_Signal_Type is
+ begin
+ return Sig_Mode;
+ end Get_Current_Mode_Signal;
+
+ procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : Address)
+ is
+ pragma Unreferenced (Ctxt);
+ pragma Unreferenced (Addr);
+ begin
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig);
+ Sig_Mode := Mode_Signal_Type'Val
+ (Sig.Mode and Ghdl_Rti_Signal_Mode_Mask);
+ Sig_Kind := Kind_Signal_Type'Val
+ ((Sig.Mode and Ghdl_Rti_Signal_Kind_Mask)
+ / Ghdl_Rti_Signal_Kind_Offset);
+ Sig_Has_Active :=
+ (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0;
+ end Ghdl_Signal_Name_Rti;
+
+ procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+ Has_Active : Boolean) is
+ begin
+ Sig_Rti := null;
+ Sig_Mode := Mode;
+ Sig_Kind := Kind;
+ Sig_Has_Active := Has_Active;
+ end Ghdl_Signal_Set_Mode;
+
+ function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is
+ begin
+ return Sig.Sig_Kind /= Kind_Signal_No;
+ end Is_Signal_Guarded;
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Signal_Ptr, Target => Address);
+
+ function Create_Signal
+ (Mode : Mode_Type;
+ Init_Val : Value_Union;
+ Mode_Sig : Mode_Signal_Type;
+ Resolv_Proc : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ Resolv : Resolved_Signal_Acc;
+ S : Ghdl_Signal_Data (Mode_Sig);
+ begin
+ Sig_Table.Increment_Last;
+
+ if Current_Resolv = null then
+ if Resolv_Proc /= null then
+ Resolv := new Resolved_Signal_Type'
+ (Resolv_Proc => Resolv_Proc,
+ Resolv_Inst => Resolv_Inst,
+ Resolv_Ptr => Null_Address,
+ Sig_Range => (Sig_Table.Last, Sig_Table.Last),
+ Disconnect_Time => Bad_Time);
+ else
+ Resolv := null;
+ end if;
+ else
+ if Resolv_Proc /= null then
+ -- Only one resolution function is allowed!
+ Internal_Error ("create_signal");
+ end if;
+ Resolv := Current_Resolv;
+ if Current_Resolv.Sig_Range.Last = Sig_Table.Last then
+ Current_Resolv := null;
+ end if;
+ end if;
+
+ case Mode_Sig is
+ when Mode_Signal_User =>
+ S.Nbr_Drivers := 0;
+ S.Drivers := null;
+ S.Effective := null;
+ S.Resolv := Resolv;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ S.Conv := null;
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ S.Time := 0;
+ when Mode_Guard =>
+ S.Guard_Func := null;
+ S.Guard_Instance := System.Null_Address;
+ when Mode_Transaction
+ | Mode_End =>
+ null;
+ end case;
+
+ Res := new Ghdl_Signal'(Value => Init_Val,
+ Driving_Value => Init_Val,
+ Last_Value => Init_Val,
+ -- Note: use -Std_Time'last instead of
+ -- Std_Time'First so that NOW - x'last_event
+ -- returns time'high at initialization!
+ Last_Event => -Std_Time'Last,
+ Last_Active => -Std_Time'Last,
+ Event => False,
+ Active => False,
+ Has_Active => False,
+ Sig_Kind => Sig_Kind,
+
+ Is_Direct_Active => False,
+ Mode => Mode,
+ Flags => (Propag => Propag_None,
+ Is_Dumped => False,
+ Cyc_Event => False,
+ Seen => False),
+
+ Net => No_Signal_Net,
+ Link => null,
+ Alink => null,
+ Flink => null,
+
+ Event_List => null,
+ Rti => Sig_Rti,
+
+ Nbr_Ports => 0,
+ Ports => null,
+
+ S => S);
+
+ if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then
+ Resolv.Resolv_Ptr := To_Address (Res);
+ end if;
+
+ case Flag_Activity is
+ when Activity_All =>
+ Res.Has_Active := True;
+ when Activity_Minimal =>
+ Res.Has_Active := Sig_Has_Active;
+ when Activity_None =>
+ Res.Has_Active := False;
+ end case;
+
+ -- Put the signal in the table.
+ Sig_Table.Table (Sig_Table.Last) := Res;
+
+ return Res;
+ end Create_Signal;
+
+ procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is
+ begin
+ Sig.Value := Val;
+ Sig.Driving_Value := Val;
+ Sig.Last_Value := Val;
+ end Ghdl_Signal_Init;
+
+ procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr;
+ Rti : Ghdl_Rti_Access)
+ is
+ S_Rti : Ghdl_Rtin_Object_Acc;
+ begin
+ S_Rti := To_Ghdl_Rtin_Object_Acc (Rti);
+ if Flag_Activity = Activity_Minimal then
+ if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then
+ Sig.Has_Active := True;
+ end if;
+ end if;
+ end Ghdl_Signal_Merge_Rti;
+
+ procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc;
+ Instance : System.Address;
+ Sig : System.Address;
+ Nbr_Sig : Ghdl_Index_Type)
+ is
+ begin
+ if Current_Resolv /= null then
+ Internal_Error ("Ghdl_Signal_Create_Resolution");
+ end if;
+ Current_Resolv := new Resolved_Signal_Type'
+ (Resolv_Proc => Proc,
+ Resolv_Inst => Instance,
+ Resolv_Ptr => Sig,
+ Sig_Range => (First => Sig_Table.Last + 1,
+ Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)),
+ Disconnect_Time => Bad_Time);
+ end Ghdl_Signal_Create_Resolution;
+
+ procedure Check_New_Source (Sig : Ghdl_Signal_Ptr)
+ is
+ use Grt.Stdio;
+ use Grt.Astdio;
+ begin
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then
+ if Sig.S.Resolv = null then
+ -- LRM 4.3.1.2 Signal Declaration
+ -- It is an error if, after the elaboration of a description, a
+ -- signal has multiple sources and it is not a resolved signal.
+ if Sig.Rti /= null then
+ Put ("for signal: ");
+ Disp_Signals.Put_Signal_Name (stderr, Sig);
+ New_Line (stderr);
+ end if;
+ Error ("several sources for unresolved signal");
+ elsif Sig.S.Mode_Sig = Mode_Buffer and False then
+ -- LRM 1.1.1.2 Ports
+ -- A BUFFER port may have at most one source.
+
+ -- FIXME: this is not true with VHDL-02.
+ -- With VHDL-87/93, should also check that: any actual associated
+ -- with a formal buffer port may have at most one source.
+ Error ("buffer port which more than one source");
+ end if;
+ end if;
+ end Check_New_Source;
+
+ -- Return TRUE if already present.
+ function Ghdl_Signal_Add_Driver (Sign : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc)
+ return Boolean
+ is
+ type Size_T is mod 2**Standard'Address_Size;
+
+ function Malloc (Size : Size_T) return Driver_Arr_Ptr;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T)
+ return Driver_Arr_Ptr;
+ pragma Import (C, Realloc);
+
+ function Size (N : Ghdl_Index_Type) return Size_T is
+ begin
+ return Size_T (N * Driver_Fat_Array'Component_Size
+ / System.Storage_Unit);
+ end Size;
+
+ Proc : Process_Acc;
+ begin
+ Proc := Get_Current_Process;
+ if Sign.S.Nbr_Drivers = 0 then
+ Check_New_Source (Sign);
+ Sign.S.Drivers := Malloc (Size (1));
+ Sign.S.Nbr_Drivers := 1;
+ else
+ -- Do not create a driver twice.
+ for I in 0 .. Sign.S.Nbr_Drivers - 1 loop
+ if Sign.S.Drivers (I).Proc = Proc then
+ return True;
+ end if;
+ end loop;
+ Check_New_Source (Sign);
+ Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1;
+ Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers));
+ end if;
+ Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) :=
+ (First_Trans => Trans,
+ Last_Trans => Trans,
+ Proc => Proc);
+ return False;
+ end Ghdl_Signal_Add_Driver;
+
+ procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Sign.Value);
+ if Ghdl_Signal_Add_Driver (Sign, Trans) then
+ Free (Trans);
+ end if;
+ end Ghdl_Process_Add_Driver;
+
+ procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr;
+ Drv : Ghdl_Value_Ptr)
+ is
+ Trans : Transaction_Acc;
+ Trans1 : Transaction_Acc;
+ begin
+ -- Create transaction for current driving value.
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Sign.Value);
+ if Ghdl_Signal_Add_Driver (Sign, Trans) then
+ Free (Trans);
+ return;
+ end if;
+ -- Create transaction for the next driving value.
+ Trans1 := new Transaction'(Kind => Trans_Direct,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val_Ptr => Drv);
+ Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1;
+ Trans.Next := Trans1;
+ end Ghdl_Signal_Add_Direct_Driver;
+
+ procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
+ is
+ type Size_T is new Integer;
+
+ function Malloc (Size : Size_T) return Signal_Arr_Ptr;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T)
+ return Signal_Arr_Ptr;
+ pragma Import (C, Realloc);
+
+ function Size (N : Ghdl_Index_Type) return Size_T is
+ begin
+ return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit);
+ end Size;
+ begin
+ if Targ.Nbr_Ports = 0 then
+ Targ.Ports := Malloc (Size (1));
+ Targ.Nbr_Ports := 1;
+ else
+ Targ.Nbr_Ports := Targ.Nbr_Ports + 1;
+ Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports));
+ end if;
+ Targ.Ports (Targ.Nbr_Ports - 1) := Src;
+ end Append_Port;
+
+ -- Add SRC to port list of TARG, but only if not already in this list.
+ procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ for I in 1 .. Targ.Nbr_Ports loop
+ if Targ.Ports (I - 1) = Src then
+ return;
+ end if;
+ end loop;
+ Append_Port (Targ, Src);
+ end Add_Port;
+
+ procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ Check_New_Source (Targ);
+ Append_Port (Targ, Src);
+ end Ghdl_Signal_Add_Source;
+
+ procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr;
+ Time : Std_Time) is
+ begin
+ if Sign.S.Resolv = null then
+ Internal_Error ("ghdl_signal_set_disconnect: not resolved");
+ end if;
+ if Sign.S.Resolv.Disconnect_Time /= Bad_Time then
+ Error ("disconnection already specified for signal");
+ end if;
+ if Time < 0 then
+ Error ("disconnection time is negative");
+ end if;
+ Sign.S.Resolv.Disconnect_Time := Time;
+ end Ghdl_Signal_Set_Disconnect;
+
+ procedure Direct_Assign
+ (Targ : out Value_Union; Val : Ghdl_Value_Ptr; Mode : Mode_Type)
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Targ.B1 := Val.B1;
+ when Mode_E8 =>
+ Targ.E8 := Val.E8;
+ when Mode_E32 =>
+ Targ.E32 := Val.E32;
+ when Mode_I32 =>
+ Targ.I32 := Val.I32;
+ when Mode_I64 =>
+ Targ.I64 := Val.I64;
+ when Mode_F64 =>
+ Targ.F64 := Val.F64;
+ end case;
+ end Direct_Assign;
+
+ function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type)
+ return Boolean
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ return Left.B1 = Right.B1;
+ when Mode_E8 =>
+ return Left.E8 = Right.E8;
+ when Mode_E32 =>
+ return Left.E32 = Right.E32;
+ when Mode_I32 =>
+ return Left.I32 = Right.I32;
+ when Mode_I64 =>
+ return Left.I64 = Right.I64;
+ when Mode_F64 =>
+ return Left.F64 = Right.F64;
+ end case;
+ end Value_Equal;
+
+ procedure Error_Trans_Error (Trans : Transaction_Acc) is
+ begin
+ Error_C ("range check error on signal at ");
+ Error_C (Trans.File);
+ Error_C (":");
+ Error_C (Natural (Trans.Line));
+ Error_E ("");
+ end Error_Trans_Error;
+ pragma No_Return (Error_Trans_Error);
+
+ function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type
+ is
+ Proc : Process_Acc;
+ begin
+ if Sig.S.Drivers = null then
+ Error ("assignment to a signal without any driver");
+ end if;
+ Proc := Get_Current_Process;
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ if Sig.S.Drivers (I).Proc = Proc then
+ return I;
+ end if;
+ end loop;
+ Error ("assignment to a signal without a driver for the process");
+ end Find_Driver;
+
+ function Get_Driver (Sig : Ghdl_Signal_Ptr) return Driver_Acc
+ is
+ Proc : Process_Acc;
+ begin
+ if Sig.S.Drivers = null then
+ return null;
+ end if;
+ Proc := Get_Current_Process;
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ if Sig.S.Drivers (I).Proc = Proc then
+ return Sig.S.Drivers (I)'Access;
+ end if;
+ end loop;
+ return null;
+ end Get_Driver;
+
+ -- Return TRUE iff SIG has a future transaction for the current time,
+ -- ie iff SIG will be active in the next delta cycle. This is used to
+ -- recompute wether SIG must be in the active chain. SIG must be a user
+ -- signal.
+ function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr)
+ return Boolean is
+ begin
+ if Sig.Is_Direct_Active then
+ return True;
+ end if;
+
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ declare
+ Trans : constant Transaction_Acc :=
+ Sig.S.Drivers (I - 1).First_Trans.Next;
+ begin
+ if Trans.Kind /= Trans_Direct
+ and then Trans.Time = Current_Time
+ then
+ return True;
+ end if;
+ end;
+ end loop;
+ return False;
+ end Has_Transaction_In_Next_Delta;
+
+ -- Unused but well-known signal which always terminate
+ -- ghdl_signal_active_chain.
+ -- As a consequence, every element of the chain has a link field set to
+ -- a non-null value (this is of course not true for SIGNAL_END). This may
+ -- be used to quickly check if a signal is in the list.
+ -- This signal is not in the signal table.
+ Signal_End : Ghdl_Signal_Ptr;
+
+ -- List of signals which have projected waveforms in the future (beyond
+ -- the next delta cycle).
+ Future_List : aliased Ghdl_Signal_Ptr;
+
+ procedure Ghdl_Signal_Start_Assign (Sign : Ghdl_Signal_Ptr;
+ Reject : Std_Time;
+ Trans : Transaction_Acc;
+ After : Std_Time)
+ is
+ Assign_Time : Std_Time;
+ Drv : constant Ghdl_Index_Type := Find_Driver (Sign);
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Drv);
+ begin
+ -- LRM93 8.4.1
+ -- It is an error if the time expression in a waveform element
+ -- evaluates to a negative value.
+ if After < 0 then
+ Error ("negative time expression in signal assignment");
+ end if;
+
+ if After = 0 then
+ -- Put SIGN on the active list if the transaction is scheduled
+ -- for the next delta cycle.
+ if Sign.Link = null then
+ Sign.Link := Grt.Threads.Atomic_Insert
+ (Ghdl_Signal_Active_Chain'access, Sign);
+ end if;
+ else
+ -- AFTER > 0.
+ -- Put SIGN on the future list.
+ if Sign.Flink = null then
+ Sign.Flink := Grt.Threads.Atomic_Insert (Future_List'access, Sign);
+ end if;
+ end if;
+
+ Assign_Time := Current_Time + After;
+ if Assign_Time < 0 then
+ -- Beyond the future
+ Free_In (Trans);
+ return;
+ end if;
+
+ -- Handle sign as direct driver.
+ if Driver.Last_Trans.Kind = Trans_Direct then
+ if After /= 0 then
+ Internal_Error ("direct assign with non-0 after");
+ end if;
+ -- FIXME: can be a bound-error too!
+ if Trans.Kind = Trans_Value then
+ case Sign.Mode is
+ when Mode_B1 =>
+ Driver.Last_Trans.Val_Ptr.B1 := Trans.Val.B1;
+ when Mode_E8 =>
+ Driver.Last_Trans.Val_Ptr.E8 := Trans.Val.E8;
+ when Mode_E32 =>
+ Driver.Last_Trans.Val_Ptr.E32 := Trans.Val.E32;
+ when Mode_I32 =>
+ Driver.Last_Trans.Val_Ptr.I32 := Trans.Val.I32;
+ when Mode_I64 =>
+ Driver.Last_Trans.Val_Ptr.I64 := Trans.Val.I64;
+ when Mode_F64 =>
+ Driver.Last_Trans.Val_Ptr.F64 := Trans.Val.F64;
+ end case;
+ Free_In (Trans);
+ elsif Trans.Kind = Trans_Error then
+ Error_Trans_Error (Trans);
+ else
+ Internal_Error ("direct assign with non-value");
+ end if;
+ return;
+ end if;
+
+ -- LRM93 8.4.1
+ -- 1. All old transactions that are projected to occur at or after the
+ -- time at which the earliest new transaction is projected to occur
+ -- are deleted from the projected output waveform.
+ if Driver.Last_Trans.Time >= Assign_Time then
+ declare
+ -- LAST is the last transaction to keep.
+ Last : Transaction_Acc;
+ Next : Transaction_Acc;
+ begin
+ Last := Driver.First_Trans;
+ -- Find the first transaction to be deleted.
+ Next := Last.Next;
+ while Next /= null and then Next.Time < Assign_Time loop
+ Last := Next;
+ Next := Next.Next;
+ end loop;
+ -- Delete old transactions.
+ if Next /= null then
+ -- Set the last transaction of the driver.
+ Driver.Last_Trans := Last;
+ -- Cut the chain. This is not strickly necessary, since
+ -- it will be overriden below, by appending TRANS to the
+ -- driver.
+ Last.Next := null;
+ -- Free removed transactions.
+ loop
+ Last := Next.Next;
+ Free (Next);
+ exit when Last = null;
+ Next := Last;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- 2. The new transaction are then appended to the projected output
+ -- waveform in the order of their projected occurence.
+ Trans.Time := Assign_Time;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+
+ -- If the initial delay is inertial delay according to the definitions
+ -- of section 8.4, the projected output waveform is further modified
+ -- as follows:
+ -- 1. All of the new transactions are marked.
+ -- 2. An old transaction is marked if the time at which it is projected
+ -- to occur is less than the time at which the first new transaction
+ -- is projected to occur minus the pulse rejection limit.
+ -- 3. For each remaining unmarked, old transaction, the old transaction
+ -- is marked if it immediatly precedes a marked transaction and its
+ -- value component is the same as that of the marked transaction;
+ -- 4. The transaction that determines the current value of the driver
+ -- is marked.
+ -- 5. All unmarked transactions (all of which are old transactions) are
+ -- deleted from the projected output waveform.
+ --
+ -- GHDL: only transactions that are projected to occur at [T-R, T[
+ -- can be deleted (R is the reject time, T is now + after time).
+ if Reject > 0 then
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any inertially
+ -- delayed signal assignment statement is [...] or greater than the
+ -- time expression associated with the first waveform element.
+ if Reject > After then
+ Error ("pulse rejection greater than first waveform delay");
+ end if;
+
+ declare
+ Prev : Transaction_Acc;
+ Next : Transaction_Acc;
+ begin
+ -- Find the first transaction after the project time less the
+ -- rejection time.
+ -- PREV will be the last old transaction which is projected to
+ -- occur before T - R.
+ Prev := Driver.First_Trans;
+ loop
+ Next := Prev.Next;
+ exit when Next.Time >= Assign_Time - Reject;
+ Prev := Next;
+ end loop;
+
+ -- Scan every transaction until TRANS. If a transaction value is
+ -- different from the TRANS value, then delete all previous
+ -- transactions (from T - R to the currently scanned transaction),
+ -- since they are not marked.
+ while Next /= Trans loop
+ if Next.Kind /= Trans.Kind
+ or else
+ (Trans.Kind = Trans_Value
+ and then not Value_Equal (Next.Val, Trans.Val, Sign.Mode))
+ then
+ -- NEXT is different from TRANS.
+ -- Delete ]PREV;NEXT].
+ declare
+ D, N : Transaction_Acc;
+ begin
+ D := Prev.Next;
+ Next := Next.Next;
+ Prev.Next := Next;
+ loop
+ N := D.Next;
+ Free (D);
+ exit when N = Next;
+ D := N;
+ end loop;
+ end;
+ else
+ Next := Next.Next;
+ end if;
+ end loop;
+
+ -- A previous assignment (with a 0 after time) may have put this
+ -- signal on the active chain. But maybe this previous
+ -- transaction has been removed (due to rejection) and therefore
+ -- this signal won't be active at the next delta. So remove it
+ -- from the active chain. This is a little bit costly (because
+ -- the chain is simply linked), but that issue doesn't appear
+ -- frequently.
+ if Sign.Link /= null
+ and then not Has_Transaction_In_Next_Delta (Sign)
+ then
+ if Ghdl_Signal_Active_Chain = Sign then
+ -- At the head of the chain.
+ -- FIXME: this is not atomic.
+ Ghdl_Signal_Active_Chain := Sign.Link;
+ else
+ -- In the middle of the chain.
+ declare
+ Prev : Ghdl_Signal_Ptr := Ghdl_Signal_Active_Chain;
+ begin
+ while Prev.Link /= Sign loop
+ Prev := Prev.Link;
+ end loop;
+ Prev.Link := Sign.Link;
+ end;
+ end if;
+ Sign.Link := null;
+ end if;
+ end;
+ elsif Reject /= 0 then
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any inertially
+ -- delayed signal assignment statement is either negative or [...].
+ Error ("pulse rejection is negative");
+ end if;
+
+ -- Do some checks.
+ if Driver.Last_Trans.Next /= null then
+ Error ("ghdl_signal_start_assign internal_error");
+ end if;
+ end Ghdl_Signal_Start_Assign;
+
+ procedure Ghdl_Signal_Next_Assign (Sign : Ghdl_Signal_Ptr;
+ Val : Value_Union;
+ After : Std_Time)
+ is
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign));
+
+ Trans : Transaction_Acc;
+ begin
+ if After > 0 and then Sign.Flink = null then
+ -- Put SIGN on the future list.
+ Sign.Flink := Future_List;
+ Future_List := Sign;
+ end if;
+
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + After,
+ Next => null,
+ Val => Val);
+ if Trans.Time <= Driver.Last_Trans.Time then
+ Error ("transactions not in ascending order");
+ end if;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+ end Ghdl_Signal_Next_Assign;
+
+ procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is
+ begin
+ if Sign.Link = null then
+ Sign.Link := Grt.Threads.Atomic_Insert
+ (Ghdl_Signal_Active_Chain'access, Sign);
+ end if;
+
+ -- Must be always set (as Sign.Link may be set by a regular driver).
+ Sign.Is_Direct_Active := True;
+ end Ghdl_Signal_Direct_Assign;
+
+ procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => 0,
+ Next => null,
+ File => File);
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_Error;
+
+ procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => 0,
+ Next => null,
+ File => File);
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_Error;
+
+ procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign));
+
+ Trans : Transaction_Acc;
+ begin
+ if After > 0 and then Sign.Flink = null then
+ -- Put SIGN on the future list.
+ Sign.Flink := Future_List;
+ Future_List := Sign;
+ end if;
+
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => Current_Time + After,
+ Next => null,
+ File => File);
+ if Trans.Time <= Driver.Last_Trans.Time then
+ Error ("transactions not in ascending order");
+ end if;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+ end Ghdl_Signal_Next_Assign_Error;
+
+ procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Is_Signal_Guarded (Sign) then
+ Error ("null transaction for a non-guarded target");
+ end if;
+ Trans := new Transaction'(Kind => Trans_Null,
+ Line => 0,
+ Time => 0,
+ Next => null);
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_Null;
+
+ procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr)
+ is
+ Trans : Transaction_Acc;
+ Time : Std_Time;
+ begin
+ if not Is_Signal_Guarded (Sign) then
+ Error ("null transaction for a non-guarded target");
+ end if;
+ Trans := new Transaction'(Kind => Trans_Null,
+ Line => 0,
+ Time => 0,
+ Next => null);
+ Time := Sign.S.Resolv.Disconnect_Time;
+ Ghdl_Signal_Start_Assign (Sign, Time, Trans, Time);
+ end Ghdl_Signal_Disconnect;
+
+ procedure Ghdl_Signal_Associate (Sig : Ghdl_Signal_Ptr; Val : Value_Union)
+ is
+ begin
+ Sig.Value := Val;
+ Sig.Driving_Value := Val;
+ end Ghdl_Signal_Associate;
+
+ function Ghdl_Create_Signal_B1
+ (Init_Val : Ghdl_B1;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_B1;
+
+ procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1) is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_B1, B1 => Init_Val));
+ end Ghdl_Signal_Init_B1;
+
+ procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1) is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_B1, B1 => Val));
+ end Ghdl_Signal_Associate_B1;
+
+ procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.B1
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_B1;
+
+ procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_B1;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_B1;
+
+ procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_B1, B1 => Val), After);
+ end Ghdl_Signal_Next_Assign_B1;
+
+ function Ghdl_Create_Signal_E8
+ (Init_Val : Ghdl_E8;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_E8, Value_Union'(Mode => Mode_E8, E8 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_E8;
+
+ procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8) is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E8, E8 => Init_Val));
+ end Ghdl_Signal_Init_E8;
+
+ procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8) is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E8, E8 => Val));
+ end Ghdl_Signal_Associate_E8;
+
+ procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.E8
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E8, E8 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_E8;
+
+ procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E8;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E8, E8 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_E8;
+
+ procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_E8, E8 => Val), After);
+ end Ghdl_Signal_Next_Assign_E8;
+
+ function Ghdl_Create_Signal_E32
+ (Init_Val : Ghdl_E32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_E32, Value_Union'(Mode => Mode_E32, E32 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_E32;
+
+ procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E32, E32 => Init_Val));
+ end Ghdl_Signal_Init_E32;
+
+ procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E32, E32 => Val));
+ end Ghdl_Signal_Associate_E32;
+
+ procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.E32
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E32, E32 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_E32;
+
+ procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E32;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E32, E32 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_E32;
+
+ procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_E32, E32 => Val), After);
+ end Ghdl_Signal_Next_Assign_E32;
+
+ function Ghdl_Create_Signal_I32
+ (Init_Val : Ghdl_I32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_I32, Value_Union'(Mode => Mode_I32, I32 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_I32;
+
+ procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I32, I32 => Init_Val));
+ end Ghdl_Signal_Init_I32;
+
+ procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I32, I32 => Val));
+ end Ghdl_Signal_Associate_I32;
+
+ procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.I32
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I32, I32 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_I32;
+
+ procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I32;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I32, I32 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_I32;
+
+ procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_I32, I32 => Val), After);
+ end Ghdl_Signal_Next_Assign_I32;
+
+ function Ghdl_Create_Signal_I64
+ (Init_Val : Ghdl_I64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_I64, Value_Union'(Mode => Mode_I64, I64 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_I64;
+
+ procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I64, I64 => Init_Val));
+ end Ghdl_Signal_Init_I64;
+
+ procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I64, I64 => Val));
+ end Ghdl_Signal_Associate_I64;
+
+ procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.I64
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I64, I64 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_I64;
+
+ procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I64;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I64, I64 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_I64;
+
+ procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_I64, I64 => Val), After);
+ end Ghdl_Signal_Next_Assign_I64;
+
+ function Ghdl_Create_Signal_F64
+ (Init_Val : Ghdl_F64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_F64, Value_Union'(Mode => Mode_F64, F64 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_F64;
+
+ procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_F64, F64 => Init_Val));
+ end Ghdl_Signal_Init_F64;
+
+ procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_F64, F64 => Val));
+ end Ghdl_Signal_Associate_F64;
+
+ procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.F64
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_F64, F64 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_F64;
+
+ procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_F64;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_F64, F64 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_F64;
+
+ procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_F64, F64 => Val), After);
+ end Ghdl_Signal_Next_Assign_F64;
+
+ procedure Ghdl_Signal_Internal_Checks
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ -- Check drivers.
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ declare
+ Trans : Transaction_Acc;
+ begin
+ Trans := Sig.S.Drivers (J - 1).First_Trans;
+ while Trans.Next /= null loop
+ if Trans.Next.Time < Trans.Time then
+ Internal_Error ("ghdl_signal_internal_checks: "
+ & "bad transaction order");
+ end if;
+ Trans := Trans.Next;
+ end loop;
+ if Trans /= Sig.S.Drivers (J - 1).Last_Trans then
+ Internal_Error ("ghdl_signal_internal_checks: "
+ & "last transaction mismatch");
+ end if;
+ end;
+ end loop;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Ghdl_Signal_Internal_Checks;
+
+ procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Targ.S.Effective /= null then
+ Error ("internal error: already effective value");
+ end if;
+ Targ.S.Effective := Src;
+ end Ghdl_Signal_Effective_Value;
+
+ Bit_Signal_Rti : aliased Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => null);
+
+ Boolean_Signal_Rti : aliased Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => null);
+
+ function Ghdl_Create_Signal_Attribute
+ (Mode : Mode_Signal_Type; Time : Std_Time)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+-- Sig_Type : Ghdl_Desc_Ptr;
+ begin
+ case Mode is
+ when Mode_Transaction =>
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Bit_Signal_Rti'Address));
+ when Mode_Quiet
+ | Mode_Stable =>
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Boolean_Signal_Rti'Address));
+ when others =>
+ Internal_Error ("ghdl_create_signal_attribute");
+ end case;
+ -- Note: bit and boolean are both mode_b1.
+ Res := Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => True),
+ Mode, null, Null_Address);
+ Sig_Rti := null;
+ Last_Implicit_Signal := Res;
+
+ if Mode /= Mode_Transaction then
+ Res.S.Time := Time;
+ Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Res.Value);
+ end if;
+
+ if Time > 0 then
+ Res.Flink := Future_List;
+ Future_List := Res;
+ end if;
+
+ return Res;
+ end Ghdl_Create_Signal_Attribute;
+
+ function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Stable, Val);
+ end Ghdl_Create_Stable_Signal;
+
+ function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Quiet, Val);
+ end Ghdl_Create_Quiet_Signal;
+
+ function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Transaction, 0);
+ end Ghdl_Create_Transaction_Signal;
+
+ procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Add_Port (Last_Implicit_Signal, Sig);
+ end Ghdl_Signal_Attribute_Register_Prefix;
+
+ --Guard_String : constant String := "guard";
+ --Guard_Name : constant Ghdl_Str_Len_Address_Type :=
+ -- (Len => 5, Str => Guard_String'Address);
+ --function To_Ghdl_Str_Len_Ptr is new Ada.Unchecked_Conversion
+ -- (Source => System.Address, Target => Ghdl_Str_Len_Ptr);
+
+ Guard_Rti : aliased constant Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => Std_Standard_Boolean_RTI_Ptr);
+
+ function Ghdl_Signal_Create_Guard (This : System.Address;
+ Proc : Guard_Func_Acc)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ begin
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Guard_Rti'Address));
+ Res := Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Proc.all (This)),
+ Mode_Guard, null, Null_Address);
+ Sig_Rti := null;
+ Res.S.Guard_Func := Proc;
+ Res.S.Guard_Instance := This;
+ Last_Implicit_Signal := Res;
+ return Res;
+ end Ghdl_Signal_Create_Guard;
+
+ procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Add_Port (Last_Implicit_Signal, Sig);
+ Sig.Has_Active := True;
+ end Ghdl_Signal_Guard_Dependence;
+
+ function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ begin
+ Res := Create_Signal (Sig.Mode, Sig.Value,
+ Mode_Delayed, null, Null_Address);
+ Res.S.Time := Val;
+ if Val > 0 then
+ Res.Flink := Future_List;
+ Future_List := Res;
+ end if;
+ Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Res.Value);
+ Append_Port (Res, Sig);
+ return Res;
+ end Ghdl_Create_Delayed_Signal;
+
+ function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index
+ is
+ begin
+ -- Note: we may start from ptr.instance_name.sig_index, but
+ -- instance_name is *not* set for conversion signals.
+ for I in reverse Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I) = Ptr then
+ return I;
+ end if;
+ end loop;
+ return -1;
+ end Signal_Ptr_To_Index;
+
+ function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type is
+ begin
+ return Sig.Nbr_Ports;
+ end Ghdl_Signal_Get_Nbr_Ports;
+
+ function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type is
+ begin
+ return Sig.S.Nbr_Drivers;
+ end Ghdl_Signal_Get_Nbr_Drivers;
+
+ function Ghdl_Signal_Read_Port
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr
+ is
+ begin
+ if Index >= Sig.Nbr_Ports then
+ Internal_Error ("ghdl_signal_read_port: bad index");
+ end if;
+ return To_Ghdl_Value_Ptr (Sig.Ports (Index).Driving_Value'Address);
+ end Ghdl_Signal_Read_Port;
+
+ function Ghdl_Signal_Read_Driver
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr
+ is
+ Trans : Transaction_Acc;
+ begin
+ if Index >= Sig.S.Nbr_Drivers then
+ Internal_Error ("ghdl_signal_read_driver: bad index");
+ end if;
+ Trans := Sig.S.Drivers (Index).First_Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ return To_Ghdl_Value_Ptr (Trans.Val'Address);
+ when Trans_Direct =>
+ Internal_Error ("ghdl_signal_read_driver: trans_direct");
+ when Trans_Null =>
+ return null;
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ end Ghdl_Signal_Read_Driver;
+
+ procedure Ghdl_Signal_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type;
+ Mode : Mode_Signal_Type)
+ is
+ Data : Sig_Conversion_Acc;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Data := new Sig_Conversion_Type'(Func => Func,
+ Instance => Instance,
+ Src => (-1, -1),
+ Dest => (-1, -1));
+ Data.Src.First := Signal_Ptr_To_Index (Src);
+ Data.Src.Last := Data.Src.First + Sig_Table_Index (Src_Len) - 1;
+
+ Data.Dest.First := Signal_Ptr_To_Index (Dst);
+ Data.Dest.Last := Data.Dest.First + Sig_Table_Index (Dst_Len) - 1;
+
+ -- Convert DEST to new mode.
+ for I in Data.Dest.First .. Data.Dest.Last loop
+ Sig := Sig_Table.Table (I);
+ case Mode is
+ when Mode_Conv_In =>
+ Sig.S := (Mode_Sig => Mode_Conv_In,
+ Conv => Data);
+ when Mode_Conv_Out =>
+ Sig.S := (Mode_Sig => Mode_Conv_Out,
+ Conv => Data);
+ when others =>
+ Internal_Error ("ghdl_signal_conversion");
+ end case;
+ end loop;
+ end Ghdl_Signal_Conversion;
+
+ procedure Ghdl_Signal_In_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type)
+ is
+ begin
+ Ghdl_Signal_Conversion
+ (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_In);
+ end Ghdl_Signal_In_Conversion;
+
+ procedure Ghdl_Signal_Out_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type)
+ is
+ begin
+ Ghdl_Signal_Conversion
+ (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_Out);
+ end Ghdl_Signal_Out_Conversion;
+
+ function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null then
+ -- FIXME: disp signal and process.
+ Error ("'driving error: no driver in process for signal");
+ end if;
+ if Drv.First_Trans.Kind /= Trans_Null then
+ return True;
+ else
+ return False;
+ end if;
+ end Ghdl_Signal_Driving;
+
+ function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.B1;
+ end if;
+ end Ghdl_Signal_Driving_Value_B1;
+
+ function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E8
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.E8;
+ end if;
+ end Ghdl_Signal_Driving_Value_E8;
+
+ function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E32
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.E32;
+ end if;
+ end Ghdl_Signal_Driving_Value_E32;
+
+ function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I32
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.I32;
+ end if;
+ end Ghdl_Signal_Driving_Value_I32;
+
+ function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I64
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.I64;
+ end if;
+ end Ghdl_Signal_Driving_Value_I64;
+
+ function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_F64
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.F64;
+ end if;
+ end Ghdl_Signal_Driving_Value_F64;
+
+ Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr;
+
+ procedure Flush_Active_List
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Next_Sig : Ghdl_Signal_Ptr;
+ begin
+ -- Free active_chain.
+ Sig := Ghdl_Signal_Active_Chain;
+ loop
+ Next_Sig := Sig.Link;
+ exit when Next_Sig = null;
+ Sig.Link := null;
+ Sig := Next_Sig;
+ end loop;
+ Ghdl_Signal_Active_Chain := Sig;
+ end Flush_Active_List;
+
+ function Find_Next_Time return Std_Time
+ is
+ Res : Std_Time;
+ Sig : Ghdl_Signal_Ptr;
+
+ procedure Check_Transaction (Trans : Transaction_Acc)
+ is
+ begin
+ if Trans = null or else Trans.Kind = Trans_Direct then
+ -- Activity of direct drivers is done through link.
+ return;
+ end if;
+
+ if Trans.Time = Res and Sig.Link = null then
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+ elsif Trans.Time < Res then
+ Flush_Active_List;
+
+ -- Put sig on the list.
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+
+ Res := Trans.Time;
+ end if;
+ if Res = Current_Time then
+ -- Must have been in the active list.
+ Internal_Error ("find_next_time(2)");
+ end if;
+ end Check_Transaction;
+ begin
+ -- If there is signals in the active list, then next cycle is a delta
+ -- cycle, so next time is current_time.
+ if Ghdl_Signal_Active_Chain.Link /= null then
+ return Current_Time;
+ end if;
+ if Ghdl_Implicit_Signal_Active_Chain.Link /= null then
+ return Current_Time;
+ end if;
+ Res := Std_Time'Last;
+
+ Sig := Future_List;
+ while Sig.Flink /= null loop
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Check_Transaction (Sig.S.Drivers (J - 1).First_Trans.Next);
+ end loop;
+ when Mode_Delayed
+ | Mode_Stable
+ | Mode_Quiet =>
+ Check_Transaction (Sig.S.Attr_Trans.Next);
+ when others =>
+ Internal_Error ("find_next_time(3)");
+ end case;
+ Sig := Sig.Flink;
+ end loop;
+ return Res;
+ end Find_Next_Time;
+
+-- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr)
+-- return Natural
+-- is
+-- Length : Natural;
+-- begin
+-- Length := Sig.Nbr_Ports;
+-- for I in 0 .. Sig.Nbr_Drivers - 1 loop
+-- case Sig.Drivers (I).First_Trans.Kind is
+-- when Trans_Value =>
+-- Length := Length + 1;
+-- when Trans_Null =>
+-- null;
+-- when Trans_Error =>
+-- Error ("range check error");
+-- end case;
+-- end loop;
+-- return Length;
+-- end Get_Nbr_Non_Null_Source;
+
+ function To_Resolver_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Resolver_Acc);
+
+ procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc)
+ is
+ Sig : constant Ghdl_Signal_Ptr :=
+ Sig_Table.Table (Resolv.Sig_Range.First);
+ Length : Ghdl_Index_Type;
+ type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean;
+ Vec : Bool_Array_Type;
+ begin
+ -- Compute number of non-null drivers.
+ Length := 0;
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ case Sig.S.Drivers (I - 1).First_Trans.Kind is
+ when Trans_Value =>
+ Length := Length + 1;
+ Vec (I) := True;
+ when Trans_Null =>
+ Vec (I) := False;
+ when Trans_Error =>
+ Error ("range check error");
+ when Trans_Direct =>
+ Internal_Error ("compute_resolved_signal: trans_direct");
+ end case;
+ end loop;
+
+ -- Check driving condition on all signals.
+ for J in Resolv.Sig_Range.First + 1.. Resolv.Sig_Range.Last loop
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ if (Sig_Table.Table (J).S.Drivers (I - 1).First_Trans.Kind
+ /= Trans_Null)
+ xor Vec (I)
+ then
+ Error ("null-transaction required");
+ end if;
+ end loop;
+ end loop;
+
+ -- if no driving sources and register, exit.
+ if Length = 0
+ and then Sig.Nbr_Ports = 0
+ and then Sig.Sig_Kind = Kind_Signal_Register
+ then
+ return;
+ end if;
+
+ -- Call the procedure.
+ Resolv.Resolv_Proc.all (Resolv.Resolv_Inst,
+ Resolv.Resolv_Ptr,
+ Vec'Address,
+ Length,
+ Sig.S.Nbr_Drivers,
+ Sig.Nbr_Ports);
+ end Compute_Resolved_Signal;
+
+ procedure Call_Conversion_Function (Conv : Sig_Conversion_Acc)
+ is
+ F : Conversion_Func_Acc;
+ begin
+ F := To_Conversion_Func_Acc (Conv.Func);
+ F.all (Conv.Instance);
+ end Call_Conversion_Function;
+
+ procedure Resume_Process_If_Event
+ (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc)
+ is
+ El : Action_List_Acc;
+ begin
+ El := new Action_List'(Dynamic => False,
+ Proc => Proc,
+ Next => Sig.Event_List);
+ Sig.Event_List := El;
+ end Resume_Process_If_Event;
+
+ -- Order of signals:
+ -- To be computed: driving value or/and effective value
+ -- To be considered: ports, signals, implicit signals, resolution,
+ -- conversion
+ --
+
+ procedure Add_Propagation (P : Propagation_Type) is
+ begin
+ Propagation.Increment_Last;
+ Propagation.Table (Propagation.Last) := P;
+ end Add_Propagation;
+
+ procedure Add_Forward_Propagation (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ Add_Propagation
+ ((Kind => Imp_Forward_Build,
+ Forward => new Forward_Build_Type'(Src => Sig.Ports (I - 1),
+ Targ => Sig)));
+ end loop;
+ end Add_Forward_Propagation;
+
+ -- Put SIG in PROPAGATION table until ORDER level.
+ procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag);
+
+ -- Return TRUE is the effective value of SIG is the driving value of SIG.
+ function Is_Eff_Drv (Sig : Ghdl_Signal_Ptr) return Boolean
+ is
+ begin
+ case Sig.S.Mode_Sig is
+ when Mode_Signal
+ | Mode_Buffer =>
+ return True;
+ when Mode_Linkage
+ | Mode_Out =>
+ -- No effective value.
+ return False;
+ when Mode_Inout
+ | Mode_In =>
+ if Sig.S.Effective = null then
+ if Sig.S.Nbr_Drivers > 0 or Sig.Nbr_Ports > 0 then
+ -- Only for inout.
+ return True;
+ else
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ return False;
+ when Mode_Stable
+ | Mode_Guard
+ | Mode_Quiet
+ | Mode_Transaction
+ | Mode_Delayed =>
+ return True;
+ when Mode_End =>
+ return False;
+ end case;
+ end Is_Eff_Drv;
+
+ procedure Order_Signal_List (Sig : Ghdl_Signal_Ptr;
+ Order : Propag_Order_Flag)
+ is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ Order_Signal (Sig.Ports (I - 1), Order);
+ end loop;
+ end Order_Signal_List;
+
+ -- Put SIG in PROPAGATION table until ORDER level.
+ procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag)
+ is
+ begin
+ if Sig = null then
+ return;
+ end if;
+
+ -- Catch infinite loops, which must never happen.
+ -- Also exit if the signal is already fully ordered.
+ case Sig.Flags.Propag is
+ when Propag_None =>
+ null;
+ when Propag_Being_Driving =>
+ Internal_Error ("order_signal: being driving");
+ when Propag_Being_Effective =>
+ Internal_Error ("order_signal: being effective");
+ when Propag_Driving =>
+ null;
+ when Propag_Done =>
+ -- If sig was already handled, nothing to do!
+ return;
+ end case;
+
+ -- First, the driving value.
+ if Sig.Flags.Propag = Propag_None then
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ if Sig.S.Nbr_Drivers = 0 and Sig.Nbr_Ports = 0 then
+ -- No source.
+ Sig.Flags.Propag := Propag_Driving;
+ elsif Sig.S.Resolv = null then
+ -- Not resolved (so at most one source).
+ if Sig.S.Nbr_Drivers = 1 then
+ -- Not resolved, 1 source : a driver.
+ if Is_Eff_Drv (Sig) then
+ Add_Propagation ((Kind => Eff_One_Driver, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ else
+ Add_Propagation ((Kind => Drv_One_Driver, Sig => Sig));
+ Sig.Flags.Propag := Propag_Driving;
+ end if;
+ else
+ Sig.Flags.Propag := Propag_Being_Driving;
+ -- not resolved, 1 source : Source is a port.
+ Order_Signal (Sig.Ports (0), Propag_Driving);
+ if Is_Eff_Drv (Sig) then
+ Add_Propagation ((Kind => Eff_One_Port, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ else
+ Add_Propagation ((Kind => Drv_One_Port, Sig => Sig));
+ Sig.Flags.Propag := Propag_Driving;
+ end if;
+ end if;
+ else
+ -- Resolved signal.
+ declare
+ Resolv : Resolved_Signal_Acc;
+ S : Ghdl_Signal_Ptr;
+ begin
+ -- Compute driving value of brothers.
+ Resolv := Sig.S.Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ if S.Flags.Propag /= Propag_None then
+ Internal_Error ("order_signal(1)");
+ end if;
+ S.Flags.Propag := Propag_Being_Driving;
+ end loop;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ -- Compute driving value of the sources.
+ for J in 1 .. S.Nbr_Ports loop
+ Order_Signal (S.Ports (J - 1), Propag_Driving);
+ end loop;
+ end loop;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ S.Flags.Propag := Propag_Driving;
+ end loop;
+
+ if Is_Eff_Drv (Sig) then
+ if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then
+ Add_Propagation ((Kind => Eff_One_Resolved,
+ Sig => Sig));
+ else
+ Add_Propagation ((Kind => Eff_Multiple,
+ Resolv => Resolv));
+ end if;
+ else
+ if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then
+ Add_Propagation ((Kind => Drv_One_Resolved,
+ Sig => Sig));
+ else
+ Add_Propagation ((Kind => Drv_Multiple,
+ Resolv => Resolv));
+ end if;
+ end if;
+ end;
+ end if;
+ when Mode_Signal_Implicit =>
+ Sig.Flags.Propag := Propag_Being_Driving;
+ Order_Signal_List (Sig, Propag_Done);
+ Sig.Flags.Propag := Propag_Done;
+ if Sig.S.Mode_Sig in Mode_Signal_Forward then
+ Add_Forward_Propagation (Sig);
+ end if;
+ case Mode_Signal_Implicit (Sig.S.Mode_Sig) is
+ when Mode_Guard =>
+ Add_Propagation ((Kind => Imp_Guard, Sig => Sig));
+ when Mode_Stable =>
+ Add_Propagation ((Kind => Imp_Stable, Sig => Sig));
+ when Mode_Quiet =>
+ Add_Propagation ((Kind => Imp_Quiet, Sig => Sig));
+ when Mode_Transaction =>
+ Add_Propagation ((Kind => Imp_Transaction, Sig => Sig));
+ when Mode_Delayed =>
+ Add_Propagation ((Kind => Imp_Delayed, Sig => Sig));
+ end case;
+ return;
+ when Mode_Conv_In =>
+ -- In conversion signals have no driving value
+ null;
+ when Mode_Conv_Out =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Being_Driving;
+ end loop;
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Driving);
+ end loop;
+ Add_Propagation ((Kind => Out_Conversion, Conv => Conv));
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Done;
+ end loop;
+ end;
+ when Mode_End =>
+ Internal_Error ("order_signal: mode_end");
+ end case;
+ end if;
+
+ -- Effective value.
+ if Order = Propag_Driving then
+ -- Will be done later.
+ return;
+ end if;
+
+ case Sig.S.Mode_Sig is
+ when Mode_Signal
+ | Mode_Buffer =>
+ -- Effective value is driving value.
+ Sig.Flags.Propag := Propag_Done;
+ when Mode_Linkage
+ | Mode_Out =>
+ -- No effective value.
+ Sig.Flags.Propag := Propag_Done;
+ when Mode_Inout
+ | Mode_In =>
+ if Sig.S.Effective = null then
+ -- Effective value is driving value or initial value.
+ null;
+ else
+ Sig.Flags.Propag := Propag_Being_Effective;
+ Order_Signal (Sig.S.Effective, Propag_Done);
+ Add_Propagation ((Kind => Eff_Actual, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ end if;
+ when Mode_Stable
+ | Mode_Guard
+ | Mode_Quiet
+ | Mode_Transaction
+ | Mode_Delayed =>
+ -- Sig.Propag is already set to PROPAG_DONE.
+ null;
+ when Mode_Conv_In =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Being_Effective;
+ end loop;
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Done);
+ end loop;
+ Add_Propagation ((Kind => In_Conversion, Conv => Conv));
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Done;
+ end loop;
+ end;
+ when Mode_Conv_Out =>
+ -- No effective value.
+ null;
+ when Mode_End =>
+ Internal_Error ("order_signal: mode_end");
+ end case;
+ end Order_Signal;
+
+ procedure Set_Net (Sig : Ghdl_Signal_Ptr;
+ Net : Signal_Net_Type;
+ Link : Ghdl_Signal_Ptr)
+ is
+ use Astdio;
+ use Stdio;
+ begin
+ if Sig = null then
+ return;
+ end if;
+
+ if Boolean'(False) then
+ Put ("set_net ");
+ Put_I32 (stdout, Ghdl_I32 (Net));
+ Put (" on ");
+ Put (stdout, Sig.all'Address);
+ Put (" ");
+ Disp_Signals.Disp_Mode_Signal (Sig.S.Mode_Sig);
+ New_Line;
+ end if;
+
+ if Sig.Net /= No_Signal_Net then
+ if Sig.Net /= Net then
+ -- Renumber.
+ if Boolean'(False) then
+ Put ("set_net renumber ");
+ Put_I32 (stdout, Ghdl_I32 (Net));
+ Put (" on ");
+ Put (stdout, Sig.all'Address);
+ New_Line;
+ end if;
+
+ declare
+ S : Ghdl_Signal_Ptr;
+ Old : constant Signal_Net_Type := Sig.Net;
+ begin
+ -- Merge the old net into NET.
+ S := Sig;
+ loop
+ S.Net := Net;
+ S := S.Link;
+ exit when S = Sig;
+ end loop;
+
+ -- Add to the ring.
+ S := Sig.Link;
+ Sig.Link := Link.Link;
+ Link.Link := S;
+
+ -- Check.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I).Net = Old then
+-- Disp_Signals.Disp_Signals_Table;
+-- Disp_Signals.Disp_Signals_Map;
+
+ Internal_Error ("set_net: link corrupted");
+ end if;
+ end loop;
+ end;
+ end if;
+ return;
+ end if;
+
+ Sig.Net := Net;
+
+ -- Add SIG in the LINK ring.
+ -- Note: this works even if LINK is not a ring (ie, LINK.link = null).
+ if Link.Link = null and then Sig /= Link then
+ Internal_Error ("set_net: bad link");
+ end if;
+ Sig.Link := Link.Link;
+ Link.Link := Sig;
+
+ -- Dependences.
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for I in 1 .. Sig.Nbr_Ports loop
+ Set_Net (Sig.Ports (I - 1), Net, Link);
+ end loop;
+ Set_Net (Sig.S.Effective, Net, Link);
+ if Sig.S.Resolv /= null then
+ for I in Sig.S.Resolv.Sig_Range.First
+ .. Sig.S.Resolv.Sig_Range.Last
+ loop
+ Set_Net (Sig_Table.Table (I), Net, Link);
+ end loop;
+ end if;
+ when Mode_Signal_Forward =>
+ null;
+ when Mode_Transaction
+ | Mode_Guard =>
+ for I in 1 .. Sig.Nbr_Ports loop
+ Set_Net (Sig.Ports (I - 1), Net, Link);
+ end loop;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ declare
+ S : Ghdl_Signal_Ptr;
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ S := Sig_Table.Table (Conv.Src.First);
+ if Sig = S or else S.Net /= Net then
+ for J in Conv.Src.First .. Conv.Src.Last loop
+ Set_Net (Sig_Table.Table (J), Net, Link);
+ end loop;
+ for J in Conv.Dest.First .. Conv.Dest.Last loop
+ Set_Net (Sig_Table.Table (J), Net, Link);
+ end loop;
+ end if;
+ end;
+ when Mode_End =>
+ Internal_Error ("set_net");
+ end case;
+ end Set_Net;
+
+ function Get_Propagation_Net (P : Signal_Net_Type) return Signal_Net_Type
+ is
+ begin
+ case Propagation.Table (P).Kind is
+ when Drv_Multiple
+ | Eff_Multiple =>
+ return Sig_Table.Table
+ (Propagation.Table (P).Resolv.Sig_Range.First).Net;
+ when In_Conversion
+ | Out_Conversion =>
+ return Sig_Table.Table
+ (Propagation.Table (P).Conv.Src.First).Net;
+ when Imp_Forward_Build =>
+ return Propagation.Table (P).Forward.Src.Net;
+ when others =>
+ return Propagation.Table (P).Sig.Net;
+ end case;
+ end Get_Propagation_Net;
+
+ Last_Signal_Net : Signal_Net_Type;
+
+ -- Create a net for SIG, or if one of its dependences has already a net,
+ -- merge SIG in this net.
+ procedure Merge_Net (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Resolv = null
+ and then Sig.Nbr_Ports = 0
+ and then Sig.S.Effective = null
+ then
+ Internal_Error ("merge_net(1)");
+ end if;
+
+ if Sig.S.Effective /= null
+ and then Sig.S.Effective.Net /= No_Signal_Net
+ then
+ -- Avoid to create a net, just merge.
+ Set_Net (Sig, Sig.S.Effective.Net, Sig.S.Effective);
+ return;
+ end if;
+ end if;
+
+ if Sig.Nbr_Ports >= 1
+ and then Sig.Ports (0).Net /= No_Signal_Net
+ then
+ -- Avoid to create a net, just merge.
+ Set_Net (Sig, Sig.Ports (0).Net, Sig.Ports (0));
+ else
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Sig, Last_Signal_Net, Sig);
+ end if;
+ end Merge_Net;
+
+ -- Create nets.
+ -- For all signals, set the net field.
+ procedure Create_Nets
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Last_Signal_Net := No_Signal_Net;
+
+ for I in reverse Propagation.First .. Propagation.Last loop
+ case Propagation.Table (I).Kind is
+ when Drv_Error
+ | Prop_End =>
+ null;
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ null;
+ when Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ -- Do not create a net if the signal has no dependences.
+ if Sig.Net = No_Signal_Net
+ and then (Sig.S.Effective /= null or Sig.Nbr_Ports /= 0)
+ then
+ Merge_Net (Sig);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port
+ | Imp_Guard
+ | Imp_Transaction
+ | Eff_Actual
+ | Drv_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Net = No_Signal_Net then
+ Merge_Net (Sig);
+ end if;
+ when Imp_Forward =>
+ -- Should not yet appear.
+ Internal_Error ("create_nets - forward");
+ when Imp_Forward_Build =>
+ Sig := Propagation.Table (I).Forward.Src;
+ if Sig.Net = No_Signal_Net then
+ -- Create a new net with only sig.
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Sig, Last_Signal_Net, Sig);
+ end if;
+ when Imp_Quiet
+ | Imp_Stable
+ | Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Net = No_Signal_Net then
+ -- Create a new net with only sig.
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Sig.Net := Last_Signal_Net;
+ Sig.Link := Sig;
+ end if;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ Link : Ghdl_Signal_Ptr;
+ begin
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Resolv := Propagation.Table (I).Resolv;
+ Link := Sig_Table.Table (Resolv.Sig_Range.First);
+ for J in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Set_Net (Sig_Table.Table (J), Last_Signal_Net, Link);
+ end loop;
+ end;
+ when In_Conversion
+ | Out_Conversion =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ Link : Ghdl_Signal_Ptr;
+ begin
+ Conv := Propagation.Table (I).Conv;
+ Link := Sig_Table.Table (Conv.Src.First);
+ if Link.Net = No_Signal_Net then
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Link, Last_Signal_Net, Link);
+ end if;
+ end;
+ end case;
+ end loop;
+
+ -- Reorder propagation table.
+ declare
+ type Off_Array is array (Signal_Net_Type range <>) of Signal_Net_Type;
+ Offs : Off_Array (0 .. Last_Signal_Net) := (others => 0);
+
+ Last_Off : Signal_Net_Type;
+ Num : Signal_Net_Type;
+
+-- procedure Disp_Offs
+-- is
+-- use Grt.Astdio;
+-- use Grt.Stdio;
+-- begin
+-- for I in Offs'Range loop
+-- if Offs (I) /= 0 then
+-- Put_I32 (stdout, Ghdl_I32 (I));
+-- Put (": ");
+-- Put_I32 (stdout, Ghdl_I32 (Offs (I)));
+-- New_Line;
+-- end if;
+-- end loop;
+-- end Disp_Offs;
+
+ type Propag_Array is array (Signal_Net_Type range <>)
+ of Propagation_Type;
+
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Object => Forward_Build_Type, Name => Forward_Build_Acc);
+
+ Net : Signal_Net_Type;
+ begin
+ -- 1) Count number of propagation cell per net.
+ for I in Propagation.First .. Propagation.Last loop
+ Net := Get_Propagation_Net (I);
+ Offs (Net) := Offs (Net) + 1;
+ end loop;
+
+ -- 2) Convert numbers to offsets.
+ Last_Off := 1;
+ for I in 1 .. Last_Signal_Net loop
+ Num := Offs (I);
+ if Num /= 0 then
+ -- Reserve one slot for a prepended 'prop_end'.
+ Offs (I) := Last_Off + 1;
+ Last_Off := Last_Off + 1 + Num;
+ end if;
+ end loop;
+ Offs (0) := Last_Off + 1;
+
+ declare
+ Propag : Propag_Array (1 .. Last_Off); -- := (others => 0);
+ begin
+ for I in Propagation.First .. Propagation.Last loop
+ Net := Get_Propagation_Net (I);
+ if Net /= No_Signal_Net then
+ Propag (Offs (Net)) := Propagation.Table (I);
+ Offs (Net) := Offs (Net) + 1;
+ end if;
+ end loop;
+ Propagation.Set_Last (Last_Off);
+ Propagation.Release;
+ for I in Propagation.First .. Propagation.Last loop
+ if Propag (I).Kind = Imp_Forward_Build then
+ Propagation.Table (I) := (Kind => Imp_Forward,
+ Sig => Propag (I).Forward.Targ);
+ Deallocate (Propag (I).Forward);
+ else
+ Propagation.Table (I) := Propag (I);
+ end if;
+ end loop;
+ end;
+ for I in 1 .. Last_Signal_Net loop
+ -- Ignore holes.
+ if Offs (I) /= 0 then
+ Propagation.Table (Offs (I)) :=
+ (Kind => Prop_End, Updated => True);
+ end if;
+ end loop;
+ Propagation.Table (1) := (Kind => Prop_End, Updated => True);
+
+ -- 4) Convert back from offset to start position (on the prop_end
+ -- cell).
+ Offs (0) := 1;
+ Last_Off := 1;
+ for I in 1 .. Last_Signal_Net loop
+ if Offs (I) /= 0 then
+ Num := Offs (I);
+ Offs (I) := Last_Off;
+ Last_Off := Num;
+ end if;
+ end loop;
+
+ -- 5) Re-map the nets to cell indexes.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+ if Sig.Net = No_Signal_Net then
+ if Sig.S.Resolv /= null then
+ Sig.Net := Net_One_Resolved;
+ elsif Sig.S.Nbr_Drivers = 1 then
+ if Sig.S.Drivers (0).Last_Trans.Kind = Trans_Direct then
+ Sig.Net := Net_One_Direct;
+ else
+ Sig.Net := Net_One_Driver;
+ end if;
+ end if;
+ else
+ Sig.Net := Offs (Sig.Net);
+ end if;
+ Sig.Link := null;
+ end loop;
+ end;
+ end Create_Nets;
+
+ function Get_Nbr_Future return Ghdl_I32
+ is
+ Res : Ghdl_I32;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Res := 0;
+ Sig := Future_List;
+ while Sig.Flink /= null loop
+ Res := Res + 1;
+ Sig := Sig.Flink;
+ end loop;
+ return Res;
+ end Get_Nbr_Future;
+
+ -- Check every scalar subelement of a resolved signal has a driver
+ -- in the same process.
+ procedure Check_Resolved_Driver (Resolv : Resolved_Signal_Acc)
+ is
+ First_Sig : Ghdl_Signal_Ptr;
+ Nbr : Ghdl_Index_Type;
+ begin
+ First_Sig := Sig_Table.Table (Resolv.Sig_Range.First);
+ Nbr := First_Sig.S.Nbr_Drivers;
+ for I in Resolv.Sig_Range.First + 1 .. Resolv.Sig_Range.Last loop
+ if Sig_Table.Table (I).S.Nbr_Drivers /= Nbr then
+ -- FIXME: provide more information (signal name, process name).
+ Error ("missing drivers for subelement of a resolved signal");
+ end if;
+ end loop;
+ end Check_Resolved_Driver;
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address;
+ pragma Import (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => Resolved_Signal_Acc, Object => Resolved_Signal_Type);
+
+ procedure Order_All_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Resolv : Resolved_Signal_Acc;
+ begin
+ -- Do checks and optimization.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ -- LRM 5.3
+ -- If, by the above rules, no disconnection specification applies to
+ -- the drivers of a guarded, scalar signal S whose type mark is T
+ -- (including a scalar subelement of a composite signal), then the
+ -- following default disconnection specification is implicitly
+ -- assumed:
+ -- disconnect S : T after 0 ns;
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ Resolv := Sig.S.Resolv;
+ if Resolv /= null and then Resolv.Disconnect_Time = Bad_Time then
+ Resolv.Disconnect_Time := 0;
+ end if;
+
+ if Resolv /= null
+ and then Resolv.Sig_Range.First = I
+ and then Resolv.Sig_Range.Last > I
+ then
+ -- Check every scalar subelement of a resolved signal
+ -- has a driver in the same process.
+ Check_Resolved_Driver (Resolv);
+ end if;
+
+ if Resolv /= null
+ and then Resolv.Sig_Range.First = I
+ and then Resolv.Sig_Range.Last = I
+ and then
+ (Resolv.Resolv_Proc
+ = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr))
+ and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1
+ then
+ -- Optimization: remove resolver if there is at most one
+ -- source.
+ Free (Sig.S.Resolv);
+ end if;
+ end if;
+ end loop;
+
+ -- Really order them.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Driving);
+ end loop;
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Done);
+ end loop;
+
+ Create_Nets;
+ end Order_All_Signals;
+
+ -- Add SIG in active_chain.
+ procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr);
+ pragma Inline (Add_Active_Chain);
+
+ procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Sig.Link = null then
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+ end if;
+ end Add_Active_Chain;
+
+ Clear_List : Ghdl_Signal_Ptr := null;
+
+ -- Mark SIG as active and put it on Clear_List (if not already).
+ procedure Mark_Active (Sig : Ghdl_Signal_Ptr);
+ pragma Inline (Mark_Active);
+
+ procedure Mark_Active (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if not Sig.Active then
+ Sig.Active := True;
+ Sig.Last_Active := Current_Time;
+ Sig.Alink := Clear_List;
+ Clear_List := Sig;
+ end if;
+ end Mark_Active;
+
+ procedure Set_Guard_Activity (Sig : Ghdl_Signal_Ptr) is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ if Sig.Ports (I - 1).Active then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ end Set_Guard_Activity;
+
+ procedure Set_Stable_Quiet_Activity
+ (Mode : Propagation_Kind_Type; Sig : Ghdl_Signal_Ptr) is
+ begin
+ case Mode is
+ when Imp_Stable =>
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Event then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ when Imp_Quiet
+ | Imp_Transaction =>
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Active then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ when others =>
+ Internal_Error ("set_stable_quiet_activity");
+ end case;
+ end Set_Stable_Quiet_Activity;
+
+ function Get_Resolved_Activity (Sig : Ghdl_Signal_Ptr) return Boolean
+ is
+ Trans : Transaction_Acc;
+ Res : Boolean := False;
+ begin
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ -- In fact we knew the signal was active!
+ Res := True;
+ elsif Trans.Time = Current_Time then
+ Free (Sig.S.Drivers (J - 1).First_Trans);
+ Sig.S.Drivers (J - 1).First_Trans := Trans;
+ Res := True;
+ end if;
+ end if;
+ end loop;
+ if Res then
+ return True;
+ end if;
+ for J in 1 .. Sig.Nbr_Ports loop
+ if Sig.Ports (J - 1).Active then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Get_Resolved_Activity;
+
+ procedure Set_Conversion_Activity (Conv : Sig_Conversion_Acc)
+ is
+ Active : Boolean := False;
+ begin
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Active := Active or Sig_Table.Table (I).Active;
+ end loop;
+ if Active then
+ Call_Conversion_Function (Conv);
+ end if;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Active := Active;
+ end loop;
+ end Set_Conversion_Activity;
+
+ procedure Delayed_Implicit_Process (Sig : Ghdl_Signal_Ptr)
+ is
+ Pfx : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ Last : Transaction_Acc;
+ Prev : Transaction_Acc;
+ begin
+ Pfx := Sig.Ports (0);
+ if Pfx.Event then
+ -- LRM 14.1
+ -- P: process (S)
+ -- begin
+ -- R <= transport S after T;
+ -- end process;
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + Sig.S.Time,
+ Next => null,
+ Val => Pfx.Value);
+ -- Find the last transaction.
+ Last := Sig.S.Attr_Trans;
+ Prev := Last;
+ while Last.Next /= null loop
+ Prev := Last;
+ Last := Last.Next;
+ end loop;
+ -- Maybe, remove it.
+ if Last.Time > Trans.Time then
+ Internal_Error ("delayed time");
+ elsif Last.Time = Trans.Time then
+ if Prev /= Last then
+ Free (Last);
+ else
+ -- No transaction.
+ if Last.Time /= 0 then
+ -- This can happen only at time = 0.
+ Internal_Error ("delayed");
+ end if;
+ end if;
+ else
+ Prev := Last;
+ end if;
+ -- Append the transaction.
+ Prev.Next := Trans;
+ if Sig.S.Time = 0 then
+ Add_Active_Chain (Sig);
+ end if;
+ end if;
+ end Delayed_Implicit_Process;
+
+ -- Set the effective value of signal SIG to VAL.
+ -- If the value is different from the previous one, resume processes.
+ procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union)
+ is
+ El : Action_List_Acc;
+ begin
+ if not Value_Equal (Sig.Value, Val, Sig.Mode) then
+ Sig.Last_Value := Sig.Value;
+ Sig.Value := Val;
+ Sig.Event := True;
+ Sig.Last_Event := Current_Time;
+ Sig.Flags.Cyc_Event := True;
+
+ El := Sig.Event_List;
+ while El /= null loop
+ Resume_Process (El.Proc);
+ El := El.Next;
+ end loop;
+ end if;
+ end Set_Effective_Value;
+
+ procedure Run_Propagation (Start : Signal_Net_Type)
+ is
+ I : Signal_Net_Type;
+ Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ First_Trans : Transaction_Acc;
+ begin
+ I := Start;
+ loop
+ -- First: the driving value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ Sig := Propagation.Table (I).Sig;
+ First_Trans := Sig.S.Drivers (0).First_Trans;
+ Trans := First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ -- Note: already or will be marked as active in
+ -- update_signals.
+ Mark_Active (Sig);
+ Direct_Assign (First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ Sig.Driving_Value := First_Trans.Val;
+ elsif Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (First_Trans);
+ Sig.S.Drivers (0).First_Trans := Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ Sig.Driving_Value := Trans.Val;
+ when Trans_Direct =>
+ Internal_Error ("run_propagation: trans_direct");
+ when Trans_Null =>
+ Error ("null transaction");
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ end if;
+ end if;
+ when Drv_One_Resolved
+ | Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Get_Resolved_Activity (Sig) then
+ Mark_Active (Sig);
+ Compute_Resolved_Signal (Propagation.Table (I).Sig.S.Resolv);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Ports (0).Active then
+ Mark_Active (Sig);
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ end if;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ -- Note: the signal may have drivers (inout ports).
+ if Sig.S.Effective.Active and not Sig.Active then
+ Mark_Active (Sig);
+ end if;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ declare
+ Active : Boolean := False;
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Sig := Sig_Table.Table (I);
+ Active := Active or Get_Resolved_Activity (Sig);
+ end loop;
+ if Active then
+ -- Mark the first signal as active (since only this one
+ -- will be checked to set effective value).
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ Mark_Active (Sig_Table.Table (I));
+ end loop;
+ Compute_Resolved_Signal (Resolv);
+ end if;
+ end;
+ when Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Forward =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Link = null then
+ Sig.Link := Ghdl_Implicit_Signal_Active_Chain;
+ Ghdl_Implicit_Signal_Active_Chain := Sig;
+ end if;
+ when Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (Sig.S.Attr_Trans);
+ Sig.S.Attr_Trans := Trans;
+ Sig.Driving_Value := Trans.Val;
+ end if;
+ when In_Conversion =>
+ null;
+ when Out_Conversion =>
+ Set_Conversion_Activity (Propagation.Table (I).Conv);
+ when Prop_End =>
+ return;
+ when Drv_Error =>
+ Internal_Error ("update signals");
+ end case;
+
+ -- Second: the effective value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Drv_One_Port
+ | Drv_One_Resolved
+ | Drv_Multiple =>
+ null;
+ when Eff_One_Driver
+ | Eff_One_Port
+ | Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ when Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ if Sig_Table.Table (Resolv.Sig_Range.First).Active then
+ -- If one signal is active, all are active.
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ Sig := Sig_Table.Table (I);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end loop;
+ end if;
+ end;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.S.Effective.Value);
+ end if;
+ when Imp_Forward
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Guard =>
+ -- Guard signal is active iff one of its dependence is active.
+ Sig := Propagation.Table (I).Sig;
+ Set_Guard_Activity (Sig);
+ if Sig.Active then
+ Sig.Driving_Value.B1 :=
+ Sig.S.Guard_Func.all (Sig.S.Guard_Instance);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ when Imp_Stable
+ | Imp_Quiet =>
+ Sig := Propagation.Table (I).Sig;
+ Set_Stable_Quiet_Activity (Propagation.Table (I).Kind, Sig);
+ if Sig.Active then
+ Sig.Driving_Value :=
+ Value_Union'(Mode => Mode_B1, B1 => False);
+ -- Set driver.
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + Sig.S.Time,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => True));
+ if Sig.S.Attr_Trans.Next /= null then
+ Free (Sig.S.Attr_Trans.Next);
+ end if;
+ Sig.S.Attr_Trans.Next := Trans;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ if Sig.S.Time = 0 then
+ Add_Active_Chain (Sig);
+ end if;
+ else
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (Sig.S.Attr_Trans);
+ Sig.S.Attr_Trans := Trans;
+ Sig.Driving_Value := Trans.Val;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ end if;
+ when Imp_Transaction =>
+ -- LRM 12.6.3 Updating Implicit Signals
+ -- Finally, for any implicit signal S'Transaction, the current
+ -- value of the signal is modified if and only if S is active.
+ -- If signal S is active, then S'Transaction is updated by
+ -- assigning the value of the expression (not S'Transaction)
+ -- to the variable representing the current value of
+ -- S'Transaction.
+ Sig := Propagation.Table (I).Sig;
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Active then
+ Mark_Active (Sig);
+ Set_Effective_Value
+ (Sig, Value_Union'(Mode => Mode_B1,
+ B1 => not Sig.Value.B1));
+ exit;
+ end if;
+ end loop;
+ when Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ Delayed_Implicit_Process (Sig);
+ when In_Conversion =>
+ Set_Conversion_Activity (Propagation.Table (I).Conv);
+ when Out_Conversion =>
+ null;
+ when Prop_End =>
+ null;
+ when Drv_Error =>
+ Internal_Error ("run_propagation(2)");
+ end case;
+ I := I + 1;
+ end loop;
+ end Run_Propagation;
+
+ procedure Reset_Active_Flag
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ -- 1) Reset active flag.
+ Sig := Clear_List;
+ Clear_List := null;
+ while Sig /= null loop
+ if Options.Flag_Stats then
+ if Sig.Active then
+ Nbr_Active := Nbr_Active + 1;
+ end if;
+ if Sig.Event then
+ Nbr_Events := Nbr_Events + 1;
+ end if;
+ end if;
+ Sig.Active := False;
+ Sig.Event := False;
+
+ Sig := Sig.Alink;
+ end loop;
+
+-- for I in Sig_Table.First .. Sig_Table.Last loop
+-- Sig := Sig_Table.Table (I);
+-- if Sig.Active or Sig.Event then
+-- Internal_Error ("reset_active_flag");
+-- end if;
+-- end loop;
+ end Reset_Active_Flag;
+
+ procedure Update_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Next_Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ begin
+ -- LRM93 12.6.2
+ -- 1) Reset active flag.
+ Reset_Active_Flag;
+
+ -- For each active signals
+ Sig := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Signal_End;
+ while Sig.S.Mode_Sig /= Mode_End loop
+ Next_Sig := Sig.Link;
+ Sig.Link := null;
+
+ case Sig.Net is
+ when Net_One_Driver =>
+ -- This signal is active.
+ Mark_Active (Sig);
+
+ Trans := Sig.S.Drivers (0).First_Trans.Next;
+ Free (Sig.S.Drivers (0).First_Trans);
+ Sig.S.Drivers (0).First_Trans := Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ Sig.Driving_Value := Trans.Val;
+ when Trans_Direct =>
+ Internal_Error ("update_signals: trans_direct");
+ when Trans_Null =>
+ Error ("null transaction");
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when Net_One_Direct =>
+ Mark_Active (Sig);
+ Sig.Is_Direct_Active := False;
+
+ Trans := Sig.S.Drivers (0).Last_Trans;
+ Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode);
+ Sig.S.Drivers (0).First_Trans.Val := Sig.Driving_Value;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when Net_One_Resolved =>
+ -- This signal is active.
+ Mark_Active (Sig);
+ Sig.Is_Direct_Active := False;
+
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ elsif Trans.Time = Current_Time then
+ Free (Sig.S.Drivers (J - 1).First_Trans);
+ Sig.S.Drivers (J - 1).First_Trans := Trans;
+ end if;
+ end if;
+ end loop;
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when No_Signal_Net =>
+ Internal_Error ("update_signals: no_signal_net");
+
+ when others =>
+ Sig.Is_Direct_Active := False;
+ if not Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := True;
+ Run_Propagation (Sig.Net + 1);
+
+ -- Put it on the list, so that updated flag will be cleared.
+ Add_Active_Chain (Sig);
+ end if;
+ end case;
+
+ Sig := Next_Sig;
+ end loop;
+
+ -- Implicit signals (forwarded).
+ loop
+ Sig := Ghdl_Implicit_Signal_Active_Chain;
+ exit when Sig.Link = null;
+ Ghdl_Implicit_Signal_Active_Chain := Sig.Link;
+ Sig.Link := null;
+
+ if not Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := True;
+ Run_Propagation (Sig.Net + 1);
+
+ -- Put it on the list, so that updated flag will be cleared.
+ Add_Active_Chain (Sig);
+ end if;
+ end loop;
+
+ -- Un-mark updated.
+ Sig := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Signal_End;
+ while Sig.Link /= null loop
+ Propagation.Table (Sig.Net).Updated := False;
+ Next_Sig := Sig.Link;
+ Sig.Link := null;
+
+ -- Maybe put SIG in the active list, if it will be active during
+ -- the next cycle.
+ -- This can happen only for 'quiet, 'stable or 'delayed.
+ case Sig.S.Mode_Sig is
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ declare
+ Trans : Transaction_Acc;
+ begin
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Sig.Link := Ghdl_Implicit_Signal_Active_Chain;
+ Ghdl_Implicit_Signal_Active_Chain := Sig;
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+
+ Sig := Next_Sig;
+ end loop;
+ end Update_Signals;
+
+ procedure Run_Propagation_Init (Start : Signal_Net_Type)
+ is
+ I : Signal_Net_Type;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ I := Start;
+ loop
+ -- First: the driving value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ -- Nothing to do: drivers were already created.
+ null;
+ when Drv_One_Resolved
+ | Eff_One_Resolved =>
+ -- Execute the resolution function.
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Nbr_Ports > 0 then
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port =>
+ -- Copy value.
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ when Eff_Actual =>
+ null;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ Compute_Resolved_Signal (Propagation.Table (I).Resolv);
+ when Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Delayed =>
+ -- LRM 14.1
+ -- Assuming that the initial value of R is the same as the
+ -- initial value of S, [...]
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ when In_Conversion =>
+ null;
+ when Out_Conversion =>
+ Call_Conversion_Function (Propagation.Table (I).Conv);
+ when Prop_End =>
+ return;
+ when Drv_Error =>
+ Internal_Error ("init_signals");
+ end case;
+
+ -- Second: the effective value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Drv_One_Port
+ | Drv_One_Resolved
+ | Drv_Multiple =>
+ null;
+ when Eff_One_Driver
+ | Eff_One_Port
+ | Eff_One_Resolved
+ | Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ Sig.Value := Sig.Driving_Value;
+ when Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Sig := Sig_Table.Table (I);
+ Sig.Value := Sig.Driving_Value;
+ end loop;
+ end;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ Sig.Value := Sig.S.Effective.Value;
+ when Imp_Guard =>
+ -- Guard signal is active iff one of its dependence is active.
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value.B1 :=
+ Sig.S.Guard_Func.all (Sig.S.Guard_Instance);
+ Sig.Value := Sig.Driving_Value;
+ when Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward
+ | Imp_Forward_Build =>
+ -- Already initialized during creation.
+ null;
+ when In_Conversion =>
+ Call_Conversion_Function (Propagation.Table (I).Conv);
+ when Out_Conversion =>
+ null;
+ when Prop_End =>
+ null;
+ when Drv_Error =>
+ Internal_Error ("init_signals(2)");
+ end case;
+
+ I := I + 1;
+ end loop;
+ end Run_Propagation_Init;
+
+ procedure Init_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ case Sig.Net is
+ when Net_One_Driver
+ | Net_One_Direct =>
+ -- Nothing to do: drivers were already created.
+ null;
+
+ when Net_One_Resolved =>
+ Sig.Has_Active := True;
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ Sig.Value := Sig.Driving_Value;
+ end if;
+
+ when No_Signal_Net =>
+ null;
+
+ when others =>
+ if Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := False;
+ Run_Propagation_Init (Sig.Net + 1);
+ end if;
+ end case;
+ end loop;
+
+ end Init_Signals;
+
+ procedure Init is
+ begin
+ Signal_End := new Ghdl_Signal'(Value => (Mode => Mode_B1,
+ B1 => False),
+ Driving_Value => (Mode => Mode_B1,
+ B1 => False),
+ Last_Value => (Mode => Mode_B1,
+ B1 => False),
+ Last_Event => 0,
+ Last_Active => 0,
+ Event => False,
+ Active => False,
+ Has_Active => False,
+ Is_Direct_Active => False,
+ Sig_Kind => Kind_Signal_No,
+ Mode => Mode_B1,
+
+ Flags => (Propag => Propag_None,
+ Is_Dumped => False,
+ Cyc_Event => False,
+ Seen => False),
+
+ Net => No_Signal_Net,
+ Link => null,
+ Alink => null,
+ Flink => null,
+
+ Event_List => null,
+ Rti => null,
+
+ Nbr_Ports => 0,
+ Ports => null,
+
+ S => (Mode_Sig => Mode_End));
+
+ Ghdl_Signal_Active_Chain := Signal_End;
+ Ghdl_Implicit_Signal_Active_Chain := Signal_End;
+ Future_List := Signal_End;
+
+ Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr;
+ Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr;
+ end Init;
+
+end Grt.Signals;
diff --git a/src/translate/grt/grt-signals.ads b/src/translate/grt/grt-signals.ads
new file mode 100644
index 000000000..d792f1634
--- /dev/null
+++ b/src/translate/grt/grt-signals.ads
@@ -0,0 +1,919 @@
+-- GHDL Run Time (GRT) - signals management.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Ada.Unchecked_Conversion;
+with Grt.Table;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+limited with Grt.Processes;
+pragma Elaborate_All (Grt.Table);
+
+package Grt.Signals is
+ pragma Suppress (All_Checks);
+
+ -- Kind of transaction.
+ type Transaction_Kind is
+ (
+ -- Normal transaction, with a value.
+ Trans_Value,
+ -- Normal transaction, with a pointer to a value (direct assignment).
+ Trans_Direct,
+ -- Null transaction.
+ Trans_Null,
+ -- Like a normal transaction, but without a value due to check error.
+ Trans_Error
+ );
+
+ type Transaction;
+ type Transaction_Acc is access Transaction;
+ type Transaction (Kind : Transaction_Kind) is record
+ -- Line for error. Put here to compact the record.
+ Line : Ghdl_I32;
+
+ Next : Transaction_Acc;
+ Time : Std_Time;
+ case Kind is
+ when Trans_Value =>
+ Val : Value_Union;
+ when Trans_Direct =>
+ Val_Ptr : Ghdl_Value_Ptr;
+ when Trans_Null =>
+ null;
+ when Trans_Error =>
+ -- Filename for error.
+ File : Ghdl_C_String;
+ end case;
+ end record;
+
+ type Process_Acc is access Grt.Processes.Process_Type;
+
+ -- A driver is bound to a process (PROC) and contains a list of
+ -- transactions.
+ type Driver_Type is record
+ First_Trans : Transaction_Acc;
+ Last_Trans : Transaction_Acc;
+ Proc : Process_Acc;
+ end record;
+
+ type Driver_Acc is access all Driver_Type;
+ type Driver_Fat_Array is array (Ghdl_Index_Type) of aliased Driver_Type;
+ type Driver_Arr_Ptr is access Driver_Fat_Array;
+
+ -- Function access type used to evaluate the guard expression.
+ type Guard_Func_Acc is access function (This : System.Address)
+ return Ghdl_B1;
+ pragma Convention (C, Guard_Func_Acc);
+
+ -- Simply linked list of processes to be resumed in case of events.
+
+ type Ghdl_Signal;
+ type Ghdl_Signal_Ptr is access Ghdl_Signal;
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Ghdl_Signal_Ptr);
+
+ type Signal_Fat_Array is array (Ghdl_Index_Type) of Ghdl_Signal_Ptr;
+ type Signal_Arr_Ptr is access Signal_Fat_Array;
+
+ function To_Signal_Arr_Ptr is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Signal_Arr_Ptr);
+
+ -- List of processes to wake-up in case of event on the signal.
+ type Action_List;
+ type Action_List_Acc is access Action_List;
+
+ type Action_List (Dynamic : Boolean) is record
+ -- Next action for the current signal.
+ Next : Action_List_Acc;
+
+ -- Process to wake-up.
+ Proc : Process_Acc;
+
+ case Dynamic is
+ when True =>
+ -- For a non-sensitized process.
+ -- Previous action (to speed-up remove from the chain).
+ Prev : Action_List_Acc;
+
+ Sig : Ghdl_Signal_Ptr;
+
+ -- Chain of signals for the process.
+ Chain : Action_List_Acc;
+ when False =>
+ null;
+ end case;
+ end record;
+
+ -- Resolution function.
+ -- There is a wrapper around resolution functions to simplify the call
+ -- from GRT.
+ -- INSTANCE is the opaque parameter given when the resolver is
+ -- registers (RESOLV_INST).
+ -- VAL is the signal (which may be composite).
+ -- BOOL_VEC is an array of NBR_DRV booleans (bytes) and indicates
+ -- non-null drivers. There are VEC_LEN non-null drivers. So the number
+ -- of values is VEC_LEN + NBR_PORTS. This number of values is the length
+ -- of the array for the resolution function.
+ type Resolver_Acc is access procedure
+ (Instance : System.Address;
+ Val : System.Address;
+ Bool_Vec : System.Address;
+ Vec_Len : Ghdl_Index_Type;
+ Nbr_Drv : Ghdl_Index_Type;
+ Nbr_Ports : Ghdl_Index_Type);
+
+ -- On some platforms, GNAT use a descriptor (instead of a trampoline) for
+ -- nested subprograms. This descriptor contains the address of the
+ -- subprogram and the address of the chain. An unaligned pointer to this
+ -- descriptor (address + 1) is then used for 'Access, and every indirect
+ -- call check for unaligned address.
+ --
+ -- Disable this feature (as a resolver is never a nested subprogram), so
+ -- code generated by ghdl is compatible with ghdl runtimes built with
+ -- gnat.
+ pragma Convention (C, Resolver_Acc);
+
+ -- How to compute resolved signal.
+ type Resolved_Signal_Type is record
+ Resolv_Proc : Resolver_Acc;
+ Resolv_Inst : System.Address;
+ Resolv_Ptr : System.Address;
+ Sig_Range : Sig_Table_Range;
+ Disconnect_Time : Std_Time;
+ end record;
+
+ type Resolved_Signal_Acc is access Resolved_Signal_Type;
+
+ type Conversion_Func_Acc is access procedure (Instance : System.Address);
+ pragma Convention (C, Conversion_Func_Acc);
+
+ function To_Conversion_Func_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Conversion_Func_Acc);
+
+ -- Signal conversion data.
+ type Sig_Conversion_Type is record
+ -- Function which performs the conversion.
+ Func : System.Address;
+ Instance : System.Address;
+
+ Src : Sig_Table_Range;
+ Dest : Sig_Table_Range;
+ end record;
+ type Sig_Conversion_Acc is access Sig_Conversion_Type;
+
+ type Forward_Build_Type is record
+ Src : Ghdl_Signal_Ptr;
+ Targ : Ghdl_Signal_Ptr;
+ end record;
+ type Forward_Build_Acc is access Forward_Build_Type;
+
+ -- Used to order the signals for the propagation of signals values.
+ type Propag_Order_Flag is
+ (
+ -- The signal was not yet ordered.
+ Propag_None,
+ -- The signal is being ordered for driving value.
+ -- This stage is used to catch loop (which can not occur).
+ Propag_Being_Driving,
+ -- The signal has been ordered for driving value.
+ Propag_Driving,
+ -- The signal is being ordered for effective value.
+ Propag_Being_Effective,
+ -- The signal has completly been ordered.
+ Propag_Done);
+
+ -- Each signal belongs to a signal_net.
+ -- Signals on the same net must be updated in order.
+ -- Signals on different nets have no direct relation-ship, and thus may
+ -- be updated without order.
+ -- Net NO_SIGNAL_NET is special: it groups all lonely signals.
+ type Signal_Net_Type is new Integer;
+ No_Signal_Net : constant Signal_Net_Type := 0;
+ Net_One_Driver : constant Signal_Net_Type := -1;
+ Net_One_Direct : constant Signal_Net_Type := -2;
+ Net_One_Resolved : constant Signal_Net_Type := -3;
+
+ -- Flush the list of active signals.
+ procedure Flush_Active_List;
+
+ type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal)
+ is record
+ case Mode_Sig is
+ when Mode_Signal_User =>
+ Nbr_Drivers : Ghdl_Index_Type;
+ Drivers : Driver_Arr_Ptr;
+
+ -- Signal which defines the effective value of this signal,
+ -- if any.
+ Effective : Ghdl_Signal_Ptr;
+
+ -- Null if not resolved.
+ Resolv : Resolved_Signal_Acc;
+
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ -- Conversion paramaters for conv_in, conv_out.
+ Conv : Sig_Conversion_Acc;
+
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ -- Time parameter for 'stable, 'quiet or 'delayed
+ Time : Std_Time;
+ Attr_Trans : Transaction_Acc;
+
+ when Mode_Guard =>
+ -- Guard function and instance used to compute the
+ -- guard expression.
+ Guard_Func : Guard_Func_Acc;
+ Guard_Instance : System.Address;
+
+ when Mode_Transaction
+ | Mode_End =>
+ null;
+ end case;
+ end record;
+ pragma Suppress (Discriminant_Check, On => Ghdl_Signal_Data);
+
+ type Ghdl_Signal_Flags is record
+ -- Status of the ordering.
+ Propag : Propag_Order_Flag;
+
+ -- If set, the signal is dumped in a GHW file.
+ Is_Dumped : Boolean;
+
+ -- Set when an event occured.
+ -- Only reset by GHW file dumper.
+ Cyc_Event : Boolean;
+
+ -- Set if the signal has already been visited. When outside of the
+ -- algorithm that use it, it must be cleared.
+ Seen : Boolean;
+ end record;
+ pragma Pack (Ghdl_Signal_Flags);
+
+ type Ghdl_Signal is record
+ -- Fields known by the compilers.
+ Value : Value_Union;
+ Driving_Value : Value_Union;
+ Last_Value : Value_Union;
+ Last_Event : Std_Time;
+ Last_Active : Std_Time;
+
+ Event : Boolean;
+ Active : Boolean;
+ -- If set, the activity of the signal is required by the user.
+ Has_Active : Boolean;
+
+ -- Internal fields.
+ -- NOTE: keep above fields (components) in sync with translation.
+
+ -- If set, the signal has an active direct driver.
+ Is_Direct_Active : Boolean;
+
+ -- Kind of the signal (none, bus or register).
+ Sig_Kind : Kind_Signal_Type;
+
+ -- Values mode of this signal.
+ Mode : Mode_Type;
+
+ -- Misc flags.
+ Flags : Ghdl_Signal_Flags;
+
+ -- Net of the signal.
+ Net : Signal_Net_Type;
+
+ -- Chain of signals that will be active in the next delta-cycle.
+ -- (Also used to build nets).
+ Link : Ghdl_Signal_Ptr;
+
+ -- Chain of signals whose active flag was set. Used to clear the active
+ -- flag at the end of the delta cycle.
+ Alink : Ghdl_Signal_Ptr;
+
+ -- Chain of signals that have a projected waveform in the real future.
+ Flink : Ghdl_Signal_Ptr;
+
+ -- List of processes to resume when there is an event on
+ -- this signal.
+ Event_List : Action_List_Acc;
+
+ -- Path of the signal (with its name) in the design hierarchy.
+ -- Used to get the type of the signal.
+ Rti : Ghdl_Rtin_Object_Acc;
+
+ -- For user signals: the sources of a signals are drivers
+ -- and connected ports.
+ -- For implicit signals: PORTS is used as dependence list.
+ Nbr_Ports : Ghdl_Index_Type;
+ Ports : Signal_Arr_Ptr;
+
+ -- Mode of the signal (in, out ...)
+ --Mode_Signal : Mode_Signal_Type;
+ S : Ghdl_Signal_Data;
+ end record;
+
+ -- Each simple signal declared can be accessed by SIG_TABLE.
+ package Sig_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_Signal_Ptr,
+ Table_Index_Type => Sig_Table_Index,
+ Table_Low_Bound => 0,
+ Table_Initial => 128);
+
+ -- Return the next time at which a driver becomes active.
+ function Find_Next_Time return Std_Time;
+
+ -- Elementary propagation computation.
+ -- See LRM 12.6.2 and 12.6.3
+ type Propagation_Kind_Type is
+ (
+ -- How to compute driving value:
+ -- Default value.
+ Drv_Error,
+
+ -- One source, a driver and not resolved:
+ -- the driving value is the driver.
+ Drv_One_Driver,
+
+ -- Same as previous, and the effective value is the driving value.
+ Eff_One_Driver,
+
+ -- One source, a port and not resolved:
+ -- the driving value is the driving value of the port.
+ -- Dependence.
+ Drv_One_Port,
+
+ -- Same as previous, and the effective value is the driving value.
+ Eff_One_Port,
+
+ -- Several sources or resolved:
+ -- signal is not composite.
+ Drv_One_Resolved,
+ Eff_One_Resolved,
+
+ -- Use the resolution function, signal is composite.
+ Drv_Multiple,
+
+ -- Same as previous, but the effective value is the previous value.
+ Eff_Multiple,
+
+ -- The effective value is the actual associated.
+ Eff_Actual,
+
+ -- Sig must be updated but does not belong to the same net.
+ Imp_Forward,
+ Imp_Forward_Build,
+
+ -- Implicit guard signal.
+ -- Its value must be evaluated after the effective value of its
+ -- dependences.
+ Imp_Guard,
+
+ -- Implicit stable.
+ -- Its value must be evaluated after the effective value of its
+ -- dependences.
+ Imp_Stable,
+
+ -- Implicit quiet.
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Quiet,
+
+ -- Implicit transaction.
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Transaction,
+
+ -- Implicit delayed
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Delayed,
+
+ -- in_conversion.
+ -- Pseudo-signal which is set by conversion function.
+ In_Conversion,
+ Out_Conversion,
+
+ -- End of propagation.
+ Prop_End
+ );
+
+ type Propagation_Type (Kind : Propagation_Kind_Type := Drv_Error) is record
+ case Kind is
+ when Drv_Error =>
+ null;
+ when Drv_One_Driver
+ | Eff_One_Driver
+ | Drv_One_Port
+ | Eff_One_Port
+ | Imp_Forward
+ | Imp_Guard
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Stable
+ | Imp_Delayed
+ | Eff_Actual
+ | Eff_One_Resolved
+ | Drv_One_Resolved =>
+ Sig : Ghdl_Signal_Ptr;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ Resolv : Resolved_Signal_Acc;
+ when In_Conversion
+ | Out_Conversion =>
+ Conv : Sig_Conversion_Acc;
+ when Imp_Forward_Build =>
+ Forward : Forward_Build_Acc;
+ when Prop_End =>
+ Updated : Boolean;
+ end case;
+ end record;
+
+ package Propagation is new Grt.Table
+ (Table_Component_Type => Propagation_Type,
+ Table_Index_Type => Signal_Net_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 128);
+
+ -- Get the signal index of PTR.
+ function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index;
+
+ -- Compute propagation order of signals.
+ procedure Order_All_Signals;
+
+ -- Initialize the package (mainly the lists).
+ procedure Init;
+
+ -- Initialize all signals.
+ procedure Init_Signals;
+
+ -- Update signals.
+ procedure Update_Signals;
+
+ -- Set the effective value of signal SIG to VAL.
+ -- If the value is different from the previous one, resume processes.
+ procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union);
+
+ -- Add PROC in the list of processes to be resumed in case of event on
+ -- SIG.
+ procedure Resume_Process_If_Event
+ (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc);
+
+ -- Creating a signal:
+ -- 1a) call Ghdl_Signal_Name_Rti (CTXT and ADDR are unused) to register
+ -- the RTI for the whole signal (in particular the mode and the
+ -- has_active flag)
+ -- or
+ -- 1b) call Ghdl_Signal_Set_Mode to register the mode and the has_active
+ -- flag. In that case, the signal has no name.
+ --
+ -- 2) call Ghdl_Create_Signal_XXX for each non-composite element
+
+ procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+
+ procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+ Has_Active : Boolean);
+
+ -- FIXME: document.
+ -- Merge RTI with SIG: adjust the has_active flag of SIG according to RTI.
+ procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr;
+ Rti : Ghdl_Rti_Access);
+
+ -- Assigning a waveform to a signal:
+ --
+ -- For simple waveform (sig <= val), the short form can be used:
+ -- Ghdl_Signal_Simple_Assign_XX (Sig, Val);
+ -- For all other forms
+ -- SIG <= reject R inertial V1 after T1, V2 after T2, ...:
+ -- Ghdl_Signal_Start_Assign_XX (SIG, R, V1, T1);
+ -- Ghdl_Signal_Next_Assign_XX (SIG, V2, T2);
+ -- ...
+ -- If the delay mechanism is transport, they R = 0,
+ -- if there is no rejection time, the mechanism is internal and R = T1.
+
+ -- Performs some internal checks on signals (transaction order).
+ -- Internal_error is called in case of error.
+ procedure Ghdl_Signal_Internal_Checks;
+
+ procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+ procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+ procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+
+ procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr);
+
+ procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr;
+ Time : Std_Time);
+
+ procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr);
+
+ procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time);
+
+ function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1;
+
+ function Ghdl_Create_Signal_B1 (Init_Val : Ghdl_B1;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1);
+ procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1);
+ procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1);
+ procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_B1;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_B1;
+
+ function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8);
+ procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8);
+ procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8);
+ procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E8;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E8;
+
+ function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32);
+ procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32);
+ procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32);
+ procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E32;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E32;
+
+ function Ghdl_Create_Signal_I32 (Init_Val : Ghdl_I32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32);
+ procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32);
+ procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I32;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I32;
+
+ function Ghdl_Create_Signal_I64 (Init_Val : Ghdl_I64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64);
+ procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64);
+ procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64);
+ procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I64;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I64;
+
+ function Ghdl_Create_Signal_F64 (Init_Val : Ghdl_F64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64);
+ procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64);
+ procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_F64;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_F64;
+
+ -- Add a driver to SIGN for the current process.
+ procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr);
+
+ -- Add a direct driver for the current process. This is an optimization
+ -- that could be used when a driver has no projected waveforms.
+ --
+ -- Assignment using direct driver:
+ -- * the driver value is set
+ -- * put the signal on the ghdl_signal_active_chain, if the signal will
+ -- be active and if not already on the chain.
+ procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr;
+ Drv : Ghdl_Value_Ptr);
+
+ -- Used for connexions:
+ -- SRC is a source for TARG.
+ procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr);
+
+ -- The effective value of TARG is the effective value of SRC.
+ procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr);
+
+ -- Conversions. In order to do conversion from A to B, an intermediate
+ -- signal T must be created. The flow is A -> T -> B.
+ -- The link from A -> T is a conversion, added by one of the two
+ -- following procedures. The type of A and T is different.
+ -- The link from T -> B is a normal connection: either an effective
+ -- one (for in conversion) or a source (for out conversion).
+
+ -- Add an in conversion (from SRC to DEST using function FUNC).
+ -- The effective value can be read and writen directly.
+ procedure Ghdl_Signal_In_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type);
+
+ -- Add an out conversion.
+ -- The driving value can be read and writen directly.
+ procedure Ghdl_Signal_Out_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type);
+
+ -- Mark the next (and not yet created) NBR_SIG signals as resolved.
+ procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc;
+ Instance : System.Address;
+ Sig : System.Address;
+ Nbr_Sig : Ghdl_Index_Type);
+
+ -- Create a new 'stable (VAL) signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr;
+ -- Create a new 'quiet (VAL) signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr;
+ -- Create a new 'transaction signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr;
+
+ -- Create a new SIG'delayed (VAL) signal.
+ function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time)
+ return Ghdl_Signal_Ptr;
+
+ -- Add SIG in the set of prefix for the last created signal.
+ procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr);
+
+ -- Create a new implicitly defined GUARD signal.
+ function Ghdl_Signal_Create_Guard (This : System.Address;
+ Proc : Guard_Func_Acc)
+ return Ghdl_Signal_Ptr;
+
+ -- Add SIG to the list of referenced signals that appear in the guard
+ -- expression.
+ procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr);
+
+ -- Return number of ports/drivers.
+ function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type;
+ function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type;
+
+ -- Read a source (port or driver) from a signal. This is used by
+ -- resolution functions.
+ function Ghdl_Signal_Read_Port
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr;
+ function Ghdl_Signal_Read_Driver
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr;
+
+ Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr;
+
+ -- Statistics.
+ Nbr_Active : Ghdl_I32;
+ Nbr_Events: Ghdl_I32;
+ function Get_Nbr_Future return Ghdl_I32;
+private
+ pragma Export (C, Ghdl_Signal_Name_Rti,
+ "__ghdl_signal_name_rti");
+ pragma Export (C, Ghdl_Signal_Merge_Rti,
+ "__ghdl_signal_merge_rti");
+
+ pragma Export (C, Ghdl_Signal_Simple_Assign_Error,
+ "__ghdl_signal_simple_assign_error");
+ pragma Export (C, Ghdl_Signal_Start_Assign_Error,
+ "__ghdl_signal_start_assign_error");
+ pragma Export (C, Ghdl_Signal_Next_Assign_Error,
+ "__ghdl_signal_next_assign_error");
+
+ pragma Export (C, Ghdl_Signal_Start_Assign_Null,
+ "__ghdl_signal_start_assign_null");
+
+ pragma Export (C, Ghdl_Signal_Direct_Assign,
+ "__ghdl_signal_direct_assign");
+
+ pragma Export (C, Ghdl_Signal_Set_Disconnect,
+ "__ghdl_signal_set_disconnect");
+ pragma Export (C, Ghdl_Signal_Disconnect,
+ "__ghdl_signal_disconnect");
+
+ pragma Export (Ada, Ghdl_Signal_Driving,
+ "__ghdl_signal_driving");
+
+ pragma Export (Ada, Ghdl_Create_Signal_B1,
+ "__ghdl_create_signal_b1");
+ pragma Export (Ada, Ghdl_Signal_Init_B1,
+ "__ghdl_signal_init_b1");
+ pragma Export (Ada, Ghdl_Signal_Associate_B1,
+ "__ghdl_signal_associate_b1");
+ pragma Export (Ada, Ghdl_Signal_Simple_Assign_B1,
+ "__ghdl_signal_simple_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Start_Assign_B1,
+ "__ghdl_signal_start_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Next_Assign_B1,
+ "__ghdl_signal_next_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Driving_Value_B1,
+ "__ghdl_signal_driving_value_b1");
+
+ pragma Export (C, Ghdl_Create_Signal_E8,
+ "__ghdl_create_signal_e8");
+ pragma Export (C, Ghdl_Signal_Init_E8,
+ "__ghdl_signal_init_e8");
+ pragma Export (C, Ghdl_Signal_Associate_E8,
+ "__ghdl_signal_associate_e8");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_E8,
+ "__ghdl_signal_simple_assign_e8");
+ pragma Export (C, Ghdl_Signal_Start_Assign_E8,
+ "__ghdl_signal_start_assign_e8");
+ pragma Export (C, Ghdl_Signal_Next_Assign_E8,
+ "__ghdl_signal_next_assign_e8");
+ pragma Export (C, Ghdl_Signal_Driving_Value_E8,
+ "__ghdl_signal_driving_value_e8");
+
+ pragma Export (C, Ghdl_Create_Signal_E32,
+ "__ghdl_create_signal_e32");
+ pragma Export (C, Ghdl_Signal_Init_E32,
+ "__ghdl_signal_init_e32");
+ pragma Export (C, Ghdl_Signal_Associate_E32,
+ "__ghdl_signal_associate_e32");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_E32,
+ "__ghdl_signal_simple_assign_e32");
+ pragma Export (C, Ghdl_Signal_Start_Assign_E32,
+ "__ghdl_signal_start_assign_e32");
+ pragma Export (C, Ghdl_Signal_Next_Assign_E32,
+ "__ghdl_signal_next_assign_e32");
+ pragma Export (C, Ghdl_Signal_Driving_Value_E32,
+ "__ghdl_signal_driving_value_e32");
+
+ pragma Export (C, Ghdl_Create_Signal_I32,
+ "__ghdl_create_signal_i32");
+ pragma Export (C, Ghdl_Signal_Init_I32,
+ "__ghdl_signal_init_i32");
+ pragma Export (C, Ghdl_Signal_Associate_I32,
+ "__ghdl_signal_associate_i32");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_I32,
+ "__ghdl_signal_simple_assign_i32");
+ pragma Export (C, Ghdl_Signal_Start_Assign_I32,
+ "__ghdl_signal_start_assign_i32");
+ pragma Export (C, Ghdl_Signal_Next_Assign_I32,
+ "__ghdl_signal_next_assign_i32");
+ pragma Export (C, Ghdl_Signal_Driving_Value_I32,
+ "__ghdl_signal_driving_value_i32");
+
+ pragma Export (C, Ghdl_Create_Signal_I64,
+ "__ghdl_create_signal_i64");
+ pragma Export (C, Ghdl_Signal_Init_I64,
+ "__ghdl_signal_init_i64");
+ pragma Export (C, Ghdl_Signal_Associate_I64,
+ "__ghdl_signal_associate_i64");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_I64,
+ "__ghdl_signal_simple_assign_i64");
+ pragma Export (C, Ghdl_Signal_Start_Assign_I64,
+ "__ghdl_signal_start_assign_i64");
+ pragma Export (C, Ghdl_Signal_Next_Assign_I64,
+ "__ghdl_signal_next_assign_i64");
+ pragma Export (C, Ghdl_Signal_Driving_Value_I64,
+ "__ghdl_signal_driving_value_i64");
+
+ pragma Export (C, Ghdl_Create_Signal_F64,
+ "__ghdl_create_signal_f64");
+ pragma Export (C, Ghdl_Signal_Init_F64,
+ "__ghdl_signal_init_f64");
+ pragma Export (C, Ghdl_Signal_Associate_F64,
+ "__ghdl_signal_associate_f64");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_F64,
+ "__ghdl_signal_simple_assign_f64");
+ pragma Export (C, Ghdl_Signal_Start_Assign_F64,
+ "__ghdl_signal_start_assign_f64");
+ pragma Export (C, Ghdl_Signal_Next_Assign_F64,
+ "__ghdl_signal_next_assign_f64");
+ pragma Export (C, Ghdl_Signal_Driving_Value_F64,
+ "__ghdl_signal_driving_value_f64");
+
+ pragma Export (C, Ghdl_Process_Add_Driver,
+ "__ghdl_process_add_driver");
+ pragma Export (C, Ghdl_Signal_Add_Direct_Driver,
+ "__ghdl_signal_add_direct_driver");
+
+ pragma Export (C, Ghdl_Signal_Add_Source,
+ "__ghdl_signal_add_source");
+ pragma Export (C, Ghdl_Signal_Effective_Value,
+ "__ghdl_signal_effective_value");
+ pragma Export (C, Ghdl_Signal_In_Conversion,
+ "__ghdl_signal_in_conversion");
+ pragma Export (C, Ghdl_Signal_Out_Conversion,
+ "__ghdl_signal_out_conversion");
+
+ pragma Export (C, Ghdl_Signal_Create_Resolution,
+ "__ghdl_signal_create_resolution");
+
+ pragma Export (C, Ghdl_Create_Stable_Signal,
+ "__ghdl_create_stable_signal");
+ pragma Export (C, Ghdl_Create_Quiet_Signal,
+ "__ghdl_create_quiet_signal");
+ pragma Export (C, Ghdl_Create_Transaction_Signal,
+ "__ghdl_create_transaction_signal");
+ pragma Export (C, Ghdl_Signal_Attribute_Register_Prefix,
+ "__ghdl_signal_attribute_register_prefix");
+ pragma Export (C, Ghdl_Create_Delayed_Signal,
+ "__ghdl_create_delayed_signal");
+
+ pragma Export (Ada, Ghdl_Signal_Create_Guard,
+ "__ghdl_signal_create_guard");
+ pragma Export (C, Ghdl_Signal_Guard_Dependence,
+ "__ghdl_signal_guard_dependence");
+
+ pragma Export (C, Ghdl_Signal_Get_Nbr_Ports,
+ "__ghdl_signal_get_nbr_ports");
+ pragma Export (C, Ghdl_Signal_Get_Nbr_Drivers,
+ "__ghdl_signal_get_nbr_drivers");
+ pragma Export (C, Ghdl_Signal_Read_Port,
+ "__ghdl_signal_read_port");
+ pragma Export (C, Ghdl_Signal_Read_Driver,
+ "__ghdl_signal_read_driver");
+
+ pragma Export (C, Ghdl_Signal_Active_Chain,
+ "__ghdl_signal_active_chain");
+
+end Grt.Signals;
diff --git a/src/translate/grt/grt-stack2.adb b/src/translate/grt/grt-stack2.adb
new file mode 100644
index 000000000..82341d072
--- /dev/null
+++ b/src/translate/grt/grt-stack2.adb
@@ -0,0 +1,205 @@
+-- GHDL Run Time (GRT) - secondary stack.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Grt.Errors; use Grt.Errors;
+with Grt.Stdio;
+with Grt.Astdio;
+
+package body Grt.Stack2 is
+ -- This should be storage_elements.storage_element, but I don't want to
+ -- use system.storage_elements package (not pure). Unfortunatly, this is
+ -- currently a failure (storage_elements is automagically used).
+ type Memory is array (Mark_Id range <>) of Character;
+
+ type Chunk_Type (First, Last : Mark_Id);
+ type Chunk_Acc is access all Chunk_Type;
+ type Chunk_Type (First, Last : Mark_Id) is record
+ Next : Chunk_Acc;
+ Mem : Memory (First .. Last);
+ end record;
+
+ type Stack2_Type is record
+ First_Chunk : Chunk_Acc;
+ Last_Chunk : Chunk_Acc;
+ Top : Mark_Id;
+ end record;
+ type Stack2_Acc is access all Stack2_Type;
+
+ function To_Acc is new Ada.Unchecked_Conversion
+ (Source => Stack2_Ptr, Target => Stack2_Acc);
+ function To_Addr is new Ada.Unchecked_Conversion
+ (Source => Stack2_Acc, Target => Stack2_Ptr);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Chunk_Type, Name => Chunk_Acc);
+
+ function Mark (S : Stack2_Ptr) return Mark_Id
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ return S2.Top;
+ end Mark;
+
+ procedure Release (S : Stack2_Ptr; Mark : Mark_Id)
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ S2.Top := Mark;
+ end Release;
+
+ function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
+ return System.Address
+ is
+ pragma Suppress (All_Checks);
+
+ S2 : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ N_Chunk : Chunk_Acc;
+
+ Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
+ Max_Size : constant Mark_Id :=
+ ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align;
+
+ Res : System.Address;
+ begin
+ S2 := To_Acc (S);
+
+ -- Find the chunk to which S2.TOP belong.
+ Chunk := S2.First_Chunk;
+ loop
+ exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last;
+ Chunk := Chunk.Next;
+ exit when Chunk = null;
+ end loop;
+
+ if Chunk /= null then
+ -- If there is enough place in it, allocate from the chunk.
+ if S2.Top + Max_Size <= Chunk.Last then
+ Res := Chunk.Mem (S2.Top)'Address;
+ S2.Top := S2.Top + Max_Size;
+ return Res;
+ end if;
+
+ -- If there is not enough place in it:
+ -- find a chunk which has enough room, deallocate skipped chunk.
+ loop
+ N_Chunk := Chunk.Next;
+ exit when N_Chunk = null;
+ if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then
+ -- Not enough place in this chunk.
+ Chunk.Next := N_Chunk.Next;
+ Free (N_Chunk);
+ if Chunk.Next = null then
+ S2.Last_Chunk := Chunk;
+ exit;
+ end if;
+ else
+ Res := N_Chunk.Mem (N_Chunk.First)'Address;
+ S2.Top := N_Chunk.First + Max_Size;
+ return Res;
+ end if;
+ end loop;
+ end if;
+
+ -- If not such chunk, allocate a chunk
+ S2.Top := S2.Last_Chunk.Last + 1;
+ Chunk := new Chunk_Type (First => S2.Top,
+ Last => S2.Top + Max_Size - 1);
+ Chunk.Next := null;
+ S2.Last_Chunk.Next := Chunk;
+ S2.Last_Chunk := Chunk;
+ S2.Top := Chunk.Last + 1;
+ return Chunk.Mem (Chunk.First)'Address;
+ end Allocate;
+
+ function Create return Stack2_Ptr is
+ Res : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ begin
+ Chunk := new Chunk_Type (First => 1, Last => 8 * 1024);
+ Chunk.Next := null;
+ Res := new Stack2_Type'(First_Chunk => Chunk,
+ Last_Chunk => Chunk,
+ Top => 1);
+ return To_Addr (Res);
+ end Create;
+
+ procedure Check_Empty (S : Stack2_Ptr)
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ if S2 /= null and then S2.Top /= S2.First_Chunk.First then
+ Internal_Error ("stack2.check_empty: stack is not empty");
+ end if;
+ end Check_Empty;
+
+ -- May be used to debug.
+ procedure Dump_Stack2 (S : Stack2_Ptr);
+ pragma Unreferenced (Dump_Stack2);
+
+ procedure Dump_Stack2 (S : Stack2_Ptr)
+ is
+ use Grt.Astdio;
+ use Grt.Stdio;
+ use System;
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Chunk_Acc, Target => Address);
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Mark_Id, Target => Address);
+ S2 : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ begin
+ S2 := To_Acc (S);
+ Put ("Stack 2 at ");
+ Put (stdout, Address (S));
+ New_Line;
+ Put ("First Chunk at ");
+ Put (stdout, To_Address (S2.First_Chunk));
+ Put (", last chunk at ");
+ Put (stdout, To_Address (S2.Last_Chunk));
+ Put (", top at ");
+ Put (stdout, To_Address (S2.Top));
+ New_Line;
+ Chunk := S2.First_Chunk;
+ while Chunk /= null loop
+ Put ("Chunk ");
+ Put (stdout, To_Address (Chunk));
+ Put (": first: ");
+ Put (stdout, To_Address (Chunk.First));
+ Put (", last: ");
+ Put (stdout, To_Address (Chunk.Last));
+ Put (", len: ");
+ Put (stdout, To_Address (Chunk.Last - Chunk.First + 1));
+ Put (", next = ");
+ Put (stdout, To_Address (Chunk.Next));
+ New_Line;
+ Chunk := Chunk.Next;
+ end loop;
+ end Dump_Stack2;
+end Grt.Stack2;
diff --git a/src/translate/grt/grt-stack2.ads b/src/translate/grt/grt-stack2.ads
new file mode 100644
index 000000000..b3de6b76d
--- /dev/null
+++ b/src/translate/grt/grt-stack2.ads
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - secondary stack.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Types; use Grt.Types;
+
+-- Secondary stack management.
+package Grt.Stack2 is
+ type Stack2_Ptr is new System.Address;
+ Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address);
+
+ type Mark_Id is new Integer_Address;
+
+ function Mark (S : Stack2_Ptr) return Mark_Id;
+ procedure Release (S : Stack2_Ptr; Mark : Mark_Id);
+ function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
+ return System.Address;
+ function Create return Stack2_Ptr;
+
+ -- Check S is empty.
+ procedure Check_Empty (S : Stack2_Ptr);
+end Grt.Stack2;
diff --git a/src/translate/grt/grt-stacks.adb b/src/translate/grt/grt-stacks.adb
new file mode 100644
index 000000000..adb008d02
--- /dev/null
+++ b/src/translate/grt/grt-stacks.adb
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - process stacks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Stacks is
+ procedure Error_Grow_Failed is
+ begin
+ Error ("cannot grow the stack");
+ end Error_Grow_Failed;
+
+ procedure Error_Memory_Access is
+ begin
+ Error
+ ("invalid memory access (dangling accesses or stack size too small)");
+ end Error_Memory_Access;
+
+ procedure Error_Null_Access is
+ begin
+ Error ("NULL access dereferenced");
+ end Error_Null_Access;
+end Grt.Stacks;
diff --git a/src/translate/grt/grt-stacks.ads b/src/translate/grt/grt-stacks.ads
new file mode 100644
index 000000000..dd9434080
--- /dev/null
+++ b/src/translate/grt/grt-stacks.ads
@@ -0,0 +1,87 @@
+-- GHDL Run Time (GRT) - process stacks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+
+package Grt.Stacks is
+ -- Instance is the parameter of the process procedure.
+ -- This is in fact a fully opaque type whose content is private to the
+ -- process.
+ type Instance is limited private;
+ type Instance_Acc is access all Instance;
+ pragma Convention (C, Instance_Acc);
+
+ -- A process is identified by a procedure having a single private
+ -- parameter (its instance).
+ type Proc_Acc is access procedure (Self : Instance_Acc);
+ pragma Convention (C, Proc_Acc);
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Instance_Acc, System.Address);
+
+ type Stack_Type is new Address;
+ Null_Stack : constant Stack_Type := Stack_Type (Null_Address);
+
+ -- Initialize the stacks package.
+ -- This may adjust stack sizes.
+ -- Must be called after grt.options.decode.
+ procedure Stack_Init;
+
+ -- Create a new stack, which on first execution will call FUNC with
+ -- an argument ARG.
+ function Stack_Create (Func : Proc_Acc; Arg : Instance_Acc)
+ return Stack_Type;
+
+ -- Resume stack TO and save the current context to the stack pointed by
+ -- CUR.
+ procedure Stack_Switch (To : Stack_Type; From : Stack_Type);
+
+ -- Delete stack STACK, which must not be currently executed.
+ procedure Stack_Delete (Stack : Stack_Type);
+
+ -- Error during stack handling:
+ -- Cannot grow the stack.
+ procedure Error_Grow_Failed;
+ pragma No_Return (Error_Grow_Failed);
+
+ -- Invalid memory access detected (other than dereferencing a NULL access).
+ procedure Error_Memory_Access;
+ pragma No_Return (Error_Memory_Access);
+
+ -- A NULL access is dereferenced.
+ procedure Error_Null_Access;
+ pragma No_Return (Error_Null_Access);
+private
+ type Instance is null record;
+
+ pragma Import (C, Stack_Init, "grt_stack_init");
+ pragma Import (C, Stack_Create, "grt_stack_create");
+ pragma Import (C, Stack_Switch, "grt_stack_switch");
+ pragma Import (C, Stack_Delete, "grt_stack_delete");
+
+ pragma Export (C, Error_Grow_Failed, "grt_stack_error_grow_failed");
+ pragma Export (C, Error_Memory_Access, "grt_stack_error_memory_access");
+ pragma Export (C, Error_Null_Access, "grt_stack_error_null_access");
+end Grt.Stacks;
diff --git a/src/translate/grt/grt-stats.adb b/src/translate/grt/grt-stats.adb
new file mode 100644
index 000000000..5bc046d00
--- /dev/null
+++ b/src/translate/grt/grt-stats.adb
@@ -0,0 +1,370 @@
+-- GHDL Run Time (GRT) - statistics.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Signals;
+with Grt.Processes;
+with Grt.Types; use Grt.Types;
+with Grt.Disp;
+
+package body Grt.Stats is
+ type Clock_T is new Integer;
+
+ type Time_Stats is record
+ Wall : Clock_T;
+ User : Clock_T;
+ Sys : Clock_T;
+ end record;
+
+ -- Number of CLOCK_T per second.
+ One_Second : Clock_T;
+
+
+ -- Get number of seconds per CLOCK_T.
+ function Get_Clk_Tck return Clock_T;
+ pragma Import (C, Get_Clk_Tck, "grt_get_clk_tck");
+
+ -- Get wall, user and system times.
+ -- This is a binding to times(2).
+ procedure Get_Times (Wall : Address; User : Address; Sys : Address);
+ pragma Import (C, Get_Times, "grt_get_times");
+
+ procedure Get_Stats (Stats : out Time_Stats)
+ is
+ begin
+ Get_Times (Stats.Wall'Address, Stats.User'Address, Stats.Sys'Address);
+ end Get_Stats;
+
+ function "-" (L : Time_Stats; R : Time_Stats) return Time_Stats
+ is
+ begin
+ return Time_Stats'(Wall => L.Wall - R.Wall,
+ User => L.User - R.User,
+ Sys => L.Sys - R.Sys);
+ end "-";
+
+ function "+" (L : Time_Stats; R : Time_Stats) return Time_Stats
+ is
+ begin
+ return Time_Stats'(Wall => L.Wall + R.Wall,
+ User => L.User + R.User,
+ Sys => L.Sys + R.Sys);
+ end "+";
+
+ procedure Put (Stream : FILEs; Val : Clock_T)
+ is
+ procedure Fprintf_Clock (Stream : FILEs; A, B : Clock_T);
+ pragma Import (C, Fprintf_Clock, "__ghdl_fprintf_clock");
+
+ Sec : Clock_T;
+ Ms : Clock_T;
+ begin
+ Sec := Val / One_Second;
+
+ -- Avoid overflow.
+ Ms := ((Val mod One_Second) * 1000) / One_Second;
+
+ Fprintf_Clock (Stream, Sec, Ms);
+ end Put;
+
+ procedure Put (Stream : FILEs; T : Time_Stats) is
+ begin
+ Put (Stream, "wall: ");
+ Put (Stream, T.Wall);
+ Put (Stream, " user: ");
+ Put (Stream, T.User);
+ Put (Stream, " sys: ");
+ Put (Stream, T.Sys);
+ end Put;
+
+ type Counter_Kind is (Counter_Elab, Counter_Order,
+ Counter_Process, Counter_Update,
+ Counter_Next, Counter_Resume);
+
+ type Counter_Array is array (Counter_Kind) of Time_Stats;
+ Counters : Counter_Array := (others => (0, 0, 0));
+
+ Init_Time : Time_Stats;
+ Last_Counter : Counter_Kind;
+ Last_Time : Time_Stats;
+
+-- -- Stats at origin.
+-- Start_Time : Time_Stats;
+-- End_Elab_Time : Time_Stats;
+-- End_Order_Time : Time_Stats;
+
+-- Start_Proc_Time : Time_Stats;
+-- Proc_Times : Time_Stats;
+
+-- Start_Update_Time : Time_Stats;
+-- Update_Times : Time_Stats;
+
+-- Start_Next_Time_Time : Time_Stats;
+-- Next_Time_Times : Time_Stats;
+
+-- Start_Resume_Time : Time_Stats;
+-- Resume_Times : Time_Stats;
+
+-- Running_Time : Time_Stats;
+-- Simu_Time : Time_Stats;
+
+ procedure Start_Elaboration is
+ begin
+ One_Second := Get_Clk_Tck;
+
+ Get_Stats (Init_Time);
+ Last_Time := Init_Time;
+ Last_Counter := Counter_Elab;
+ end Start_Elaboration;
+
+ procedure Change_Counter (Cnt : Counter_Kind)
+ is
+ New_Time : Time_Stats;
+ begin
+ Get_Stats (New_Time);
+ Counters (Last_Counter) := Counters (Last_Counter)
+ + (New_Time - Last_Time);
+ Last_Time := New_Time;
+ Last_Counter := Cnt;
+ end Change_Counter;
+
+ procedure Start_Order is
+ begin
+ Change_Counter (Counter_Order);
+ end Start_Order;
+
+ procedure Start_Processes is
+ begin
+ Change_Counter (Counter_Process);
+ end Start_Processes;
+
+ procedure Start_Update is
+ begin
+ Change_Counter (Counter_Update);
+ end Start_Update;
+
+ procedure Start_Next_Time is
+ begin
+ Change_Counter (Counter_Next);
+ end Start_Next_Time;
+
+ procedure Start_Resume is
+ begin
+ Change_Counter (Counter_Resume);
+ end Start_Resume;
+
+ procedure End_Simulation is
+ begin
+ Change_Counter (Last_Counter);
+ end End_Simulation;
+
+ procedure Disp_Signals_Stats
+ is
+ use Grt.Signals;
+ Nbr_No_Drivers : Ghdl_I32;
+ Nbr_Resolv : Ghdl_I32;
+ Nbr_Multi_Src : Ghdl_I32;
+ Nbr_Active : Ghdl_I32;
+ Nbr_Drivers : Ghdl_I32;
+ Nbr_Direct_Drivers : Ghdl_I32;
+
+ type Propagation_Kind_Array is array (Propagation_Kind_Type) of Ghdl_I32;
+ Propag_Count : Propagation_Kind_Array;
+
+ type Mode_Array is array (Mode_Type) of Ghdl_I32;
+ Mode_Counts : Mode_Array;
+
+ type Mode_Name_Type is array (Mode_Type) of String (1 .. 4);
+ Mode_Names : constant Mode_Name_Type := (Mode_B1 => "B1: ",
+ Mode_E8 => "E8: ",
+ Mode_E32 => "E32:",
+ Mode_I32 => "I32:",
+ Mode_I64 => "I64:",
+ Mode_F64 => "F64:");
+ begin
+ Put (stdout, "Number of simple signals: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1));
+ New_Line;
+ Put (stdout, "Number of signals with projected wave: ");
+ Put_I32 (stdout, Get_Nbr_Future);
+ New_Line;
+
+ Nbr_No_Drivers := 0;
+ Nbr_Resolv := 0;
+ Nbr_Multi_Src := 0;
+ Nbr_Active := 0;
+ Nbr_Drivers := 0;
+ Nbr_Direct_Drivers := 0;
+ Mode_Counts := (others => 0);
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ declare
+ Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ begin
+ Sig := Sig_Table.Table (I);
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Nbr_Drivers = 0 then
+ Nbr_No_Drivers := Nbr_No_Drivers + 1;
+ end if;
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 1 then
+ Nbr_Multi_Src := Nbr_Multi_Src + 1;
+ end if;
+ if Sig.S.Resolv /= null then
+ Nbr_Resolv := Nbr_Resolv + 1;
+ end if;
+ Nbr_Drivers := Nbr_Drivers + Ghdl_I32 (Sig.S.Nbr_Drivers);
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).Last_Trans;
+ if Trans /= null and then Trans.Kind = Trans_Direct then
+ Nbr_Direct_Drivers := Nbr_Direct_Drivers + 1;
+ end if;
+ end loop;
+ end if;
+ Mode_Counts (Sig.Mode) := Mode_Counts (Sig.Mode) + 1;
+ if Sig.Has_Active then
+ Nbr_Active := Nbr_Active + 1;
+ end if;
+ end;
+ end loop;
+ Put (stdout, "Number of non-driven simple signals: ");
+ Put_I32 (stdout, Nbr_No_Drivers);
+ New_Line;
+ Put (stdout, "Number of resolved simple signals: ");
+ Put_I32 (stdout, Nbr_Resolv);
+ New_Line;
+ Put (stdout, "Number of multi-sourced signals: ");
+ Put_I32 (stdout, Nbr_Multi_Src);
+ New_Line;
+ Put (stdout, "Number of signals whose activity is managed: ");
+ Put_I32 (stdout, Nbr_Active);
+ New_Line;
+ Put (stdout, "Number of drivers: ");
+ Put_I32 (stdout, Nbr_Drivers);
+ New_Line;
+ Put (stdout, "Number of direct drivers: ");
+ Put_I32 (stdout, Nbr_Direct_Drivers);
+ New_Line;
+ Put (stdout, "Number of signals per mode:");
+ New_Line;
+ for I in Mode_Type loop
+ Put (stdout, " ");
+ Put (stdout, Mode_Names (I));
+ Put (stdout, " ");
+ Put_I32 (stdout, Mode_Counts (I));
+ New_Line;
+ end loop;
+ New_Line;
+
+ Propag_Count := (others => 0);
+ for I in Propagation.First .. Propagation.Last loop
+ Propag_Count (Propagation.Table (I).Kind) :=
+ Propag_Count (Propagation.Table (I).Kind) + 1;
+ end loop;
+
+ Put (stdout, "Propagation table length: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Signals.Propagation.Last));
+ New_Line;
+ Put (stdout, "Propagation table count:");
+ New_Line;
+ for I in Propagation_Kind_Type loop
+ if Propag_Count (I) /= 0 then
+ Put (stdout, " ");
+ Grt.Disp.Disp_Propagation_Kind (I);
+ Put (stdout, ": ");
+ Put_I32 (stdout, Propag_Count (I));
+ New_Line;
+ end if;
+ end loop;
+ end Disp_Signals_Stats;
+
+ -- Disp all statistics.
+ procedure Disp_Stats
+ is
+ N : Natural;
+ begin
+ Put (stdout, "total: ");
+ Put (stdout, Last_Time - Init_Time);
+ New_Line (stdout);
+ Put (stdout, " elab: ");
+ Put (stdout, Counters (Counter_Elab));
+ New_Line (stdout);
+ Put (stdout, " internal elab: ");
+ Put (stdout, Counters (Counter_Order));
+ New_Line (stdout);
+ Put (stdout, " cycle (sum): ");
+ Put (stdout, Counters (Counter_Process) + Counters (Counter_Resume)
+ + Counters (Counter_Update) + Counters (Counter_Next));
+ New_Line (stdout);
+ Put (stdout, " processes: ");
+ Put (stdout, Counters (Counter_Process));
+ New_Line (stdout);
+ Put (stdout, " resume: ");
+ Put (stdout, Counters (Counter_Resume));
+ New_Line (stdout);
+ Put (stdout, " update: ");
+ Put (stdout, Counters (Counter_Update));
+ New_Line (stdout);
+ Put (stdout, " next compute: ");
+ Put (stdout, Counters (Counter_Next));
+ New_Line (stdout);
+
+ Disp_Signals_Stats;
+
+ Put (stdout, "Number of delta cycles: ");
+ Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Delta_Cycles));
+ New_Line;
+ Put (stdout, "Number of non-delta cycles: ");
+ Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Cycles));
+ New_Line;
+
+ Put (stdout, "Nbr of events: ");
+ Put_I32 (stdout, Signals.Nbr_Events);
+ New_Line;
+ Put (stdout, "Nbr of active: ");
+ Put_I32 (stdout, Signals.Nbr_Active);
+ New_Line;
+
+ Put (stdout, "Number of processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Processes));
+ New_Line;
+ Put (stdout, "Number of sensitized processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Sensitized_Processes));
+ New_Line;
+ Put (stdout, "Number of resumed processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Resumed_Processes));
+ New_Line;
+ Put (stdout, "Average number of resumed processes per cycle: ");
+ N := Processes.Nbr_Delta_Cycles + Processes.Nbr_Cycles;
+ if N = 0 then
+ Put (stdout, "-");
+ else
+ Put_I32 (stdout, Ghdl_I32 (Processes.Get_Nbr_Resumed_Processes / N));
+ end if;
+ New_Line;
+ end Disp_Stats;
+end Grt.Stats;
diff --git a/src/translate/grt/grt-stats.ads b/src/translate/grt/grt-stats.ads
new file mode 100644
index 000000000..6f60261af
--- /dev/null
+++ b/src/translate/grt/grt-stats.ads
@@ -0,0 +1,54 @@
+-- GHDL Run Time (GRT) - statistics.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Stats is
+ -- Entry points to gather statistics.
+ procedure Start_Elaboration;
+ procedure Start_Order;
+
+ -- Time in user processes.
+ procedure Start_Processes;
+
+
+ -- Time in next time computation.
+ procedure Start_Next_Time;
+
+
+ -- Time in signals update.
+ procedure Start_Update;
+
+
+ -- Time in process resume
+ procedure Start_Resume;
+
+
+ procedure End_Simulation;
+
+ -- Disp all statistics.
+ procedure Disp_Stats;
+end Grt.Stats;
+
+
+
diff --git a/src/translate/grt/grt-std_logic_1164.adb b/src/translate/grt/grt-std_logic_1164.adb
new file mode 100644
index 000000000..5be308bd6
--- /dev/null
+++ b/src/translate/grt/grt-std_logic_1164.adb
@@ -0,0 +1,146 @@
+-- GHDL Run Time (GRT) std_logic_1664 subprograms.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with Grt.Lib;
+
+package body Grt.Std_Logic_1164 is
+ Assert_DC_Msg : constant String :=
+ "STD_LOGIC_1164: '-' operand for matching ordering operator";
+
+ Assert_DC_Msg_Bound : constant Std_String_Bound :=
+ (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To,
+ Length => Assert_DC_Msg'Length));
+
+ Assert_DC_Msg_Str : aliased constant Std_String :=
+ (Base => To_Std_String_Basep (Assert_DC_Msg'Address),
+ Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address));
+
+ Filename : constant String := "std_logic_1164.vhdl" & NUL;
+ Loc : aliased constant Ghdl_Location :=
+ (Filename => To_Ghdl_C_String (Filename'Address),
+ Line => 58,
+ Col => 3);
+
+ procedure Assert_Not_Match (V : Std_Ulogic)
+ is
+ use Grt.Lib;
+ begin
+ if V = '-' then
+ Ghdl_Ieee_Assert_Failed
+ (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity,
+ To_Ghdl_Location_Ptr (Loc'Address));
+ end if;
+ end Assert_Not_Match;
+
+ function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Match_Eq_Table (Left, Right));
+ end Ghdl_Std_Ulogic_Match_Eq;
+
+ function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Not_Table (Match_Eq_Table (Left, Right)));
+ end Ghdl_Std_Ulogic_Match_Ne;
+
+ function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Match_Lt_Table (Left, Right));
+ end Ghdl_Std_Ulogic_Match_Lt;
+
+ function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right),
+ Match_Eq_Table (Left, Right)));
+ end Ghdl_Std_Ulogic_Match_Le;
+
+ Assert_Arr_Msg : constant String :=
+ "parameters of '?=' array operator are not of the same length";
+
+ Assert_Arr_Msg_Bound : constant Std_String_Bound :=
+ (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To,
+ Length => Assert_Arr_Msg'Length));
+
+ Assert_Arr_Msg_Str : aliased constant Std_String :=
+ (Base => To_Std_String_Basep (Assert_Arr_Msg'Address),
+ Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address));
+
+
+ function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32
+ is
+ use Grt.Lib;
+ L_Arr : constant Ghdl_E8_Array_Base_Ptr :=
+ To_Ghdl_E8_Array_Base_Ptr (L);
+ R_Arr : constant Ghdl_E8_Array_Base_Ptr :=
+ To_Ghdl_E8_Array_Base_Ptr (R);
+ Res : Std_Ulogic := '1';
+ begin
+ if L_Len /= R_Len then
+ Ghdl_Ieee_Assert_Failed
+ (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity,
+ To_Ghdl_Location_Ptr (Loc'Address));
+ end if;
+ for I in 1 .. L_Len loop
+ Res := And_Table
+ (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1),
+ R_Arr (I - 1))));
+ end loop;
+ return Std_Ulogic'Pos (Res);
+ end Ghdl_Std_Ulogic_Array_Match_Eq;
+
+ function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32 is
+ begin
+ return Std_Ulogic'Pos
+ (Not_Table (Std_Ulogic'Val
+ (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len))));
+ end Ghdl_Std_Ulogic_Array_Match_Ne;
+end Grt.Std_Logic_1164;
diff --git a/src/translate/grt/grt-std_logic_1164.ads b/src/translate/grt/grt-std_logic_1164.ads
new file mode 100644
index 000000000..4d1569553
--- /dev/null
+++ b/src/translate/grt/grt-std_logic_1164.ads
@@ -0,0 +1,124 @@
+-- GHDL Run Time (GRT) std_logic_1664 subprograms.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with Grt.Types; use Grt.Types;
+
+package Grt.Std_Logic_1164 is
+ type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-');
+
+ type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic;
+ type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic;
+
+ -- LRM08 9.2.3 Relational operators
+ Match_Eq_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUU1",
+ "UXXXXXXX1",
+ "UX10XX101",
+ "UX01XX011",
+ "UXXXXXXX1",
+ "UXXXXXXX1",
+ "UX10XX101",
+ "UX01XX011",
+ "111111111");
+
+ Match_Lt_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUUX",
+ "UXXXXXXXX",
+ "UX01XX01X",
+ "UX00XX00X",
+ "UXXXXXXXX",
+ "UXXXXXXXX",
+ "UX01XX01X",
+ "UX00XX00X",
+ "XXXXXXXXX");
+
+ And_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UU0UUU0UX", -- U
+ "UX0XXX0XX", -- X
+ "000000000", -- 0
+ "UX01XX01X", -- 1
+ "UX0XXX0XX", -- Z
+ "UX0XXX0XX", -- W
+ "000000000", -- L
+ "UX01XX01X", -- H
+ "UX0XXX0XX"); -- -
+
+ Or_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUU1UUU1U", -- U
+ "UXX1XXX1X", -- X
+ "UX01XX01X", -- 0
+ "111111111", -- 1
+ "UXX1XXX1X", -- Z
+ "UXX1XXX1X", -- W
+ "UX01XX01X", -- L
+ "111111111", -- H
+ "UXX1XXX1X"); -- -
+
+ Xor_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUUU", -- U
+ "UXXXXXXXX", -- X
+ "UX01XX01X", -- 0
+ "UX10XX10X", -- 1
+ "UXXXXXXXX", -- Z
+ "UXXXXXXXX", -- W
+ "UX01XX01X", -- L
+ "UX10XX10X", -- H
+ "UXXXXXXXX"); -- -
+
+ Not_Table : constant Stdlogic_Table_1d := "UX10XX10X";
+
+ function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8;
+ -- For Gt and Ge, use Lt and Le with swapped parameters.
+
+ function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32;
+ function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32;
+
+private
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le");
+
+ pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq,
+ "__ghdl_std_ulogic_array_match_eq");
+ pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne,
+ "__ghdl_std_ulogic_array_match_ne");
+end Grt.Std_Logic_1164;
diff --git a/src/translate/grt/grt-stdio.ads b/src/translate/grt/grt-stdio.ads
new file mode 100644
index 000000000..229249ac9
--- /dev/null
+++ b/src/translate/grt/grt-stdio.ads
@@ -0,0 +1,107 @@
+-- GHDL Run Time (GRT) - stdio binding.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.C; use Grt.C;
+
+-- This package provides a thin binding to the stdio.h of the C library.
+-- It mimics GNAT package Interfaces.C_Streams.
+-- The purpose of this package is to remove dependencies on the GNAT run time.
+
+package Grt.Stdio is
+ pragma Preelaborate (Grt.Stdio);
+
+ -- Type FILE *.
+ type FILEs is new System.Address;
+
+ -- NULL for a stream.
+ NULL_Stream : constant FILEs;
+
+ -- Predefined streams.
+ function stdout return FILEs;
+ function stderr return FILEs;
+ function stdin return FILEs;
+
+ -- The following subprograms are translation of the C prototypes.
+
+ function fopen (path: chars; mode : chars) return FILEs;
+
+ function fwrite (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t;
+
+ function fread (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t;
+
+ function fputc (c : int; stream : FILEs) return int;
+ procedure fputc (c : int; stream : FILEs);
+
+ function fputs (s : chars; stream : FILEs) return int;
+
+ function fgetc (stream : FILEs) return int;
+ function fgets (s : chars; size : int; stream : FILEs) return chars;
+ function ungetc (c : int; stream : FILEs) return int;
+
+ function fflush (stream : FILEs) return int;
+ procedure fflush (stream : FILEs);
+
+ function feof (stream : FILEs) return int;
+
+ function ftell (stream : FILEs) return long;
+
+ function fclose (stream : FILEs) return int;
+ procedure fclose (Stream : FILEs);
+private
+ -- This is a little bit dubious, but this package should be preelaborated,
+ -- and Null_Address is not static (since defined in the private part
+ -- of System).
+ -- I am pretty sure the C definition of NULL is 0.
+ NULL_Stream : constant FILEs := FILEs (System'To_Address (0));
+
+ pragma Import (C, fopen);
+
+ pragma Import (C, fwrite);
+ pragma Import (C, fread);
+
+ pragma Import (C, fputs);
+ pragma Import (C, fputc);
+
+ pragma Import (C, fgetc);
+ pragma Import (C, fgets);
+ pragma Import (C, ungetc);
+
+ pragma Import (C, fflush);
+ pragma Import (C, feof);
+ pragma Import (C, ftell);
+ pragma Import (C, fclose);
+
+ pragma Import (C, stdout, "__ghdl_get_stdout");
+ pragma Import (C, stderr, "__ghdl_get_stderr");
+ pragma Import (C, stdin, "__ghdl_get_stdin");
+end Grt.Stdio;
diff --git a/src/translate/grt/grt-table.adb b/src/translate/grt/grt-table.adb
new file mode 100644
index 000000000..36aa99982
--- /dev/null
+++ b/src/translate/grt/grt-table.adb
@@ -0,0 +1,120 @@
+-- GHDL Run Time (GRT) - Resizable array
+-- Copyright (C) 2008 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with System; use System;
+with Grt.C; use Grt.C;
+
+package body Grt.Table is
+
+ -- Maximum index of table before resizing.
+ Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound);
+
+ -- Current value of Last
+ Last_Val : Table_Index_Type;
+
+ function Malloc (Size : size_t) return Table_Ptr;
+ pragma Import (C, Malloc);
+
+ procedure Free (T : Table_Ptr);
+ pragma Import (C, Free);
+
+ -- Resize and reallocate the table according to LAST_VAL.
+ procedure Resize is
+ function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr;
+ pragma Import (C, Realloc);
+
+ New_Size : size_t;
+ begin
+ while Max < Last_Val loop
+ Max := Max + (Max - Table_Low_Bound + 1);
+ end loop;
+
+ New_Size := size_t ((Max - Table_Low_Bound + 1) *
+ (Table_Type'Component_Size / Storage_Unit));
+
+ Table := Realloc (Table, New_Size);
+
+ if Table = null then
+ raise Storage_Error;
+ end if;
+ end Resize;
+
+ procedure Append (New_Val : Table_Component_Type) is
+ begin
+ Increment_Last;
+ Table (Last_Val) := New_Val;
+ end Append;
+
+ procedure Decrement_Last is
+ begin
+ Last_Val := Table_Index_Type'Pred (Last_Val);
+ end Decrement_Last;
+
+ procedure Free is
+ begin
+ Free (Table);
+ Table := null;
+ end Free;
+
+ procedure Increment_Last is
+ begin
+ Last_Val := Table_Index_Type'Succ (Last_Val);
+
+ if Last_Val > Max then
+ Resize;
+ end if;
+ end Increment_Last;
+
+ function Last return Table_Index_Type is
+ begin
+ return Last_Val;
+ end Last;
+
+ procedure Release is
+ begin
+ Max := Last_Val;
+ Resize;
+ end Release;
+
+ procedure Set_Last (New_Val : Table_Index_Type) is
+ begin
+ if New_Val < Last_Val then
+ Last_Val := New_Val;
+ else
+ Last_Val := New_Val;
+
+ if Last_Val > Max then
+ Resize;
+ end if;
+ end if;
+ end Set_Last;
+
+begin
+ Last_Val := Table_Index_Type'Pred (Table_Low_Bound);
+ Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1;
+
+ Table := Malloc (size_t (Table_Initial *
+ (Table_Type'Component_Size / Storage_Unit)));
+end Grt.Table;
diff --git a/src/translate/grt/grt-table.ads b/src/translate/grt/grt-table.ads
new file mode 100644
index 000000000..f814eff5c
--- /dev/null
+++ b/src/translate/grt/grt-table.ads
@@ -0,0 +1,75 @@
+-- GHDL Run Time (GRT) - Resizable array
+-- Copyright (C) 2008 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+generic
+ type Table_Component_Type is private;
+ type Table_Index_Type is range <>;
+
+ Table_Low_Bound : Table_Index_Type;
+ Table_Initial : Positive;
+
+package Grt.Table is
+ pragma Elaborate_Body;
+
+ type Table_Type is
+ array (Table_Index_Type range <>) of Table_Component_Type;
+ subtype Fat_Table_Type is
+ Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+
+ -- Thin pointer.
+ type Table_Ptr is access all Fat_Table_Type;
+
+ -- The table itself.
+ Table : aliased Table_Ptr := null;
+
+ -- Get the high bound.
+ function Last return Table_Index_Type;
+ pragma Inline (Last);
+
+ -- Get the low bound.
+ First : constant Table_Index_Type := Table_Low_Bound;
+
+ -- Increase the length by 1.
+ procedure Increment_Last;
+ pragma Inline (Increment_Last);
+
+ -- Decrease the length by 1.
+ procedure Decrement_Last;
+ pragma Inline (Decrement_Last);
+
+ -- Set the last bound.
+ procedure Set_Last (New_Val : Table_Index_Type);
+
+ -- Release extra memory.
+ procedure Release;
+
+ -- Free all the memory used by the table.
+ -- The table won't be useable anymore.
+ procedure Free;
+
+ -- Append a new element.
+ procedure Append (New_Val : Table_Component_Type);
+ pragma Inline (Append);
+end Grt.Table;
diff --git a/src/translate/grt/grt-threads.ads b/src/translate/grt/grt-threads.ads
new file mode 100644
index 000000000..248f2c41b
--- /dev/null
+++ b/src/translate/grt/grt-threads.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - threading.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Unithread;
+
+package Grt.Threads renames Grt.Unithread;
diff --git a/src/translate/grt/grt-types.ads b/src/translate/grt/grt-types.ads
new file mode 100644
index 000000000..fed822554
--- /dev/null
+++ b/src/translate/grt/grt-types.ads
@@ -0,0 +1,327 @@
+-- GHDL Run Time (GRT) - common types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+
+package Grt.Types is
+ pragma Preelaborate (Grt.Types);
+
+ type Ghdl_B1 is new Boolean;
+ type Ghdl_E8 is new Unsigned_8;
+ type Ghdl_U32 is new Unsigned_32;
+ subtype Ghdl_E32 is Ghdl_U32;
+ type Ghdl_I32 is new Integer_32;
+ type Ghdl_I64 is new Integer_64;
+ type Ghdl_U64 is new Unsigned_64;
+ type Ghdl_F64 is new IEEE_Float_64;
+
+ type Ghdl_Ptr is new Address;
+ type Ghdl_Index_Type is mod 2 ** 32;
+ subtype Ghdl_Real is Ghdl_F64;
+
+ type Ghdl_Dir_Type is (Dir_To, Dir_Downto);
+ for Ghdl_Dir_Type use (Dir_To => 0, Dir_Downto => 1);
+ for Ghdl_Dir_Type'Size use 8;
+
+ -- Access to an unconstrained string.
+ type String_Access is access String;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Access, Object => String);
+
+ subtype Std_Integer is Ghdl_I32;
+
+ type Std_Time is new Ghdl_I64;
+ Bad_Time : constant Std_Time := Std_Time'First;
+
+ type Std_Integer_Trt is record
+ Left : Std_Integer;
+ Right : Std_Integer;
+ Dir : Ghdl_Dir_Type;
+ Length : Ghdl_Index_Type;
+ end record;
+
+ subtype Std_Character is Character;
+ type Std_String_Uncons is array (Ghdl_Index_Type range <>) of Std_Character;
+ subtype Std_String_Base is Std_String_Uncons (Ghdl_Index_Type);
+ type Std_String_Basep is access all Std_String_Base;
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Basep);
+
+ type Std_String_Bound is record
+ Dim_1 : Std_Integer_Trt;
+ end record;
+ type Std_String_Boundp is access all Std_String_Bound;
+ function To_Std_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Boundp);
+
+ type Std_String is record
+ Base : Std_String_Basep;
+ Bounds : Std_String_Boundp;
+ end record;
+ type Std_String_Ptr is access all Std_String;
+ function To_Std_String_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Ptr);
+
+ type Std_Bit is ('0', '1');
+ type Std_Bit_Vector_Uncons is array (Ghdl_Index_Type range <>) of Std_Bit;
+ subtype Std_Bit_Vector_Base is Std_Bit_Vector_Uncons (Ghdl_Index_Type);
+ type Std_Bit_Vector_Basep is access all Std_Bit_Vector_Base;
+
+ -- An unconstrained array.
+ -- It is in fact a fat pointer to the base and the bounds.
+ type Ghdl_Uc_Array is record
+ Base : Address;
+ Bounds : Address;
+ end record;
+ type Ghdl_Uc_Array_Acc is access Ghdl_Uc_Array;
+ function To_Ghdl_Uc_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Uc_Array_Acc);
+
+ -- Verilog types.
+
+ type Ghdl_Logic32 is record
+ Val : Ghdl_U32;
+ Xz : Ghdl_U32;
+ end record;
+ type Ghdl_Logic32_Ptr is access Ghdl_Logic32;
+ type Ghdl_Logic32_Vec is array (Ghdl_U32) of Ghdl_Logic32;
+ type Ghdl_Logic32_Vptr is access Ghdl_Logic32_Vec;
+
+ function To_Ghdl_Logic32_Vptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Logic32_Vptr);
+
+ function To_Ghdl_Logic32_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Logic32_Ptr);
+
+ -- Mimics C strings (NUL ended).
+ -- Note: this is 1 based.
+ type Ghdl_C_String is access String (Positive);
+ NUL : constant Character := Character'Val (0);
+
+ Nl : constant Character := Character'Val (10); -- LF, nl or '\n'.
+
+ function strlen (Str : Ghdl_C_String) return Natural;
+ pragma Import (C, strlen);
+
+ function Strcmp (L , R : Ghdl_C_String) return Integer;
+ pragma Import (C, Strcmp);
+
+ function To_Ghdl_C_String is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_C_String);
+
+ -- Str_len.
+ type String_Ptr is access String (1 .. Natural'Last);
+ type Ghdl_Str_Len_Type is record
+ Len : Natural;
+ Str : String_Ptr;
+ end record;
+ -- Same as previous one, but using 'address.
+ type Ghdl_Str_Len_Address_Type is record
+ Len : Natural;
+ Str : Address;
+ end record;
+ type Ghdl_Str_Len_Ptr is access constant Ghdl_Str_Len_Type;
+ type Ghdl_Str_Len_Array is array (Natural) of Ghdl_Str_Len_Type;
+ type Ghdl_Str_Len_Array_Ptr is access all Ghdl_Str_Len_Array;
+
+ -- Location is used for errors/messages.
+ type Ghdl_Location is record
+ Filename : Ghdl_C_String;
+ Line : Integer;
+ Col : Integer;
+ end record;
+ type Ghdl_Location_Ptr is access Ghdl_Location;
+ function To_Ghdl_Location_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Location_Ptr);
+
+ -- Signal index.
+ type Sig_Table_Index is new Integer;
+
+ -- A range of signals.
+ type Sig_Table_Range is record
+ First, Last : Sig_Table_Index;
+ end record;
+
+ -- Simple values, used for signals.
+ type Mode_Type is
+ (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64);
+
+ type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1;
+ subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type);
+ type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base;
+ function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr);
+
+ type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8;
+ subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type);
+ type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base;
+ function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr);
+
+ type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32;
+ subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type);
+ type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base;
+ function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr);
+
+ type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32;
+
+ type Value_Union (Mode : Mode_Type := Mode_B1) is record
+ case Mode is
+ when Mode_B1 =>
+ B1 : Ghdl_B1;
+ when Mode_E8 =>
+ E8 : Ghdl_E8;
+ when Mode_E32 =>
+ E32 : Ghdl_E32;
+ when Mode_I32 =>
+ I32 : Ghdl_I32;
+ when Mode_I64 =>
+ I64 : Ghdl_I64;
+ when Mode_F64 =>
+ F64 : Ghdl_F64;
+ end case;
+ end record;
+ pragma Unchecked_Union (Value_Union);
+
+ type Ghdl_Value_Ptr is access Value_Union;
+ function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Value_Ptr);
+
+ -- Ranges.
+ type Ghdl_Range_B1 is record
+ Left : Ghdl_B1;
+ Right : Ghdl_B1;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_E8 is record
+ Left : Ghdl_E8;
+ Right : Ghdl_E8;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_E32 is record
+ Left : Ghdl_E32;
+ Right : Ghdl_E32;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_I32 is record
+ Left : Ghdl_I32;
+ Right : Ghdl_I32;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_I64 is record
+ Left : Ghdl_I64;
+ Right : Ghdl_I64;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_F64 is record
+ Left : Ghdl_F64;
+ Right : Ghdl_F64;
+ Dir : Ghdl_Dir_Type;
+ end record;
+
+ type Ghdl_Range_Type (K : Mode_Type := Mode_B1) is record
+ case K is
+ when Mode_B1 =>
+ B1 : Ghdl_Range_B1;
+ when Mode_E8 =>
+ E8 : Ghdl_Range_E8;
+ when Mode_E32 =>
+ E32 : Ghdl_Range_E32;
+ when Mode_I32 =>
+ I32 : Ghdl_Range_I32;
+ when Mode_I64 =>
+ P64 : Ghdl_Range_I64;
+ when Mode_F64 =>
+ F64 : Ghdl_Range_F64;
+ end case;
+ end record;
+ pragma Unchecked_Union (Ghdl_Range_Type);
+
+ type Ghdl_Range_Ptr is access all Ghdl_Range_Type;
+
+ function To_Ghdl_Range_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Range_Ptr);
+
+ type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr;
+
+ -- Mode of a signal.
+ type Mode_Signal_Type is
+ (Mode_Signal,
+ Mode_Linkage, Mode_Buffer, Mode_Out, Mode_Inout, Mode_In,
+ Mode_Stable, Mode_Quiet, Mode_Delayed, Mode_Transaction, Mode_Guard,
+ Mode_Conv_In, Mode_Conv_Out,
+ Mode_End);
+
+ subtype Mode_Signal_Port is
+ Mode_Signal_Type range Mode_Linkage .. Mode_In;
+
+ -- Not implicit signals.
+ subtype Mode_Signal_User is
+ Mode_Signal_Type range Mode_Signal .. Mode_In;
+
+ -- Implicit signals.
+ subtype Mode_Signal_Implicit is
+ Mode_Signal_Type range Mode_Stable .. Mode_Guard;
+
+ subtype Mode_Signal_Forward is
+ Mode_Signal_Type range Mode_Stable .. Mode_Delayed;
+
+ -- Kind of a signal.
+ type Kind_Signal_Type is
+ (Kind_Signal_No, Kind_Signal_Register, Kind_Signal_Bus);
+
+ -- Note: we could use system.storage_elements, but unfortunatly,
+ -- this doesn't work with pragma no_run_time (gnat 3.15p).
+ type Integer_Address is mod Memory_Size;
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Integer_Address, Target => Address);
+
+ function To_Integer is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Integer_Address);
+
+ -- The NOW value.
+ Current_Time : Std_Time;
+ -- Copy of Current_Time before updating it.
+ -- To be used by hooks.
+ Cycle_Time : Std_Time;
+ -- The current delta cycle number.
+ Current_Delta : Integer;
+private
+ pragma Export (C, Current_Time, "__ghdl_now");
+end Grt.Types;
diff --git a/src/translate/grt/grt-unithread.adb b/src/translate/grt/grt-unithread.adb
new file mode 100644
index 000000000..6acb52169
--- /dev/null
+++ b/src/translate/grt/grt-unithread.adb
@@ -0,0 +1,106 @@
+-- GHDL Run Time (GRT) - mono-thread version.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Unithread is
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ procedure Finish is
+ begin
+ null;
+ end Finish;
+
+ procedure Run_Parallel (Subprg : Parallel_Subprg_Acc) is
+ begin
+ Subprg.all;
+ end Run_Parallel;
+
+ function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr)
+ return Ghdl_Signal_Ptr
+ is
+ Prev : Ghdl_Signal_Ptr;
+ begin
+ Prev := List.all;
+ List.all := El;
+ return Prev;
+ end Atomic_Insert;
+
+ function Atomic_Inc (Val : access Natural) return Natural
+ is
+ Res : Natural;
+ begin
+ Res := Val.all;
+ Val.all := Val.all + 1;
+ return Res;
+ end Atomic_Inc;
+
+ Current_Process : Process_Acc;
+
+ -- Called by linux.c
+ function Grt_Get_Current_Process return Process_Acc;
+ pragma Export (C, Grt_Get_Current_Process);
+
+ function Grt_Get_Current_Process return Process_Acc is
+ begin
+ return Current_Process;
+ end Grt_Get_Current_Process;
+
+
+ procedure Set_Current_Process (Proc : Process_Acc) is
+ begin
+ Current_Process := Proc;
+ end Set_Current_Process;
+
+ function Get_Current_Process return Process_Acc is
+ begin
+ return Current_Process;
+ end Get_Current_Process;
+
+ Stack2 : Stack2_Ptr;
+
+ function Get_Stack2 return Stack2_Ptr is
+ begin
+ return Stack2;
+ end Get_Stack2;
+
+ procedure Set_Stack2 (St : Stack2_Ptr) is
+ begin
+ Stack2 := St;
+ end Set_Stack2;
+
+ Main_Stack : Stack_Type;
+
+ function Get_Main_Stack return Stack_Type is
+ begin
+ return Main_Stack;
+ end Get_Main_Stack;
+
+ procedure Set_Main_Stack (St : Stack_Type) is
+ begin
+ Main_Stack := St;
+ end Set_Main_Stack;
+end Grt.Unithread;
diff --git a/src/translate/grt/grt-unithread.ads b/src/translate/grt/grt-unithread.ads
new file mode 100644
index 000000000..b35b7be33
--- /dev/null
+++ b/src/translate/grt/grt-unithread.ads
@@ -0,0 +1,73 @@
+-- GHDL Run Time (GRT) - mono-thread version.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Signals; use Grt.Signals;
+with Grt.Stack2; use Grt.Stack2;
+with Grt.Stacks; use Grt.Stacks;
+
+package Grt.Unithread is
+ procedure Init;
+ procedure Finish;
+
+ type Parallel_Subprg_Acc is access procedure;
+ procedure Run_Parallel (Subprg : Parallel_Subprg_Acc);
+
+ -- Return the old value of LIST.all and store EL into LIST.all.
+ function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr)
+ return Ghdl_Signal_Ptr;
+
+ -- Return the old value.
+ function Atomic_Inc (Val : access Natural) return Natural;
+
+ -- Set and get the current process being executed by the thread.
+ procedure Set_Current_Process (Proc : Process_Acc);
+ function Get_Current_Process return Process_Acc;
+
+ -- The secondary stack for the thread. In this implementation, there is
+ -- only one secondary stack, shared by all processes. This is allowed,
+ -- because a wait statement cannot appear within a function. So at a wait
+ -- statement, the secondary stack must be empty.
+ function Get_Stack2 return Stack2_Ptr;
+ procedure Set_Stack2 (St : Stack2_Ptr);
+
+ -- The main stack. This is initialized by STACK_INIT.
+ -- The return point.
+ function Get_Main_Stack return Stack_Type;
+ procedure Set_Main_Stack (St : Stack_Type);
+private
+ pragma Inline (Run_Parallel);
+ pragma Inline (Atomic_Insert);
+ pragma Inline (Atomic_Inc);
+ pragma Inline (Get_Stack2);
+ pragma Inline (Set_Stack2);
+
+ pragma Inline (Get_Main_Stack);
+ pragma Export (C, Set_Main_Stack, "grt_set_main_stack");
+
+ pragma Inline (Set_Current_Process);
+ pragma Inline (Get_Current_Process);
+
+end Grt.Unithread;
diff --git a/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb
new file mode 100644
index 000000000..3d703bc85
--- /dev/null
+++ b/src/translate/grt/grt-values.adb
@@ -0,0 +1,639 @@
+-- GHDL Run Time (GRT) - 'value subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Utils;
+
+package body Grt.Values is
+
+ NBSP : constant Character := Character'Val (160);
+ HT : constant Character := Character'Val (9);
+
+ -- Return True IFF C is a whitespace character (as defined in LRM93 14.3)
+ function Is_Whitespace (C : in Character) return Boolean is
+ begin
+ return C = ' ' or C = NBSP or C = HT;
+ end Is_Whitespace;
+
+ -- Increase POS to skip leading whitespace characters, decrease LEN to
+ -- skip trailing whitespaces in string S.
+ procedure Remove_Whitespaces (S : Std_String_Basep;
+ Len : in out Ghdl_Index_Type;
+ Pos : in out Ghdl_Index_Type) is
+ begin
+ -- GHDL: allow several leading whitespace.
+ while Pos < Len loop
+ exit when not Is_Whitespace (S (Pos));
+ Pos := Pos + 1;
+ end loop;
+
+ -- GHDL: allow several leading whitespace.
+ while Len > Pos loop
+ exit when not Is_Whitespace (S (Len - 1));
+ Len := Len - 1;
+ end loop;
+ if Pos = Len then
+ Error_E ("'value: empty string");
+ end if;
+ end Remove_Whitespaces;
+
+ -- Convert C to lowercase.
+ function To_LC (C : in Character) return Character is
+ begin
+ if C >= 'A' and then C <= 'Z' then
+ return Character'Val
+ (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A'));
+ else
+ return C;
+ end if;
+ end To_LC;
+
+ -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF.
+ -- Comparaison is case insensitive, but REF must be lowercase (REF is
+ -- supposed to come from an RTI).
+ function String_Match (S : Std_String_Basep;
+ Pos : Ghdl_Index_Type;
+ Len : Ghdl_Index_Type;
+ Ref : Ghdl_C_String) return Boolean
+ is
+ P : Ghdl_Index_Type;
+ C : Character;
+ begin
+ P := 0;
+ loop
+ C := Ref (Natural (P + 1));
+ if Pos + P = Len then
+ -- End of string.
+ return C = ASCII.NUL;
+ end if;
+ if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then
+ return False;
+ end if;
+ P := P + 1;
+ end loop;
+ end String_Match;
+
+ -- Return the value of STR for enumerated type RTI.
+ function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_Index_Type
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ Remove_Whitespaces (S, Len, Pos);
+
+ for I in 0 .. Enum_Rti.Nbr - 1 loop
+ if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then
+ return I;
+ end if;
+ end loop;
+ Error_C ("'value: '");
+ Error_C_Std (S (Pos .. Len));
+ Error_C ("' not in enumeration '");
+ Error_C (Enum_Rti.Name);
+ Error_E ("'");
+ end Ghdl_Value_Enum;
+
+ function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_B1
+ is
+ begin
+ return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_B1;
+
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E8
+ is
+ begin
+ return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_E8;
+
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E32
+ is
+ begin
+ return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_E32;
+
+ -- Convert S (INIT_POS .. LEN) to a signed integer.
+ function Ghdl_Value_I64 (S : Std_String_Basep;
+ Len : Ghdl_Index_Type;
+ Init_Pos : Ghdl_Index_Type)
+ return Ghdl_I64
+ is
+ Pos : Ghdl_Index_Type := Init_Pos;
+ C : Character;
+ Sep : Character;
+ Val, D, Base : Ghdl_I64;
+ Exp : Integer;
+ begin
+ C := S (Pos);
+
+ -- Be user friendly.
+ -- FIXME: reference.
+ if C = '-' or C = '+' then
+ Error_E ("'value: leading sign +/- not allowed");
+ end if;
+
+ Val := 0;
+ loop
+ if C in '0' .. '9' then
+ Val := Val * 10 + Character'Pos (C) - Character'Pos ('0');
+ Pos := Pos + 1;
+ exit when Pos >= Len;
+ C := S (Pos);
+ else
+ Error_E ("'value: decimal digit expected");
+ end if;
+ case C is
+ when '_' =>
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: trailing underscore");
+ end if;
+ C := S (Pos);
+ when '#'
+ | ':'
+ | 'E'
+ | 'e' =>
+ exit;
+ when ' '
+ | NBSP
+ | HT =>
+ Pos := Pos + 1;
+ exit;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ if Pos >= Len then
+ return Val;
+ end if;
+
+ if C = '#' or C = ':' then
+ Base := Val;
+ Val := 0;
+ Sep := C;
+ Pos := Pos + 1;
+ if Base < 2 or Base > 16 then
+ Error_E ("'value: bad base");
+ end if;
+ if Pos >= Len then
+ Error_E ("'value: missing based integer");
+ end if;
+ C := S (Pos);
+ loop
+ case C is
+ when '0' .. '9' =>
+ D := Character'Pos (C) - Character'Pos ('0');
+ when 'a' .. 'f' =>
+ D := Character'Pos (C) - Character'Pos ('a') + 10;
+ when 'A' .. 'F' =>
+ D := Character'Pos (C) - Character'Pos ('A') + 10;
+ when others =>
+ Error_E ("'value: digit expected");
+ end case;
+ if D >= Base then
+ Error_E ("'value: digit >= base");
+ end if;
+ Val := Val * Base + D;
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ C := S (Pos);
+ if C = '#' or C = ':' then
+ if C /= Sep then
+ Error_E ("'value: sign number mismatch");
+ end if;
+ Pos := Pos + 1;
+ exit;
+ elsif C = '_' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after underscore");
+ end if;
+ C := S (Pos);
+ end if;
+ end loop;
+ else
+ Base := 10;
+ end if;
+
+ -- Handle exponent.
+ if C = 'e' or C = 'E' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after exponent");
+ end if;
+ C := S (Pos);
+ if C = '+' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after sign");
+ end if;
+ C := S (Pos);
+ elsif C = '-' then
+ Error_E ("'value: negativ exponent not allowed");
+ end if;
+ Exp := 0;
+ loop
+ if C in '0' .. '9' then
+ Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0');
+ Pos := Pos + 1;
+ exit when Pos >= Len;
+ C := S (Pos);
+ else
+ Error_E ("'value: decimal digit expected");
+ end if;
+ case C is
+ when '_' =>
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: trailing underscore");
+ end if;
+ C := S (Pos);
+ when ' '
+ | NBSP
+ | HT =>
+ Pos := Pos + 1;
+ exit;
+ when others =>
+ null;
+ end case;
+ end loop;
+ while Exp > 0 loop
+ if Exp mod 2 = 1 then
+ Val := Val * Base;
+ end if;
+ Exp := Exp / 2;
+ Base := Base * Base;
+ end loop;
+ end if;
+
+ if Pos /= Len then
+ Error_E ("'value: trailing characters after blank");
+ end if;
+
+ return Val;
+ end Ghdl_Value_I64;
+
+ function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ -- LRM 14.1
+ -- Leading [and trailing] whitespace is allowed and ignored.
+ --
+ -- GHDL: allow several leading whitespace.
+ Remove_Whitespaces (S, Len, Pos);
+
+ return Ghdl_Value_I64 (S, Len, Pos);
+ end Ghdl_Value_I64;
+
+ function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32
+ is
+ begin
+ return Ghdl_I32 (Ghdl_Value_I64 (Str));
+ end Ghdl_Value_I32;
+
+ -- From patch attached to https://gna.org/bugs/index.php?18352
+ -- thanks to Christophe Curis https://gna.org/users/lobotomy
+ function Ghdl_Value_F64 (S : Std_String_Basep;
+ Len : Ghdl_Index_Type;
+ Init_Pos : Ghdl_Index_Type)
+ return Ghdl_F64
+ is
+ Pos : Ghdl_Index_Type := Init_Pos;
+ C : Character;
+ Is_Negative, Is_Neg_Exp : Boolean := False;
+ Base : Ghdl_F64;
+ Intg : Ghdl_I32;
+ Val, Df : Ghdl_F64;
+ Sep : Character;
+ FrcExp : Ghdl_F64;
+ begin
+ C := S (Pos);
+ if C = '-' then
+ Is_Negative := True;
+ Pos := Pos + 1;
+ elsif C = '+' then
+ Pos := Pos + 1;
+ end if;
+
+ if Pos >= Len then
+ Error_E ("'value: decimal digit expected");
+ end if;
+
+ -- Read Integer-or-Base part (may be optional)
+ Intg := 0;
+ while Pos < Len loop
+ C := S (Pos);
+ if C in '0' .. '9' then
+ Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
+ elsif C /= '_' then
+ exit;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+
+ if Pos = Len then
+ return Ghdl_F64 (Intg);
+ end if;
+
+ -- Special case: base was specified
+ if C = '#' or C = ':' then
+ if Intg < 2 or Intg > 16 then
+ Error_E ("'value: bad base");
+ end if;
+ Base := Ghdl_F64 (Intg);
+ Val := 0.0;
+ Sep := C;
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: missing based decimal");
+ end if;
+
+ -- Get the Integer part of the Value
+ while Pos < Len loop
+ C := S (Pos);
+ case C is
+ when '0' .. '9' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') );
+ when 'A' .. 'F' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
+ when 'a' .. 'f' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
+ when others =>
+ exit;
+ end case;
+ if C /= '_' then
+ if Df >= Base then
+ Error_E ("'value: digit greater than base");
+ end if;
+ Val := Val * Base + Df;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ else
+ Base := 10.0;
+ Sep := ' ';
+ Val := Ghdl_F64 (Intg);
+ end if;
+
+ -- Handle the Fractional part
+ if C = '.' then
+ Pos := Pos + 1;
+ FrcExp := 1.0;
+ while Pos < Len loop
+ C := S (Pos);
+ case C is
+ when '0' .. '9' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0'));
+ when 'A' .. 'F' =>
+ exit when Sep = ' ';
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
+ when 'a' .. 'f' =>
+ exit when Sep = ' ';
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
+ when others =>
+ exit;
+ end case;
+ if C /= '_' then
+ FrcExp := FrcExp / Base;
+ if Df > Base then
+ Error_E ("'value: digit greater than base");
+ end if;
+ Val := Val + Df * FrcExp;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ end if;
+
+ -- If base was specified, we must find here the end marker
+ if Sep /= ' ' then
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ if C /= Sep then
+ Error_E ("'value: sign number mismatch");
+ end if;
+ Pos := Pos + 1;
+ end if;
+
+ -- Handle exponent
+ if Pos < Len then
+ C := S (Pos);
+ if C = 'e' or C = 'E' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after exponent");
+ end if;
+ C := S (Pos);
+ if C = '-' then
+ Is_Neg_Exp := True;
+ Pos := Pos + 1;
+ elsif C = '+' then
+ Pos := Pos + 1;
+ end if;
+ Intg := 0;
+ while Pos < Len loop
+ C := S (Pos);
+ if C in '0' .. '9' then
+ Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
+ else
+ exit;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ -- This Exponentiation method is sub-optimal,
+ -- but it does not depend on any library
+ FrcExp := 1.0;
+ if Is_Neg_Exp then
+ while Intg > 0 loop
+ FrcExp := FrcExp / 10.0;
+ Intg := Intg - 1;
+ end loop;
+ else
+ while Intg > 0 loop
+ FrcExp := FrcExp * 10.0;
+ Intg := Intg - 1;
+ end loop;
+ end if;
+ Val := Val * FrcExp;
+ end if;
+ end if;
+
+ if Pos /= Len then
+ Error_E ("'value: trailing characters after blank");
+ end if;
+
+ if Is_Negative then
+ Val := -Val;
+ end if;
+
+ return Val;
+ end Ghdl_Value_F64;
+
+ -- From patch attached to https://gna.org/bugs/index.php?18352
+ -- thanks to Christophe Curis https://gna.org/users/lobotomy
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ -- LRM 14.1
+ -- Leading and trailing whitespace is allowed and ignored.
+ --
+ -- GHDL: allow several leading whitespace.
+ Remove_Whitespaces (S, Len, Pos);
+
+ return Ghdl_Value_F64 (S, Len, Pos);
+ end Ghdl_Value_F64;
+
+ procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr;
+ Is_Real : out Boolean;
+ Lit_Pos : out Ghdl_Index_Type;
+ Lit_End : out Ghdl_Index_Type;
+ Unit_Pos : out Ghdl_Index_Type)
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ begin
+ -- LRM 14.1
+ -- Leading and trailing whitespace is allowed and ignored.
+ Lit_Pos := 0;
+ Remove_Whitespaces (S, Len, Lit_Pos);
+
+ -- Split between abstract literal (optionnal) and unit name.
+ Lit_End := Lit_Pos;
+ Is_Real := False;
+ while Lit_End < Len loop
+ exit when Is_Whitespace (S (Lit_End));
+ if S (Lit_End) = '.' then
+ Is_Real := True;
+ end if;
+ Lit_End := Lit_End + 1;
+ end loop;
+ if Lit_End = Len then
+ -- No literal
+ Unit_Pos := Lit_Pos;
+ Lit_End := 0;
+ else
+ Unit_Pos := Lit_End + 1;
+ while Unit_Pos < Len loop
+ exit when not Is_Whitespace (S (Unit_Pos));
+ Unit_Pos := Unit_Pos + 1;
+ end loop;
+ end if;
+ end Ghdl_Value_Physical_Split;
+
+ function Ghdl_Value_Physical_Type (Str : Std_String_Ptr;
+ Rti : Ghdl_Rti_Access)
+ return Ghdl_I64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Unit_Pos : Ghdl_Index_Type;
+ Lit_Pos : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+
+ Found_Real : Boolean;
+
+ Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc :=
+ To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Multiple : Ghdl_Rti_Access;
+ Mult : Ghdl_I64;
+ begin
+ -- Remove trailing whitespaces. FIXME: also called in physical_split.
+ Lit_Pos := 0;
+ Remove_Whitespaces (S, Len, Lit_Pos);
+
+ -- Extract literal and unit
+ Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos);
+
+ -- Find unit value
+ Multiple := null;
+ for i in 0 .. Phys_Rti.Nbr - 1 loop
+ Unit_Name :=
+ Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i));
+ if String_Match (S, Unit_Pos, Len, Unit_Name) then
+ Multiple := Phys_Rti.Units (i);
+ exit;
+ end if;
+ end loop;
+ if Multiple = null then
+ Error_C ("'value: unit '");
+ Error_C_Std (S (Unit_Pos .. Len - 1));
+ Error_C ("' not in physical type '");
+ Error_C (Phys_Rti.Name);
+ Error_E ("'");
+ end if;
+
+ Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti);
+
+ if Lit_End = 0 then
+ return Mult;
+ else
+ if Found_Real then
+ return Ghdl_I64
+ (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult));
+ else
+ return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult;
+ end if;
+ end if;
+ end Ghdl_Value_Physical_Type;
+
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I64
+ is
+ begin
+ if Rti.Kind /= Ghdl_Rtik_Type_P64 then
+ Error_E ("Physical_Type_64'value: incorrect RTI");
+ end if;
+ return Ghdl_Value_Physical_Type (Str, Rti);
+ end Ghdl_Value_P64;
+
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I32
+ is
+ begin
+ if Rti.Kind /= Ghdl_Rtik_Type_P32 then
+ Error_E ("Physical_Type_32'value: incorrect RTI");
+ end if;
+ return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti));
+ end Ghdl_Value_P32;
+
+end Grt.Values;
diff --git a/src/translate/grt/grt-values.ads b/src/translate/grt/grt-values.ads
new file mode 100644
index 000000000..8df8c3f63
--- /dev/null
+++ b/src/translate/grt/grt-values.ads
@@ -0,0 +1,69 @@
+-- GHDL Run Time (GRT) - 'value subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Values is
+ -- Return True IFF C is a whitespace character (as defined in LRM93 14.3)
+ function Is_Whitespace (C : in Character) return Boolean;
+
+ -- Convert C to lowercase.
+ function To_LC (C : in Character) return Character;
+
+ -- Extract position of numeric literal and unit in string STR.
+ -- Set IS_REAL if the unit is a real number (presence of '.').
+ -- Set UNIT_POS to the position of the first character of the unit name.
+ -- Set LIT_POS to the position of the first character of the numeric
+ -- literal (after whitespaces are skipped).
+ -- Set LIT_END to the position of the next character of the numeric lit.
+ procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr;
+ Is_Real : out Boolean;
+ Lit_Pos : out Ghdl_Index_Type;
+ Lit_End : out Ghdl_Index_Type;
+ Unit_Pos : out Ghdl_Index_Type);
+
+ function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_B1;
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E8;
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E32;
+ function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32;
+ function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64;
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64;
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I64;
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I32;
+private
+ pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1");
+ pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8");
+ pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32");
+ pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32");
+ pragma Export (C, Ghdl_Value_I64, "__ghdl_value_i64");
+ pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64");
+ pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64");
+ pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32");
+end Grt.Values;
diff --git a/src/translate/grt/grt-vcd.adb b/src/translate/grt/grt-vcd.adb
new file mode 100644
index 000000000..d4a9ea066
--- /dev/null
+++ b/src/translate/grt/grt-vcd.adb
@@ -0,0 +1,845 @@
+-- GHDL Run Time (GRT) - VCD generator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Interfaces;
+with Grt.Stdio; use Grt.Stdio;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Errors; use Grt.Errors;
+with Grt.Signals; use Grt.Signals;
+with Grt.Table;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.C; use Grt.C;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Types; use Grt.Rtis_Types;
+with Grt.Vstrings;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Vcd is
+ -- If TRUE, put $date in vcd file.
+ -- Can be set to FALSE to make vcd comparaison easier.
+ Flag_Vcd_Date : Boolean := True;
+
+ Stream : FILEs;
+
+ procedure My_Vcd_Put (Str : String)
+ is
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (Str'Address, Str'Length, 1, Stream);
+ end My_Vcd_Put;
+
+ procedure My_Vcd_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Stream);
+ end My_Vcd_Putc;
+
+ procedure My_Vcd_Close is
+ begin
+ fclose (Stream);
+ Stream := NULL_Stream;
+ end My_Vcd_Close;
+
+ -- VCD filename.
+ -- Stream corresponding to the VCD filename.
+ --Vcd_Stream : FILEs;
+
+ -- Index type of the table of vcd variables to dump.
+ type Vcd_Index_Type is new Integer;
+
+ -- Return TRUE if OPT is an option for VCD.
+ function Vcd_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ Mode : constant String := "wt" & NUL;
+ Vcd_Filename : String_Access;
+ begin
+ if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then
+ return False;
+ end if;
+ if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then
+ Flag_Vcd_Date := False;
+ return True;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 5) = '=' then
+ if Vcd_Close /= null then
+ Error ("--vcd: file already set");
+ return True;
+ end if;
+
+ -- Add an extra NUL character.
+ Vcd_Filename := new String (1 .. Opt'Length - 6 + 1);
+ Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
+ Vcd_Filename (Vcd_Filename'Last) := NUL;
+
+ if Vcd_Filename.all = "-" & NUL then
+ Stream := stdout;
+ else
+ Stream := fopen (Vcd_Filename.all'Address, Mode'Address);
+ if Stream = NULL_Stream then
+ Error_C ("cannot open ");
+ Error_E (Vcd_Filename (Vcd_Filename'First
+ .. Vcd_Filename'Last - 1));
+ return True;
+ end if;
+ end if;
+ Vcd_Putc := My_Vcd_Putc'Access;
+ Vcd_Put := My_Vcd_Put'Access;
+ Vcd_Close := My_Vcd_Close'Access;
+ return True;
+ else
+ return False;
+ end if;
+ end Vcd_Option;
+
+ procedure Vcd_Help is
+ begin
+ Put_Line (" --vcd=FILENAME dump signal values into a VCD file");
+ Put_Line (" --vcd-nodate do not write date in VCD file");
+ end Vcd_Help;
+
+ procedure Vcd_Newline is
+ begin
+ Vcd_Putc (Nl);
+ end Vcd_Newline;
+
+ procedure Vcd_Putline (Str : String) is
+ begin
+ Vcd_Put (Str);
+ Vcd_Newline;
+ end Vcd_Putline;
+
+-- procedure Vcd_Put (Str : Ghdl_Str_Len_Type)
+-- is
+-- begin
+-- Put_Str_Len (Vcd_Stream, Str);
+-- end Vcd_Put;
+
+ procedure Vcd_Put_I32 (V : Ghdl_I32)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ begin
+ Vstrings.To_String (Str, First, V);
+ Vcd_Put (Str (First .. Str'Last));
+ end Vcd_Put_I32;
+
+ procedure Vcd_Put_Idcode (N : Vcd_Index_Type)
+ is
+ Str : String (1 .. 8);
+ V, R : Vcd_Index_Type;
+ L : Natural;
+ begin
+ L := 0;
+ V := N;
+ loop
+ R := V mod 93;
+ V := V / 93;
+ L := L + 1;
+ Str (L) := Character'Val (33 + R);
+ exit when V = 0;
+ end loop;
+ Vcd_Put (Str (1 .. L));
+ end Vcd_Put_Idcode;
+
+ procedure Vcd_Put_Name (Obj : VhpiHandleT)
+ is
+ Name : String (1 .. 128);
+ Name_Len : Integer;
+ begin
+ Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len);
+ if Name_Len <= Name'Last then
+ Vcd_Put (Name (1 .. Name_Len));
+ else
+ -- Truncate.
+ Vcd_Put (Name);
+ end if;
+ end Vcd_Put_Name;
+
+ procedure Vcd_Put_End is
+ begin
+ Vcd_Putline ("$end");
+ end Vcd_Put_End;
+
+ -- Called before elaboration.
+ procedure Vcd_Init
+ is
+ begin
+ if Vcd_Close = null then
+ return;
+ end if;
+ if Flag_Vcd_Date then
+ Vcd_Putline ("$date");
+ Vcd_Put (" ");
+ declare
+ type time_t is new Interfaces.Integer_64;
+ Cur_Time : time_t;
+
+ function time (Addr : Address) return time_t;
+ pragma Import (C, time);
+
+ function ctime (Timep: Address) return Ghdl_C_String;
+ pragma Import (C, ctime);
+
+ Ct : Ghdl_C_String;
+ begin
+ Cur_Time := time (Null_Address);
+ Ct := ctime (Cur_Time'Address);
+ for I in Positive loop
+ exit when Ct (I) = NUL;
+ Vcd_Putc (Ct (I));
+ end loop;
+ -- Note: ctime already append a LF.
+ end;
+ Vcd_Put_End;
+ end if;
+ Vcd_Putline ("$version");
+ Vcd_Putline (" GHDL v0");
+ Vcd_Put_End;
+ Vcd_Putline ("$timescale");
+ Vcd_Putline (" 1 fs");
+ Vcd_Put_End;
+ end Vcd_Init;
+
+ package Vcd_Table is new Grt.Table
+ (Table_Component_Type => Verilog_Wire_Info,
+ Table_Index_Type => Vcd_Index_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 32);
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("Vcd.Avhpi_Error!");
+ null;
+ end Avhpi_Error;
+
+ function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind
+ is
+ Rti1 : Ghdl_Rti_Access;
+ begin
+ if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
+ else
+ Rti1 := Rti;
+ end if;
+
+ if Rti1 = Std_Standard_Boolean_RTI_Ptr then
+ return Vcd_Bool;
+ end if;
+ if Rti1 = Std_Standard_Bit_RTI_Ptr then
+ return Vcd_Bit;
+ end if;
+ if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then
+ return Vcd_Stdlogic;
+ end if;
+ if Rti1.Kind = Ghdl_Rtik_Type_I32 then
+ return Vcd_Integer32;
+ end if;
+ if Rti1.Kind = Ghdl_Rtik_Type_F64 then
+ return Vcd_Float64;
+ end if;
+ return Vcd_Bad;
+ end Rti_To_Vcd_Kind;
+
+ function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc)
+ return Vcd_Var_Kind
+ is
+ It : Ghdl_Rti_Access;
+ begin
+ if Rti.Nbr_Dim /= 1 then
+ return Vcd_Bad;
+ end if;
+ It := Rti.Indexes (0);
+ if It.Kind /= Ghdl_Rtik_Subtype_Scalar then
+ return Vcd_Bad;
+ end if;
+ if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind
+ /= Ghdl_Rtik_Type_I32
+ then
+ return Vcd_Bad;
+ end if;
+ case Rti_To_Vcd_Kind (Rti.Element) is
+ when Vcd_Bit =>
+ return Vcd_Bitvector;
+ when Vcd_Stdlogic =>
+ return Vcd_Stdlogic_Vector;
+ when others =>
+ return Vcd_Bad;
+ end case;
+ end Rti_To_Vcd_Kind;
+
+ procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info)
+ is
+ Sig_Type : VhpiHandleT;
+ Rti : Ghdl_Rti_Access;
+ Error : AvhpiErrorT;
+ Sig_Addr : Address;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Rti := Avhpi_Get_Rti (Sig_Type);
+ Sig_Addr := Avhpi_Get_Address (Sig);
+ Info.Kind := Vcd_Bad;
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Subtype_Scalar =>
+ Info.Kind := Rti_To_Vcd_Kind (Rti);
+ Info.Addr := Sig_Addr;
+ Info.Irange := null;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Info.Kind := Rti_To_Vcd_Kind (St.Basetype);
+ Info.Addr := Sig_Addr;
+ Info.Irange := To_Ghdl_Range_Ptr
+ (Loc_To_Addr (St.Common.Depth, St.Bounds,
+ Avhpi_Get_Context (Sig)));
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Uc : Ghdl_Uc_Array_Acc;
+ begin
+ Info.Kind := Rti_To_Vcd_Kind
+ (To_Ghdl_Rtin_Type_Array_Acc (Rti));
+ Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr);
+ Info.Addr := Uc.Base;
+ Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds);
+ end;
+ when others =>
+ Info.Irange := null;
+ end case;
+
+ -- Do not allow null-array.
+ if Info.Irange /= null and then Info.Irange.I32.Len = 0 then
+ Info.Kind := Vcd_Bad;
+ Info.Irange := null;
+ return;
+ end if;
+
+ if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then
+ case Vhpi_Get_Mode (Sig) is
+ when VhpiInMode
+ | VhpiInoutMode
+ | VhpiBufferMode
+ | VhpiLinkageMode =>
+ Info.Val := Vcd_Effective;
+ when VhpiOutMode =>
+ Info.Val := Vcd_Driving;
+ when VhpiErrorMode =>
+ Info.Kind := Vcd_Bad;
+ end case;
+ else
+ Info.Val := Vcd_Effective;
+ end if;
+ end Get_Verilog_Wire;
+
+ procedure Add_Signal (Sig : VhpiHandleT)
+ is
+ N : Vcd_Index_Type;
+ Vcd_El : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Sig, Vcd_El);
+
+ if Vcd_El.Kind = Vcd_Bad then
+ Vcd_Put ("$comment ");
+ Vcd_Put_Name (Sig);
+ Vcd_Put (" is not handled");
+ --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind));
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ return;
+ else
+ Vcd_Table.Increment_Last;
+ N := Vcd_Table.Last;
+
+ Vcd_Table.Table (N) := Vcd_El;
+ Vcd_Put ("$var ");
+ case Vcd_El.Kind is
+ when Vcd_Integer32 =>
+ Vcd_Put ("integer 32");
+ when Vcd_Float64 =>
+ Vcd_Put ("real 64");
+ when Vcd_Bool
+ | Vcd_Bit
+ | Vcd_Stdlogic =>
+ Vcd_Put ("reg 1");
+ when Vcd_Bitvector
+ | Vcd_Stdlogic_Vector =>
+ Vcd_Put ("reg ");
+ Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len));
+ when Vcd_Bad =>
+ null;
+ end case;
+ Vcd_Putc (' ');
+ Vcd_Put_Idcode (N);
+ Vcd_Putc (' ');
+ Vcd_Put_Name (Sig);
+ if Vcd_El.Irange /= null then
+ Vcd_Putc ('[');
+ Vcd_Put_I32 (Vcd_El.Irange.I32.Left);
+ Vcd_Putc (':');
+ Vcd_Put_I32 (Vcd_El.Irange.I32.Right);
+ Vcd_Putc (']');
+ end if;
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ if Boolean'(False) then
+ Vcd_Put ("$comment ");
+ Vcd_Put_Name (Sig);
+ Vcd_Put (" is ");
+ case Vcd_El.Val is
+ when Vcd_Effective =>
+ Vcd_Put ("effective ");
+ when Vcd_Driving =>
+ Vcd_Put ("driving ");
+ end case;
+ Vcd_Put_End;
+ end if;
+ end if;
+ end Add_Signal;
+
+ procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract signals.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Add_Signal (Decl);
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ -- Extract sub-scopes.
+ Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiBlockStmtK
+ | VhpiCompInstStmtK =>
+ Vcd_Put ("$scope module ");
+ Vcd_Put_Name (Decl);
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ Vcd_Put_Hierarchy (Decl);
+ Vcd_Put ("$upscope ");
+ Vcd_Put_End;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ end Vcd_Put_Hierarchy;
+
+ procedure Vcd_Put_Bit (V : Ghdl_B1)
+ is
+ C : Character;
+ begin
+ if V then
+ C := '1';
+ else
+ C := '0';
+ end if;
+ Vcd_Putc (C);
+ end Vcd_Put_Bit;
+
+ procedure Vcd_Put_Stdlogic (V : Ghdl_E8)
+ is
+ type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character;
+ -- "UX01ZWLH-"
+ -- Map_Vlg : constant Map_Type := "xx01zz01x";
+ Map_Std : constant Map_Type := "UX01ZWLH-";
+ begin
+ if V not in Map_Type'Range then
+ Vcd_Putc ('?');
+ else
+ Vcd_Putc (Map_Std (V));
+ end if;
+ end Vcd_Put_Stdlogic;
+
+ procedure Vcd_Put_Integer32 (V : Ghdl_U32)
+ is
+ Val : Ghdl_U32;
+ N : Natural;
+ begin
+ Val := V;
+ N := 32;
+ while N > 1 loop
+ exit when (Val and 16#8000_0000#) /= 0;
+ Val := Val * 2;
+ N := N - 1;
+ end loop;
+
+ while N > 0 loop
+ if (Val and 16#8000_0000#) /= 0 then
+ Vcd_Putc ('1');
+ else
+ Vcd_Putc ('0');
+ end if;
+ Val := Val * 2;
+ N := N - 1;
+ end loop;
+ end Vcd_Put_Integer32;
+
+ -- Using the floor attribute of Ghdl_F64 will result on a link error while
+ -- trying to simulate a design. So it was needed to create a floor function
+ function Digit_Floor (V : Ghdl_F64) return Ghdl_I32
+ is
+ Var : Ghdl_I32;
+ begin
+ -- V is always positive here and only of interest when it is a digit
+ if V > 10.0 then
+ return -1;
+ else
+ Var := Ghdl_I32(V-0.5); --Ghdl_I32 rounds to the nearest integer
+ -- The rounding made by Ghdl_I32 is asymetric :
+ -- 0.5 will be rounded to 1, but -0.5 to -1 instead of 0
+ if Var > 0 then
+ return Var;
+ else
+ return 0;
+ end if;
+ end if;
+ end Digit_Floor;
+
+ procedure Vcd_Put_Float64 (V : Ghdl_F64)
+ is
+ Val_tmp, Fact : Ghdl_F64;
+ Digit, Exp, Delta_Exp, N_Exp : Ghdl_I32;
+ --
+ begin
+ Exp := 0;
+ if V /= V then
+ Vcd_Put("NaN");
+ return;
+ end if;
+ if V < 0.0 then
+ Vcd_Putc ('-');
+ Val_tmp := -V;
+ elsif V = 0.0 then
+ Vcd_Put("0.0");
+ return;
+ else
+ Val_tmp := V;
+ end if;
+ if Val_tmp > Ghdl_F64'Last then
+ Vcd_Put("Inf");
+ return;
+ elsif Val_tmp < 1.0 then
+ Fact := 10.0;
+ Delta_Exp := -1;
+ else
+ Fact := 0.1;
+ Delta_Exp := 1;
+ end if;
+
+ -- Seek the first digit
+ loop
+ Digit := Digit_Floor(Val_tmp);
+ if Digit > 0 then
+ exit;
+ end if;
+ Exp := Exp + Delta_Exp;
+ Val_tmp := Val_tmp * Fact;
+ end loop;
+ Vcd_Putc(Character'Val(Digit + 48));
+ Vcd_Putc('.');
+ for i in 0..4 loop -- 5 digits displayed after the point
+ Val_tmp := abs(Val_tmp - Ghdl_F64(Digit))*10.0;
+ Digit := Digit_Floor(Val_tmp);
+ Vcd_Putc(Character'Val(Digit + 48));
+ end loop;
+ Vcd_Putc('E');
+ if Exp < 0 then
+ Vcd_Putc('-');
+ Exp := -Exp;
+ end if;
+ N_Exp := 100;
+ while N_Exp > 0 loop
+ Vcd_Putc(Character'Val(Exp/N_Exp + 48));
+ Exp := Exp mod N_Exp;
+ N_Exp := N_Exp/10;
+ end loop;
+ end Vcd_Put_Float64;
+
+ procedure Vcd_Put_Var (I : Vcd_Index_Type)
+ is
+ Addr : Address;
+ V : Verilog_Wire_Info renames Vcd_Table.Table (I);
+ Len : Ghdl_Index_Type;
+ begin
+ Addr := V.Addr;
+ if V.Irange = null then
+ Len := 1;
+ else
+ Len := V.Irange.I32.Len;
+ end if;
+ case V.Val is
+ when Vcd_Effective =>
+ case V.Kind is
+ when Vcd_Bit
+ | Vcd_Bool =>
+ Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(0).Value.B1);
+ when Vcd_Stdlogic =>
+ Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(0).Value.E8);
+ when Vcd_Integer32 =>
+ Vcd_Putc ('b');
+ Vcd_Put_Integer32 (To_Signal_Arr_Ptr (Addr)(0).Value.E32);
+ Vcd_Putc (' ');
+ when Vcd_Float64 =>
+ Vcd_Putc ('r');
+ Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0).Value.F64);
+ Vcd_Putc (' ');
+ when Vcd_Bitvector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(J).Value.B1);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Stdlogic_Vector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(J).Value.E8);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Bad =>
+ null;
+ end case;
+ when Vcd_Driving =>
+ case V.Kind is
+ when Vcd_Bit
+ | Vcd_Bool =>
+ Vcd_Put_Bit
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.B1);
+ when Vcd_Stdlogic =>
+ Vcd_Put_Stdlogic
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E8);
+ when Vcd_Integer32 =>
+ Vcd_Putc ('b');
+ Vcd_Put_Integer32
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E32);
+ Vcd_Putc (' ');
+ when Vcd_Float64 =>
+ Vcd_Putc ('r');
+ Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0)
+ .Driving_Value.F64);
+ Vcd_Putc (' ');
+ when Vcd_Bitvector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Bit
+ (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.B1);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Stdlogic_Vector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Stdlogic
+ (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.E8);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Bad =>
+ null;
+ end case;
+ end case;
+ Vcd_Put_Idcode (I);
+ Vcd_Newline;
+ end Vcd_Put_Var;
+
+ function Verilog_Wire_Changed (Info : Verilog_Wire_Info;
+ Last : Std_Time)
+ return Boolean
+ is
+ Len : Ghdl_Index_Type;
+ begin
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ case Info.Val is
+ when Vcd_Effective =>
+ case Info.Kind is
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Stdlogic
+ | Vcd_Bitvector
+ | Vcd_Stdlogic_Vector
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ for J in 0 .. Len - 1 loop
+ if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Event = Last then
+ return True;
+ end if;
+ end loop;
+ when Vcd_Bad =>
+ null;
+ end case;
+ when Vcd_Driving =>
+ case Info.Kind is
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Stdlogic
+ | Vcd_Bitvector
+ | Vcd_Stdlogic_Vector
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ for J in 0 .. Len - 1 loop
+ if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Active = Last
+ then
+ return True;
+ end if;
+ end loop;
+ when Vcd_Bad =>
+ null;
+ end case;
+ end case;
+ return False;
+ end Verilog_Wire_Changed;
+
+ procedure Vcd_Put_Time
+ is
+ Str : String (1 .. 21);
+ First : Natural;
+ begin
+ Vcd_Putc ('#');
+ Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time));
+ Vcd_Put (Str (First .. Str'Last));
+ Vcd_Newline;
+ end Vcd_Put_Time;
+
+ procedure Vcd_Cycle;
+
+ -- Called after elaboration.
+ procedure Vcd_Start
+ is
+ Root : VhpiHandleT;
+ begin
+ -- Do nothing if there is no VCD file to generate.
+ if Vcd_Close = null then
+ return;
+ end if;
+
+ -- Be sure the RTI of std_ulogic is set.
+ Search_Types_RTI;
+
+ -- Put hierarchy.
+ Get_Root_Inst (Root);
+ Vcd_Put_Hierarchy (Root);
+
+ -- End of header.
+ Vcd_Put ("$enddefinitions ");
+ Vcd_Put_End;
+
+ Register_Cycle_Hook (Vcd_Cycle'Access);
+ end Vcd_Start;
+
+ -- Called before each non delta cycle.
+ procedure Vcd_Cycle is
+ begin
+ -- Disp values.
+ Vcd_Put_Time;
+ if Cycle_Time = 0 then
+ -- Disp all values.
+ for I in Vcd_Table.First .. Vcd_Table.Last loop
+ Vcd_Put_Var (I);
+ end loop;
+ else
+ -- Disp only values changed.
+ for I in Vcd_Table.First .. Vcd_Table.Last loop
+ if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then
+ Vcd_Put_Var (I);
+ end if;
+ end loop;
+ end if;
+ end Vcd_Cycle;
+
+ -- Called at the end of the simulation.
+ procedure Vcd_End is
+ begin
+ if Vcd_Close /= null then
+ Vcd_Close.all;
+ end if;
+ end Vcd_End;
+
+ Vcd_Hooks : aliased constant Hooks_Type :=
+ (Option => Vcd_Option'Access,
+ Help => Vcd_Help'Access,
+ Init => Vcd_Init'Access,
+ Start => Vcd_Start'Access,
+ Finish => Vcd_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vcd_Hooks'Access);
+ end Register;
+end Grt.Vcd;
diff --git a/src/translate/grt/grt-vcd.ads b/src/translate/grt/grt-vcd.ads
new file mode 100644
index 000000000..ed015af80
--- /dev/null
+++ b/src/translate/grt/grt-vcd.ads
@@ -0,0 +1,65 @@
+-- GHDL Run Time (GRT) - VCD generator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package Grt.Vcd is
+ -- Abstract type for IO.
+ type Vcd_Put_Acc is access procedure (Str : String);
+ type Vcd_Putc_Acc is access procedure (C : Character);
+ type Vcd_Close_Acc is access procedure;
+
+ Vcd_Put : Vcd_Put_Acc;
+ Vcd_Putc : Vcd_Putc_Acc;
+ Vcd_Close : Vcd_Close_Acc;
+
+ type Vcd_Var_Kind is (Vcd_Bad,
+ Vcd_Bool,
+ Vcd_Integer32,
+ Vcd_Float64,
+ Vcd_Bit, Vcd_Stdlogic,
+ Vcd_Bitvector, Vcd_Stdlogic_Vector);
+
+ -- Which value to be displayed: effective or driving (for out signals).
+ type Vcd_Value_Kind is (Vcd_Effective, Vcd_Driving);
+
+ type Verilog_Wire_Info is record
+ Addr : Address;
+ Irange : Ghdl_Range_Ptr;
+ Kind : Vcd_Var_Kind;
+ Val : Vcd_Value_Kind;
+ end record;
+
+ procedure Get_Verilog_Wire (Sig : VhpiHandleT;
+ Info : out Verilog_Wire_Info);
+
+ -- Return TRUE if last change time of the wire described by INFO is LAST.
+ function Verilog_Wire_Changed (Info : Verilog_Wire_Info;
+ Last : Std_Time)
+ return Boolean;
+
+ procedure Register;
+end Grt.Vcd;
diff --git a/src/translate/grt/grt-vcdz.adb b/src/translate/grt/grt-vcdz.adb
new file mode 100644
index 000000000..8e1ceb6f1
--- /dev/null
+++ b/src/translate/grt/grt-vcdz.adb
@@ -0,0 +1,116 @@
+-- GHDL Run Time (GRT) - VCD .gz module.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Vcd; use Grt.Vcd;
+with Grt.Errors; use Grt.Errors;
+with Grt.Types; use Grt.Types;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Zlib; use Grt.Zlib;
+with Grt.C; use Grt.C;
+
+package body Grt.Vcdz is
+ Stream : gzFile;
+
+ procedure My_Vcd_Put (Str : String)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := gzwrite (Stream, Str'Address, Str'Length);
+ end My_Vcd_Put;
+
+ procedure My_Vcd_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := gzputc (Stream, Character'Pos (C));
+ end My_Vcd_Putc;
+
+ procedure My_Vcd_Close is
+ begin
+ gzclose (Stream);
+ Stream := NULL_gzFile;
+ end My_Vcd_Close;
+
+ -- VCD filename.
+
+ -- Return TRUE if OPT is an option for VCD.
+ function Vcdz_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ Vcd_Filename : String_Access := null;
+ Mode : constant String := "wb" & NUL;
+ begin
+ if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then
+ return False;
+ end if;
+ if Opt'Length > 7 and then Opt (F + 7) = '=' then
+ if Vcd_Close /= null then
+ Error ("--vcdgz: file already set");
+ return True;
+ end if;
+
+ -- Add an extra NUL character.
+ Vcd_Filename := new String (1 .. Opt'Length - 8 + 1);
+ Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last);
+ Vcd_Filename (Vcd_Filename'Last) := NUL;
+
+ Stream := gzopen (Vcd_Filename.all'Address, Mode'Address);
+ if Stream = NULL_gzFile then
+ Error_C ("cannot open ");
+ Error_E (Vcd_Filename (Vcd_Filename'First
+ .. Vcd_Filename'Last - 1));
+ return True;
+ end if;
+ Vcd_Putc := My_Vcd_Putc'Access;
+ Vcd_Put := My_Vcd_Put'Access;
+ Vcd_Close := My_Vcd_Close'Access;
+ return True;
+ else
+ return False;
+ end if;
+ end Vcdz_Option;
+
+ procedure Vcdz_Help is
+ begin
+ Put_Line
+ (" --vcdgz=FILENAME dump signal values into a VCD gzip'ed file");
+ end Vcdz_Help;
+
+ Vcdz_Hooks : aliased constant Hooks_Type :=
+ (Option => Vcdz_Option'Access,
+ Help => Vcdz_Help'Access,
+ Init => Proc_Hook_Nil'Access,
+ Start => Proc_Hook_Nil'Access,
+ Finish => Proc_Hook_Nil'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vcdz_Hooks'Access);
+ end Register;
+end Grt.Vcdz;
diff --git a/src/translate/grt/grt-vcdz.ads b/src/translate/grt/grt-vcdz.ads
new file mode 100644
index 000000000..aba61c222
--- /dev/null
+++ b/src/translate/grt/grt-vcdz.ads
@@ -0,0 +1,28 @@
+-- GHDL Run Time (GRT) - VCD .gz module.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Vcdz is
+ procedure Register;
+end Grt.Vcdz;
diff --git a/src/translate/grt/grt-vital_annotate.adb b/src/translate/grt/grt-vital_annotate.adb
new file mode 100644
index 000000000..93ecb8119
--- /dev/null
+++ b/src/translate/grt/grt-vital_annotate.adb
@@ -0,0 +1,688 @@
+-- GHDL Run Time (GRT) - VITAL annotator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Options;
+with Grt.Avhpi; use Grt.Avhpi;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Vital_Annotate is
+ -- Point of the annotation.
+ Sdf_Top : VhpiHandleT;
+
+ -- Instance being annotated.
+ Sdf_Inst : VhpiHandleT;
+
+ Flag_Dump : Boolean := False;
+ Flag_Verbose : constant Boolean := False;
+
+ function Name_Compare (Handle : VhpiHandleT;
+ Name : String;
+ Property : VhpiStrPropertyT := VhpiNameP)
+ return Boolean
+ is
+ Obj_Name : String (1 .. Name'Length);
+ Len : Natural;
+ begin
+ Vhpi_Get_Str (Property, Handle, Obj_Name, Len);
+ if Len = Name'Length and then Obj_Name = Name then
+ return True;
+ else
+ return False;
+ end if;
+ end Name_Compare;
+
+ -- Note: RES may alias CUR.
+ procedure Find_Instance (Cur : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Name : String;
+ Ok : out Boolean)
+ is
+ Error : AvhpiErrorT;
+ It : VhpiHandleT;
+ begin
+ Ok := False;
+ Vhpi_Iterator (VhpiInternalRegions, Cur, It, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ loop
+ Vhpi_Scan (It, Res, Error);
+ exit when Error /= AvhpiErrorOk;
+ if Name_Compare (Res, Name) then
+ Ok := True;
+ return;
+ end if;
+ end loop;
+ return;
+-- Put ("find instance: ");
+-- Put (Name);
+-- New_Line;
+ end Find_Instance;
+
+ procedure Find_Generic (Gen_Name : String;
+ Gen_Handle : out VhpiHandleT;
+ Port1_Name : String;
+ Port1_Handle : out VhpiHandleT;
+ Port2_Name : String;
+ Port2_Handle : out VhpiHandleT)
+ is
+ Error : AvhpiErrorT;
+ It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ begin
+ Gen_Handle := Null_Handle;
+ Port1_Handle := Null_Handle;
+ Port2_Handle := Null_Handle;
+
+ Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+
+ -- Look for the generic.
+ loop
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK;
+ if Name_Compare (Decl, Gen_Name) then
+ Gen_Handle := Decl;
+ exit;
+ end if;
+ end loop;
+
+ -- Skip generics.
+ while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ end loop;
+
+ -- Look for ports.
+ loop
+ exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK;
+ if Name_Compare (Decl, Port1_Name) then
+ Port1_Handle := Decl;
+ exit when Port2_Name'Length = 0;
+ end if;
+ if Port2_Name'Length > 0
+ and then Name_Compare (Decl, Port2_Name)
+ then
+ Port2_Handle := Decl;
+ exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined;
+ end if;
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ end loop;
+
+ end Find_Generic;
+
+ procedure Sdf_Header (Context : Sdf_Context_Type)
+ is
+ begin
+ if Flag_Dump then
+ case Context.Version is
+ when Sdf_2_1 =>
+ Put ("found SDF file version 2.1");
+ when Sdf_Version_Unknown =>
+ Put ("found SDF file without version");
+ when Sdf_Version_Bad =>
+ Put ("found SDF file with unknown version");
+ end case;
+ New_Line;
+ end if;
+ end Sdf_Header;
+
+ procedure Sdf_Celltype (Context : Sdf_Context_Type)
+ is
+ begin
+ if Flag_Dump then
+ Put ("celltype: ");
+ Put (Context.Celltype (1 .. Context.Celltype_Len));
+ New_Line;
+ Put ("instance:");
+ return;
+ end if;
+ Sdf_Inst := Sdf_Top;
+ end Sdf_Celltype;
+
+ procedure Sdf_Instance (Context : in out Sdf_Context_Type;
+ Instance : String;
+ Status : out Boolean)
+ is
+ pragma Unreferenced (Context);
+ begin
+ if Flag_Dump then
+ Put (' ');
+ Put (Instance);
+ Status := True;
+ return;
+ end if;
+
+ Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status);
+ end Sdf_Instance;
+
+ procedure Sdf_Instance_End (Context : Sdf_Context_Type;
+ Status : out Boolean)
+ is
+ begin
+ if Flag_Dump then
+ Status := True;
+ New_Line;
+ return;
+ end if;
+ case Vhpi_Get_Kind (Sdf_Inst) is
+ when VhpiRootInstK =>
+ declare
+ Hdl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Status := False;
+ Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("VhpiDesignUnit");
+ return;
+ end if;
+ case Vhpi_Get_Kind (Hdl) is
+ when VhpiArchBodyK =>
+ Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("VhpiPrimaryUnit");
+ return;
+ end if;
+ when others =>
+ Internal_Error ("sdf_instance_end");
+ end case;
+ Status := Name_Compare
+ (Hdl, Context.Celltype (1 .. Context.Celltype_Len));
+ end;
+ when VhpiCompInstStmtK =>
+ Status := Name_Compare
+ (Sdf_Inst,
+ Context.Celltype (1 .. Context.Celltype_Len),
+ VhpiCompNameP);
+ when others =>
+ Status := False;
+ end case;
+ end Sdf_Instance_End;
+
+ VitalDelayType01 : VhpiHandleT;
+ VitalDelayType01Z : VhpiHandleT;
+ VitalDelayType01ZX : VhpiHandleT;
+ VitalDelayArrayType01 : VhpiHandleT;
+ VitalDelayType : VhpiHandleT;
+ VitalDelayArrayType : VhpiHandleT;
+
+ type Map_Type is array (1 .. 12) of Natural;
+ Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0);
+ Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0);
+ Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0);
+ Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0);
+ --Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12);
+
+ function Write_Td_Delay_Generic (Context : Sdf_Context_Type;
+ Gen : VhpiHandleT;
+ Nbr : Natural;
+ Map : Map_Type)
+ return Boolean
+ is
+ It : VhpiHandleT;
+ El : VhpiHandleT;
+ Error : AvhpiErrorT;
+ N : Natural;
+ begin
+ Vhpi_Iterator (VhpiIndexedNames, Gen, It, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexedNames");
+ return False;
+ end if;
+ for I in 1 .. Nbr loop
+ Vhpi_Scan (It, El, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("scan on vhpiIndexedNames");
+ return False;
+ end if;
+ N := Map (I);
+ if Context.Timing_Set (N) then
+ if Vhpi_Put_Value (El, Context.Timing (N) * 1000) /= AvhpiErrorOk
+ then
+ Internal_Error ("vhpi_put_value");
+ return False;
+ end if;
+ end if;
+ end loop;
+ return True;
+ end Write_Td_Delay_Generic;
+
+ function Write_Td_Delay_Generic (Context : Sdf_Context_Type;
+ Gen : VhpiHandleT)
+ return Boolean
+ is
+ Gen_Basetype : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("write_td_delay_generic: vhpiBaseType");
+ return False;
+ end if;
+ if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then
+ case Context.Timing_Nbr is
+ when 1 =>
+ return Write_Td_Delay_Generic (Context, Gen, 2, Map_1);
+ when 2 =>
+ return Write_Td_Delay_Generic (Context, Gen, 2, Map_2);
+ when others =>
+ Errors.Error
+ ("timing generic type mismatch SDF timing specification");
+ end case;
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then
+ case Context.Timing_Nbr is
+ when 1 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_1);
+ when 2 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_2);
+ when 3 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_3);
+ when 6 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_6);
+ when others =>
+ Errors.Error
+ ("timing generic type mismatch SDF timing specification");
+ end case;
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then
+ if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk
+ then
+ Internal_Error ("vhpi_put_value (vitaldelaytype)");
+ else
+ return True;
+ end if;
+ else
+ Internal_Error ("write_td_delay_generic: unhandled generic type");
+ end if;
+ end Write_Td_Delay_Generic;
+
+ procedure Generic_Get_Bounds (Port : VhpiHandleT;
+ Left : out Ghdl_I32;
+ Len : out Ghdl_Index_Type;
+ Up : out Boolean)
+ is
+ Port_Type, Port_Range : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Right : VhpiIntT;
+ begin
+ Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error);
+ Left := 0;
+ Len := 0;
+ Up := True;
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiSubtype - port");
+ return;
+ end if;
+ Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexConstraints - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiLeftBoundP - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiRightBoundP - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIsUpP - port");
+ return;
+ end if;
+ if Up then
+ Len := Ghdl_Index_Type (Right - Left) + 1;
+ else
+ Len := Ghdl_Index_Type (Left - Right) + 1;
+ end if;
+ end Generic_Get_Bounds;
+
+ procedure Sdf_Generic (Context : in out Sdf_Context_Type;
+ Name : String;
+ Ok : out Boolean)
+ is
+ Gen : VhpiHandleT;
+ Gen_Basetype : VhpiHandleT;
+ Port1, Port2 : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ if Flag_Dump then
+ Put ("generic: ");
+ Put (Name);
+ if Context.Timing_Nbr = 0 then
+ Put (' ');
+ Put_I64 (stdout, Context.Timing (1));
+ else
+ for I in 1 .. 12 loop
+ Put (' ');
+ if Context.Timing_Set (I) then
+ Put_I64 (stdout, Context.Timing (I));
+ else
+ Put ('?');
+ end if;
+ end loop;
+ end if;
+
+ New_Line;
+ Ok := True;
+ return;
+ end if;
+
+ Ok := False;
+
+ if Context.Port_Num = 1 then
+ Context.Ports (2).Name_Len := 0;
+ end if;
+ Find_Generic
+ (Name, Gen,
+ Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1,
+ Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2);
+ if Vhpi_Get_Kind (Gen) = VhpiUndefined
+ or else Vhpi_Get_Kind (Port1) = VhpiUndefined
+ or else (Context.Port_Num = 2
+ and then Vhpi_Get_Kind (Port2) = VhpiUndefined)
+ then
+ return;
+ end if;
+
+ -- Extract subtype.
+ Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiBaseType");
+ return;
+ end if;
+ if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX)
+ then
+ Ok := Write_Td_Delay_Generic (Context, Gen);
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType)
+ then
+ declare
+ Left_Gen, Left1, Left2 : Ghdl_I32;
+ Len_Gen, Len1, Len2 : Ghdl_Index_Type;
+ Up_Gen, Up1, Up2 : Boolean;
+ Pos : Ghdl_Index_Type;
+ Gen_El : VhpiHandleT;
+ begin
+ Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen);
+ if Context.Port_Num >= 1
+ and then Context.Ports (1).L /= Invalid_Dnumber
+ then
+ Generic_Get_Bounds (Port1, Left1, Len1, Up1);
+ if Up1 then
+ Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1);
+ else
+ Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L);
+ end if;
+ else
+ Pos := 0;
+ end if;
+ if Context.Port_Num >= 2
+ and then Context.Ports (2).L /= Invalid_Dnumber
+ then
+ Generic_Get_Bounds (Port2, Left2, Len2, Up2);
+ Pos := Pos * Len2;
+ if Up2 then
+ Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2);
+ else
+ Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L);
+ end if;
+ end if;
+ Vhpi_Handle_By_Index
+ (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexedNames - gen_el");
+ return;
+ end if;
+ Ok := Write_Td_Delay_Generic (Context, Gen_El);
+ end;
+ else
+ Errors.Error_C ("vital: unhandled generic type for generic ");
+ Errors.Error_E (Name);
+ end if;
+ end Sdf_Generic;
+
+
+ procedure Annotate (Arg : String)
+ is
+ S, E : Natural;
+ Ok : Boolean;
+ begin
+ if Flag_Verbose then
+ Put ("sdf annotate: ");
+ Put (Arg);
+ New_Line;
+ end if;
+
+ -- Find scope by name.
+ Get_Root_Inst (Sdf_Top);
+ E := Arg'First;
+ S := E;
+ L1: loop
+ -- Skip path separator.
+ while Arg (E) = '/' or Arg (E) = '.' loop
+ E := E + 1;
+ exit L1 when E > Arg'Last;
+ end loop;
+
+ exit L1 when E > Arg'Last or else Arg (E) = '=';
+
+ -- Instance element.
+ S := E;
+ while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop
+ E := E + 1;
+ exit L1 when E > Arg'Last;
+ end loop;
+
+ -- Path element.
+ if E - 1 >= S then
+ Find_Instance (Sdf_Top, Sdf_Top, Arg (S .. E - 1), Ok);
+ if not Ok then
+ Error_C ("cannot find instance '");
+ Error_C (Arg (S .. E - 1));
+ Error_E ("' for sdf annotation");
+ return;
+ end if;
+ end if;
+ end loop L1;
+
+ -- start annotation.
+ if E >= Arg'Last or else Arg (E) /= '=' then
+ Error_C ("no filename in sdf option '");
+ Error_C (Arg);
+ Error_E ("'");
+ return;
+ end if;
+ if not Sdf.Parse_Sdf_File (Arg (E + 1 .. Arg'Last)) then
+ null;
+ end if;
+ end Annotate;
+
+ procedure Extract_Vital_Delay_Type
+ is
+ It : VhpiHandleT;
+ Pkg : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Basetype : VhpiHandleT;
+ Status : AvhpiErrorT;
+ begin
+ Get_Package_Inst (It);
+ loop
+ Vhpi_Scan (It, Pkg, Status);
+ exit when Status /= AvhpiErrorOk;
+ exit when Name_Compare (Pkg, "vital_timing")
+ and then Name_Compare (Pkg, "ieee", VhpiLibLogicalNameP);
+ end loop;
+ if Status /= AvhpiErrorOk then
+ Error ("package ieee.vital_timing not found, SDF annotation aborted");
+ return;
+ end if;
+ Vhpi_Iterator (VhpiDecls, Pkg, It, Status);
+ if Status /= AvhpiErrorOk then
+ Error ("cannot iterate on vital_timing");
+ return;
+ end if;
+ loop
+ Vhpi_Scan (It, Decl, Status);
+ exit when Status /= AvhpiErrorOk;
+ if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK
+ or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK
+ then
+ Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status);
+ if Status = AvhpiErrorOk then
+ if Name_Compare (Decl, "vitaldelaytype01") then
+ VitalDelayType01 := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01z") then
+ VitalDelayType01Z := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01zx") then
+ VitalDelayType01ZX := Basetype;
+ elsif Name_Compare (Decl, "vitaldelayarraytype01") then
+ VitalDelayArrayType01 := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype") then
+ VitalDelayType := Basetype;
+ elsif Name_Compare (Decl, "vitaldelayarraytype") then
+ VitalDelayArrayType := Basetype;
+ end if;
+ end if;
+ end if;
+ end loop;
+ if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01 in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01Z in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01ZX in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then
+ Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then
+ Error ("cannot find VitalDelayType in ieee.vital_timing");
+ return;
+ end if;
+ end Extract_Vital_Delay_Type;
+
+ Has_Sdf_Option : Boolean := False;
+
+ procedure Sdf_Start
+ is
+ use Grt.Options;
+ Len : Integer;
+ Beg : Integer;
+ Arg : Ghdl_C_String;
+ begin
+ if not Has_Sdf_Option then
+ -- Nothing to do.
+ return;
+ end if;
+ Flag_Dump := False;
+
+ -- Extract VitalDelayType(s) from VITAL_Timing package.
+ Extract_Vital_Delay_Type;
+
+ -- Annotate.
+ for I in 1 .. Last_Opt loop
+ Arg := Argv (I);
+ Len := strlen (Arg);
+ if Len > 5 and then Arg (1 .. 6) = "--sdf=" then
+ Sdf_Mtm := Typical;
+ Beg := 7;
+ if Len > 10 then
+ if Arg (7 .. 10) = "typ=" then
+ Beg := 11;
+ elsif Arg (7 .. 10) = "min=" then
+ Sdf_Mtm := Minimum;
+ Beg := 11;
+ elsif Arg (7 .. 10) = "max=" then
+ Sdf_Mtm := Maximum;
+ Beg := 11;
+ end if;
+ end if;
+ Annotate (Arg (Beg .. Len));
+ end if;
+ end loop;
+ end Sdf_Start;
+
+ function Sdf_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then
+ Flag_Dump := True;
+ if Sdf.Parse_Sdf_File (Opt (12 .. Opt'Last)) then
+ null;
+ end if;
+ return True;
+ end if;
+ if Opt'Length > 5 and then Opt (1 .. 6) = "--sdf=" then
+ Has_Sdf_Option := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Sdf_Option;
+
+ procedure Sdf_Help is
+ begin
+ Put_Line (" --sdf=[min=|typ=|max=]TOP=FILENAME");
+ Put_Line (" annotate TOP with SDF delay file FILENAME");
+ end Sdf_Help;
+
+ Sdf_Hooks : aliased constant Hooks_Type :=
+ (Option => Sdf_Option'Access,
+ Help => Sdf_Help'Access,
+ Init => Proc_Hook_Nil'Access,
+ Start => Sdf_Start'Access,
+ Finish => Proc_Hook_Nil'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Sdf_Hooks'Access);
+ end Register;
+end Grt.Vital_Annotate;
diff --git a/src/translate/grt/grt-vital_annotate.ads b/src/translate/grt/grt-vital_annotate.ads
new file mode 100644
index 000000000..acf82bba2
--- /dev/null
+++ b/src/translate/grt/grt-vital_annotate.ads
@@ -0,0 +1,42 @@
+-- GHDL Run Time (GRT) - VITAL annotator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Sdf; use Grt.Sdf;
+
+package Grt.Vital_Annotate is
+ pragma Elaborate_Body (Grt.Vital_Annotate);
+
+ procedure Sdf_Header (Context : Sdf_Context_Type);
+ procedure Sdf_Celltype (Context : Sdf_Context_Type);
+ procedure Sdf_Instance (Context : in out Sdf_Context_Type;
+ Instance : String;
+ Status : out Boolean);
+ procedure Sdf_Instance_End (Context : Sdf_Context_Type;
+ Status : out Boolean);
+ procedure Sdf_Generic (Context : in out Sdf_Context_Type;
+ Name : String;
+ Ok : out Boolean);
+
+ procedure Register;
+end Grt.Vital_Annotate;
diff --git a/src/translate/grt/grt-vpi.adb b/src/translate/grt/grt-vpi.adb
new file mode 100644
index 000000000..9b77319f1
--- /dev/null
+++ b/src/translate/grt/grt-vpi.adb
@@ -0,0 +1,988 @@
+-- GHDL Run Time (GRT) - VPI interface.
+-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Description: VPI interface for GRT runtime
+-- the main purpose of this code is to interface with the
+-- Icarus Verilog Interactive (IVI) simulator GUI
+
+-------------------------------------------------------------------------------
+-- TODO:
+-------------------------------------------------------------------------------
+-- DONE:
+-- * The GHDL VPI implementation doesn't support time
+-- callbacks (cbReadOnlySynch). This is needed to support
+-- IVI run. Currently, the GHDL simulation runs until
+-- complete once a single 'run' is performed...
+-- * You are loading '_'-prefixed symbols when you
+-- load the vpi plugin. On Linux, there is no leading
+-- '_'. I just added code to try both '_'-prefixed and
+-- non-'_'-prefixed symbols. I have placed the changed
+-- file in the same download dir as the snapshot
+-- * I did find out why restart doesn't work for GHDL.
+-- You are passing back the leaf name of signals when the
+-- FullName is requested.
+-------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Signals; use Grt.Signals;
+with Grt.Table;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Vcd; use Grt.Vcd;
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Types;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Vpi is
+ -- The VPI interface requires libdl (dlopen, dlsym) to be linked in.
+ -- This is now set in Makefile, since this is target dependent.
+ -- pragma Linker_Options ("-ldl");
+
+ --errAnyString: constant String := "grt-vcd.adb: any string" & NUL;
+ --errNoString: constant String := "grt-vcd.adb: no string" & NUL;
+
+ type Vpi_Index_Type is new Integer;
+
+-------------------------------------------------------------------------------
+-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ ------------------------------------------------------------------------
+ -- debugging helpers
+ procedure dbgPut (Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, stderr);
+ end dbgPut;
+
+ procedure dbgPut (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), stderr);
+ end dbgPut;
+
+ procedure dbgNew_Line is
+ begin
+ dbgPut (Nl);
+ end dbgNew_Line;
+
+ procedure dbgPut_Line (Str : String)
+ is
+ begin
+ dbgPut (Str);
+ dbgNew_Line;
+ end dbgPut_Line;
+
+-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type)
+-- is
+-- begin
+-- Put_Str_Len(stderr, Str);
+-- dbgNew_Line;
+-- end dbgPut_Line;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => vpiHandle, Object => struct_vpiHandle);
+
+ ------------------------------------------------------------------------
+ -- NUL-terminate strings.
+ -- note: there are several buffers
+ -- see IEEE 1364-2001
+-- tmpstring1: string(1..1024);
+-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String
+-- is
+-- begin
+-- for i in 1..Str.Len loop
+-- tmpstring1(i):= Str.Str(i);
+-- end loop;
+-- tmpstring1(Str.Len+1):= NUL;
+-- return To_Ghdl_C_String (tmpstring1'Address);
+-- end NulTerminate1;
+
+-------------------------------------------------------------------------------
+-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_iterate(int type, vpiHandle ref)
+ -- Obtain an iterator handle to objects with a one-to-many relationship.
+ -- see IEEE 1364-2001, page 685
+ function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle
+ is
+ Res : vpiHandle;
+ Rel : VhpiOneToManyT;
+ Error : AvhpiErrorT;
+ begin
+ --dbgPut_Line ("vpi_iterate");
+
+ case aType is
+ when vpiNet =>
+ Rel := VhpiDecls;
+ when vpiModule =>
+ if Ref = null then
+ Res := new struct_vpiHandle (vpiModule);
+ Get_Root_Inst (Res.Ref);
+ return Res;
+ else
+ Rel := VhpiInternalRegions;
+ end if;
+ when vpiInternalScope =>
+ Rel := VhpiInternalRegions;
+ when others =>
+ return null;
+ end case;
+
+ -- find the proper start object for our scan
+ if Ref = null then
+ return null;
+ end if;
+
+ Res := new struct_vpiHandle (aType);
+ Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error);
+
+ if Error /= AvhpiErrorOk then
+ Free (Res);
+ end if;
+ return Res;
+ end vpi_iterate;
+
+ ------------------------------------------------------------------------
+ -- int vpi_get(int property, vpiHandle ref)
+ -- Get the value of an integer or boolean property of an object.
+ -- see IEEE 1364-2001, chapter 27.6, page 667
+-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer
+-- is
+-- begin
+-- case aRef.Kind is
+-- when Ghdl_Name_Entity
+-- | Ghdl_Name_Architecture
+-- | Ghdl_Name_Block
+-- | Ghdl_Name_Generate_Iterative
+-- | Ghdl_Name_Generate_Conditional
+-- | Ghdl_Name_Instance =>
+-- return vpiModule;
+-- when Ghdl_Name_Signal =>
+-- return vpiNet;
+-- when others =>
+-- return vpiUndefined;
+-- end case;
+-- end ii_vpi_get_type;
+
+ function vpi_get (Property: integer; Ref: vpiHandle) return Integer
+ is
+ begin
+ case Property is
+ when vpiType=>
+ return Ref.mType;
+ when vpiTimePrecision=>
+ return -9; -- is this nano-seconds?
+ when others=>
+ dbgPut_Line ("vpi_get: unknown property");
+ return 0;
+ end case;
+ end vpi_get;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_scan(vpiHandle iter)
+ -- Scan the Verilog HDL hierarchy for objects with a one-to-many
+ -- relationship.
+ -- see IEEE 1364-2001, chapter 27.36, page 709
+ function vpi_scan (Iter: vpiHandle) return vpiHandle
+ is
+ Res : VhpiHandleT;
+ Error : AvhpiErrorT;
+ R : vpiHandle;
+ begin
+ --dbgPut_Line ("vpi_scan");
+ if Iter = null then
+ return null;
+ end if;
+
+ -- There is only one top-level module.
+ if Iter.mType = vpiModule then
+ case Vhpi_Get_Kind (Iter.Ref) is
+ when VhpiRootInstK =>
+ R := new struct_vpiHandle (Iter.mType);
+ R.Ref := Iter.Ref;
+ Iter.Ref := Null_Handle;
+ return R;
+ when VhpiUndefined =>
+ return null;
+ when others =>
+ -- Fall through.
+ null;
+ end case;
+ end if;
+
+ loop
+ Vhpi_Scan (Iter.Ref, Res, Error);
+ exit when Error /= AvhpiErrorOk;
+
+ case Vhpi_Get_Kind (Res) is
+ when VhpiEntityDeclK
+ | VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiCompInstStmtK =>
+ case Iter.mType is
+ when vpiInternalScope
+ | vpiModule =>
+ return new struct_vpiHandle'(mType => vpiModule,
+ Ref => Res);
+ when others =>
+ null;
+ end case;
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ if Iter.mType = vpiNet then
+ declare
+ Info : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Res, Info);
+ if Info.Kind /= Vcd_Bad then
+ return new struct_vpiHandle'(mType => vpiNet,
+ Ref => Res);
+ end if;
+ end;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ return null;
+ end vpi_scan;
+
+ ------------------------------------------------------------------------
+ -- char *vpi_get_str(int property, vpiHandle ref)
+ -- see IEEE 1364-2001, page xxx
+ Tmpstring2 : String (1 .. 1024);
+ function vpi_get_str (Property : Integer; Ref : vpiHandle)
+ return Ghdl_C_String
+ is
+ Prop : VhpiStrPropertyT;
+ Len : Natural;
+ begin
+ --dbgPut_Line ("vpiGetStr");
+
+ if Ref = null then
+ return null;
+ end if;
+
+ case Property is
+ when vpiFullName=>
+ Prop := VhpiFullNameP;
+ when vpiName=>
+ Prop := VhpiNameP;
+ when others=>
+ dbgPut_Line ("vpi_get_str: undefined property");
+ return null;
+ end case;
+ Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len);
+ Tmpstring2 (Len + 1) := NUL;
+ if Property = vpiFullName then
+ for I in Tmpstring2'First .. Len loop
+ if Tmpstring2 (I) = ':' then
+ Tmpstring2 (I) := '.';
+ end if;
+ end loop;
+ -- Remove the initial '.'.
+ return To_Ghdl_C_String (Tmpstring2 (2)'Address);
+ else
+ return To_Ghdl_C_String (Tmpstring2'Address);
+ end if;
+ end vpi_get_str;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_handle(int type, vpiHandle ref)
+ -- Obtain a handle to an object with a one-to-one relationship.
+ -- see IEEE 1364-2001, chapter 27.16, page 682
+ function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle
+ is
+ Res : vpiHandle;
+ begin
+ --dbgPut_Line ("vpi_handle");
+
+ if Ref = null then
+ return null;
+ end if;
+
+ case aType is
+ when vpiScope =>
+ case Ref.mType is
+ when vpiModule =>
+ Res := new struct_vpiHandle (vpiScope);
+ Res.Ref := Ref.Ref;
+ return Res;
+ when others =>
+ return null;
+ end case;
+ when vpiRightRange
+ | vpiLeftRange =>
+ case Ref.mType is
+ when vpiNet =>
+ Res := new struct_vpiHandle (aType);
+ Res.Ref := Ref.Ref;
+ return Res;
+ when others =>
+ return null;
+ end case;
+ when others =>
+ return null;
+ end case;
+ end vpi_handle;
+
+ ------------------------------------------------------------------------
+ -- void vpi_get_value(vpiHandle expr, p_vpi_value value);
+ -- Retrieve the simulation value of an object.
+ -- see IEEE 1364-2001, chapter 27.14, page 675
+ Tmpstring3idx : integer;
+ Tmpstring3 : String (1 .. 1024);
+ procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1)
+ is
+ begin
+ case Val is
+ when True =>
+ Tmpstring3 (Tmpstring3idx) := '1';
+ when False =>
+ Tmpstring3 (Tmpstring3idx) := '0';
+ end case;
+ Tmpstring3idx := Tmpstring3idx + 1;
+ end ii_vpi_get_value_bin_str_B1;
+
+ procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8)
+ is
+ type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character;
+ Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-";
+ begin
+ if Val not in Map_Type_E8'range then
+ Tmpstring3 (Tmpstring3idx) := '?';
+ else
+ Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val);
+ end if;
+ Tmpstring3idx := Tmpstring3idx + 1;
+ end ii_vpi_get_value_bin_str_E8;
+
+ function ii_vpi_get_value_bin_str (Obj : VhpiHandleT)
+ return Ghdl_C_String
+ is
+ Info : Verilog_Wire_Info;
+ Len : Ghdl_Index_Type;
+ begin
+ case Vhpi_Get_Kind (Obj) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ null;
+ when others =>
+ return null;
+ end case;
+
+ -- Get verilog compat info.
+ Get_Verilog_Wire (Obj, Info);
+ if Info.Kind = Vcd_Bad then
+ return null;
+ end if;
+
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ Tmpstring3idx := 1; -- reset string buffer
+
+ case Info.Val is
+ when Vcd_Effective =>
+ case Info.Kind is
+ when Vcd_Bad
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ return null;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_B1
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Value.B1);
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_E8
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Value.E8);
+ end loop;
+ end case;
+ when Vcd_Driving =>
+ case Info.Kind is
+ when Vcd_Bad
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ return null;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_B1
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.B1);
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_E8
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.E8);
+ end loop;
+ end case;
+ end case;
+ Tmpstring3 (Tmpstring3idx) := NUL;
+ return To_Ghdl_C_String (Tmpstring3'Address);
+ end ii_vpi_get_value_bin_str;
+
+ procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value)
+ is
+ begin
+ case Value.Format is
+ when vpiObjTypeVal=>
+ -- fill in the object type and value:
+ -- For an integer, vpiIntVal
+ -- For a real, vpiRealVal
+ -- For a scalar, either vpiScalar or vpiStrength
+ -- For a time variable, vpiTimeVal with vpiSimTime
+ -- For a vector, vpiVectorVal
+ dbgPut_Line ("vpi_get_value: vpiObjTypeVal");
+ when vpiBinStrVal=>
+ Value.Str := ii_vpi_get_value_bin_str (Expr.Ref);
+ --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all);
+ when vpiOctStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal");
+ when vpiDecStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal");
+ when vpiHexStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal");
+ when vpiScalarVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal");
+ when vpiIntVal=>
+ case Expr.mType is
+ when vpiLeftRange
+ | vpiRightRange=>
+ declare
+ Info : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Expr.Ref, Info);
+ if Info.Irange /= null then
+ if Expr.mType = vpiLeftRange then
+ Value.Integer_m := Integer (Info.Irange.I32.Left);
+ else
+ Value.Integer_m := Integer (Info.Irange.I32.Right);
+ end if;
+ else
+ Value.Integer_m := 0;
+ end if;
+ end;
+ when others=>
+ dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType");
+ end case;
+ when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal");
+ when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal");
+ when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal");
+ when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal");
+ when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal");
+ when others=> dbgPut_Line("vpi_get_value: unknown mFormat");
+ end case;
+ end vpi_get_value;
+
+ ------------------------------------------------------------------------
+ -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ -- Alter the simulation value of an object.
+ -- see IEEE 1364-2001, chapter 27.14, page 675
+ -- FIXME
+
+ procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr;
+ Value : Character)
+ is
+ Tempval : Value_Union;
+ begin
+ -- use the Set_Effective_Value procedure to update the signal
+ case Value is
+ when '0' =>
+ Tempval.B1 := false;
+ when '1' =>
+ Tempval.B1 := true;
+ when others =>
+ dbgPut_Line("ii_vpi_put_value_bin_str_B1: "
+ & "wrong character - signal wont be set");
+ return;
+ end case;
+ SigPtr.Driving_Value := Tempval;
+ Set_Effective_Value (SigPtr, Tempval);
+ end ii_vpi_put_value_bin_str_B1;
+
+ procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr;
+ Value : Character)
+ is
+ Tempval : Value_Union;
+ begin
+ case Value is
+ when 'U' =>
+ Tempval.E8 := 0;
+ when 'X' =>
+ Tempval.E8 := 1;
+ when '0' =>
+ Tempval.E8 := 2;
+ when '1' =>
+ Tempval.E8 := 3;
+ when 'Z' =>
+ Tempval.E8 := 4;
+ when 'W' =>
+ Tempval.E8 := 5;
+ when 'L' =>
+ Tempval.E8 := 6;
+ when 'H' =>
+ Tempval.E8 := 7;
+ when '-' =>
+ Tempval.E8 := 8;
+ when others =>
+ dbgPut_Line("ii_vpi_put_value_bin_str_B8: "
+ & "wrong character - signal wont be set");
+ return;
+ end case;
+ SigPtr.Driving_Value := Tempval;
+ Set_Effective_Value (SigPtr, Tempval);
+ end ii_vpi_put_value_bin_str_E8;
+
+
+ procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT;
+ ValueStr : Ghdl_C_String)
+ is
+ Info : Verilog_Wire_Info;
+ Len : Ghdl_Index_Type;
+ begin
+ -- Check the Obj type.
+ -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT
+ -- when it doesnt come from a callback.
+ case Vhpi_Get_Kind(Obj) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ null;
+ when others =>
+ return;
+ end case;
+
+ -- The following code segment was copied from the
+ -- ii_vpi_get_value function.
+ -- Get verilog compat info.
+ Get_Verilog_Wire (Obj, Info);
+ if Info.Kind = Vcd_Bad then
+ return;
+ end if;
+
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ -- Step 1: convert vpi object to internal format.
+ -- p_vpi_handle -> Ghdl_Signal_Ptr
+ -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic
+
+ -- Step 2: convert datum to appropriate type.
+ -- Ghdl_C_String -> Value_Union
+
+ -- Step 3: assigns value to object using Set_Effective_Value
+ -- call (from grt-signals)
+ -- Set_Effective_Value(sig_ptr, conv_value);
+
+
+ -- Took the skeleton from ii_vpi_get_value function
+ -- This point of the function must convert the string value to the
+ -- native ghdl format.
+ case Info.Kind is
+ when Vcd_Bad =>
+ return;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_put_value_bin_str_B1(
+ To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1)));
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_put_value_bin_str_E8(
+ To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1)));
+ end loop;
+ when Vcd_Integer32
+ | Vcd_Float64 =>
+ null;
+ end case;
+
+ -- Always return null, because this simulation kernel cannot send
+ -- a handle to the event back.
+ return;
+ end ii_vpi_put_value_bin_str;
+
+
+ -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ function vpi_put_value (aObj: vpiHandle;
+ aValue: p_vpi_value;
+ aWhen: p_vpi_time;
+ aFlags: integer)
+ return vpiHandle
+ is
+ pragma Unreferenced (aWhen);
+ pragma Unreferenced (aFlags);
+ begin
+ -- A very simple write procedure for VPI.
+ -- Basically, it accepts bin_str values and converts to appropriate
+ -- types (only std_logic and bit values and vectors).
+
+ -- It'll use Set_Effective_Value procedure to update signals
+
+ -- Ignoring aWhen and aFlags, for now.
+
+ -- Checks the format of aValue. Only vpiBinStrVal will be accepted
+ -- for now.
+ case aValue.Format is
+ when vpiObjTypeVal =>
+ dbgPut_Line ("vpi_put_value: vpiObjTypeVal");
+ when vpiBinStrVal =>
+ ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str);
+ -- dbgPut_Line ("vpi_put_value: vpiBinStrVal");
+ when vpiOctStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal");
+ when vpiDecStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal");
+ when vpiHexStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal");
+ when vpiScalarVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal");
+ when vpiIntVal =>
+ dbgPut_Line ("vpi_put_value: vpiIntVal");
+ when vpiRealVal =>
+ dbgPut_Line("vpi_put_value: vpiRealVal");
+ when vpiStringVal =>
+ dbgPut_Line("vpi_put_value: vpiStringVal");
+ when vpiTimeVal =>
+ dbgPut_Line("vpi_put_value: vpiTimeVal");
+ when vpiVectorVal =>
+ dbgPut_Line("vpi_put_value: vpiVectorVal");
+ when vpiStrengthVal =>
+ dbgPut_Line("vpi_put_value: vpiStrengthVal");
+ when others =>
+ dbgPut_Line("vpi_put_value: unknown mFormat");
+ end case;
+
+ -- Must return a scheduled event caused by vpi_put_value()
+ -- Still dont know how to do it.
+ return null;
+ end vpi_put_value;
+
+ ------------------------------------------------------------------------
+ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t);
+ -- see IEEE 1364-2001, page xxx
+ Sim_Time : Std_Time;
+ procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time)
+ is
+ pragma Unreferenced (Obj);
+ begin
+ --dbgPut_Line ("vpi_get_time");
+ Time.mType := vpiSimTime;
+ Time.mHigh := 0;
+ Time.mLow := Integer (Sim_Time / 1000000);
+ Time.mReal := 0.0;
+ end vpi_get_time;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_register_cb(p_cb_data data)
+ g_cbEndOfCompile : p_cb_data;
+ g_cbEndOfSimulation: p_cb_data;
+ --g_cbValueChange: s_cb_data;
+ g_cbReadOnlySync: p_cb_data;
+
+ type Vpi_Var_Type is record
+ Info : Verilog_Wire_Info;
+ Cb : s_cb_data;
+ end record;
+
+ package Vpi_Table is new Grt.Table
+ (Table_Component_Type => Vpi_Var_Type,
+ Table_Index_Type => Vpi_Index_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 32);
+
+ function vpi_register_cb (Data : p_cb_data) return vpiHandle
+ is
+ Res : p_cb_data := null;
+ begin
+ --dbgPut_Line ("vpi_register_cb");
+ case Data.Reason is
+ when cbEndOfCompile =>
+ Res := new s_cb_data'(Data.all);
+ g_cbEndOfCompile := Res;
+ Sim_Time:= 0;
+ when cbEndOfSimulation =>
+ Res := new s_cb_data'(Data.all);
+ g_cbEndOfSimulation := Res;
+ when cbValueChange =>
+ declare
+ N : Vpi_Index_Type;
+ begin
+ --g_cbValueChange:= aData.all;
+ Vpi_Table.Increment_Last;
+ N := Vpi_Table.Last;
+ Vpi_Table.Table (N).Cb := Data.all;
+ Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info);
+ end;
+ when cbReadOnlySynch=>
+ Res := new s_cb_data'(Data.all);
+ g_cbReadOnlySync := Res;
+ when others=>
+ dbgPut_Line ("vpi_register_cb: unknwon reason");
+ end case;
+ if Res /= null then
+ return new struct_vpiHandle'(mType => vpiCallback,
+ Cb => Res);
+ else
+ return null;
+ end if;
+ end vpi_register_cb;
+
+-------------------------------------------------------------------------------
+-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ -- int vpi_free_object(vpiHandle ref)
+ function vpi_free_object (aRef: vpiHandle) return integer
+ is
+ pragma Unreferenced (aRef);
+ begin
+ return 0;
+ end vpi_free_object;
+
+ -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
+ function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer
+ is
+ pragma Unreferenced (aVlog_info_p);
+ begin
+ return 0;
+ end vpi_get_vlog_info;
+
+ -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
+ function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
+ return vpiHandle
+ is
+ pragma Unreferenced (aRef);
+ pragma Unreferenced (aIndex);
+ begin
+ return null;
+ end vpi_handle_by_index;
+
+ -- unsigned int vpi_mcd_close(unsigned int mcd)
+ function vpi_mcd_close (Mcd: integer) return integer
+ is
+ pragma Unreferenced (Mcd);
+ begin
+ return 0;
+ end vpi_mcd_close;
+
+ -- char *vpi_mcd_name(unsigned int mcd)
+ function vpi_mcd_name (Mcd: integer) return integer
+ is
+ pragma Unreferenced (Mcd);
+ begin
+ return 0;
+ end vpi_mcd_name;
+
+ -- unsigned int vpi_mcd_open(char *name)
+ function vpi_mcd_open (Name : Ghdl_C_String) return Integer
+ is
+ pragma Unreferenced (Name);
+ begin
+ return 0;
+ end vpi_mcd_open;
+
+ -- void vpi_register_systf(const struct t_vpi_systf_data*ss)
+ procedure vpi_register_systf(aSs: System.Address)
+ is
+ pragma Unreferenced (aSs);
+ begin
+ null;
+ end vpi_register_systf;
+
+ -- int vpi_remove_cb(vpiHandle ref)
+ function vpi_remove_cb (Ref : vpiHandle) return Integer
+ is
+ pragma Unreferenced (Ref);
+ begin
+ return 0;
+ end vpi_remove_cb;
+
+ -- void vpi_vprintf(const char*fmt, va_list ap)
+ procedure vpi_vprintf (Fmt : Address; Ap : Address)
+ is
+ pragma Unreferenced (Fmt);
+ pragma Unreferenced (Ap);
+ begin
+ null;
+ end vpi_vprintf;
+
+ -- missing here, see grt-cvpi.c:
+ -- vpi_mcd_open_x
+ -- vpi_mcd_vprintf
+ -- vpi_mcd_fputc
+ -- vpi_mcd_fgetc
+ -- vpi_sim_vcontrol
+ -- vpi_chk_error
+ -- pi_handle_by_name
+
+------------------------------------------------------------------------------
+-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * *
+------------------------------------------------------------------------------
+
+ -- VCD filename.
+ Vpi_Filename : String_Access := null;
+
+ ------------------------------------------------------------------------
+ -- Return TRUE if OPT is an option for VPI.
+ function Vpi_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ begin
+ if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then
+ return False;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 5) = '=' then
+ -- Add an extra NUL character.
+ Vpi_Filename := new String (1 .. Opt'Length - 6 + 1);
+ Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
+ Vpi_Filename (Vpi_Filename'Last) := NUL;
+ return True;
+ else
+ return False;
+ end if;
+ end Vpi_Option;
+
+ ------------------------------------------------------------------------
+ procedure Vpi_Help is
+ begin
+ Put_Line (" --vpi=FILENAME load VPI module");
+ end Vpi_Help;
+
+ ------------------------------------------------------------------------
+ -- Called before elaboration.
+
+ -- void loadVpiModule(const char* modulename)
+ function LoadVpiModule (Filename: Address) return Integer;
+ pragma Import (C, LoadVpiModule, "loadVpiModule");
+
+
+ procedure Vpi_Init
+ is
+ begin
+ Sim_Time:= 0;
+
+ --g_cbEndOfCompile.mCb_rtn:= null;
+ --g_cbEndOfSimulation.mCb_rtn:= null;
+ --g_cbValueChange.mCb_rtn:= null;
+
+ if Vpi_Filename /= null then
+ if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then
+ Error ("cannot load VPI module");
+ end if;
+ end if;
+ end Vpi_Init;
+
+ procedure Vpi_Cycle;
+
+ ------------------------------------------------------------------------
+ -- Called after elaboration.
+ procedure Vpi_Start
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if Vpi_Filename = null then
+ return;
+ end if;
+
+ Grt.Rtis_Types.Search_Types_RTI;
+ Register_Cycle_Hook (Vpi_Cycle'Access);
+ if g_cbEndOfCompile /= null then
+ Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile);
+ end if;
+ end Vpi_Start;
+
+ ------------------------------------------------------------------------
+ -- Called before each non delta cycle.
+ procedure Vpi_Cycle
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if g_cbReadOnlySync /= null
+ and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000)
+ then
+ Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync);
+ end if;
+
+ for I in Vpi_Table.First .. Vpi_Table.Last loop
+ if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then
+ Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all
+ (To_p_cb_data (Vpi_Table.Table (I).Cb'Address));
+ end if;
+ end loop;
+
+ if Current_Time /= Std_Time'last then
+ Sim_Time:= Current_Time;
+ end if;
+ end Vpi_Cycle;
+
+ ------------------------------------------------------------------------
+ -- Called at the end of the simulation.
+ procedure Vpi_End
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if g_cbEndOfSimulation /= null then
+ Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation);
+ end if;
+ end Vpi_End;
+
+ Vpi_Hooks : aliased constant Hooks_Type :=
+ (Option => Vpi_Option'Access,
+ Help => Vpi_Help'Access,
+ Init => Vpi_Init'Access,
+ Start => Vpi_Start'Access,
+ Finish => Vpi_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vpi_Hooks'Access);
+ end Register;
+end Grt.Vpi;
diff --git a/src/translate/grt/grt-vpi.ads b/src/translate/grt/grt-vpi.ads
new file mode 100644
index 000000000..86fb07374
--- /dev/null
+++ b/src/translate/grt/grt-vpi.ads
@@ -0,0 +1,252 @@
+-- GHDL Run Time (GRT) - VPI interface.
+-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Description: VPI interface for GRT runtime
+-- the main purpose of this code is to interface with the
+-- Icarus Verilog Interactive (IVI) simulator GUI
+
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package Grt.Vpi is
+
+ -- properties, see vpi_user.h
+ vpiUndefined: constant integer := -1;
+ vpiType: constant integer := 1;
+ vpiName: constant integer := 2;
+ vpiFullName: constant integer := 3;
+ vpiTimePrecision: constant integer := 12;
+
+ -- object codes, see vpi_user.h
+ vpiModule: constant integer := 32;
+ vpiNet: constant integer := 36;
+ vpiScope: constant integer := 84;
+ vpiInternalScope: constant integer := 92;
+ vpiLeftRange: constant integer := 79;
+ vpiRightRange: constant integer := 83;
+
+ -- Additionnal constants.
+ vpiCallback : constant Integer := 200;
+
+ -- codes for the format tag of the vpi_value structure
+ vpiBinStrVal: constant integer := 1;
+ vpiOctStrVal: constant integer := 2;
+ vpiDecStrVal: constant integer := 3;
+ vpiHexStrVal: constant integer := 4;
+ vpiScalarVal: constant integer := 5;
+ vpiIntVal: constant integer := 6;
+ vpiRealVal: constant integer := 7;
+ vpiStringVal: constant integer := 8;
+ vpiVectorVal: constant integer := 9;
+ vpiStrengthVal: constant integer := 10;
+ vpiTimeVal: constant integer := 11;
+ vpiObjTypeVal: constant integer := 12;
+ vpiSuppressVal: constant integer := 13;
+
+ -- codes for type tag of vpi_time structure
+ vpiSimTime: constant integer := 2;
+
+ -- codes for the reason tag of cb_data structure
+ cbValueChange: constant integer:= 1;
+ cbReadOnlySynch: constant integer:= 7;
+ cbEndOfCompile: constant integer:= 10;
+ cbEndOfSimulation:constant integer:= 12;
+
+ type struct_vpiHandle (mType : Integer := vpiUndefined);
+ type vpiHandle is access struct_vpiHandle;
+
+ -- typedef struct t_vpi_time {
+ -- int type;
+ -- unsigned int high;
+ -- unsigned int low;
+ -- double real;
+ -- } s_vpi_time, *p_vpi_time;
+ type s_vpi_time is record
+ mType : Integer;
+ mHigh : Integer; -- this should be unsigned
+ mLow : Integer; -- this should be unsigned
+ mReal : Float; -- this should be double
+ end record;
+ type p_vpi_time is access s_vpi_time;
+
+ -- typedef struct t_vpi_value
+ -- { int format;
+ -- union
+ -- { char*str;
+ -- int scalar;
+ -- int integer;
+ -- double real;
+ -- struct t_vpi_time *time;
+ -- struct t_vpi_vecval *vector;
+ -- struct t_vpi_strengthval *strength;
+ -- char*misc;
+ -- } value;
+ -- } s_vpi_value, *p_vpi_value;
+ type s_vpi_value (Format : integer) is record
+ case Format is
+ when vpiBinStrVal
+ | vpiOctStrVal
+ | vpiDecStrVal
+ | vpiHexStrVal
+ | vpiStringVal =>
+ Str : Ghdl_C_String;
+ when vpiScalarVal =>
+ Scalar : Integer;
+ when vpiIntVal =>
+ Integer_m : Integer;
+ --when vpiRealVal=> null; -- what is the equivalent to double?
+ --when vpiTimeVal=> mTime: p_vpi_time;
+ --when vpiVectorVal=> mVector: p_vpi_vecval;
+ --when vpiStrengthVal=> mStrength: p_vpi_strengthval;
+ when others =>
+ null;
+ end case;
+ end record;
+ type p_vpi_value is access s_vpi_value;
+
+ --typedef struct t_cb_data {
+ -- int reason;
+ -- int (*cb_rtn)(struct t_cb_data*cb);
+ -- vpiHandle obj;
+ -- p_vpi_time time;
+ -- p_vpi_value value;
+ -- int index;
+ -- char*user_data;
+ --} s_cb_data, *p_cb_data;
+ type s_cb_data;
+
+ type p_cb_data is access all s_cb_data;
+ function To_p_cb_data is new Ada.Unchecked_Conversion
+ (Source => Address, Target => p_cb_data);
+
+ type cb_rtn_type is access function (Cb : p_cb_data) return Integer;
+ pragma Convention (C, cb_rtn_type);
+
+ type s_cb_data is record
+ Reason : Integer;
+ Cb_Rtn : cb_rtn_type;
+ Obj : vpiHandle;
+ Time : p_vpi_time;
+ Value : p_vpi_value;
+ Index : Integer;
+ User_Data : Address;
+ end record;
+
+ type struct_vpiHandle (mType : Integer := vpiUndefined) is record
+ case mType is
+ when vpiCallback =>
+ Cb : p_cb_data;
+ when others =>
+ Ref : VhpiHandleT;
+ end case;
+ end record;
+
+ -- vpiHandle vpi_iterate(int type, vpiHandle ref)
+ function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle;
+ pragma Export (C, vpi_iterate, "vpi_iterate");
+
+ -- int vpi_get(int property, vpiHandle ref)
+ function vpi_get (Property : Integer; Ref : vpiHandle) return Integer;
+ pragma Export (C, vpi_get, "vpi_get");
+
+ -- vpiHandle vpi_scan(vpiHandle iter)
+ function vpi_scan (Iter : vpiHandle) return vpiHandle;
+ pragma Export (C, vpi_scan, "vpi_scan");
+
+ -- char *vpi_get_str(int property, vpiHandle ref)
+ function vpi_get_str (Property : Integer; Ref : vpiHandle)
+ return Ghdl_C_String;
+ pragma Export (C, vpi_get_str, "vpi_get_str");
+
+ -- vpiHandle vpi_handle(int type, vpiHandle ref)
+ function vpi_handle (aType: integer; Ref: vpiHandle)
+ return vpiHandle;
+ pragma Export (C, vpi_handle, "vpi_handle");
+
+ -- void vpi_get_value(vpiHandle expr, p_vpi_value value);
+ procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value);
+ pragma Export (C, vpi_get_value, "vpi_get_value");
+
+ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t);
+ procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time);
+ pragma Export (C, vpi_get_time, "vpi_get_time");
+
+ -- vpiHandle vpi_register_cb(p_cb_data data)
+ function vpi_register_cb (Data : p_cb_data) return vpiHandle;
+ pragma Export (C, vpi_register_cb, "vpi_register_cb");
+
+-------------------------------------------------------------------------------
+-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ -- int vpi_free_object(vpiHandle ref)
+ function vpi_free_object(aRef: vpiHandle) return integer;
+ pragma Export (C, vpi_free_object, "vpi_free_object");
+
+ -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
+ function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer;
+ pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info");
+
+ -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
+ function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
+ return vpiHandle;
+ pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index");
+
+ -- unsigned int vpi_mcd_close(unsigned int mcd)
+ function vpi_mcd_close (Mcd : Integer) return Integer;
+ pragma Export (C, vpi_mcd_close, "vpi_mcd_close");
+
+ -- char *vpi_mcd_name(unsigned int mcd)
+ function vpi_mcd_name (Mcd : Integer) return Integer;
+ pragma Export (C, vpi_mcd_name, "vpi_mcd_name");
+
+ -- unsigned int vpi_mcd_open(char *name)
+ function vpi_mcd_open (Name : Ghdl_C_String) return Integer;
+ pragma Export (C, vpi_mcd_open, "vpi_mcd_open");
+
+ -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ function vpi_put_value (aObj : vpiHandle;
+ aValue : p_vpi_value;
+ aWhen : p_vpi_time;
+ aFlags : integer)
+ return vpiHandle;
+ pragma Export (C, vpi_put_value, "vpi_put_value");
+
+ -- void vpi_register_systf(const struct t_vpi_systf_data*ss)
+ procedure vpi_register_systf (aSs : Address);
+ pragma Export (C, vpi_register_systf, "vpi_register_systf");
+
+ -- int vpi_remove_cb(vpiHandle ref)
+ function vpi_remove_cb (Ref : vpiHandle) return integer;
+ pragma Export (C, vpi_remove_cb, "vpi_remove_cb");
+
+ -- void vpi_vprintf(const char*fmt, va_list ap)
+ procedure vpi_vprintf (Fmt: Address; Ap: Address);
+ pragma Export (C, vpi_vprintf, "vpi_vprintf");
+
+-------------------------------------------------------------------------------
+-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ procedure Register;
+
+end Grt.Vpi;
+
diff --git a/src/translate/grt/grt-vstrings.adb b/src/translate/grt/grt-vstrings.adb
new file mode 100644
index 000000000..30c58ab41
--- /dev/null
+++ b/src/translate/grt/grt-vstrings.adb
@@ -0,0 +1,422 @@
+-- GHDL Run Time (GRT) - variable strings.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Errors; use Grt.Errors;
+with Grt.C; use Grt.C;
+
+package body Grt.Vstrings is
+ procedure Free (Fs : Fat_String_Acc);
+ pragma Import (C, Free);
+
+ function Malloc (Len : Natural) return Fat_String_Acc;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Fat_String_Acc; Len : Natural)
+ return Fat_String_Acc;
+ pragma Import (C, Realloc);
+
+
+ procedure Free (Vstr : in out Vstring) is
+ begin
+ Free (Vstr.Str);
+ Vstr := (Str => null,
+ Max => 0,
+ Len => 0);
+ end Free;
+
+ procedure Grow (Vstr : in out Vstring; Sum : Natural)
+ is
+ Nlen : constant Natural := Vstr.Len + Sum;
+ Nmax : Natural;
+ begin
+ Vstr.Len := Nlen;
+ if Nlen <= Vstr.Max then
+ return;
+ end if;
+ if Vstr.Max = 0 then
+ Nmax := 32;
+ else
+ Nmax := Vstr.Max;
+ end if;
+ while Nmax < Nlen loop
+ Nmax := Nmax * 2;
+ end loop;
+ Vstr.Str := Realloc (Vstr.Str, Nmax);
+ if Vstr.Str = null then
+ Internal_Error ("grt.vstrings.grow: memory exhausted");
+ end if;
+ Vstr.Max := Nmax;
+ end Grow;
+
+ procedure Append (Vstr : in out Vstring; C : Character)
+ is
+ begin
+ Grow (Vstr, 1);
+ Vstr.Str (Vstr.Len) := C;
+ end Append;
+
+ procedure Append (Vstr : in out Vstring; Str : String)
+ is
+ S : constant Natural := Vstr.Len;
+ begin
+ Grow (Vstr, Str'Length);
+ Vstr.Str (S + 1 .. S + Str'Length) := Str;
+ end Append;
+
+ procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String)
+ is
+ S : constant Natural := Vstr.Len;
+ L : constant Natural := strlen (Str);
+ begin
+ Grow (Vstr, L);
+ Vstr.Str (S + 1 .. S + L) := Str (1 .. L);
+ end Append;
+
+ function Length (Vstr : Vstring) return Natural is
+ begin
+ return Vstr.Len;
+ end Length;
+
+ procedure Truncate (Vstr : in out Vstring; Len : Natural) is
+ begin
+ if Len > Vstr.Len then
+ Internal_Error ("grt.vstrings.truncate: bad len");
+ end if;
+ Vstr.Len := Len;
+ end Truncate;
+
+ procedure Put (Stream : FILEs; Vstr : Vstring)
+ is
+ S : size_t;
+ begin
+ S := size_t (Vstr.Len);
+ if S > 0 then
+ S := fwrite (Vstr.Str (1)'Address, S, 1, Stream);
+ end if;
+ end Put;
+
+ procedure Free (Rstr : in out Rstring) is
+ begin
+ Free (Rstr.Str);
+ Rstr := (Str => null,
+ Max => 0,
+ First => 0);
+ end Free;
+
+ function Length (Rstr : Rstring) return Natural is
+ begin
+ return Rstr.Max + 1 - Rstr.First;
+ end Length;
+
+ procedure Grow (Rstr : in out Rstring; Min : Natural)
+ is
+ Len : constant Natural := Length (Rstr);
+ Nlen : constant Natural := Len + Min;
+ Nstr : Fat_String_Acc;
+ Nfirst : Natural;
+ Nmax : Natural;
+ begin
+ if Nlen <= Rstr.Max then
+ return;
+ end if;
+ if Rstr.Max = 0 then
+ Nmax := 32;
+ else
+ Nmax := Rstr.Max;
+ end if;
+ while Nmax < Nlen loop
+ Nmax := Nmax * 2;
+ end loop;
+ Nstr := Malloc (Nmax);
+ Nfirst := Nmax + 1 - Len;
+ if Rstr.Str /= null then
+ Nstr (Nfirst .. Nmax) := Rstr.Str (Rstr.First .. Rstr.Max);
+ Free (Rstr.Str);
+ end if;
+ Rstr := (Str => Nstr,
+ Max => Nmax,
+ First => Nfirst);
+ end Grow;
+
+ procedure Prepend (Rstr : in out Rstring; C : Character)
+ is
+ begin
+ Grow (Rstr, 1);
+ Rstr.First := Rstr.First - 1;
+ Rstr.Str (Rstr.First) := C;
+ end Prepend;
+
+ procedure Prepend (Rstr : in out Rstring; Str : String)
+ is
+ begin
+ Grow (Rstr, Str'Length);
+ Rstr.First := Rstr.First - Str'Length;
+ Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1) := Str;
+ end Prepend;
+
+ procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String)
+ is
+ L : constant Natural := strlen (Str);
+ begin
+ Grow (Rstr, L);
+ Rstr.First := Rstr.First - L;
+ Rstr.Str (Rstr.First .. Rstr.First + L - 1) := Str (1 .. L);
+ end Prepend;
+
+ function Get_Address (Rstr : Rstring) return Address
+ is
+ begin
+ return Rstr.Str (Rstr.First)'Address;
+ end Get_Address;
+
+ procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural)
+ is
+ begin
+ Len := Length (Rstr);
+ if Len > Str'Length then
+ Str := Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1);
+ else
+ Str (Str'First .. Str'First + Len - 1) :=
+ Rstr.Str (Rstr.First .. Rstr.First + Len - 1);
+ end if;
+ end Copy;
+
+ procedure Put (Stream : FILEs; Rstr : Rstring)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream);
+ end Put;
+
+ generic
+ type Ntype is range <>;
+ --Max_Len : Natural;
+ procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype);
+
+ procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype)
+ is
+ subtype R_Type is String (1 .. Str'Length);
+ S : R_Type renames Str;
+ P : Natural := S'Last;
+ V : Ntype;
+ begin
+ if N > 0 then
+ V := -N;
+ else
+ V := N;
+ end if;
+ loop
+ S (P) := Character'Val (48 - (V rem 10));
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ if N < 0 then
+ P := P - 1;
+ S (P) := '-';
+ end if;
+ First := P;
+ end Gen_To_String;
+
+ procedure To_String_I32 is new Gen_To_String (Ntype => Ghdl_I32);
+
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32)
+ renames To_String_I32;
+
+ procedure To_String_I64 is new Gen_To_String (Ntype => Ghdl_I64);
+
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64)
+ renames To_String_I64;
+
+ procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64)
+ is
+ function Trunc (V : Ghdl_F64) return Ghdl_F64;
+ pragma Import (C, Trunc);
+
+ P : Natural := Str'First;
+ V : Ghdl_F64;
+ Vmax : Ghdl_F64;
+ Vd : Ghdl_F64;
+ Exp : Integer;
+ D : Integer;
+ B : Boolean;
+ begin
+ -- Handle sign.
+ if N < 0.0 then
+ Str (P) := '-';
+ P := P + 1;
+ V := -N;
+ else
+ V := N;
+ end if;
+
+ -- Compute the mantissa.
+ -- and normalize V in [0 .. 10.0[
+ -- FIXME: should do a dichotomy.
+ if V = 0.0 then
+ Exp := 0;
+ elsif V < 1.0 then
+ Exp := 0;
+ loop
+ exit when V >= 1.0;
+ Exp := Exp - 1;
+ V := V * 10.0;
+ end loop;
+ else
+ Exp := 0;
+ loop
+ exit when V < 10.0;
+ Exp := Exp + 1;
+ V := V / 10.0;
+ end loop;
+ end if;
+
+ Vmax := 10.0 ** (1 - 15);
+ for I in 0 .. 15 loop
+ -- Vd := Ghdl_F64'Truncation (V);
+ Vd := Trunc (V);
+ Str (P) := Character'Val (48 + Integer (Vd));
+ P := P + 1;
+ V := (V - Vd) * 10.0;
+
+ if I = 0 then
+ Str (P) := '.';
+ P := P + 1;
+ end if;
+ exit when I > 0 and V < Vmax;
+ Vmax := Vmax * 10.0;
+ end loop;
+
+ if Exp /= 0 then
+ -- LRM93 14.3
+ -- if the exponent is present, the `e' is written as a lower case
+ -- character.
+ Str (P) := 'e';
+ P := P + 1;
+
+ if Exp < 0 then
+ Str (P) := '-';
+ P := P + 1;
+ Exp := -Exp;
+ end if;
+ B := False;
+ for I in 0 .. 4 loop
+ D := (Exp / 10000) mod 10;
+ if D /= 0 or B or I = 4 then
+ Str (P) := Character'Val (48 + D);
+ P := P + 1;
+ B := True;
+ end if;
+ Exp := (Exp - D * 10000) * 10;
+ end loop;
+ end if;
+
+ Last := P - 1;
+ end To_String;
+
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Nbr_Digits : Ghdl_I32)
+ is
+ procedure Snprintf_Nf (Str : in out String;
+ Len : Natural;
+ Ndigits : Ghdl_I32;
+ V : Ghdl_F64);
+ pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf");
+ begin
+ Snprintf_Nf (Str, Str'Length, Nbr_Digits, N);
+ Last := strlen (To_Ghdl_C_String (Str'Address));
+ end To_String;
+
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Format : Ghdl_C_String)
+ is
+ procedure Snprintf_Fmtf (Str : in out String;
+ Len : Natural;
+ Format : Ghdl_C_String;
+ V : Ghdl_F64);
+ pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf");
+ begin
+ -- FIXME: check format ('%', f/g/e/a)
+ Snprintf_Fmtf (Str, Str'Length, Format, N);
+ Last := strlen (To_Ghdl_C_String (Str'Address));
+ end To_String;
+
+ procedure To_String (Str : out String_Time_Unit;
+ First : out Natural;
+ Value : Ghdl_I64;
+ Unit : Ghdl_I64)
+ is
+ V, U : Ghdl_I64;
+ D : Natural;
+ P : Natural := Str'Last;
+ Has_Digits : Boolean;
+ begin
+ -- Always work on negative values.
+ if Value > 0 then
+ V := -Value;
+ else
+ V := Value;
+ end if;
+
+ Has_Digits := False;
+ U := Unit;
+ loop
+ if U = 1 then
+ if Has_Digits then
+ Str (P) := '.';
+ P := P - 1;
+ else
+ Has_Digits := True;
+ end if;
+ end if;
+
+ D := Natural (-(V rem 10));
+ if D /= 0 or else Has_Digits then
+ Str (P) := Character'Val (48 + D);
+ P := P - 1;
+ Has_Digits := True;
+ end if;
+ U := U / 10;
+ V := V / 10;
+ exit when V = 0 and then U = 0;
+ end loop;
+ if not Has_Digits then
+ Str (P) := '0';
+ else
+ P := P + 1;
+ end if;
+ if Value < 0 then
+ P := P - 1;
+ Str (P) := '-';
+ end if;
+ First := P;
+ end To_String;
+end Grt.Vstrings;
diff --git a/src/translate/grt/grt-vstrings.ads b/src/translate/grt/grt-vstrings.ads
new file mode 100644
index 000000000..94967bb0f
--- /dev/null
+++ b/src/translate/grt/grt-vstrings.ads
@@ -0,0 +1,143 @@
+-- GHDL Run Time (GRT) - variable strings.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Types; use Grt.Types;
+with System; use System;
+
+package Grt.Vstrings is
+ -- A Vstring (Variable string) is an object which contains an unbounded
+ -- string.
+ type Vstring is limited private;
+
+ -- Deallocate all storage internally allocated.
+ procedure Free (Vstr : in out Vstring);
+
+ -- Append a character.
+ procedure Append (Vstr : in out Vstring; C : Character);
+
+ -- Append a string.
+ procedure Append (Vstr : in out Vstring; Str : String);
+
+ -- Append a C string.
+ procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String);
+
+ -- Get length of VSTR.
+ function Length (Vstr : Vstring) return Natural;
+
+ -- Truncate VSTR to LEN.
+ -- It is an error if LEN is greater than the current length.
+ procedure Truncate (Vstr : in out Vstring; Len : Natural);
+
+ -- Display VSTR.
+ procedure Put (Stream : FILEs; Vstr : Vstring);
+
+
+ -- A Rstring is link a Vstring but characters can only be prepended.
+ type Rstring is limited private;
+
+ -- Deallocate storage associated with Rstr.
+ procedure Free (Rstr : in out Rstring);
+
+ -- Prepend characters or strings.
+ procedure Prepend (Rstr : in out Rstring; C : Character);
+ procedure Prepend (Rstr : in out Rstring; Str : String);
+ procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String);
+
+ -- Get the length of RSTR.
+ function Length (Rstr : Rstring) return Natural;
+
+ -- Return the address of the first character of RSTR.
+ function Get_Address (Rstr : Rstring) return Address;
+
+ -- Display RSTR.
+ procedure Put (Stream : FILEs; Rstr : Rstring);
+
+ -- Copy RSTR to STR, and return length of the string to LEN.
+ procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural);
+
+ -- Write the image of N into STR padded to the right. FIRST is the index
+ -- of the first character, so the result is in STR (FIRST .. STR'last).
+ -- Requires at least 11 characters.
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32);
+
+ -- Write the image of N into STR padded to the right. FIRST is the index
+ -- of the first character, so the result is in STR (FIRST .. STR'last).
+ -- Requires at least 21 characters.
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64);
+
+ -- Write the image of N into STR. LAST is the index of the last character,
+ -- so the result is in STR (STR'first .. LAST).
+ -- Requires at least 24 characters.
+ -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1)
+ -- + exp_digits (4) -> 24.
+ procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64);
+
+ subtype String_Real_Digits is String (1 .. 128);
+
+ -- Write the image of N into STR using NBR_DIGITS digits after the decimal
+ -- point.
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Nbr_Digits : Ghdl_I32);
+
+ subtype String_Real_Format is String (1 .. 128);
+
+ -- Write the image of N into STR using NBR_DIGITS digits after the decimal
+ -- point.
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Format : Ghdl_C_String);
+
+ -- Write the image of VALUE to STR using UNIT as unit. The output is in
+ -- STR (FIRST .. STR'last).
+ subtype String_Time_Unit is String (1 .. 22);
+ procedure To_String (Str : out String_Time_Unit;
+ First : out Natural;
+ Value : Ghdl_I64;
+ Unit : Ghdl_I64);
+
+private
+ subtype Fat_String is String (Positive);
+ type Fat_String_Acc is access Fat_String;
+
+ type Vstring is record
+ Str : Fat_String_Acc := null;
+ Max : Natural := 0;
+ Len : Natural := 0;
+ end record;
+
+ type Rstring is record
+ -- String whose bounds is (1 .. Max).
+ Str : Fat_String_Acc := null;
+
+ -- Last index in STR.
+ Max : Natural := 0;
+
+ -- Index of the first character.
+ First : Natural := 1;
+ end record;
+end Grt.Vstrings;
diff --git a/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb
new file mode 100644
index 000000000..63bdb9a54
--- /dev/null
+++ b/src/translate/grt/grt-waves.adb
@@ -0,0 +1,1632 @@
+-- GHDL Run Time (GRT) - wave dumper (GHW) module.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Errors; use Grt.Errors;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Table;
+with Grt.Avls; use Grt.Avls;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils;
+with Grt.Rtis_Types;
+with Grt.Signals; use Grt.Signals;
+with System; use System;
+with Grt.Vstrings; use Grt.Vstrings;
+
+pragma Elaborate_All (Grt.Rtis_Utils);
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Waves is
+ -- Waves filename.
+ Wave_Filename : String_Access := null;
+ -- Stream corresponding to the GHW filename.
+ Wave_Stream : FILEs;
+
+ Ghw_Hie_Design : constant Unsigned_8 := 1;
+ Ghw_Hie_Block : constant Unsigned_8 := 3;
+ Ghw_Hie_Generate_If : constant Unsigned_8 := 4;
+ Ghw_Hie_Generate_For : constant Unsigned_8 := 5;
+ Ghw_Hie_Instance : constant Unsigned_8 := 6;
+ Ghw_Hie_Package : constant Unsigned_8 := 7;
+ Ghw_Hie_Process : constant Unsigned_8 := 13;
+ Ghw_Hie_Generic : constant Unsigned_8 := 14;
+ Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope.
+ Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal.
+ Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port
+ Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port
+ Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port
+ Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port
+ Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port
+
+ pragma Unreferenced (Ghw_Hie_Design);
+ pragma Unreferenced (Ghw_Hie_Generic);
+
+ -- Return TRUE if OPT is an option for wave.
+ function Wave_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ begin
+ if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then
+ return False;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 6) = '=' then
+ -- Add an extra NUL character.
+ Wave_Filename := new String (1 .. Opt'Length - 7 + 1);
+ Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last);
+ Wave_Filename (Wave_Filename'Last) := NUL;
+ return True;
+ else
+ return False;
+ end if;
+ end Wave_Option;
+
+ procedure Wave_Help is
+ begin
+ Put_Line (" --wave=FILENAME dump signal values into a wave file");
+ end Wave_Help;
+
+ procedure Wave_Put (Str : String)
+ is
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (Str'Address, Str'Length, 1, Wave_Stream);
+ end Wave_Put;
+
+ procedure Wave_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Wave_Stream);
+ end Wave_Putc;
+
+ procedure Wave_Newline is
+ begin
+ Wave_Putc (Nl);
+ end Wave_Newline;
+
+ procedure Wave_Put_Byte (B : Unsigned_8)
+ is
+ V : Unsigned_8 := B;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 1, 1, Wave_Stream);
+ end Wave_Put_Byte;
+
+ procedure Wave_Put_ULEB128 (Val : Ghdl_E32)
+ is
+ V : Ghdl_E32;
+ R : Ghdl_E32;
+ begin
+ V := Val;
+ loop
+ R := V mod 128;
+ V := V / 128;
+ if V = 0 then
+ Wave_Put_Byte (Unsigned_8 (R));
+ exit;
+ else
+ Wave_Put_Byte (Unsigned_8 (128 + R));
+ end if;
+ end loop;
+ end Wave_Put_ULEB128;
+
+ procedure Wave_Put_SLEB128 (Val : Ghdl_I32)
+ is
+ function To_Ghdl_U32 is new Ada.Unchecked_Conversion
+ (Ghdl_I32, Ghdl_U32);
+ V : Ghdl_U32 := To_Ghdl_U32 (Val);
+
+-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural)
+-- return Ghdl_U32;
+-- pragma Import (Intrinsic, Shift_Right_Arithmetic);
+ R : Unsigned_8;
+ begin
+ loop
+ R := Unsigned_8 (V mod 128);
+ V := Shift_Right_Arithmetic (V, 7);
+ if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
+ then
+ Wave_Put_Byte (R);
+ exit;
+ else
+ Wave_Put_Byte (R or 16#80#);
+ end if;
+ end loop;
+ end Wave_Put_SLEB128;
+
+ procedure Wave_Put_LSLEB128 (Val : Ghdl_I64)
+ is
+ function To_Ghdl_U64 is new Ada.Unchecked_Conversion
+ (Ghdl_I64, Ghdl_U64);
+ V : Ghdl_U64 := To_Ghdl_U64 (Val);
+
+ R : Unsigned_8;
+ begin
+ loop
+ R := Unsigned_8 (V mod 128);
+ V := Shift_Right_Arithmetic (V, 7);
+ if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
+ then
+ Wave_Put_Byte (R);
+ exit;
+ else
+ Wave_Put_Byte (R or 16#80#);
+ end if;
+ end loop;
+ end Wave_Put_LSLEB128;
+
+ procedure Wave_Put_I32 (Val : Ghdl_I32)
+ is
+ V : Ghdl_I32 := Val;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 4, 1, Wave_Stream);
+ end Wave_Put_I32;
+
+ procedure Wave_Put_I64 (Val : Ghdl_I64)
+ is
+ V : Ghdl_I64 := Val;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 8, 1, Wave_Stream);
+ end Wave_Put_I64;
+
+ procedure Wave_Put_F64 (F64 : Ghdl_F64)
+ is
+ V : Ghdl_F64 := F64;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream);
+ end Wave_Put_F64;
+
+ procedure Wave_Puts (Str : Ghdl_C_String) is
+ begin
+ Put (Wave_Stream, Str);
+ end Wave_Puts;
+
+ procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Wave_Put_Byte (Ghdl_B1'Pos (Value.B1));
+ when Mode_E8 =>
+ Wave_Put_Byte (Ghdl_E8'Pos (Value.E8));
+ when Mode_E32 =>
+ Wave_Put_ULEB128 (Value.E32);
+ when Mode_I32 =>
+ Wave_Put_SLEB128 (Value.I32);
+ when Mode_I64 =>
+ Wave_Put_LSLEB128 (Value.I64);
+ when Mode_F64 =>
+ Wave_Put_F64 (Value.F64);
+ end case;
+ end Write_Value;
+
+ subtype Section_Name is String (1 .. 4);
+ type Header_Type is record
+ Name : Section_Name;
+ Pos : long;
+ end record;
+
+ package Section_Table is new Grt.Table
+ (Table_Component_Type => Header_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ -- Create a new section.
+ -- Write the header in the file.
+ -- Save the location for the directory.
+ procedure Wave_Section (Name : Section_Name) is
+ begin
+ Section_Table.Append (Header_Type'(Name => Name,
+ Pos => ftell (Wave_Stream)));
+ Wave_Put (Name);
+ end Wave_Section;
+
+ procedure Wave_Write_Size_Order is
+ begin
+ -- Byte order, 1 byte.
+ -- 0: bad, 1 : little-endian, 2 : big endian.
+ declare
+ type Byte_Arr is array (0 .. 3) of Unsigned_8;
+ function To_Byte_Arr is new Ada.Unchecked_Conversion
+ (Source => Unsigned_32, Target => Byte_Arr);
+ B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#);
+ V : Unsigned_8;
+ begin
+ if B4 (0) = 16#11# then
+ -- Big endian.
+ V := 2;
+ elsif B4 (0) = 16#44# then
+ -- Little endian.
+ V := 1;
+ else
+ -- Unknown endian.
+ V := 0;
+ end if;
+ Wave_Put_Byte (V);
+ end;
+ -- Word size, 1 byte.
+ Wave_Put_Byte (Integer'Size / 8);
+ -- File offset size, 1 byte
+ Wave_Put_Byte (1);
+ -- Unused, must be zero (MBZ).
+ Wave_Put_Byte (0);
+ end Wave_Write_Size_Order;
+
+ procedure Wave_Write_Directory
+ is
+ Pos : long;
+ begin
+ Pos := ftell (Wave_Stream);
+ Wave_Section ("DIR" & NUL);
+ Wave_Write_Size_Order;
+ Wave_Put_I32 (Ghdl_I32 (Section_Table.Last));
+ for I in Section_Table.First .. Section_Table.Last loop
+ Wave_Put (Section_Table.Table (I).Name);
+ Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos));
+ end loop;
+ Wave_Put ("EOD" & NUL);
+
+ Wave_Section ("TAI" & NUL);
+ Wave_Write_Size_Order;
+ Wave_Put_I32 (Ghdl_I32 (Pos));
+ end Wave_Write_Directory;
+
+ -- Called before elaboration.
+ procedure Wave_Init
+ is
+ Mode : constant String := "wb" & NUL;
+ begin
+ if Wave_Filename = null then
+ Wave_Stream := NULL_Stream;
+ return;
+ end if;
+ if Wave_Filename.all = "-" & NUL then
+ Wave_Stream := stdout;
+ else
+ Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address);
+ if Wave_Stream = NULL_Stream then
+ Error_C ("cannot open ");
+ Error_E (Wave_Filename (Wave_Filename'First
+ .. Wave_Filename'Last - 1));
+ return;
+ end if;
+ end if;
+ end Wave_Init;
+
+ procedure Write_File_Header
+ is
+ begin
+ -- Magic, 9 bytes.
+ Wave_Put ("GHDLwave" & Nl);
+ -- Header length.
+ Wave_Put_Byte (16);
+ -- Version-major, 1 byte.
+ Wave_Put_Byte (0);
+ -- Version-minor, 1 byte.
+ Wave_Put_Byte (1);
+
+ Wave_Write_Size_Order;
+ end Write_File_Header;
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("Waves.Avhpi_Error!");
+ null;
+ end Avhpi_Error;
+
+ package Str_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_C_String,
+ Table_Index_Type => AVL_Value,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ package Str_AVL is new Grt.Table
+ (Table_Component_Type => AVL_Node,
+ Table_Index_Type => AVL_Nid,
+ Table_Low_Bound => AVL_Root,
+ Table_Initial => 16);
+
+ Strings_Len : Natural := 0;
+
+ function Str_Compare (L, R : AVL_Value) return Integer
+ is
+ Ls, Rs : Ghdl_C_String;
+ begin
+ Ls := Str_Table.Table (L);
+ Rs := Str_Table.Table (R);
+ if L = R then
+ return 0;
+ end if;
+ return Strcmp (Ls, Rs);
+ end Str_Compare;
+
+ procedure Disp_Str_Avl (N : AVL_Nid) is
+ begin
+ Put (stdout, "node: ");
+ Put_I32 (stdout, Ghdl_I32 (N));
+ New_Line (stdout);
+ Put (stdout, " left: ");
+ Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left));
+ New_Line (stdout);
+ Put (stdout, " right: ");
+ Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right));
+ New_Line (stdout);
+ Put (stdout, " height: ");
+ Put_I32 (stdout, Str_AVL.Table (N).Height);
+ New_Line (stdout);
+ Put (stdout, " str: ");
+ --Put (stdout, Str_AVL.Table (N).Val);
+ New_Line (stdout);
+ end Disp_Str_Avl;
+
+ pragma Unreferenced (Disp_Str_Avl);
+
+ function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value
+ is
+ Res : AVL_Nid;
+ begin
+ Str_Table.Append (Str);
+ Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+ Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
+ Str_Compare'Access,
+ Str_AVL.Last, Res);
+ if Res /= Str_AVL.Last then
+ Str_AVL.Decrement_Last;
+ Str_Table.Decrement_Last;
+ else
+ Strings_Len := Strings_Len + strlen (Str);
+ end if;
+ return Str_AVL.Table (Res).Val;
+ end Create_Str_Index;
+
+ pragma Unreferenced (Create_Str_Index);
+
+ procedure Create_String_Id (Str : Ghdl_C_String)
+ is
+ Res : AVL_Nid;
+ begin
+ if Str = null then
+ return;
+ end if;
+ Str_Table.Append (Str);
+ Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+ Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
+ Str_Compare'Access,
+ Str_AVL.Last, Res);
+ if Res /= Str_AVL.Last then
+ Str_AVL.Decrement_Last;
+ Str_Table.Decrement_Last;
+ else
+ Strings_Len := Strings_Len + strlen (Str);
+ end if;
+ end Create_String_Id;
+
+ function Get_String (Str : Ghdl_C_String) return AVL_Value
+ is
+ H, L, M : AVL_Value;
+ Diff : Integer;
+ begin
+ L := Str_Table.First;
+ H := Str_Table.Last;
+ loop
+ M := (L + H) / 2;
+ Diff := Strcmp (Str, Str_Table.Table (M));
+ if Diff = 0 then
+ return M;
+ elsif Diff < 0 then
+ H := M - 1;
+ else
+ L := M + 1;
+ end if;
+ exit when L > H;
+ end loop;
+ return 0;
+ end Get_String;
+
+ procedure Write_String_Id (Str : Ghdl_C_String) is
+ begin
+ if Str = null then
+ Wave_Put_Byte (0);
+ else
+ Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str)));
+ end if;
+ end Write_String_Id;
+
+ type Type_Node is record
+ Type_Rti : Ghdl_Rti_Access;
+ Context : Rti_Context;
+ end record;
+
+ package Types_Table is new Grt.Table
+ (Table_Component_Type => Type_Node,
+ Table_Index_Type => AVL_Value,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ package Types_AVL is new Grt.Table
+ (Table_Component_Type => AVL_Node,
+ Table_Index_Type => AVL_Nid,
+ Table_Low_Bound => AVL_Root,
+ Table_Initial => 16);
+
+ function Type_Compare (L, R : AVL_Value) return Integer
+ is
+ function To_Ia is new
+ Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address);
+
+ function "<" (L, R : Ghdl_Rti_Access) return Boolean is
+ begin
+ return To_Ia (L) < To_Ia (R);
+ end "<";
+
+ Ls : Type_Node renames Types_Table.Table (L);
+ Rs : Type_Node renames Types_Table.Table (R);
+ begin
+ if Ls.Type_Rti /= Rs.Type_Rti then
+ if Ls.Type_Rti < Rs.Type_Rti then
+ return -1;
+ else
+ return 1;
+ end if;
+ end if;
+ if Ls.Context.Block /= Rs.Context.Block then
+ if Ls.Context.Block < Rs.Context.Block then
+ return -1;
+ else
+ return +1;
+ end if;
+ end if;
+ if Ls.Context.Base /= Rs.Context.Base then
+ if Ls.Context.Base < Rs.Context.Base then
+ return -1;
+ else
+ return +1;
+ end if;
+ end if;
+ return 0;
+ end Type_Compare;
+
+ -- Try to find type (RTI, CTXT) in the types_AVL table.
+ -- The first step is to canonicalize CTXT, so that it is the CTXT of
+ -- the type (and not a sub-scope of it).
+ procedure Find_Type (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ N_Ctxt : out Rti_Context;
+ Id : out AVL_Nid)
+ is
+ Depth : Ghdl_Rti_Depth;
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ N_Ctxt := Null_Context;
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal =>
+ N_Ctxt := Ctxt;
+ when others =>
+ -- Compute the canonical context.
+ if Rti.Max_Depth < Rti.Depth then
+ Internal_Error ("grt.waves.find_type");
+ end if;
+ Depth := Rti.Max_Depth;
+ if Depth = 0 or else Ctxt.Block = null then
+ N_Ctxt := Null_Context;
+ else
+ N_Ctxt := Ctxt;
+ while N_Ctxt.Block.Depth > Depth loop
+ N_Ctxt := Get_Parent_Context (N_Ctxt);
+ end loop;
+ end if;
+ end case;
+
+ -- If the type is already known, return now.
+ -- Otherwise, ID is set to AVL_Nil.
+ Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt));
+ Id := Find_Node
+ (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
+ Type_Compare'Access,
+ Types_Table.Last);
+ Types_Table.Decrement_Last;
+ end Find_Type;
+
+ procedure Write_Type_Id (Tid : AVL_Nid) is
+ begin
+ Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val));
+ end Write_Type_Id;
+
+ procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ N_Ctxt : Rti_Context;
+ Res : AVL_Nid;
+ begin
+ Find_Type (Rti, Ctxt, N_Ctxt, Res);
+ if Res = AVL_Nil then
+ -- raise Program_Error;
+ Internal_Error ("write_type_id");
+ end if;
+ Write_Type_Id (Res);
+ end Write_Type_Id;
+
+ procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ Res : AVL_Nid;
+ begin
+ -- Then, create the type.
+ Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt));
+ Types_AVL.Append (AVL_Node'(Val => Types_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+
+ Get_Node
+ (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
+ Type_Compare'Access,
+ Types_AVL.Last, Res);
+ if Res /= Types_AVL.Last then
+ --raise Program_Error;
+ Internal_Error ("wave.create_type(2)");
+ end if;
+ end Add_Type;
+
+ procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ N_Ctxt : Rti_Context;
+ Res : AVL_Nid;
+ begin
+ Find_Type (Rti, Ctxt, N_Ctxt, Res);
+ if Res /= AVL_Nil then
+ return;
+ end if;
+
+ -- First, create all the types it depends on.
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ declare
+ Enum : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Create_String_Id (Enum.Name);
+ for I in 1 .. Enum.Nbr loop
+ Create_String_Id (Enum.Names (I - 1));
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Arr : Ghdl_Rtin_Subtype_Array_Acc;
+ B_Ctxt : Rti_Context;
+ begin
+ Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Create_String_Id (Arr.Name);
+ if Rti_Complex_Type (Rti) then
+ B_Ctxt := Ctxt;
+ else
+ B_Ctxt := N_Ctxt;
+ end if;
+ Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt);
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ Create_String_Id (Arr.Name);
+ Create_Type (Arr.Element, N_Ctxt);
+ for I in 1 .. Arr.Nbr_Dim loop
+ Create_Type (Arr.Indexes (I - 1), N_Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ Create_String_Id (Sub.Name);
+ Create_Type (Sub.Basetype, N_Ctxt);
+ end;
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+ Create_String_Id (Base.Name);
+ end;
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Physical_Acc;
+ Unit_Name : Ghdl_C_String;
+ begin
+ Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Create_String_Id (Base.Name);
+ for I in 1 .. Base.Nbr loop
+ Unit_Name :=
+ Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1));
+ Create_String_Id (Unit_Name);
+ end loop;
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Rec : Ghdl_Rtin_Type_Record_Acc;
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Create_String_Id (Rec.Name);
+ for I in 1 .. Rec.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
+ Create_String_Id (El.Name);
+ Create_Type (El.Eltype, N_Ctxt);
+ end loop;
+ end;
+ when others =>
+ Internal_Error ("wave.create_type");
+-- Internal_Error ("wave.create_type: does not handle " &
+-- Ghdl_Rtik'Image (Rti.Kind));
+ end case;
+
+ -- Then, create the type.
+ Add_Type (Rti, N_Ctxt);
+ end Create_Type;
+
+ procedure Create_Object_Type (Obj : VhpiHandleT)
+ is
+ Obj_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Obj_Type);
+ Create_Type (Rti, Avhpi_Get_Context (Obj_Type));
+
+ -- The the signal type is an unconstrained array, also put the object
+ -- in the type AVL.
+ -- The real type will be written to the file.
+ if Rti.Kind = Ghdl_Rtik_Type_Array then
+ Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ end if;
+ end Create_Object_Type;
+
+ procedure Write_Object_Type (Obj : VhpiHandleT)
+ is
+ Obj_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Obj_Type);
+ if Rti.Kind = Ghdl_Rtik_Type_Array then
+ Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ else
+ Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
+ end if;
+ end Write_Object_Type;
+
+ procedure Create_Generate_Type (Gen : VhpiHandleT)
+ is
+ Iterator : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ -- Extract the iterator.
+ Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Create_Object_Type (Iterator);
+ end Create_Generate_Type;
+
+ procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT)
+ is
+ Iter : VhpiHandleT;
+ Iter_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Addr : Address;
+ Mode : Mode_Type;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract the iterator.
+ Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Write_Object_Type (Iter);
+
+ Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Iter_Type);
+ Addr := Avhpi_Get_Address (Iter);
+
+ case Get_Base_Type (Rti).Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ Mode := Mode_B1;
+ when Ghdl_Rtik_Type_E8 =>
+ Mode := Mode_E8;
+ when Ghdl_Rtik_Type_E32 =>
+ Mode := Mode_E32;
+ when Ghdl_Rtik_Type_I32 =>
+ Mode := Mode_I32;
+ when Ghdl_Rtik_Type_I64 =>
+ Mode := Mode_I64;
+ when Ghdl_Rtik_Type_F64 =>
+ Mode := Mode_F64;
+ when others =>
+ Internal_Error ("bad iterator type");
+ end case;
+ Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode);
+ end Write_Generate_Type_And_Value;
+
+ type Step_Type is (Step_Name, Step_Hierarchy);
+
+ Nbr_Scopes : Natural := 0;
+ Nbr_Scope_Signals : Natural := 0;
+ Nbr_Dumped_Signals : Natural := 0;
+
+ -- This is only valid during write_hierarchy.
+ function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural
+ is
+ function To_Integer_Address is new Ada.Unchecked_Conversion
+ (Ghdl_Signal_Ptr, Integer_Address);
+ begin
+ return Natural (To_Integer_Address (Sig.Alink));
+ end Get_Signal_Number;
+
+ procedure Write_Signal_Number (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param_Type : Natural)
+ is
+ pragma Unreferenced (Val_Name);
+ pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param_Type);
+
+ Num : Natural;
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => Integer_Address, Target => Ghdl_Signal_Ptr);
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ -- Convert to signal.
+ Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+
+ -- Get signal number.
+ Num := Get_Signal_Number (Sig);
+
+ -- If the signal number is 0, then assign a valid signal number.
+ if Num = 0 then
+ Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1;
+ Sig.Alink := To_Ghdl_Signal_Ptr
+ (Integer_Address (Nbr_Dumped_Signals));
+ Num := Nbr_Dumped_Signals;
+ end if;
+
+ -- Do the real job: write the signal number.
+ Wave_Put_ULEB128 (Ghdl_E32 (Num));
+ end Write_Signal_Number;
+
+ procedure Foreach_Scalar_Signal_Number is new
+ Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural,
+ Process => Write_Signal_Number);
+
+ procedure Write_Signal_Numbers (Decl : VhpiHandleT)
+ is
+ Ctxt : Rti_Context;
+ Sig : Ghdl_Rtin_Object_Acc;
+ begin
+ Ctxt := Avhpi_Get_Context (Decl);
+ Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl));
+ Foreach_Scalar_Signal_Number
+ (Ctxt, Sig.Obj_Type,
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0);
+ end Write_Signal_Numbers;
+
+ procedure Write_Hierarchy_El (Decl : VhpiHandleT)
+ is
+ Mode2hie : constant array (VhpiModeT) of Unsigned_8 :=
+ (VhpiErrorMode => Ghw_Hie_Signal,
+ VhpiInMode => Ghw_Hie_Port_In,
+ VhpiOutMode => Ghw_Hie_Port_Out,
+ VhpiInoutMode => Ghw_Hie_Port_Inout,
+ VhpiBufferMode => Ghw_Hie_Port_Buffer,
+ VhpiLinkageMode => Ghw_Hie_Port_Linkage);
+ V : Unsigned_8;
+ begin
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK =>
+ V := Mode2hie (Vhpi_Get_Mode (Decl));
+ when VhpiSigDeclK =>
+ V := Ghw_Hie_Signal;
+ when VhpiForGenerateK =>
+ V := Ghw_Hie_Generate_For;
+ when VhpiIfGenerateK =>
+ V := Ghw_Hie_Generate_If;
+ when VhpiBlockStmtK =>
+ V := Ghw_Hie_Block;
+ when VhpiCompInstStmtK =>
+ V := Ghw_Hie_Instance;
+ when VhpiProcessStmtK =>
+ V := Ghw_Hie_Process;
+ when VhpiPackInstK =>
+ V := Ghw_Hie_Package;
+ when VhpiRootInstK =>
+ V := Ghw_Hie_Instance;
+ when others =>
+ --raise Program_Error;
+ Internal_Error ("write_hierarchy_el");
+ end case;
+ Wave_Put_Byte (V);
+ Write_String_Id (Avhpi_Get_Base_Name (Decl));
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Write_Object_Type (Decl);
+ Write_Signal_Numbers (Decl);
+ when VhpiForGenerateK =>
+ Write_Generate_Type_And_Value (Decl);
+ when others =>
+ null;
+ end case;
+ end Write_Hierarchy_El;
+
+ -- Create a hierarchy block.
+ procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type);
+
+ procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract signals.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Decl));
+ Nbr_Scope_Signals := Nbr_Scope_Signals + 1;
+ Create_Object_Type (Decl);
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Decl);
+ end case;
+ --Wave_Put_Name (Decl);
+ --Wave_Newline;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ -- No sub-scopes for packages.
+ if Vhpi_Get_Kind (Inst) = VhpiPackInstK then
+ return;
+ end if;
+
+ -- Extract sub-scopes.
+ Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Nbr_Scopes := Nbr_Scopes + 1;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiBlockStmtK
+ | VhpiCompInstStmtK =>
+ Wave_Put_Hierarchy_Block (Decl, Step);
+ when VhpiProcessStmtK =>
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Decl));
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Decl);
+ end case;
+ when others =>
+ Internal_Error ("wave_put_hierarchy_1");
+-- Wave_Put ("unknown ");
+-- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl)));
+-- Wave_Newline;
+ end case;
+ end loop;
+ end Wave_Put_Hierarchy_1;
+
+ procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type)
+ is
+ begin
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Inst));
+ if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then
+ Create_Generate_Type (Inst);
+ end if;
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Inst);
+ end case;
+
+ Wave_Put_Hierarchy_1 (Inst, Step);
+
+ if Step = Step_Hierarchy then
+ Wave_Put_Byte (Ghw_Hie_Eos);
+ end if;
+ end Wave_Put_Hierarchy_Block;
+
+ procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type)
+ is
+ Pack_It : VhpiHandleT;
+ Pack : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ -- First packages.
+ Get_Package_Inst (Pack_It);
+ loop
+ Vhpi_Scan (Pack_It, Pack, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Wave_Put_Hierarchy_Block (Pack, Step);
+ end loop;
+
+ -- Then top entity.
+ Wave_Put_Hierarchy_Block (Root, Step);
+ end Wave_Put_Hierarchy;
+
+ procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural)
+ is
+ begin
+ if Str = AVL_Nil then
+ return;
+ end if;
+ Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1);
+ for I in 1 .. Indent loop
+ Wave_Putc (' ');
+ end loop;
+ Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val));
+-- Wave_Putc ('(');
+-- Put_I32 (Wave_Stream, Ghdl_I32 (Str));
+-- Wave_Putc (')');
+-- Put_I32 (Wave_Stream, Get_Height (Str));
+ Wave_Newline;
+ Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1);
+ end Disp_Str_AVL;
+
+ procedure Write_Strings
+ is
+ begin
+-- Wave_Put ("AVL height: ");
+-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root)));
+-- Wave_Newline;
+ Wave_Put ("strings length: ");
+ Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len));
+ Wave_Newline;
+ Disp_Str_AVL (AVL_Root, 0);
+ fflush (Wave_Stream);
+ end Write_Strings;
+
+ pragma Unreferenced (Write_Strings);
+
+ procedure Freeze_Strings
+ is
+ type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String;
+ type Str_Table1_Acc is access Str_Table1_Type;
+ Idx : AVL_Value;
+ Table1 : Str_Table1_Acc;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Str_Table1_Type, Str_Table1_Acc);
+
+ procedure Store_Strings (N : AVL_Nid) is
+ begin
+ if N = AVL_Nil then
+ return;
+ end if;
+ Store_Strings (Str_AVL.Table (N).Left);
+ Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val);
+ Idx := Idx + 1;
+ Store_Strings (Str_AVL.Table (N).Right);
+ end Store_Strings;
+ begin
+ Table1 := new Str_Table1_Type;
+ Idx := 1;
+ Store_Strings (AVL_Root);
+ Str_Table.Release;
+ Str_AVL.Free;
+ for I in Table1.all'Range loop
+ Str_Table.Table (I) := Table1 (I);
+ end loop;
+ Free (Table1);
+ end Freeze_Strings;
+
+ procedure Write_Strings_Compress
+ is
+ Last : Ghdl_C_String;
+ V : Ghdl_C_String;
+ L : Natural;
+ L1 : Natural;
+ begin
+ Wave_Section ("STR" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Str_Table.Last));
+ Wave_Put_I32 (Ghdl_I32 (Strings_Len));
+ for I in Str_Table.First .. Str_Table.Last loop
+ V := Str_Table.Table (I);
+ if I = Str_Table.First then
+ L := 1;
+ else
+ Last := Str_Table.Table (I - 1);
+
+ for I in Positive loop
+ if V (I) /= Last (I) then
+ L := I;
+ exit;
+ end if;
+ end loop;
+ L1 := L - 1;
+ loop
+ if L1 >= 32 then
+ Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#);
+ else
+ Wave_Put_Byte (Unsigned_8 (L1 mod 32));
+ end if;
+ L1 := L1 / 32;
+ exit when L1 = 0;
+ end loop;
+ end if;
+
+ if Boolean'(False) then
+ Put ("string ");
+ Put_I32 (stdout, Ghdl_I32 (I));
+ Put (": ");
+ Put (V);
+ New_Line;
+ end if;
+
+ loop
+ exit when V (L) = NUL;
+ Wave_Putc (V (L));
+ L := L + 1;
+ end loop;
+ end loop;
+ -- Last string length.
+ Wave_Put_Byte (0);
+ -- End marker.
+ Wave_Put ("EOS" & NUL);
+ end Write_Strings_Compress;
+
+ procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr)
+ is
+ Kind : Ghdl_Rtik;
+ begin
+ Kind := Rti.Kind;
+ if Kind = Ghdl_Rtik_Subtype_Scalar then
+ Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind;
+ end if;
+ case Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#);
+ Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left));
+ Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right));
+ when Ghdl_Rtik_Type_E8 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#);
+ Wave_Put_Byte (Unsigned_8 (Rng.E8.Left));
+ Wave_Put_Byte (Unsigned_8 (Rng.E8.Right));
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_P32 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#);
+ Wave_Put_SLEB128 (Rng.I32.Left);
+ Wave_Put_SLEB128 (Rng.I32.Right);
+ when Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_I64 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#);
+ Wave_Put_LSLEB128 (Rng.P64.Left);
+ Wave_Put_LSLEB128 (Rng.P64.Right);
+ when Ghdl_Rtik_Type_F64 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#);
+ Wave_Put_F64 (Rng.F64.Left);
+ Wave_Put_F64 (Rng.F64.Right);
+ when others =>
+ Internal_Error ("waves.write_range: unhandled kind");
+ --Internal_Error ("waves.write_range: unhandled kind "
+ -- & Ghdl_Rtik'Image (Kind));
+ end case;
+ end Write_Range;
+
+ procedure Write_Types
+ is
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ begin
+ Wave_Section ("TYP" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Types_Table.Last));
+ for I in Types_Table.First .. Types_Table.Last loop
+ Rti := Types_Table.Table (I).Type_Rti;
+ Ctxt := Types_Table.Table (I).Context;
+
+ if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then
+ declare
+ Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
+ To_Ghdl_Rtin_Object_Acc (Rti);
+ Arr : constant Ghdl_Rtin_Type_Array_Acc :=
+ To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
+ Addr : Ghdl_Uc_Array_Acc;
+ begin
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array));
+ Write_String_Id (null);
+ Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
+ Addr := To_Ghdl_Uc_Array_Acc
+ (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
+ declare
+ Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1);
+ begin
+ Bound_To_Range (Addr.Bounds, Arr, Rngs);
+ for I in Rngs'Range loop
+ Write_Range (Arr.Indexes (I), Rngs (I));
+ end loop;
+ end;
+ end;
+ else
+ -- Kind.
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind));
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ declare
+ Enum : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Write_String_Id (Enum.Name);
+ Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr));
+ for I in 1 .. Enum.Nbr loop
+ Write_String_Id (Enum.Names (I - 1));
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Arr : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Write_String_Id (Arr.Name);
+ Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt);
+ declare
+ Rngs : Ghdl_Range_Array
+ (0 .. Arr.Basetype.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt),
+ Arr.Basetype, Rngs);
+ for I in Rngs'Range loop
+ Write_Range (Arr.Basetype.Indexes (I), Rngs (I));
+ end loop;
+ end;
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ Write_String_Id (Arr.Name);
+ Write_Type_Id (Arr.Element, Ctxt);
+ Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim));
+ for I in 1 .. Arr.Nbr_Dim loop
+ Write_Type_Id (Arr.Indexes (I - 1), Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Rec : Ghdl_Rtin_Type_Record_Acc;
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Write_String_Id (Rec.Name);
+ Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel));
+ for I in 1 .. Rec.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
+ Write_String_Id (El.Name);
+ Write_Type_Id (El.Eltype, Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ Write_String_Id (Sub.Name);
+ Write_Type_Id (Sub.Basetype, Ctxt);
+ Write_Range
+ (Sub.Basetype,
+ To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth,
+ Sub.Range_Loc,
+ Ctxt)));
+ end;
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+ Write_String_Id (Base.Name);
+ end;
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Physical_Acc;
+ Unit : Ghdl_Rti_Access;
+ begin
+ Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Write_String_Id (Base.Name);
+ Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr));
+ for I in 1 .. Base.Nbr loop
+ Unit := Base.Units (I - 1);
+ Write_String_Id
+ (Rtis_Utils.Get_Physical_Unit_Name (Unit));
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Wave_Put_SLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I32);
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-1)");
+ end case;
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-2)");
+ end case;
+ end loop;
+ end;
+ when others =>
+ Internal_Error ("wave.write_types");
+ -- Internal_Error ("wave.write_types: does not handle " &
+ -- Ghdl_Rtik'Image (Rti.Kind));
+ end case;
+ end if;
+ end loop;
+ Wave_Put_Byte (0);
+ end Write_Types;
+
+ procedure Write_Known_Types
+ is
+ use Grt.Rtis_Types;
+
+ Boolean_Type_Id : AVL_Nid;
+ Bit_Type_Id : AVL_Nid;
+ Std_Ulogic_Type_Id : AVL_Nid;
+
+ function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid
+ is
+ Ctxt : Rti_Context;
+ Tid : AVL_Nid;
+ begin
+ Find_Type (Rti, Null_Context, Ctxt, Tid);
+ return Tid;
+ end Search_Type_Id;
+ begin
+ Search_Types_RTI;
+
+ Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr);
+
+ Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr);
+
+ if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then
+ Std_Ulogic_Type_Id := Search_Type_Id
+ (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr);
+ else
+ Std_Ulogic_Type_Id := AVL_Nil;
+ end if;
+
+ Wave_Section ("WKT" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+
+ if Boolean_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (1);
+ Write_Type_Id (Boolean_Type_Id);
+ end if;
+
+ if Bit_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (2);
+ Write_Type_Id (Bit_Type_Id);
+ end if;
+
+ if Std_Ulogic_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (3);
+ Write_Type_Id (Std_Ulogic_Type_Id);
+ end if;
+
+ Wave_Put_Byte (0);
+ end Write_Known_Types;
+
+ -- Table of signals to be dumped.
+ package Dump_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_Signal_Ptr,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 32);
+
+ function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is
+ begin
+ return Dump_Table.Table (N);
+ end Get_Dump_Entry;
+
+ pragma Unreferenced (Get_Dump_Entry);
+
+ procedure Write_Hierarchy (Root : VhpiHandleT)
+ is
+ N : Natural;
+ begin
+ -- Check Alink is 0.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I).Alink /= null then
+ Internal_Error ("wave.write_hierarchy");
+ end if;
+ end loop;
+
+ Wave_Section ("HIE" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes));
+ Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals));
+ Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1));
+ Wave_Put_Hierarchy (Root, Step_Hierarchy);
+ Wave_Put_Byte (0);
+
+ Dump_Table.Set_Last (Nbr_Dumped_Signals);
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Dump_Table.Table (I) := null;
+ end loop;
+
+ -- Save and clear.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ N := Get_Signal_Number (Sig_Table.Table (I));
+ if N /= 0 then
+ if Dump_Table.Table (N) /= null then
+ Internal_Error ("wave.write_hierarchy(2)");
+ end if;
+ Dump_Table.Table (N) := Sig_Table.Table (I);
+ Sig_Table.Table (I).Alink := null;
+ end if;
+ end loop;
+ end Write_Hierarchy;
+
+ procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is
+ begin
+ -- FIXME: for some signals, the significant value is the driving value!
+ Write_Value (Sig.Value, Sig.Mode);
+ end Write_Signal_Value;
+
+ procedure Write_Snapshot is
+ begin
+ Wave_Section ("SNP" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Write_Signal_Value (Dump_Table.Table (I));
+ end loop;
+ Wave_Put ("ESN" & NUL);
+ end Write_Snapshot;
+
+ procedure Wave_Cycle;
+
+ -- Called after elaboration.
+ procedure Wave_Start
+ is
+ Root : VhpiHandleT;
+ begin
+ -- Do nothing if there is no VCD file to generate.
+ if Wave_Stream = NULL_Stream then
+ return;
+ end if;
+
+ Write_File_Header;
+
+ -- FIXME: write infos
+ -- * date
+ -- * timescale
+ -- * design name ?
+ -- ...
+
+ -- Put hierarchy.
+ Get_Root_Inst (Root);
+ -- Vcd_Search_Packages;
+ Wave_Put_Hierarchy (Root, Step_Name);
+
+ Freeze_Strings;
+
+ -- Register_Cycle_Hook (Vcd_Cycle'Access);
+ Write_Strings_Compress;
+ Write_Types;
+ Write_Known_Types;
+ Write_Hierarchy (Root);
+
+ -- End of header mark.
+ Wave_Section ("EOH" & NUL);
+
+ Write_Snapshot;
+
+ Register_Cycle_Hook (Wave_Cycle'Access);
+
+ fflush (Wave_Stream);
+ end Wave_Start;
+
+ Wave_Time : Std_Time := 0;
+ In_Cyc : Boolean := False;
+
+ procedure Wave_Close_Cyc
+ is
+ begin
+ Wave_Put_LSLEB128 (-1);
+ Wave_Put ("ECY" & NUL);
+ In_Cyc := False;
+ end Wave_Close_Cyc;
+
+ procedure Wave_Cycle
+ is
+ Diff : Std_Time;
+ Sig : Ghdl_Signal_Ptr;
+ Last : Natural;
+ begin
+ if not In_Cyc then
+ Wave_Section ("CYC" & NUL);
+ Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+ In_Cyc := True;
+ else
+ Diff := Cycle_Time - Wave_Time;
+ Wave_Put_LSLEB128 (Ghdl_I64 (Diff));
+ end if;
+ Wave_Time := Cycle_Time;
+
+ -- Dump signals.
+ Last := 0;
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Sig := Dump_Table.Table (I);
+ if Sig.Flags.Cyc_Event then
+ Wave_Put_ULEB128 (Ghdl_U32 (I - Last));
+ Last := I;
+ Write_Signal_Value (Sig);
+ Sig.Flags.Cyc_Event := False;
+ end if;
+ end loop;
+ Wave_Put_Byte (0);
+ end Wave_Cycle;
+
+ -- Called at the end of the simulation.
+ procedure Wave_End is
+ begin
+ if Wave_Stream = NULL_Stream then
+ return;
+ end if;
+ if In_Cyc then
+ Wave_Close_Cyc;
+ end if;
+ Wave_Write_Directory;
+ fflush (Wave_Stream);
+ end Wave_End;
+
+ Wave_Hooks : aliased constant Hooks_Type :=
+ (Option => Wave_Option'Access,
+ Help => Wave_Help'Access,
+ Init => Wave_Init'Access,
+ Start => Wave_Start'Access,
+ Finish => Wave_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Wave_Hooks'Access);
+ end Register;
+end Grt.Waves;
diff --git a/src/translate/grt/grt-waves.ads b/src/translate/grt/grt-waves.ads
new file mode 100644
index 000000000..72d7ea6e1
--- /dev/null
+++ b/src/translate/grt/grt-waves.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - wave dumper (GHW) module.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Waves is
+ procedure Register;
+end Grt.Waves;
diff --git a/src/translate/grt/grt-zlib.ads b/src/translate/grt/grt-zlib.ads
new file mode 100644
index 000000000..9dfee3665
--- /dev/null
+++ b/src/translate/grt/grt-zlib.ads
@@ -0,0 +1,47 @@
+-- GHDL Run Time (GRT) - Zlib binding.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with System; use System;
+with Grt.C; use Grt.C;
+
+package Grt.Zlib is
+ pragma Linker_Options ("-lz");
+
+ type gzFile is new System.Address;
+
+ NULL_gzFile : constant gzFile := gzFile (System'To_Address (0));
+
+ function gzputc (File : gzFile; C : int) return int;
+ pragma Import (C, gzputc);
+
+ function gzwrite (File : gzFile; Buf : voids; Len : int) return int;
+ pragma Import (C, gzwrite);
+
+ function gzopen (Path : chars; Mode : chars) return gzFile;
+ pragma Import (C, gzopen);
+
+ procedure gzclose (File : gzFile);
+ pragma Import (C, gzclose);
+end Grt.Zlib;
diff --git a/src/translate/grt/grt.adc b/src/translate/grt/grt.adc
new file mode 100644
index 000000000..f2284997d
--- /dev/null
+++ b/src/translate/grt/grt.adc
@@ -0,0 +1,46 @@
+-- GHDL Run Time (GRT) - Configuration pragmas.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- The GRT library is built with a lot of restrictions.
+-- The purpose of these restrictions (mainly No_Run_Time) is not to link with
+-- the GNAT run time library. The user does not need to download or compile
+-- it.
+--
+-- However, GRT works without these restrictions. If you want to use GRT
+-- in Ada, you may compile GRT without these restrictions (remove the -gnatec
+-- flag).
+--
+-- This files is *not* names gnat.adc, in order to ease the possibility of
+-- not using it.
+pragma Restrictions (No_Exception_Handlers);
+--pragma restrictions (No_Exceptions);
+pragma Restrictions (No_Secondary_Stack);
+--pragma Restrictions (No_Elaboration_Code);
+pragma Restrictions (No_Io);
+pragma restrictions (no_dependence => Ada.Tags);
+pragma restrictions (no_dependence => GNAT);
+pragma Restrictions (Max_Tasks => 0);
+pragma Restrictions (No_Implicit_Heap_Allocations);
+pragma No_Run_Time;
diff --git a/src/translate/grt/grt.ads b/src/translate/grt/grt.ads
new file mode 100644
index 000000000..9727d0430
--- /dev/null
+++ b/src/translate/grt/grt.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - Top of hierarchy.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt is
+ pragma Pure (Grt);
+end Grt;
diff --git a/src/translate/grt/grt.ver b/src/translate/grt/grt.ver
new file mode 100644
index 000000000..031c20761
--- /dev/null
+++ b/src/translate/grt/grt.ver
@@ -0,0 +1,25 @@
+{
+ global:
+vpi_free_object;
+vpi_get;
+vpi_get_str;
+vpi_get_time;
+vpi_get_value;
+vpi_get_vlog_info;
+vpi_handle;
+vpi_handle_by_index;
+vpi_iterate;
+vpi_mcd_close;
+vpi_mcd_name;
+vpi_mcd_open;
+vpi_put_value;
+vpi_register_cb;
+vpi_register_systf;
+vpi_remove_cb;
+vpi_scan;
+vpi_vprintf;
+vpi_printf;
+ local:
+ *;
+};
+
diff --git a/src/translate/grt/main.adb b/src/translate/grt/main.adb
new file mode 100644
index 000000000..5de379449
--- /dev/null
+++ b/src/translate/grt/main.adb
@@ -0,0 +1,32 @@
+-- GHDL Run Time (GRT) - C-like entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ghdl_Main;
+
+function Main (Argc : Integer; Argv : System.Address)
+ return Integer
+is
+begin
+ return Ghdl_Main (Argc, Argv);
+end Main;
diff --git a/src/translate/grt/main.ads b/src/translate/grt/main.ads
new file mode 100644
index 000000000..f7c414274
--- /dev/null
+++ b/src/translate/grt/main.ads
@@ -0,0 +1,34 @@
+-- GHDL Run Time (GRT) - C-like entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- In the usual case of a standalone executable, this file defines the
+-- standard entry point, ie the main() function.
+--
+-- However, as explained in the manual, the user can use its own main()
+-- function, and calls the ghdl entry point ghdl_main.
+with System;
+
+function Main (Argc : Integer; Argv : System.Address) return Integer;
+pragma Export (C, Main, "main");
diff --git a/src/translate/mcode/Makefile.in b/src/translate/mcode/Makefile.in
new file mode 100644
index 000000000..beb450a08
--- /dev/null
+++ b/src/translate/mcode/Makefile.in
@@ -0,0 +1,54 @@
+PREFIX=/usr/local
+target=i686-pc-linux-gnu
+
+CFLAGS=-O
+GNATFLAGS=$(CFLAGS) -gnatn
+
+GRT_FLAGS=$(CFLAGS)
+
+all: ghdl_mcode std.v93 std.v87 ieee.v93 ieee.v87 synopsys.v93 synopsys.v87 mentor.v93
+
+
+GRTSRCDIR=grt
+
+####grt Makefile.inc
+
+ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force
+ gnatmake -aIghdldrv -aIghdl -aIortho -aIgrt $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(GRT_EXTRA_LIB) -Wl,--version-script=$(GRTSRCDIR)/grt.ver -Wl,--export-dynamic
+
+mmap_binding.o: ortho/mmap_binding.c
+ $(CC) -c -g -o $@ $<
+
+default_pathes.ads: Makefile
+ echo "-- DO NOT EDIT" > tmp-dpathes.ads
+ echo "-- This file is created by Makefile" >> tmp-dpathes.ads
+ echo "package Default_Pathes is" >> tmp-dpathes.ads
+ echo " Prefix : constant String :=">> tmp-dpathes.ads
+ echo " \"$(PREFIX)/lib/ghdl/\";" >> tmp-dpathes.ads
+ echo "end Default_Pathes;" >> tmp-dpathes.ads
+ if test -r $@ && cmp tmp-dpathes.ads $@; then \
+ echo "$@ unchanged"; \
+ else \
+ mv tmp-dpathes.ads $@; \
+ fi
+ $(RM) tmp-dpathes.ads
+
+force:
+
+LIB93_DIR:=./lib/v93
+LIB87_DIR:=./lib/v87
+LIBSRC_DIR:=./libraries
+ANALYZE=../../../ghdl_mcode -a --ieee=none
+REL_DIR=../../..
+VHDLLIBS_COPY_OBJS:=no
+CP=cp
+LN=ln -s
+
+./lib:
+ mkdir $@
+
+$(LIB93_DIR) $(LIB87_DIR): ./lib
+ mkdir $@
+
+
+####libraries Makefile.inc
diff --git a/src/translate/mcode/README b/src/translate/mcode/README
new file mode 100644
index 000000000..a10cd6efc
--- /dev/null
+++ b/src/translate/mcode/README
@@ -0,0 +1,47 @@
+This is the README from the source distribution of GHDL.
+
+To get the binary distribution or more information, go to http://ghdl.free.fr
+
+Copyright:
+**********
+GHDL is copyright (c) 2002, 2003, 2004, 2005 Tristan Gingold.
+See the GHDL manual for more details.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
+
+
+Building GHDL from sources for Windows:
+***************************************
+
+Note: this was tested with Windows XP SP2 familly edition.
+
+Note: If you want to create the installer, GHDL should be built on a
+FAT partition. NSIS rounds files date to be FAT compliant (seconds are always
+even) and because GHDL stores dates, the files date must not be modified.
+
+Required:
+* the Ada95 GNAT compiler (GNAT GPL 2005 is known to work).
+* NSIS to create the installer.
+
+Unzip,
+edit winbuild to use correct path for makensis,
+run winbuild.
+
+The installer is in the windows directory.
+
+Send bugs and comments on http://gna.org/project/ghdl
+
+Tristan Gingold.
diff --git a/src/translate/mcode/dist.sh b/src/translate/mcode/dist.sh
new file mode 100755
index 000000000..cf24141de
--- /dev/null
+++ b/src/translate/mcode/dist.sh
@@ -0,0 +1,506 @@
+#!/bin/sh
+
+# Script used to create tar balls.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+# Building a distribution:
+# * update the 'version' variable in ../../Makefile
+# * Regenerate version.ads: make -f ../../Makefile version.ads
+# * Check NEWS, README and INSTALL files.
+# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb
+# * Check GCCVERSION below.
+# * Check lists of exported files in this file.
+# * Create source tar and build binaries: ./dist.sh dist_phase1
+# * su root
+# * Build binary tar: ./dist.sh dist_phase2
+# * Run the testsuites: GHDL=ghdl ./testsuite.sh
+# * Update website/index.html (./dist.sh website helps, rename .new)
+# * upload (./dist upload)
+# * CVS commit, tag + cd image.
+# * remove previous version in /usr/local
+
+## DO NOT MODIFY this file while it is running...
+
+set -e
+
+# GTKWave version.
+GTKWAVE_VERSION=1.3.72
+
+# GHDL version (extracted from version.ads)
+VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads`
+
+CWD=`pwd`
+
+distdir=ghdl-$VERSION
+tarfile=$distdir.tar
+zipfile=$distdir.zip
+
+PREFIX=/usr/local
+bindirname=ghdl-$VERSION-i686-pc-linux
+TARINSTALL=$DISTDIR/$bindirname.tar.bz2
+VHDLDIR=$distdir/vhdl
+DOWNLOAD_HTML=../../website/download.html
+DESTDIR=$CWD/
+UNSTRIPDIR=${distdir}-unstripped
+
+PATH=/usr/gnat/bin:$PATH
+
+do_clean ()
+{
+ rm -rf $distdir
+ mkdir $distdir
+ mkdir $distdir/ghdl
+ mkdir $distdir/ghdldrv
+ mkdir $distdir/libraries
+ mkdir $distdir/libraries/std $distdir/libraries/ieee
+ mkdir $distdir/libraries/vital95 $distdir/libraries/vital2000
+ mkdir $distdir/libraries/synopsys $distdir/libraries/mentor
+ mkdir $distdir/grt
+ mkdir $distdir/grt/config
+ mkdir $distdir/ortho
+ mkdir $distdir/windows
+}
+
+# Build Makefile
+do_Makefile ()
+{
+ sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \
+ -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \
+ < Makefile.in > $distdir/Makefile
+}
+
+# Copy (or link) sources files into $distdir
+do_files ()
+{
+. ../gcc/dist-common.sh
+
+ortho_mcode_files="
+binary_file-elf.adb
+binary_file-elf.ads
+binary_file-memory.adb
+binary_file-memory.ads
+binary_file.adb
+binary_file.ads
+disa_x86.adb
+disa_x86.ads
+disassemble.ads
+dwarf.ads
+elf32.adb
+elf32.ads
+elf64.ads
+elf_common.adb
+elf_common.ads
+elf_arch32.ads
+elf_arch.ads
+hex_images.adb
+hex_images.ads
+memsegs.ads
+memsegs_mmap.ads
+memsegs_mmap.adb
+memsegs_c.c
+ortho_code-abi.ads
+ortho_code-binary.adb
+ortho_code-binary.ads
+ortho_code-consts.adb
+ortho_code-consts.ads
+ortho_code-debug.adb
+ortho_code-debug.ads
+ortho_code-decls.adb
+ortho_code-decls.ads
+ortho_code-disps.adb
+ortho_code-disps.ads
+ortho_code-dwarf.adb
+ortho_code-dwarf.ads
+ortho_code-exprs.adb
+ortho_code-exprs.ads
+ortho_code-flags.ads
+ortho_code-opts.adb
+ortho_code-opts.ads
+ortho_code-types.adb
+ortho_code-types.ads
+ortho_code-sysdeps.adb
+ortho_code-sysdeps.ads
+ortho_code-x86-emits.adb
+ortho_code-x86-emits.ads
+ortho_code-x86-insns.adb
+ortho_code-x86-insns.ads
+ortho_code-x86-abi.adb
+ortho_code-x86-abi.ads
+ortho_code-x86-flags.ads
+ortho_code-x86.adb
+ortho_code-x86.ads
+ortho_code.ads
+ortho_code_main.adb
+ortho_ident.adb
+ortho_ident.ads
+ortho_mcode.adb
+ortho_mcode.ads
+ortho_nodes.ads
+"
+
+windows_files="
+compile.bat
+complib.bat
+default_pathes.ads
+ghdl.nsi
+windows_default_path.adb
+windows_default_path.ads
+ghdlfilter.adb
+ortho_code-sysdeps.adb
+grt-modules.adb
+"
+
+drv_files="
+ghdlcomp.ads
+ghdlcomp.adb
+foreigns.ads
+foreigns.adb
+ghdlrun.adb
+ghdlrun.ads
+ghdl_mcode.adb
+"
+
+for i in $cfiles; do ln -sf $CWD/../../$i $distdir/ghdl/$i; done
+for i in $tfiles; do ln -sf $CWD/../$i $distdir/ghdl/$i; done
+
+ln -sf $CWD/../../doc/ghdl.texi $distdir/ghdl.texi
+
+for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $distdir/ortho/$i; done
+
+for i in $ortho_mcode_files; do
+ ln -sf $CWD/../../ortho/mcode/$i $distdir/ortho/$i
+done
+
+for i in $ghdl_files $drv_files; do
+ ln -sf $CWD/../ghdldrv/$i $distdir/ghdldrv/$i
+done
+
+for i in $libraries_files; do
+ ln -sf $CWD/../../libraries/$i $distdir/libraries/$i
+done
+
+for i in $grt_files; do
+ ln -sf $CWD/../grt/$i $distdir/grt/$i
+done
+
+for i in $grt_config_files; do
+ ln -sf $CWD/../grt/config/$i $distdir/grt/config/$i
+done
+
+for i in $windows_files; do
+ ln -sf $CWD/windows/$i $distdir/windows/$i
+done
+ echo "!define VERSION \"$VERSION\"" > $distdir/windows/version.nsi
+
+
+ ln -sf $CWD/winbuild.bat $distdir/winbuild.bat
+
+makeinfo --html --no-split -o $distdir/windows/ghdl.htm $CWD/../../doc/ghdl.texi
+}
+
+do_sources_dir ()
+{
+ \rm -rf $distdir
+ mkdir $distdir
+ do_clean
+ do_Makefile
+ do_files
+ ln -sf ../../../COPYING $distdir
+}
+
+# Create the tar of sources.
+do_tar ()
+{
+ do_sources_dir
+ tar cvhf $tarfile $distdir
+ bzip2 -f $tarfile
+ rm -rf $distdir
+}
+
+# Create the zip of sources.
+do_zip ()
+{
+ do_sources_dir
+ zip -r $zipfile $distdir
+ rm -rf $distdir
+}
+
+# Extract the source, configure and make.
+do_compile ()
+{
+ set -x
+
+ do_update_gcc_sources;
+
+ rm -rf $GCCDISTOBJ
+ mkdir $GCCDISTOBJ
+ cd $GCCDISTOBJ
+ ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX
+ make CFLAGS="-O -g"
+ make -C gcc vhdl.info
+ cd $CWD
+}
+
+check_root ()
+{
+ if [ $UID -ne 0 ]; then
+ echo "$0: you must be root";
+ exit 1;
+ fi
+}
+
+# Do a make install
+do_compile2 ()
+{
+ set -x
+ cd $GCCDISTOBJ
+ # Check the info file is not empty.
+ if [ -s gcc/doc/ghdl.info ]; then
+ echo "info file found"
+ else
+ echo "Error: ghdl.info not found".
+ exit 1;
+ fi
+ mkdir -p $DESTDIR/usr/local || true
+ make DESTDIR=$DESTDIR install
+ cd $CWD
+ if [ -d $UNSTRIPDIR ]; then
+ rm -rf $UNSTRIPDIR
+ fi
+ mkdir $UNSTRIPDIR
+ cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR
+ chmod -w $UNSTRIPDIR/*
+ strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl
+}
+
+# Create the tar file from the current installation.
+do_tar_install ()
+{
+ tar -C $DESTDIR -jcvf $TARINSTALL \
+ ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info \
+ ./$GCCLIBDIR/vhdl \
+ ./$GCCLIBEXECDIR/ghdl1
+}
+
+do_extract_tar_install ()
+{
+ check_root;
+ cd /
+ tar jxvf $TARINSTALL
+ cd $CWD
+}
+
+# Create the tar file to be distributed.
+do_tar_dist ()
+{
+ rm -rf $bindirname
+ mkdir $bindirname
+ sed -e "s/@TARFILE@/$dir.tar/" < INSTALL > $bindirname/INSTALL
+ ln ../../COPYING $bindirname
+ ln $TARINSTALL $bindirname
+ tar cvf $bindirname.tar $bindirname
+}
+
+# Remove the non-ghdl files of gcc in the current installation.
+do_distclean_gcc ()
+{
+ set -x
+ rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc
+ rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov
+ rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc*
+ rm -f ${DESTDIR}${PREFIX}/info/cpp.info*
+ rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gcc.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccint.info*
+ rm -f ${DESTDIR}${PREFIX}/lib/*.a ${DESTDIR}${PREFIX}/lib/*.so*
+ rm -rf ${DESTDIR}${PREFIX}/share
+ rm -rf ${DESTDIR}${PREFIX}/man
+ rm -rf ${DESTDIR}${PREFIX}/include
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0
+ rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a
+ rm -f ${DESTDIR}${GCCLIBDIR}/specs
+ rm -rf ${DESTDIR}${GCCLIBDIR}/include
+ rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools
+ rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools
+}
+
+# Remove ghdl files in the current installation.
+do_distclean_ghdl ()
+{
+ check_root;
+ set -x
+ rm -f $PREFIX/bin/ghdl
+ rm -f $PREFIX/info/ghdl.info*
+ rm -f $GCCLIBEXECDIR/ghdl1
+ rm -rf $GCCLIBDIR/vhdl
+}
+
+# Build the source tar, and build the binaries.
+do_dist_phase1 ()
+{
+ do_sources;
+ do_compile;
+ do_compile2;
+ do_distclean_gcc;
+ do_tar_install;
+ do_tar_dist;
+ rm -rf ./$PREFIX
+}
+
+# Install the binaries and create the binary tar.
+do_dist_phase2 ()
+{
+ check_root;
+ do_distclean_ghdl;
+ do_extract_tar_install;
+ echo "dist_phase2 success"
+}
+
+# Create gtkwave patch
+do_gtkwave_patch ()
+{
+# rm -rf gtkwave-patch
+ mkdir gtkwave-patch
+ diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \
+ sed -e "/^Only in/d" \
+ > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs
+ cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch
+ sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README
+ tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch
+ rm -rf gtkwave-patch
+}
+
+# Update the index.html
+# Update the doc
+do_website ()
+{
+ sed -e "
+/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/
+/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/
+/HISTORY/ a \\
+ <tr>\\
+ <td>$VERSION</td>\\
+ <td>`date +'%b %e %Y'`</td>\\
+ <td>$GCCVERSION</td>\\
+ <td><a href=\"$tarfile.bz2\">$tarfile.bz2</a></td>\\
+ <td><a href=\"$bindirname.tar\">\\
+ $bindirname.tar</a></td>\\
+ </tr>
+" < $DOWNLOAD_HTML > "$DOWNLOAD_HTML".new
+ dir=../../website/ghdl
+ echo "Updating $dir"
+ rm -rf $dir
+ makeinfo --html -o $dir ../../doc/ghdl.texi
+}
+
+# Do ftp commands to upload
+do_upload ()
+{
+if tty -s; then
+ echo -n "Please, enter password: "
+ stty -echo
+ read pass
+ stty echo
+ echo
+else
+ echo "$0: upload must be done from a tty"
+ exit 1;
+fi
+ftp -n <<EOF
+open ftpperso.free.fr
+user ghdl $pass
+prompt
+hash
+bin
+passive
+put $tarfile.bz2
+put $bindirname.tar
+put INSTALL
+lcd ../../website
+put NEWS
+put index.html
+put download.html
+put features.html
+put roadmap.html
+put manual.html
+put more.html
+put links.html
+put bug.html
+put waveviewer.html
+put gtkwave-patch.tgz
+put favicon.ico
+lcd ghdl
+cd ghdl
+mput \*
+bye
+EOF
+}
+
+if [ $# -eq 0 ]; then
+ do_zip;
+else
+ for i ; do
+ case $i in
+ clean)
+ do_clean ;;
+ Makefile|makefile)
+ do_Makefile ;;
+ files)
+ do_files ;;
+ sources)
+ do_sources_dir ;;
+ tar)
+ do_tar ;;
+ zip)
+ do_zip ;;
+ compile)
+ do_compile;;
+ update_gcc)
+ do_update_gcc_sources;;
+ compile2)
+ do_compile2;;
+ tar_install)
+ do_tar_install;;
+ tar_dist)
+ do_tar_dist;;
+ -v | --version | version)
+ echo $VERSION
+ exit 0
+ ;;
+ website)
+ do_website;;
+ upload)
+ do_upload;;
+ distclean_gcc)
+ do_distclean_gcc;;
+ distclean_ghdl)
+ do_distclean_ghdl;;
+ dist_phase1)
+ do_dist_phase1;;
+ dist_phase2)
+ do_dist_phase2;;
+ gtkwave_patch)
+ do_gtkwave_patch;;
+ *)
+ echo "usage: $0 clean|Makefile|files|all"
+ exit 1 ;;
+ esac
+ done
+fi
diff --git a/src/translate/mcode/winbuild.bat b/src/translate/mcode/winbuild.bat
new file mode 100644
index 000000000..8c2826852
--- /dev/null
+++ b/src/translate/mcode/winbuild.bat
@@ -0,0 +1,18 @@
+call windows\compile
+if errorlevel 1 goto end
+
+call windows\complib
+if errorlevel 1 goto end
+
+gnatmake windows/ghdlversion -o windows/ghdlversion.exe
+windows\ghdlversion < ../../version.ads > windows/version.nsi
+
+"c:\Program Files\NSIS\makensis" windows\ghdl.nsi
+if errorlevel 1 goto end
+
+exit /b 0
+
+:end
+echo "Error during compilation"
+exit /b 1
+
diff --git a/src/translate/mcode/windows/compile.bat b/src/translate/mcode/windows/compile.bat
new file mode 100644
index 000000000..c668ef0e2
--- /dev/null
+++ b/src/translate/mcode/windows/compile.bat
@@ -0,0 +1,24 @@
+mkdir build
+cd build
+
+rem Do the compilation
+set CFLAGS=-O -g
+gcc -c %CFLAGS% ../../grt/grt-cbinding.c
+gcc -c %CFLAGS% ../../grt/grt-cvpi.c
+gcc -c %CFLAGS% ../../grt/config/clock.c
+gcc -c %CFLAGS% ../../../ortho/mcode/memsegs_c.c
+gcc -c %CFLAGS% -DWITH_GNAT_RUN_TIME ../../grt/config/win32.c
+gnatmake %CFLAGS% -gnatn -aI../windows -aI../../.. -aI../.. -aI../../ghdldrv -aI../../../psl -aI../../grt -aI../../../ortho/mcode ghdl_mcode -aI../../../ortho -o ghdl.exe -largs grt-cbinding.o clock.o grt-cvpi.o memsegs_c.o win32.o -largs -Wl,--stack,8404992
+
+if errorlevel 1 goto failed
+
+strip ghdl.exe
+
+cd ..
+exit /b 0
+
+:failed
+echo "Compilation failed"
+cd ..
+exit /b 1
+
diff --git a/src/translate/mcode/windows/complib.bat b/src/translate/mcode/windows/complib.bat
new file mode 100644
index 000000000..88a43ce60
--- /dev/null
+++ b/src/translate/mcode/windows/complib.bat
@@ -0,0 +1,68 @@
+set GHDL=ghdl
+
+cd build
+gnatmake -aI..\windows ghdlfilter
+cd ..
+
+set REL=..\..\..
+set LIBSRC=%REL%\..\..\libraries
+set STD_SRCS=textio textio_body
+set IEEE_SRCS=std_logic_1164 std_logic_1164_body numeric_std numeric_std-body numeric_bit numeric_bit-body
+set VITAL95_SRCS=vital_timing vital_timing_body vital_primitives vital_primitives_body
+set VITAL2000_SRCS=timing_p timing_b prmtvs_p prmtvs_b memory_p memory_b
+
+set SYNOPSYS_SRCS=std_logic_arith std_logic_textio std_logic_unsigned std_logic_signed std_logic_misc std_logic_misc-body
+
+mkdir lib
+cd lib
+
+mkdir v87
+cd v87
+
+mkdir std
+cd std
+for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\std\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 --bootstrap --work=std %%F.v87
+cd ..
+
+mkdir ieee
+cd ieee
+rem Base ieee
+for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\ieee\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.v87
+rem Vital 95
+for %%F in (%VITAL95_SRCS%) do copy %LIBSRC%\vital95\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd
+cd ..
+
+mkdir synopsys
+cd synopsys
+for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.v87
+for %%F in (%VITAL95_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.vhd
+for %%F in (%SYNOPSYS_SRCS%) do copy %LIBSRC%\synopsys\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd
+cd ..
+
+cd ..
+mkdir v93
+cd v93
+
+mkdir std
+cd std
+for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\std\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 --bootstrap --work=std %%F.v93
+cd ..
+
+mkdir ieee
+cd ieee
+echo Base ieee
+for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\ieee\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.v93
+echo Vital 2000
+for %%F in (%VITAL2000_SRCS%) do copy %LIBSRC%\vital2000\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.vhd
+cd ..
+
+mkdir synopsys
+cd synopsys
+for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.v93
+for %%F in (%VITAL2000_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.vhd
+for %%F in (%SYNOPSYS_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\..\v87\synopsys\%%F.vhd
+cd ..
+
+cd ..
+
+cd ..
diff --git a/src/translate/mcode/windows/default_pathes.ads b/src/translate/mcode/windows/default_pathes.ads
new file mode 100644
index 000000000..51b350f4e
--- /dev/null
+++ b/src/translate/mcode/windows/default_pathes.ads
@@ -0,0 +1,8 @@
+with Windows_Default_Path;
+pragma Elaborate_All (Windows_Default_Path);
+
+package Default_Pathes is
+ Install_Prefix : constant String :=
+ Windows_Default_Path.Get_Windows_Exec_Path;
+ Lib_Prefix : constant String := "lib";
+end Default_Pathes;
diff --git a/src/translate/mcode/windows/ghdl.nsi b/src/translate/mcode/windows/ghdl.nsi
new file mode 100644
index 000000000..aa4d559aa
--- /dev/null
+++ b/src/translate/mcode/windows/ghdl.nsi
@@ -0,0 +1,455 @@
+; ghdl.nsi
+;
+; This script is based on example2.nsi.
+; remember the directory,
+; Check if administrator
+; uninstall support
+; TODO:
+; * allow multiple version
+; * command line installation
+; * Allow user install
+
+;--------------------------------
+!include version.nsi
+;--------------------------------
+
+; The name of the installer
+Name "Ghdl"
+
+; The file to write
+OutFile "ghdl-installer-${VERSION}.exe"
+
+SetDateSave on
+
+; The default installation directory
+InstallDir $PROGRAMFILES\Ghdl
+
+; Registry key to check for directory (so if you install again, it will
+; overwrite the old one automatically)
+InstallDirRegKey HKLM "Software\Ghdl" "Install_Dir"
+
+LicenseData ..\..\..\COPYING
+; LicenseForceSelection
+
+;--------------------------------
+
+; Pages
+
+Page license
+Page components
+Page directory
+Page instfiles
+
+UninstPage uninstConfirm
+UninstPage instfiles
+
+;--------------------------------
+Function .onInit
+ Call IsNT
+ pop $R0
+ StrCmp $R0 1 nt_ok
+ MessageBox MB_OK|MB_ICONEXCLAMATION "You must use Windows NT (XP/2000/Me...)"
+ Quit
+
+nt_ok:
+ Call IsUserAdmin
+ Pop $R0
+ StrCmp $R0 "true" Admin
+ MessageBox MB_OK|MB_ICONEXCLAMATION "You must have Admin rights"
+ Quit
+
+Admin:
+
+ ;;; Check if already installed.
+ ReadRegStr $0 HKLM "Software\Ghdl" "Install_Dir"
+ IfErrors not_installed
+ ReadRegStr $0 HKLM "Software\Ghdl" "Version"
+ IfErrors unknown_prev_version
+ Goto known_version
+unknown_prev_version:
+ StrCpy $0 "(unknown)"
+known_version:
+ MessageBox MB_OKCANCEL|MB_ICONEXCLAMATION "You already have GHDL version $0 installed. Deinstall ?" IDCANCEL install_abort IDOK deinstall
+install_abort:
+ Abort "Installation aborted"
+deinstall:
+ ReadRegStr $0 HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString"
+ IfErrors deinstall_failed
+
+ ; First version of the GHDL installer adds quotes
+ StrCpy $1 $0 1
+ StrCmp $1 '"' 0 str_ok
+ StrCpy $1 $0 "" 1
+ StrCpy $0 $1 -1
+str_ok:
+
+ ; Read install dir
+ ReadRegStr $1 HKLM "Software\Ghdl" "Install_Dir"
+ IfErrors deinstall_failed
+
+; MessageBox MB_OK 'copy $0 to $TEMP'
+
+ ClearErrors
+; MessageBox MB_OK 'copy $0 to $TEMP'
+ CopyFiles $0 $TEMP
+ IfErrors deinstall_failed
+ ExecWait '"$TEMP\uninst-ghdl.exe" /S _?=$1'
+ IfErrors deinstall_failed
+ Delete "$TEMP\uninst-ghdl.exe"
+ Return
+deinstall_failed:
+ Delete $TEMP\uninst-ghdl.exe
+ MessageBox MB_YESNO|MB_ICONSTOP "Can't deinstall GHDL: de-installer not found or failed. Continue installation ?" IDNO install_abort
+not_installed:
+ Return
+FunctionEnd
+
+;--------------------------------
+
+; The stuff to install
+Section "Ghdl Compiler (required)"
+
+ SectionIn RO
+
+ ; Set output path to the installation directory.
+ SetOutPath $INSTDIR\bin
+ File /oname=ghdl.exe ..\build\ghdl.exe
+
+ SetOutPath $INSTDIR
+ File /oname=COPYING.txt ..\..\..\COPYING
+
+ ; Write the installation path into the registry
+ WriteRegStr HKLM "Software\Ghdl" "Install_Dir" $INSTDIR
+ ; Write te version
+ WriteRegStr HKLM "Software\Ghdl" "Version" ${VERSION}
+
+ ; Write the uninstall keys for Windows
+ WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "DisplayName" "Ghdl"
+ WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString" $INSTDIR\uninst-ghdl.exe
+ WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoModify" 1
+ WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoRepair" 1
+ WriteUninstaller $INSTDIR\uninst-ghdl.exe"
+
+SectionEnd
+
+Section "VHDL standard and ieee libraries"
+ SectionIn RO
+ SetOutPath $INSTDIR\lib\v87
+ File /r ..\lib\v87\std ..\lib\v87\ieee
+ SetOutPath $INSTDIR\lib\v93
+ File /r ..\lib\v93\std ..\lib\v93\ieee
+SectionEnd
+
+Section "Synopsys libraries (Recommended)"
+ SetOutPath $INSTDIR\lib\v87
+ File /r ..\lib\v87\synopsys
+ SetOutPath $INSTDIR\lib\v93
+ File /r ..\lib\v93\synopsys
+SectionEnd
+
+Section "Documentation (Recommended)"
+ SetOutPath $INSTDIR
+ File /oname=ghdl.htm ..\..\..\doc\ghdl.html
+SectionEnd
+
+Section "Add in PATH (Recommended)"
+ WriteRegDWORD HKLM "Software\Ghdl" "PathSet" 1
+ Push $INSTDIR\Bin
+ Call AddToPath
+SectionEnd
+
+; Optional section (can be disabled by the user)
+;Section "Start Menu Shortcuts"
+;
+; CreateDirectory "$SMPROGRAMS\Ghdl"
+; CreateShortCut "$SMPROGRAMS\Ghdl\Uninstall.lnk" "$INSTDIR\uninstall.exe" "" "$INSTDIR\uninstall.exe" 0
+; CreateShortCut "$SMPROGRAMS\Ghdl\Ghdl.lnk" "$INSTDIR\example2.nsi" "" "$INSTDIR\example2.nsi" 0
+;
+;SectionEnd
+;
+
+;--------------------------------
+
+; Uninstaller
+
+Section "Uninstall"
+
+ ReadRegDWORD $0 HKLM "Software\Ghdl" "PathSet"
+ StrCmp $0 "1" "" path_not_set
+ Push $INSTDIR\Bin
+ Call un.RemoveFromPath
+
+path_not_set:
+
+ ; Remove registry keys
+ DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl"
+ DeleteRegKey HKLM Software\Ghdl
+
+ ; Remove files and uninstaller
+ Delete $INSTDIR\bin\ghdl.exe
+ Delete $INSTDIR\uninst-ghdl.exe
+ Delete $INSTDIR\COPYING.txt
+ RMDir $INSTDIR\bin
+ RMDir /r $INSTDIR\lib
+
+
+ ; Remove shortcuts, if any
+ ; Delete "$SMPROGRAMS\Ghdl\*.*"
+
+ ; Remove directories used
+ ; RMDir "$SMPROGRAMS\Ghdl"
+ RMDir "$INSTDIR"
+
+SectionEnd
+
+;;;;;;;; Misc functions
+
+; Author: Lilla (lilla@earthlink.net) 2003-06-13
+; function IsUserAdmin uses plugin \NSIS\PlusgIns\UserInfo.dll
+; This function is based upon code in \NSIS\Contrib\UserInfo\UserInfo.nsi
+; This function was tested under NSIS 2 beta 4 (latest CVS as of this writing).
+;
+; Usage:
+; Call IsUserAdmin
+; Pop $R0 ; at this point $R0 is "true" or "false"
+;
+Function IsUserAdmin
+Push $R0
+Push $R1
+Push $R2
+
+ClearErrors
+UserInfo::GetName
+IfErrors Win9x
+Pop $R1
+UserInfo::GetAccountType
+Pop $R2
+
+StrCmp $R2 "Admin" 0 Continue
+; Observation: I get here when running Win98SE. (Lilla)
+; The functions UserInfo.dll looks for are there on Win98 too,
+; but just don't work. So UserInfo.dll, knowing that admin isn't required
+; on Win98, returns admin anyway. (per kichik)
+; MessageBox MB_OK 'User "$R1" is in the Administrators group'
+StrCpy $R0 "true"
+Goto Done
+
+Continue:
+; You should still check for an empty string because the functions
+; UserInfo.dll looks for may not be present on Windows 95. (per kichik)
+StrCmp $R2 "" Win9x
+StrCpy $R0 "false"
+;MessageBox MB_OK 'User "$R1" is in the "$R2" group'
+Goto Done
+
+Win9x:
+; comment/message below is by UserInfo.nsi author:
+; This one means you don't need to care about admin or
+; not admin because Windows 9x doesn't either
+;MessageBox MB_OK "Error! This DLL can't run under Windows 9x!"
+StrCpy $R0 "true"
+
+Done:
+;MessageBox MB_OK 'User= "$R1" AccountType= "$R2" IsUserAdmin= "$R0"'
+
+Pop $R2
+Pop $R1
+Exch $R0
+FunctionEnd
+
+
+!define ALL_USERS
+
+!ifndef WriteEnvStr_RegKey
+ !ifdef ALL_USERS
+ !define WriteEnvStr_RegKey \
+ 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"'
+ !else
+ !define WriteEnvStr_RegKey 'HKCU "Environment"'
+ !endif
+!endif
+
+!verbose 3
+!include "WinMessages.NSH"
+!verbose 4
+
+; AddToPath - Adds the given dir to the search path.
+; Input - head of the stack
+; Note - Win9x systems requires reboot
+
+Function AddToPath
+ Exch $0
+ Push $1
+ Push $2
+ Push $3
+
+ # don't add if the path doesn't exist
+ IfFileExists "$0\*.*" "" AddToPath_done
+
+ ReadEnvStr $1 PATH
+ Push "$1;"
+ Push "$0;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ Push "$1;"
+ Push "$0\;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ GetFullPathName /SHORT $3 $0
+ Push "$1;"
+ Push "$3;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ Push "$1;"
+ Push "$3\;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+
+ ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
+ StrCpy $2 $1 1 -1 # copy last char
+ StrCmp $2 ";" 0 +2 # if last char == ;
+ StrCpy $1 $1 -1 # remove last char
+ StrCmp $1 "" AddToPath_NTdoIt
+ StrCpy $0 "$1;$0"
+ AddToPath_NTdoIt:
+ WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $0
+ SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
+
+ AddToPath_done:
+ Pop $3
+ Pop $2
+ Pop $1
+ Pop $0
+FunctionEnd
+
+; RemoveFromPath - Remove a given dir from the path
+; Input: head of the stack
+
+Function un.RemoveFromPath
+ Exch $0
+ Push $1
+ Push $2
+ Push $3
+ Push $4
+ Push $5
+ Push $6
+
+ IntFmt $6 "%c" 26 # DOS EOF
+
+ ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
+ StrCpy $5 $1 1 -1 # copy last char
+ StrCmp $5 ";" +2 # if last char != ;
+ StrCpy $1 "$1;" # append ;
+ Push $1
+ Push "$0;"
+ Call un.StrStr ; Find `$0;` in $1
+ Pop $2 ; pos of our dir
+ StrCmp $2 "" unRemoveFromPath_done
+ ; else, it is in path
+ # $0 - path to add
+ # $1 - path var
+ StrLen $3 "$0;"
+ StrLen $4 $2
+ StrCpy $5 $1 -$4 # $5 is now the part before the path to remove
+ StrCpy $6 $2 "" $3 # $6 is now the part after the path to remove
+ StrCpy $3 $5$6
+
+ StrCpy $5 $3 1 -1 # copy last char
+ StrCmp $5 ";" 0 +2 # if last char == ;
+ StrCpy $3 $3 -1 # remove last char
+
+ WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $3
+ SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
+
+ unRemoveFromPath_done:
+ Pop $6
+ Pop $5
+ Pop $4
+ Pop $3
+ Pop $2
+ Pop $1
+ Pop $0
+FunctionEnd
+
+###########################################
+# Utility Functions #
+###########################################
+
+; IsNT
+; no input
+; output, top of the stack = 1 if NT or 0 if not
+;
+; Usage:
+; Call IsNT
+; Pop $R0
+; ($R0 at this point is 1 or 0)
+
+!macro IsNT un
+Function ${un}IsNT
+ Push $0
+ ReadRegStr $0 HKLM "SOFTWARE\Microsoft\Windows NT\CurrentVersion" CurrentVersion
+ StrCmp $0 "" 0 IsNT_yes
+ ; we are not NT.
+ Pop $0
+ Push 0
+ Return
+
+ IsNT_yes:
+ ; NT!!!
+ Pop $0
+ Push 1
+FunctionEnd
+!macroend
+!insertmacro IsNT ""
+;!insertmacro IsNT "un."
+
+; StrStr
+; input, top of stack = string to search for
+; top of stack-1 = string to search in
+; output, top of stack (replaces with the portion of the string remaining)
+; modifies no other variables.
+;
+; Usage:
+; Push "this is a long ass string"
+; Push "ass"
+; Call StrStr
+; Pop $R0
+; ($R0 at this point is "ass string")
+
+!macro StrStr un
+Function ${un}StrStr
+Exch $R1 ; st=haystack,old$R1, $R1=needle
+ Exch ; st=old$R1,haystack
+ Exch $R2 ; st=old$R1,old$R2, $R2=haystack
+ Push $R3
+ Push $R4
+ Push $R5
+ StrLen $R3 $R1
+ StrCpy $R4 0
+ ; $R1=needle
+ ; $R2=haystack
+ ; $R3=len(needle)
+ ; $R4=cnt
+ ; $R5=tmp
+ loop:
+ StrCpy $R5 $R2 $R3 $R4
+ StrCmp $R5 $R1 done
+ StrCmp $R5 "" done
+ IntOp $R4 $R4 + 1
+ Goto loop
+done:
+ StrCpy $R1 $R2 "" $R4
+ Pop $R5
+ Pop $R4
+ Pop $R3
+ Pop $R2
+ Exch $R1
+FunctionEnd
+!macroend
+!insertmacro StrStr ""
+!insertmacro StrStr "un."
+
diff --git a/src/translate/mcode/windows/ghdlfilter.adb b/src/translate/mcode/windows/ghdlfilter.adb
new file mode 100644
index 000000000..d37c2db23
--- /dev/null
+++ b/src/translate/mcode/windows/ghdlfilter.adb
@@ -0,0 +1,58 @@
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Ghdlfilter is
+ type Mode_Kind is (Mode_93, Mode_87);
+ Mode : Mode_Kind;
+
+ Line : String (1 .. 128);
+ Len : Natural;
+
+ Comment : Boolean;
+ Block_Comment : Boolean;
+begin
+ if Argument_Count /= 1 then
+ Put_Line (Standard_Error, "usage: " & Command_Name & " -v93|-v87");
+ return;
+ end if;
+
+ if Argument (1) = "-v93" then
+ Mode := Mode_93;
+ elsif Argument (1) = "-v87" then
+ Mode := Mode_87;
+ else
+ Put_Line (Standard_Error, "bad mode");
+ return;
+ end if;
+
+ Block_Comment := False;
+
+ loop
+ exit when End_Of_File;
+ Get_Line (Line, Len);
+
+ Comment := Block_Comment;
+
+ if Len > 5 then
+ if Mode = Mode_87 and Line (Len - 4 .. Len) = "--V93" then
+ Comment := True;
+ elsif Mode = Mode_93 and Line (Len - 4 .. Len) = "--V87" then
+ Comment := True;
+ end if;
+ end if;
+ if Len = 11
+ and then Mode = Mode_87
+ and then Line (1 .. 11) = "--START-V93" then
+ Block_Comment := True;
+ end if;
+
+ if Len = 9 and then Line (1 .. 9) = "--END-V93" then
+ Block_Comment := False;
+ end if;
+
+ if Comment then
+ Put ("-- ");
+ end if;
+ Put_Line (Line (1 .. Len));
+ end loop;
+end Ghdlfilter;
diff --git a/src/translate/mcode/windows/ghdlversion.adb b/src/translate/mcode/windows/ghdlversion.adb
new file mode 100755
index 000000000..d2f1c28be
--- /dev/null
+++ b/src/translate/mcode/windows/ghdlversion.adb
@@ -0,0 +1,30 @@
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+
+procedure Ghdlversion is
+ Line : String (1 .. 128);
+ Len : Natural;
+ Pos : Natural;
+ E : Natural;
+begin
+ loop
+ exit when End_Of_File;
+ Get_Line (Line, Len);
+
+ -- Search GHDL
+ Pos := Index (Line (1 .. Len), "GHDL ");
+ if Pos /= 0 then
+ Pos := Pos + 5;
+ E := Pos;
+ while Line (E) in '0' .. '9'
+ or Line (E) in 'a' .. 'z'
+ or Line (E) = '.'
+ loop
+ exit when E = Len;
+ E := E + 1;
+ end loop;
+ Put_Line ("!define VERSION """ & Line (Pos .. E - 1) & """");
+ return;
+ end if;
+ end loop;
+end Ghdlversion;
diff --git a/src/translate/mcode/windows/grt-modules.adb b/src/translate/mcode/windows/grt-modules.adb
new file mode 100644
index 000000000..35b27c345
--- /dev/null
+++ b/src/translate/mcode/windows/grt-modules.adb
@@ -0,0 +1,37 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System.Storage_Elements; -- Work around GNAT bug.
+with Grt.Vcd;
+with Grt.Vpi;
+with Grt.Waves;
+with Grt.Vital_Annotate;
+with Grt.Disp_Tree;
+with Grt.Disp_Rti;
+
+package body Grt.Modules is
+ procedure Register_Modules is
+ begin
+ -- List of modules to be registered.
+ Grt.Disp_Tree.Register;
+ Grt.Vcd.Register;
+ Grt.Waves.Register;
+ Grt.Vpi.Register;
+ Grt.Vital_Annotate.Register;
+ Grt.Disp_Rti.Register;
+ end Register_Modules;
+end Grt.Modules;
diff --git a/src/translate/mcode/windows/ortho_code-x86-flags.ads b/src/translate/mcode/windows/ortho_code-x86-flags.ads
new file mode 100644
index 000000000..8915f3122
--- /dev/null
+++ b/src/translate/mcode/windows/ortho_code-x86-flags.ads
@@ -0,0 +1,2 @@
+with Ortho_Code.X86.Flags_Windows;
+package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Windows;
diff --git a/src/translate/mcode/windows/windows_default_path.adb b/src/translate/mcode/windows/windows_default_path.adb
new file mode 100644
index 000000000..23aa2f6e0
--- /dev/null
+++ b/src/translate/mcode/windows/windows_default_path.adb
@@ -0,0 +1,45 @@
+with Interfaces.C; use Interfaces.C;
+with System; use System;
+
+package body Windows_Default_Path is
+
+ subtype DWORD is Interfaces.C.Unsigned_Long;
+ subtype LPWSTR is String;
+ subtype HINSTANCE is Address;
+ function GetModuleFileName (Inst : HINSTANCE; Buf : Address; Size : DWORD)
+ return DWORD;
+ pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA");
+
+ function Get_Windows_Exec_Path return String
+ is
+ File : String (1 .. 256);
+ Size : DWORD;
+ P : Natural;
+ begin
+ -- Get exe file path.
+ Size := GetModuleFileName (Null_Address, File'Address, File'Length);
+ if Size = 0 or Size = File'Length then
+ return "{cannot find install path}\lib";
+ end if;
+
+ -- Remove Program file.
+ P := Natural (Size);
+ while P > 0 loop
+ exit when File (P) = '\';
+ exit when File (P) = ':' and P = 2;
+ P := P - 1;
+ end loop;
+ if File (P) = '\' and P > 1 then
+ -- Remove directory
+ P := P - 1;
+ while P > 0 loop
+ exit when File (P) = '\';
+ exit when File (P) = ':' and P = 2;
+ P := P - 1;
+ end loop;
+ end if;
+
+ return File (1 .. P);
+ end Get_Windows_Exec_Path;
+end Windows_Default_Path;
+
diff --git a/src/translate/mcode/windows/windows_default_path.ads b/src/translate/mcode/windows/windows_default_path.ads
new file mode 100644
index 000000000..8e6303446
--- /dev/null
+++ b/src/translate/mcode/windows/windows_default_path.ads
@@ -0,0 +1,5 @@
+package Windows_Default_Path is
+ -- Get the default path from executable name.
+ -- This function is called during elaboration!
+ function Get_Windows_Exec_Path return String;
+end Windows_Default_Path;
diff --git a/src/translate/ortho_front.adb b/src/translate/ortho_front.adb
new file mode 100644
index 000000000..56c7e61dd
--- /dev/null
+++ b/src/translate/ortho_front.adb
@@ -0,0 +1,445 @@
+-- Ortho entry point for translation.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Name_Table;
+with Std_Package;
+with Back_End;
+with Flags;
+with Translation;
+with Iirs; use Iirs;
+with Libraries; use Libraries;
+with Sem;
+with Errorout; use Errorout;
+with GNAT.OS_Lib;
+with Canon;
+with Disp_Vhdl;
+with Bug;
+with Trans_Be;
+with Options;
+
+package body Ortho_Front is
+ -- The action to be performed by the compiler.
+ type Action_Type is
+ (
+ -- Normal mode: compile a design file.
+ Action_Compile,
+
+ -- Elaborate a design unit.
+ Action_Elaborate,
+
+ -- Analyze files and elaborate unit.
+ Action_Anaelab,
+
+ -- Generate code for std.package.
+ Action_Compile_Std_Package
+ );
+ Action : Action_Type := Action_Compile;
+
+ -- Name of the entity to elaborate.
+ Elab_Entity : String_Acc;
+ -- Name of the architecture to elaborate.
+ Elab_Architecture : String_Acc;
+ -- Filename for the list of files to link.
+ Elab_Filelist : String_Acc;
+
+ Flag_Expect_Failure : Boolean;
+
+ type Id_Link;
+ type Id_Link_Acc is access Id_Link;
+ type Id_Link is record
+ Id : Name_Id;
+ Link : Id_Link_Acc;
+ end record;
+ Anaelab_Files : Id_Link_Acc := null;
+ Anaelab_Files_Last : Id_Link_Acc := null;
+
+ procedure Init is
+ begin
+ -- Initialize.
+ Trans_Be.Register_Translation_Back_End;
+
+ Options.Initialize;
+
+ Elab_Filelist := null;
+ Elab_Entity := null;
+ Elab_Architecture := null;
+ Flag_Expect_Failure := False;
+ end Init;
+
+ function Decode_Elab_Option (Arg : String_Acc) return Natural
+ is
+ begin
+ Elab_Architecture := null;
+ -- Entity (+ architecture) to elaborate
+ if Arg = null then
+ Error_Msg_Option
+ ("entity or configuration name required after --elab");
+ return 0;
+ end if;
+ if Arg (Arg.all'Last) = ')' then
+ -- Name is ENTITY(ARCH).
+ -- Split.
+ declare
+ P : Natural;
+ Len : Natural;
+ Is_Ext : Boolean;
+ begin
+ P := Arg.all'Last - 1;
+ Len := P - Arg.all'First + 1;
+ -- Must be at least 'e(a)'.
+ if Len < 4 then
+ Error_Msg_Option ("ill-formed name after --elab");
+ return 0;
+ end if;
+ -- Handle extended name.
+ if Arg (P) = '\' then
+ P := P - 1;
+ Is_Ext := True;
+ else
+ Is_Ext := False;
+ end if;
+ loop
+ if P = Arg.all'First then
+ Error_Msg_Option ("ill-formed name after --elab");
+ return 0;
+ end if;
+ exit when Arg (P) = '(' and Is_Ext = False;
+ if Arg (P) = '\' then
+ if Arg (P - 1) = '\' then
+ P := P - 2;
+ elsif Arg (P - 1) = '(' then
+ P := P - 1;
+ exit;
+ else
+ Error_Msg_Option ("ill-formed name after --elab");
+ return 0;
+ end if;
+ else
+ P := P - 1;
+ end if;
+ end loop;
+ Elab_Architecture := new String'(Arg (P + 1 .. Arg'Last - 1));
+ Elab_Entity := new String'(Arg (Arg'First .. P - 1));
+ end;
+ else
+ Elab_Entity := new String'(Arg.all);
+ Elab_Architecture := new String'("");
+ end if;
+ return 2;
+ end Decode_Elab_Option;
+
+ function Decode_Option (Opt : String_Acc; Arg: String_Acc) return Natural
+ is
+ begin
+ if Opt.all = "--compile-standard" then
+ Action := Action_Compile_Std_Package;
+ Flags.Bootstrap := True;
+ return 1;
+ elsif Opt.all = "--elab" then
+ if Action /= Action_Compile then
+ Error_Msg_Option ("several --elab options");
+ return 0;
+ end if;
+ Action := Action_Elaborate;
+ return Decode_Elab_Option (Arg);
+ elsif Opt.all = "--anaelab" then
+ if Action /= Action_Compile then
+ Error_Msg_Option ("several --anaelab options");
+ return 0;
+ end if;
+ Action := Action_Anaelab;
+ return Decode_Elab_Option (Arg);
+ elsif Opt'Length > 14
+ and then Opt (Opt'First .. Opt'First + 13) = "--ghdl-source="
+ then
+ if Action /= Action_Anaelab then
+ Error_Msg_Option
+ ("--ghdl-source option allowed only after --anaelab options");
+ return 0;
+ end if;
+ if Arg /= null then
+ Error_Msg_Option ("no argument allowed after --ghdl-source");
+ return 0;
+ end if;
+ declare
+ L : Id_Link_Acc;
+ begin
+ L := new Id_Link'(Id => Name_Table.Get_Identifier
+ (Opt (Opt'First + 14 .. Opt'Last)),
+ Link => null);
+ if Anaelab_Files = null then
+ Anaelab_Files := L;
+ else
+ Anaelab_Files_Last.Link := L;
+ end if;
+ Anaelab_Files_Last := L;
+ end;
+ return 2;
+ elsif Opt.all = "-l" then
+ if Arg = null then
+ Error_Msg_Option ("filename required after -l");
+ end if;
+ if Elab_Filelist /= null then
+ Error_Msg_Option ("several -l options");
+ else
+ Elab_Filelist := new String'(Arg.all);
+ end if;
+ return 2;
+ elsif Opt.all = "--help" then
+ Options.Disp_Options_Help;
+ return 1;
+ elsif Opt.all = "--expect-failure" then
+ Flag_Expect_Failure := True;
+ return 1;
+ elsif Opt'Length > 7 and then Opt (1 .. 7) = "--ghdl-" then
+ if Options.Parse_Option (Opt (7 .. Opt'Last)) then
+ return 1;
+ else
+ return 0;
+ end if;
+ elsif Options.Parse_Option (Opt.all) then
+ return 1;
+ else
+ return 0;
+ end if;
+ end Decode_Option;
+
+
+ -- Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in
+ -- the currently analyzed design file.
+ function Is_Obsolete (Design_Unit : Iir_Design_Unit)
+ return Boolean
+ is
+ List : Iir_List;
+ El : Iir;
+ begin
+ if Get_Date (Design_Unit) = Date_Obsolete then
+ return True;
+ end if;
+ List := Get_Dependence_List (Design_Unit);
+ if Is_Null_List (List) then
+ return False;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when Is_Null (El);
+ -- FIXME: there may be entity_aspect_entity...
+ if Get_Kind (El) = Iir_Kind_Design_Unit
+ and then Get_Date (El) = Date_Obsolete
+ then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Is_Obsolete;
+
+ Nbr_Parse : Natural := 0;
+
+ function Parse (Filename : String_Acc) return Boolean
+ is
+ Res : Iir_Design_File;
+ New_Design_File : Iir_Design_File;
+ Design : Iir_Design_Unit;
+ Next_Design : Iir_Design_Unit;
+
+ -- The vhdl filename to compile.
+ Vhdl_File : Name_Id;
+ begin
+ if Nbr_Parse = 0 then
+ -- Initialize only once...
+ Libraries.Load_Std_Library;
+
+ -- Here, time_base can be set.
+ Translation.Initialize;
+ Canon.Canon_Flag_Add_Labels := True;
+
+ if Flags.List_All and then Flags.List_Annotate then
+ Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
+ end if;
+
+ if Action = Action_Anaelab and then Anaelab_Files /= null
+ then
+ Libraries.Load_Work_Library (True);
+ else
+ Libraries.Load_Work_Library (False);
+ end if;
+ end if;
+ Nbr_Parse := Nbr_Parse + 1;
+
+ case Action is
+ when Action_Elaborate =>
+ Flags.Flag_Elaborate := True;
+ Flags.Flag_Only_Elab_Warnings := True;
+ Translation.Chap12.Elaborate
+ (Elab_Entity.all, Elab_Architecture.all,
+ Elab_Filelist.all, False);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+ when Action_Anaelab =>
+ -- Parse files.
+ if Anaelab_Files = null then
+ Flags.Flag_Elaborate_With_Outdated := False;
+ else
+ Flags.Flag_Elaborate_With_Outdated := True;
+ declare
+ L : Id_Link_Acc;
+ begin
+ L := Anaelab_Files;
+ while L /= null loop
+ Res := Libraries.Load_File (L.Id);
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Put units into library.
+ Design := Get_First_Design_Unit (Res);
+ while not Is_Null (Design) loop
+ Next_Design := Get_Chain (Design);
+ Set_Chain (Design, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Design);
+ Design := Next_Design;
+ end loop;
+ L := L.Link;
+ end loop;
+ end;
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Flags.Flag_Only_Elab_Warnings := False;
+ Translation.Chap12.Elaborate
+ (Elab_Entity.all, Elab_Architecture.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+ when Action_Compile_Std_Package =>
+ if Filename /= null then
+ Error_Msg_Option
+ ("--compile-standard is not compatible with a filename");
+ return False;
+ end if;
+ Translation.Translate_Standard (True);
+
+ when Action_Compile =>
+ if Filename = null then
+ Error_Msg_Option ("no input file");
+ return False;
+ end if;
+ if Nbr_Parse > 1 then
+ Error_Msg_Option ("can compile only one file (file """ &
+ Filename.all & """ ignored)");
+ return False;
+ end if;
+ Vhdl_File := Name_Table.Get_Identifier (Filename.all);
+
+ Translation.Translate_Standard (False);
+
+ Flags.Flag_Elaborate := False;
+ Res := Libraries.Load_File (Vhdl_File);
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Semantize all design units.
+ -- FIXME: outdate the design file?
+ New_Design_File := Null_Iir;
+ Design := Get_First_Design_Unit (Res);
+ while not Is_Null (Design) loop
+ -- Sem, canon, annotate a design unit.
+ Back_End.Finish_Compilation (Design, True);
+
+ Next_Design := Get_Chain (Design);
+ if Errorout.Nbr_Errors = 0 then
+ Set_Chain (Design, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Design);
+ New_Design_File := Get_Design_File (Design);
+ end if;
+
+ Design := Next_Design;
+ end loop;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Do late analysis checks.
+ Design := Get_First_Design_Unit (New_Design_File);
+ while not Is_Null (Design) loop
+ Sem.Sem_Analysis_Checks_List
+ (Design, Flags.Warn_Delayed_Checks);
+ Design := Get_Chain (Design);
+ end loop;
+
+ -- Compile only now.
+ if not Is_Null (New_Design_File) then
+ -- Note: the order of design unit is kept.
+ Design := Get_First_Design_Unit (New_Design_File);
+ while not Is_Null (Design) loop
+ if not Is_Obsolete (Design) then
+
+ if Get_Kind (Get_Library_Unit (Design))
+ = Iir_Kind_Configuration_Declaration
+ then
+ -- Defer code generation of configuration declaration.
+ -- (default binding may change between analysis and
+ -- elaboration).
+ Translation.Translate (Design, False);
+ else
+ Translation.Translate (Design, True);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This can happen (foreign attribute).
+ raise Compilation_Error;
+ end if;
+ end if;
+
+ Design := Get_Chain (Design);
+ end loop;
+ end if;
+
+ -- Save the working library.
+ Libraries.Save_Work_Library;
+ end case;
+ if Flag_Expect_Failure then
+ return False;
+ else
+ return True;
+ end if;
+ exception
+ --when File_Error =>
+ -- Error_Msg_Option ("cannot open file '" & Filename.all & "'");
+ -- return False;
+ when Compilation_Error
+ | Parse_Error =>
+ if Flag_Expect_Failure then
+ -- Very brutal...
+ GNAT.OS_Lib.OS_Exit (0);
+ end if;
+ return False;
+ when Option_Error =>
+ return False;
+ when E: others =>
+ Bug.Disp_Bug_Box (E);
+ raise;
+ end Parse;
+end Ortho_Front;
diff --git a/src/translate/trans_analyzes.adb b/src/translate/trans_analyzes.adb
new file mode 100644
index 000000000..8147e93bd
--- /dev/null
+++ b/src/translate/trans_analyzes.adb
@@ -0,0 +1,182 @@
+-- Analysis for translation.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Iirs_Utils; use Iirs_Utils;
+with Iirs_Walk; use Iirs_Walk;
+with Disp_Vhdl;
+with Ada.Text_IO;
+with Errorout;
+
+package body Trans_Analyzes is
+ Driver_List : Iir_List;
+
+ Has_After : Boolean;
+ function Extract_Driver_Target (Target : Iir) return Walk_Status
+ is
+ Base : Iir;
+ Prefix : Iir;
+ begin
+ Base := Get_Object_Prefix (Target);
+ -- Assigment to subprogram interface does not create a driver.
+ if Get_Kind (Base) = Iir_Kind_Interface_Signal_Declaration
+ and then
+ Get_Kind (Get_Parent (Base)) = Iir_Kind_Procedure_Declaration
+ then
+ return Walk_Continue;
+ end if;
+
+ Prefix := Get_Longuest_Static_Prefix (Target);
+ Add_Element (Driver_List, Prefix);
+ if Has_After then
+ Set_After_Drivers_Flag (Base, True);
+ end if;
+ return Walk_Continue;
+ end Extract_Driver_Target;
+
+ function Extract_Driver_Stmt (Stmt : Iir) return Walk_Status
+ is
+ Status : Walk_Status;
+ pragma Unreferenced (Status);
+ We : Iir;
+ begin
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Signal_Assignment_Statement =>
+ We := Get_Waveform_Chain (Stmt);
+ if We /= Null_Iir
+ and then Get_Chain (We) = Null_Iir
+ and then Get_Time (We) = Null_Iir
+ and then Get_Kind (Get_We_Value (We)) /= Iir_Kind_Null_Literal
+ then
+ Has_After := False;
+ else
+ Has_After := True;
+ end if;
+ Status := Walk_Assignment_Target
+ (Get_Target (Stmt), Extract_Driver_Target'Access);
+ when Iir_Kind_Procedure_Call_Statement =>
+ declare
+ Call : constant Iir := Get_Procedure_Call (Stmt);
+ Assoc : Iir;
+ Formal : Iir;
+ Inter : Iir;
+ begin
+ -- Very pessimist.
+ Has_After := True;
+
+ Assoc := Get_Parameter_Association_Chain (Call);
+ Inter := Get_Interface_Declaration_Chain
+ (Get_Implementation (Call));
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ if Formal = Null_Iir then
+ Formal := Inter;
+ Inter := Get_Chain (Inter);
+ else
+ Formal := Get_Association_Interface (Assoc);
+ end if;
+ if Get_Kind (Assoc)
+ = Iir_Kind_Association_Element_By_Expression
+ and then
+ Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration
+ and then Get_Mode (Formal) /= Iir_In_Mode
+ then
+ Status := Extract_Driver_Target (Get_Actual (Assoc));
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end;
+ when others =>
+ null;
+ end case;
+ return Walk_Continue;
+ end Extract_Driver_Stmt;
+
+ procedure Extract_Drivers_Sequential_Stmt_Chain (Chain : Iir)
+ is
+ Status : Walk_Status;
+ pragma Unreferenced (Status);
+ begin
+ Status := Walk_Sequential_Stmt_Chain (Chain, Extract_Driver_Stmt'Access);
+ end Extract_Drivers_Sequential_Stmt_Chain;
+
+ procedure Extract_Drivers_Declaration_Chain (Chain : Iir)
+ is
+ Decl : Iir := Chain;
+ begin
+ while Decl /= Null_Iir loop
+
+ -- Only procedures and impure functions may contain assignment.
+ if Get_Kind (Decl) = Iir_Kind_Procedure_Body
+ or else (Get_Kind (Decl) = Iir_Kind_Function_Body
+ and then
+ not Get_Pure_Flag (Get_Subprogram_Specification (Decl)))
+ then
+ Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl));
+ Extract_Drivers_Sequential_Stmt_Chain
+ (Get_Sequential_Statement_Chain (Decl));
+ end if;
+
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Extract_Drivers_Declaration_Chain;
+
+ function Extract_Drivers (Proc : Iir) return Iir_List
+ is
+ begin
+ Driver_List := Create_Iir_List;
+ Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Proc));
+ Extract_Drivers_Sequential_Stmt_Chain
+ (Get_Sequential_Statement_Chain (Proc));
+
+ return Driver_List;
+ end Extract_Drivers;
+
+ procedure Free_Drivers_List (List : in out Iir_List)
+ is
+ El : Iir;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Set_After_Drivers_Flag (Get_Object_Prefix (El), False);
+ end loop;
+ Destroy_Iir_List (List);
+ end Free_Drivers_List;
+
+ procedure Dump_Drivers (Proc : Iir; List : Iir_List)
+ is
+ use Ada.Text_IO;
+ use Errorout;
+ El : Iir;
+ begin
+ Put_Line ("List of drivers for " & Disp_Node (Proc) & ":");
+ Put_Line (" (declared at " & Disp_Location (Proc) & ")");
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Get_After_Drivers_Flag (Get_Object_Prefix (El)) then
+ Put ("* ");
+ else
+ Put (" ");
+ end if;
+ Disp_Vhdl.Disp_Vhdl (El);
+ New_Line;
+ end loop;
+ end Dump_Drivers;
+
+end Trans_Analyzes;
diff --git a/src/translate/trans_analyzes.ads b/src/translate/trans_analyzes.ads
new file mode 100644
index 000000000..ecebb7597
--- /dev/null
+++ b/src/translate/trans_analyzes.ads
@@ -0,0 +1,31 @@
+-- Analysis for translation.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Iirs; use Iirs;
+
+package Trans_Analyzes is
+ -- Extract a list of drivers from PROC.
+ function Extract_Drivers (Proc : Iir) return Iir_List;
+
+ -- Free the list.
+ procedure Free_Drivers_List (List : in out Iir_List);
+
+ -- Dump list of drivers (LIST) for process PROC.
+ procedure Dump_Drivers (Proc : Iir; List : Iir_List);
+
+end Trans_Analyzes;
diff --git a/src/translate/trans_be.adb b/src/translate/trans_be.adb
new file mode 100644
index 000000000..dd1b6c338
--- /dev/null
+++ b/src/translate/trans_be.adb
@@ -0,0 +1,182 @@
+-- Back-end for translation.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+with Disp_Tree;
+with Disp_Vhdl;
+with Sem;
+with Canon;
+with Translation;
+with Errorout; use Errorout;
+with Post_Sems;
+with Flags;
+with Ada.Text_IO;
+with Back_End;
+
+package body Trans_Be is
+ procedure Finish_Compilation
+ (Unit : Iir_Design_Unit; Main : Boolean := False)
+ is
+ use Ada.Text_IO;
+ Lib : Iir;
+ begin
+ -- No need to semantize during elaboration.
+ --if Flags.Will_Elaborate then
+ -- return;
+ --end if;
+
+ Lib := Get_Library_Unit (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Parse then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ -- Semantic analysis.
+ if Flags.Verbose then
+ Put_Line ("semantize " & Disp_Node (Lib));
+ end if;
+ Sem.Semantic (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Sem then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Sem then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ -- Post checks
+ ----------------
+
+ Post_Sems.Post_Sem_Checks (Unit);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ -- Canonalisation.
+ ------------------
+ if Flags.Verbose then
+ Put_Line ("canonicalize " & Disp_Node (Lib));
+ end if;
+
+ Canon.Canonicalize (Unit);
+
+ if (Main or Flags.Dump_All) and then Flags.Dump_Canon then
+ Disp_Tree.Disp_Tree (Unit);
+ end if;
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Unit);
+ end if;
+
+ if Flags.Flag_Elaborate then
+ if Get_Kind (Lib) = Iir_Kind_Architecture_Body then
+ declare
+ Config : Iir_Design_Unit;
+ begin
+ Config := Canon.Create_Default_Configuration_Declaration (Lib);
+ Set_Default_Configuration_Declaration (Lib, Config);
+ if (Main or Flags.Dump_All) and then Flags.Dump_Canon then
+ Disp_Tree.Disp_Tree (Config);
+ end if;
+ if (Main or Flags.List_All) and then Flags.List_Canon then
+ Disp_Vhdl.Disp_Vhdl (Config);
+ end if;
+ end;
+ end if;
+
+ -- Do not translate during elaboration.
+ -- This is done directly in Translation.Chap12.
+ return;
+ end if;
+
+ -- Translation
+ ---------------
+ if not Main then
+ -- Main units (those from the analyzed design file) are translated
+ -- directly by ortho_front.
+
+ Translation.Translate (Unit, Main);
+
+ if Errorout.Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+ end if;
+
+ end Finish_Compilation;
+
+ procedure Sem_Foreign (Decl : Iir)
+ is
+ use Translation;
+ Fi : Foreign_Info_Type;
+ pragma Unreferenced (Fi);
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Architecture_Body =>
+ Error_Msg_Sem ("FOREIGN architectures are not yet handled", Decl);
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("sem_foreign", Decl);
+ end case;
+ -- Let is generate error messages.
+ Fi := Translate_Foreign_Id (Decl);
+ end Sem_Foreign;
+
+ function Parse_Option (Opt : String) return Boolean is
+ begin
+ if Opt = "--dump-drivers" then
+ Translation.Flag_Dump_Drivers := True;
+ elsif Opt = "--no-direct-drivers" then
+ Translation.Flag_Direct_Drivers := False;
+ elsif Opt = "--no-range-checks" then
+ Translation.Flag_Range_Checks := False;
+ elsif Opt = "--no-index-checks" then
+ Translation.Flag_Index_Checks := False;
+ elsif Opt = "--no-identifiers" then
+ Translation.Flag_Discard_Identifiers := True;
+ else
+ return False;
+ end if;
+ return True;
+ end Parse_Option;
+
+ procedure Disp_Option
+ is
+ procedure P (Str : String) renames Ada.Text_IO.Put_Line;
+ begin
+ P (" --dump-drivers dump processes drivers");
+ end Disp_Option;
+
+ procedure Register_Translation_Back_End is
+ begin
+ Back_End.Finish_Compilation := Finish_Compilation'Access;
+ Back_End.Sem_Foreign := Sem_Foreign'Access;
+ Back_End.Parse_Option := Parse_Option'Access;
+ Back_End.Disp_Option := Disp_Option'Access;
+ end Register_Translation_Back_End;
+end Trans_Be;
diff --git a/src/translate/trans_be.ads b/src/translate/trans_be.ads
new file mode 100644
index 000000000..9ff06031b
--- /dev/null
+++ b/src/translate/trans_be.ads
@@ -0,0 +1,21 @@
+-- Back-end for translation.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Trans_Be is
+ procedure Register_Translation_Back_End;
+end Trans_Be;
+
diff --git a/src/translate/trans_decls.ads b/src/translate/trans_decls.ads
new file mode 100644
index 000000000..e104c71c4
--- /dev/null
+++ b/src/translate/trans_decls.ads
@@ -0,0 +1,257 @@
+-- Declarations for well-known nodes generated by translation.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ortho_Nodes; use Ortho_Nodes;
+
+package Trans_Decls is
+ -- Procedures called in case of assert failed.
+ Ghdl_Assert_Failed : O_Dnode;
+ Ghdl_Ieee_Assert_Failed : O_Dnode;
+ Ghdl_Psl_Assert_Failed : O_Dnode;
+
+ Ghdl_Psl_Cover : O_Dnode;
+ Ghdl_Psl_Cover_Failed : O_Dnode;
+ -- Procedure for report statement.
+ Ghdl_Report : O_Dnode;
+
+ -- Register a process.
+ Ghdl_Process_Register : O_Dnode;
+ Ghdl_Sensitized_Process_Register : O_Dnode;
+ Ghdl_Postponed_Process_Register : O_Dnode;
+ Ghdl_Postponed_Sensitized_Process_Register : O_Dnode;
+
+ Ghdl_Finalize_Register : O_Dnode;
+
+ -- Wait subprograms.
+ -- Short forms.
+ Ghdl_Process_Wait_Timeout : O_Dnode;
+ Ghdl_Process_Wait_Exit : O_Dnode;
+ -- Complete form:
+ Ghdl_Process_Wait_Set_Timeout : O_Dnode;
+ Ghdl_Process_Wait_Add_Sensitivity : O_Dnode;
+ Ghdl_Process_Wait_Suspend : O_Dnode;
+ Ghdl_Process_Wait_Close : O_Dnode;
+
+ -- Register a sensitivity for a process.
+ Ghdl_Process_Add_Sensitivity : O_Dnode;
+
+ -- Register a driver for a process.
+ Ghdl_Process_Add_Driver : O_Dnode;
+ Ghdl_Signal_Add_Direct_Driver : O_Dnode;
+
+ -- NOW variable.
+ Ghdl_Now : O_Dnode;
+
+ -- Protected variables.
+ Ghdl_Protected_Enter : O_Dnode;
+ Ghdl_Protected_Leave : O_Dnode;
+ Ghdl_Protected_Init : O_Dnode;
+ Ghdl_Protected_Fini : O_Dnode;
+
+ Ghdl_Signal_Set_Disconnect : O_Dnode;
+ Ghdl_Signal_Disconnect : O_Dnode;
+
+ Ghdl_Signal_Driving : O_Dnode;
+
+ Ghdl_Signal_Direct_Assign : O_Dnode;
+
+ Ghdl_Signal_Simple_Assign_Error : O_Dnode;
+ Ghdl_Signal_Start_Assign_Error : O_Dnode;
+ Ghdl_Signal_Next_Assign_Error : O_Dnode;
+
+ Ghdl_Signal_Start_Assign_Null : O_Dnode;
+ Ghdl_Signal_Next_Assign_Null : O_Dnode;
+
+ Ghdl_Create_Signal_E8 : O_Dnode;
+ Ghdl_Signal_Init_E8 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_E8 : O_Dnode;
+ Ghdl_Signal_Start_Assign_E8 : O_Dnode;
+ Ghdl_Signal_Next_Assign_E8 : O_Dnode;
+ Ghdl_Signal_Associate_E8 : O_Dnode;
+ Ghdl_Signal_Driving_Value_E8 : O_Dnode;
+
+ Ghdl_Create_Signal_E32 : O_Dnode;
+ Ghdl_Signal_Init_E32 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_E32 : O_Dnode;
+ Ghdl_Signal_Start_Assign_E32 : O_Dnode;
+ Ghdl_Signal_Next_Assign_E32 : O_Dnode;
+ Ghdl_Signal_Associate_E32 : O_Dnode;
+ Ghdl_Signal_Driving_Value_E32 : O_Dnode;
+
+ Ghdl_Create_Signal_B1 : O_Dnode;
+ Ghdl_Signal_Init_B1 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_B1 : O_Dnode;
+ Ghdl_Signal_Start_Assign_B1 : O_Dnode;
+ Ghdl_Signal_Next_Assign_B1 : O_Dnode;
+ Ghdl_Signal_Associate_B1 : O_Dnode;
+ Ghdl_Signal_Driving_Value_B1 : O_Dnode;
+
+ Ghdl_Create_Signal_I32 : O_Dnode;
+ Ghdl_Signal_Init_I32 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_I32 : O_Dnode;
+ Ghdl_Signal_Start_Assign_I32 : O_Dnode;
+ Ghdl_Signal_Next_Assign_I32 : O_Dnode;
+ Ghdl_Signal_Associate_I32 : O_Dnode;
+ Ghdl_Signal_Driving_Value_I32 : O_Dnode;
+
+ Ghdl_Create_Signal_F64 : O_Dnode;
+ Ghdl_Signal_Init_F64 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_F64 : O_Dnode;
+ Ghdl_Signal_Start_Assign_F64 : O_Dnode;
+ Ghdl_Signal_Next_Assign_F64 : O_Dnode;
+ Ghdl_Signal_Associate_F64 : O_Dnode;
+ Ghdl_Signal_Driving_Value_F64 : O_Dnode;
+
+ Ghdl_Create_Signal_I64 : O_Dnode;
+ Ghdl_Signal_Init_I64 : O_Dnode;
+ Ghdl_Signal_Simple_Assign_I64 : O_Dnode;
+ Ghdl_Signal_Start_Assign_I64 : O_Dnode;
+ Ghdl_Signal_Next_Assign_I64 : O_Dnode;
+ Ghdl_Signal_Associate_I64 : O_Dnode;
+ Ghdl_Signal_Driving_Value_I64 : O_Dnode;
+
+ Ghdl_Signal_In_Conversion : O_Dnode;
+ Ghdl_Signal_Out_Conversion : O_Dnode;
+
+ Ghdl_Signal_Add_Source : O_Dnode;
+ Ghdl_Signal_Effective_Value : O_Dnode;
+
+ Ghdl_Signal_Create_Resolution : O_Dnode;
+
+ Ghdl_Signal_Name_Rti : O_Dnode;
+ Ghdl_Signal_Merge_Rti : O_Dnode;
+
+ Ghdl_Signal_Get_Nbr_Drivers : O_Dnode;
+ Ghdl_Signal_Get_Nbr_Ports: O_Dnode;
+ Ghdl_Signal_Read_Driver : O_Dnode;
+ Ghdl_Signal_Read_Port : O_Dnode;
+
+ -- Signal attribute.
+ Ghdl_Create_Stable_Signal : O_Dnode;
+ Ghdl_Create_Quiet_Signal : O_Dnode;
+ Ghdl_Create_Transaction_Signal : O_Dnode;
+ Ghdl_Signal_Attribute_Register_Prefix : O_Dnode;
+ Ghdl_Create_Delayed_Signal : O_Dnode;
+
+ -- Guard signal.
+ Ghdl_Signal_Create_Guard : O_Dnode;
+ Ghdl_Signal_Guard_Dependence : O_Dnode;
+
+ -- Predefined subprograms.
+ Ghdl_Memcpy : O_Dnode;
+ Ghdl_Deallocate : O_Dnode;
+ Ghdl_Malloc : O_Dnode;
+ Ghdl_Malloc0 : O_Dnode;
+ Ghdl_Real_Exp : O_Dnode;
+ Ghdl_Integer_Exp : O_Dnode;
+
+ -- Procedure called in case of check failed.
+ Ghdl_Program_Error : O_Dnode;
+ Ghdl_Bound_Check_Failed_L1 : O_Dnode;
+
+ -- Stack 2.
+ Ghdl_Stack2_Allocate : O_Dnode;
+ Ghdl_Stack2_Mark : O_Dnode;
+ Ghdl_Stack2_Release : O_Dnode;
+
+ Std_Standard_Boolean_Rti : O_Dnode;
+ Std_Standard_Bit_Rti : O_Dnode;
+
+ -- Predefined file subprograms.
+ Ghdl_Text_File_Elaborate : O_Dnode;
+ Ghdl_File_Elaborate : O_Dnode;
+
+ Ghdl_Text_File_Finalize : O_Dnode;
+ Ghdl_File_Finalize : O_Dnode;
+
+ Ghdl_Text_File_Open : O_Dnode;
+ Ghdl_File_Open : O_Dnode;
+
+ Ghdl_Text_File_Open_Status : O_Dnode;
+ Ghdl_File_Open_Status : O_Dnode;
+
+ Ghdl_Text_Write : O_Dnode;
+ Ghdl_Write_Scalar : O_Dnode;
+
+ Ghdl_Read_Scalar : O_Dnode;
+
+ Ghdl_Text_Read_Length : O_Dnode;
+
+ Ghdl_Text_File_Close : O_Dnode;
+ Ghdl_File_Close : O_Dnode;
+ Ghdl_File_Flush : O_Dnode;
+
+ Ghdl_File_Endfile : O_Dnode;
+
+ -- 'Image attributes.
+ Ghdl_Image_B1 : O_Dnode;
+ Ghdl_Image_E8 : O_Dnode;
+ Ghdl_Image_E32 : O_Dnode;
+ Ghdl_Image_I32 : O_Dnode;
+ Ghdl_Image_P32 : O_Dnode;
+ Ghdl_Image_P64 : O_Dnode;
+ Ghdl_Image_F64 : O_Dnode;
+
+ -- 'Value attributes
+ Ghdl_Value_B1 : O_Dnode;
+ Ghdl_Value_E8 : O_Dnode;
+ Ghdl_Value_E32 : O_Dnode;
+ Ghdl_Value_I32 : O_Dnode;
+ Ghdl_Value_P32 : O_Dnode;
+ Ghdl_Value_P64 : O_Dnode;
+ Ghdl_Value_F64 : O_Dnode;
+
+ -- 'Path_Name
+ Ghdl_Get_Path_Name : O_Dnode;
+ Ghdl_Get_Instance_Name : O_Dnode;
+
+ -- For PSL.
+ Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode;
+
+ -- For std_logic_1164 (vhdl 2008).
+ Ghdl_Std_Ulogic_Match_Eq : O_Dnode;
+ Ghdl_Std_Ulogic_Match_Ne : O_Dnode;
+ Ghdl_Std_Ulogic_Match_Lt : O_Dnode;
+ Ghdl_Std_Ulogic_Match_Le : O_Dnode;
+ Ghdl_Std_Ulogic_Array_Match_Eq : O_Dnode;
+ Ghdl_Std_Ulogic_Array_Match_Ne : O_Dnode;
+
+ -- For To_String (vhdl 2008).
+ Ghdl_To_String_I32 : O_Dnode;
+ Ghdl_To_String_F64 : O_Dnode;
+ Ghdl_To_String_F64_Digits : O_Dnode;
+ Ghdl_To_String_F64_Format : O_Dnode;
+ Ghdl_To_String_B1 : O_Dnode;
+ Ghdl_To_String_E8 : O_Dnode;
+ Ghdl_To_String_E32 : O_Dnode;
+ Ghdl_To_String_Char : O_Dnode;
+ Ghdl_To_String_P32 : O_Dnode;
+ Ghdl_To_String_P64 : O_Dnode;
+ Ghdl_Time_To_String_Unit : O_Dnode;
+ Ghdl_Array_Char_To_String_B1 : O_Dnode;
+ Ghdl_Array_Char_To_String_E8 : O_Dnode;
+ Ghdl_Array_Char_To_String_E32 : O_Dnode;
+ Ghdl_BV_To_String : O_Dnode;
+ Ghdl_BV_To_Ostring : O_Dnode;
+ Ghdl_BV_To_Hstring : O_Dnode;
+
+ -- Register a package
+ Ghdl_Rti_Add_Package : O_Dnode;
+ Ghdl_Rti_Add_Top : O_Dnode;
+
+ Ghdl_Elaborate : O_Dnode;
+end Trans_Decls;
diff --git a/src/translate/translation.adb b/src/translate/translation.adb
new file mode 100644
index 000000000..7c5fbe85c
--- /dev/null
+++ b/src/translate/translation.adb
@@ -0,0 +1,31355 @@
+-- Iir to ortho translator.
+-- Copyright (C) 2002, 2003, 2004, 2005, 2006 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+with Ortho_Nodes; use Ortho_Nodes;
+with Ortho_Ident; use Ortho_Ident;
+with Evaluation; use Evaluation;
+with Flags; use Flags;
+with Ada.Text_IO;
+with Types; use Types;
+with Errorout; use Errorout;
+with Name_Table; -- use Name_Table;
+with Iirs_Utils; use Iirs_Utils;
+with Std_Package; use Std_Package;
+with Libraries;
+with Files_Map;
+with Std_Names;
+with Configuration;
+with Interfaces.C_Streams;
+with Sem_Names;
+with Sem_Inst;
+with Sem;
+with Iir_Chains; use Iir_Chains;
+with Nodes;
+with Nodes_Meta;
+with GNAT.Table;
+with Ieee.Std_Logic_1164;
+with Canon;
+with Canon_PSL;
+with PSL.Nodes;
+with PSL.NFAs;
+with PSL.NFAs.Utils;
+with Trans_Decls; use Trans_Decls;
+with Trans_Analyzes;
+
+package body Translation is
+
+ -- Ortho type node for STD.BOOLEAN.
+ Std_Boolean_Type_Node : O_Tnode;
+ Std_Boolean_True_Node : O_Cnode;
+ Std_Boolean_False_Node : O_Cnode;
+ -- Array of STD.BOOLEAN.
+ Std_Boolean_Array_Type : O_Tnode;
+ -- Std_ulogic indexed array of STD.Boolean.
+ Std_Ulogic_Boolean_Array_Type : O_Tnode;
+ -- Ortho type node for string template pointer.
+ Std_String_Ptr_Node : O_Tnode;
+ Std_String_Node : O_Tnode;
+
+ -- Ortho type for std.standard.integer.
+ Std_Integer_Otype : O_Tnode;
+
+ -- Ortho type for std.standard.real.
+ Std_Real_Otype : O_Tnode;
+
+ -- Ortho type node for std.standard.time.
+ Std_Time_Otype : O_Tnode;
+
+ -- Node for the variable containing the current filename.
+ Current_Filename_Node : O_Dnode := O_Dnode_Null;
+ Current_Library_Unit : Iir := Null_Iir;
+
+ -- Global declarations.
+ Ghdl_Ptr_Type : O_Tnode;
+ Sizetype : O_Tnode;
+ Ghdl_I32_Type : O_Tnode;
+ Ghdl_I64_Type : O_Tnode;
+ Ghdl_Real_Type : O_Tnode;
+ -- Constant character.
+ Char_Type_Node : O_Tnode;
+ -- Array of char.
+ Chararray_Type : O_Tnode;
+ -- Pointer to array of char.
+ Char_Ptr_Type : O_Tnode;
+ -- Array of char ptr.
+ Char_Ptr_Array_Type : O_Tnode;
+ Char_Ptr_Array_Ptr_Type : O_Tnode;
+
+ Ghdl_Index_Type : O_Tnode;
+ Ghdl_Index_0 : O_Cnode;
+ Ghdl_Index_1 : O_Cnode;
+
+ -- Type for a file (this is in fact a index in a private table).
+ Ghdl_File_Index_Type : O_Tnode;
+ Ghdl_File_Index_Ptr_Type : O_Tnode;
+
+ -- Record containing a len and string fields.
+ Ghdl_Str_Len_Type_Node : O_Tnode;
+ Ghdl_Str_Len_Type_Len_Field : O_Fnode;
+ Ghdl_Str_Len_Type_Str_Field : O_Fnode;
+ Ghdl_Str_Len_Ptr_Node : O_Tnode;
+ Ghdl_Str_Len_Array_Type_Node : O_Tnode;
+
+ -- Location.
+ Ghdl_Location_Type_Node : O_Tnode;
+ Ghdl_Location_Filename_Node : O_Fnode;
+ Ghdl_Location_Line_Node : O_Fnode;
+ Ghdl_Location_Col_Node : O_Fnode;
+ Ghdl_Location_Ptr_Node : O_Tnode;
+
+ -- Allocate memory for a block.
+ Ghdl_Alloc_Ptr : O_Dnode;
+
+ -- bool type.
+ Ghdl_Bool_Type : O_Tnode;
+ type Enode_Boolean_Array is array (Boolean) of O_Cnode;
+ Ghdl_Bool_Nodes : Enode_Boolean_Array;
+ Ghdl_Bool_False_Node : O_Cnode renames Ghdl_Bool_Nodes (False);
+ Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True);
+
+ Ghdl_Bool_Array_Type : O_Tnode;
+ Ghdl_Bool_Array_Ptr : O_Tnode;
+
+ -- Comparaison type.
+ Ghdl_Compare_Type : O_Tnode;
+ Ghdl_Compare_Lt : O_Cnode;
+ Ghdl_Compare_Eq : O_Cnode;
+ Ghdl_Compare_Gt : O_Cnode;
+
+ -- Dir type.
+ Ghdl_Dir_Type_Node : O_Tnode;
+ Ghdl_Dir_To_Node : O_Cnode;
+ Ghdl_Dir_Downto_Node : O_Cnode;
+
+ -- Signals.
+ Ghdl_Scalar_Bytes : O_Tnode;
+ Ghdl_Signal_Type : O_Tnode;
+ Ghdl_Signal_Value_Field : O_Fnode;
+ Ghdl_Signal_Driving_Value_Field : O_Fnode;
+ Ghdl_Signal_Last_Value_Field : O_Fnode;
+ Ghdl_Signal_Last_Event_Field : O_Fnode;
+ Ghdl_Signal_Last_Active_Field : O_Fnode;
+ Ghdl_Signal_Event_Field : O_Fnode;
+ Ghdl_Signal_Active_Field : O_Fnode;
+ Ghdl_Signal_Has_Active_Field : O_Fnode;
+
+ Ghdl_Signal_Ptr : O_Tnode;
+ Ghdl_Signal_Ptr_Ptr : O_Tnode;
+
+ type Object_Kind_Type is (Mode_Value, Mode_Signal);
+
+ -- Well known identifiers.
+ Wki_This : O_Ident;
+ Wki_Size : O_Ident;
+ Wki_Res : O_Ident;
+ Wki_Dir_To : O_Ident;
+ Wki_Dir_Downto : O_Ident;
+ Wki_Left : O_Ident;
+ Wki_Right : O_Ident;
+ Wki_Dir : O_Ident;
+ Wki_Length : O_Ident;
+ Wki_I : O_Ident;
+ Wki_Instance : O_Ident;
+ Wki_Arch_Instance : O_Ident;
+ Wki_Name : O_Ident;
+ Wki_Sig : O_Ident;
+ Wki_Obj : O_Ident;
+ Wki_Rti : O_Ident;
+ Wki_Parent : O_Ident;
+ Wki_Filename : O_Ident;
+ Wki_Line : O_Ident;
+ Wki_Lo : O_Ident;
+ Wki_Hi : O_Ident;
+ Wki_Mid : O_Ident;
+ Wki_Cmp : O_Ident;
+ Wki_Upframe : O_Ident;
+ Wki_Frame : O_Ident;
+ Wki_Val : O_Ident;
+ Wki_L_Len : O_Ident;
+ Wki_R_Len : O_Ident;
+
+ -- ALLOCATION_KIND defines the type of memory storage.
+ -- ALLOC_STACK means the object is allocated on the local stack and
+ -- deallocated at the end of the function.
+ -- ALLOC_SYSTEM for object created during design elaboration and whose
+ -- life is infinite.
+ -- ALLOC_RETURN for unconstrained object returns by function.
+ -- ALLOC_HEAP for object created by new.
+ type Allocation_Kind is
+ (Alloc_Stack, Alloc_Return, Alloc_Heap, Alloc_System);
+
+ package Chap10 is
+ -- There are three data storage kind: global, local or instance.
+ -- For example, a constant can have:
+ -- * a global storage when declared inside a package. This storage
+ -- can be accessed from any point.
+ -- * a local storage when declared in a subprogram. This storage
+ -- can be accessed from the subprogram, is created when the subprogram
+ -- is called and destroy when the subprogram exit.
+ -- * an instance storage when declared inside a process. This storage
+ -- can be accessed from the process via an instance pointer, is
+ -- created during elaboration.
+ --procedure Push_Global_Factory (Storage : O_Storage);
+ --procedure Pop_Global_Factory;
+ procedure Set_Global_Storage (Storage : O_Storage);
+
+ -- Set the global scope handling.
+ Global_Storage : O_Storage;
+
+ -- Scope for variables. This is used both to build instances (so it
+ -- contains the record type that contains objects declared in that
+ -- scope) and to use instances (it contains the path to access to these
+ -- objects).
+ type Var_Scope_Type is private;
+
+ type Var_Scope_Acc is access all Var_Scope_Type;
+ for Var_Scope_Acc'Storage_Size use 0;
+
+ Null_Var_Scope : constant Var_Scope_Type;
+
+ type Var_Type is private;
+ Null_Var : constant Var_Type;
+
+ -- Return the record type for SCOPE.
+ function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode;
+
+ -- Return the size for instances of SCOPE.
+ function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode;
+
+ -- Return True iff SCOPE is defined.
+ function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean;
+
+ -- Create an empty and incomplete scope type for SCOPE using NAME.
+ procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident);
+
+ -- Declare a pointer PTR_TYPE with NAME to scope type SCOPE.
+ procedure Declare_Scope_Acc
+ (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode);
+
+ -- Start to build an instance.
+ -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted
+ -- record type, that will be completed.
+ procedure Push_Instance_Factory (Scope : Var_Scope_Acc);
+
+ -- Manually add a field to the current instance being built.
+ function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode)
+ return O_Fnode;
+
+ -- In the scope being built, add a field NAME that contain sub-scope
+ -- CHILD. CHILD is modified so that accesses to CHILD objects is done
+ -- via SCOPE.
+ procedure Add_Scope_Field
+ (Name : O_Ident; Child : in out Var_Scope_Type);
+
+ -- Return the offset of field for CHILD in its parent scope.
+ function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode)
+ return O_Cnode;
+
+ -- Finish the building of the current instance and return the type
+ -- built.
+ procedure Pop_Instance_Factory (Scope : Var_Scope_Acc);
+
+ -- Create a new scope, in which variable are created locally
+ -- (ie, on the stack). Always created unlocked.
+ procedure Push_Local_Factory;
+
+ -- Destroy a local scope.
+ procedure Pop_Local_Factory;
+
+ -- Set_Scope defines how to access to variables of SCOPE.
+ -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD
+ -- in scope SCOPE_PARENT.
+ procedure Set_Scope_Via_Field
+ (Scope : in out Var_Scope_Type;
+ Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc);
+
+ -- Variables defined in SCOPE can be accessed by dereferencing
+ -- field SCOPE_FIELD defined in SCOPE_PARENT.
+ procedure Set_Scope_Via_Field_Ptr
+ (Scope : in out Var_Scope_Type;
+ Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc);
+
+ -- Variables/scopes defined in SCOPE can be accessed via
+ -- dereference of parameter SCOPE_PARAM.
+ procedure Set_Scope_Via_Param_Ptr
+ (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode);
+
+ -- Variables/scopes defined in SCOPE can be accessed via DECL.
+ procedure Set_Scope_Via_Decl
+ (Scope : in out Var_Scope_Type; Decl : O_Dnode);
+
+ -- Variables/scopes defined in SCOPE can be accessed by derefencing
+ -- VAR.
+ procedure Set_Scope_Via_Var_Ptr
+ (Scope : in out Var_Scope_Type; Var : Var_Type);
+
+ -- No more accesses to SCOPE_TYPE are allowed. Scopes must be cleared
+ -- before being set.
+ procedure Clear_Scope (Scope : in out Var_Scope_Type);
+
+ -- Reset the identifier.
+ type Id_Mark_Type is limited private;
+ type Local_Identifier_Type is private;
+
+ procedure Reset_Identifier_Prefix;
+ procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type;
+ Name : String;
+ Val : Iir_Int32 := 0);
+ procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type;
+ Name : Name_Id;
+ Val : Iir_Int32 := 0);
+ procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type);
+ procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type);
+
+ -- Save/restore the local identifier number; this is used by package
+ -- body, which has the same prefix as the package declaration, so it
+ -- must continue local identifiers numbers.
+ -- This is used by subprogram bodies too.
+ procedure Save_Local_Identifier (Id : out Local_Identifier_Type);
+ procedure Restore_Local_Identifier (Id : Local_Identifier_Type);
+
+ -- Create an identifier from IIR node ID without the prefix.
+ function Create_Identifier_Without_Prefix (Id : Iir)
+ return O_Ident;
+ function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String)
+ return O_Ident;
+
+ -- Create an identifier from the current prefix.
+ function Create_Identifier return O_Ident;
+
+ -- Create an identifier from IIR node ID with prefix.
+ function Create_Identifier (Id : Iir; Str : String := "")
+ return O_Ident;
+ function Create_Identifier
+ (Id : Iir; Val : Iir_Int32; Str : String := "")
+ return O_Ident;
+ function Create_Identifier (Id : Name_Id; Str : String := "")
+ return O_Ident;
+ -- Create a prefixed identifier from a string.
+ function Create_Identifier (Str : String) return O_Ident;
+
+ -- Create an identifier for a variable.
+ -- IE, if the variable is global, prepend the prefix,
+ -- if the variable belong to an instance, no prefix is added.
+ type Var_Ident_Type is private;
+ function Create_Var_Identifier (Id : Iir) return Var_Ident_Type;
+ function Create_Var_Identifier (Id : String) return Var_Ident_Type;
+ function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural)
+ return Var_Ident_Type;
+ function Create_Uniq_Identifier return Var_Ident_Type;
+
+ -- Create variable NAME of type VTYPE in the current scope.
+ -- If the current scope is the global scope, then a variable is
+ -- created at the top level (using decl_global_storage).
+ -- If the current scope is not the global scope, then a field is added
+ -- to the current scope.
+ function Create_Var
+ (Name : Var_Ident_Type;
+ Vtype : O_Tnode;
+ Storage : O_Storage := Global_Storage)
+ return Var_Type;
+
+ -- Create a global variable.
+ function Create_Global_Var
+ (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage)
+ return Var_Type;
+
+ -- Create a global constant and initialize it to INITIAL_VALUE.
+ function Create_Global_Const
+ (Name : O_Ident;
+ Vtype : O_Tnode;
+ Storage : O_Storage;
+ Initial_Value : O_Cnode)
+ return Var_Type;
+ procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode);
+
+ -- Return the (real) reference to a variable created by Create_Var.
+ function Get_Var (Var : Var_Type) return O_Lnode;
+
+ -- Return a reference to the instance of type ITYPE.
+ function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode;
+
+ -- Return the address of the instance for block BLOCK.
+ function Get_Instance_Access (Block : Iir) return O_Enode;
+
+ -- Return the storage for the variable VAR.
+ function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind;
+
+ -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced
+ -- several times.
+ function Is_Var_Stable (Var : Var_Type) return Boolean;
+
+ -- Used only to generate RTI.
+ function Is_Var_Field (Var : Var_Type) return Boolean;
+ function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode;
+ function Get_Var_Label (Var : Var_Type) return O_Dnode;
+
+ -- For package instantiation.
+
+ -- Associate INST_SCOPE as the instantiated scope for ORIG_SCOPE.
+ procedure Push_Instantiate_Var_Scope
+ (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc);
+
+ -- Remove the association for INST_SCOPE.
+ procedure Pop_Instantiate_Var_Scope
+ (Inst_Scope : Var_Scope_Acc);
+
+ -- Get the associated instantiated scope for SCOPE.
+ function Instantiated_Var_Scope (Scope : Var_Scope_Acc)
+ return Var_Scope_Acc;
+
+ -- Create a copy of VAR using instantiated scope (if needed).
+ function Instantiate_Var (Var : Var_Type) return Var_Type;
+
+ -- Create a copy of SCOPE using instantiated scope (if needed).
+ function Instantiate_Var_Scope (Scope : Var_Scope_Type)
+ return Var_Scope_Type;
+ private
+ type Local_Identifier_Type is new Natural;
+ type Id_Mark_Type is record
+ Len : Natural;
+ Local_Id : Local_Identifier_Type;
+ end record;
+
+ type Var_Ident_Type is record
+ Id : O_Ident;
+ end record;
+
+ -- An instance contains all the data (variable, signals, constant...)
+ -- which are declared by an entity and an architecture.
+ -- (An architecture inherits the data of its entity).
+ --
+ -- The processes and implicit guard signals of an entity/architecture
+ -- are translated into functions. The first argument of these functions
+ -- is a pointer to the instance.
+
+ type Inst_Build_Kind_Type is (Local, Global, Instance);
+ type Inst_Build_Type (Kind : Inst_Build_Kind_Type);
+ type Inst_Build_Acc is access Inst_Build_Type;
+ type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record
+ Prev : Inst_Build_Acc;
+ Prev_Id_Start : Natural;
+ case Kind is
+ when Local =>
+ -- Previous global storage.
+ Prev_Global_Storage : O_Storage;
+ when Global =>
+ null;
+ when Instance =>
+ Scope : Var_Scope_Acc;
+ Elements : O_Element_List;
+ end case;
+ end record;
+
+ -- Kind of variable:
+ -- VAR_NONE: the variable doesn't exist.
+ -- VAR_GLOBAL: the variable is a global variable (static or not).
+ -- VAR_LOCAL: the variable is on the stack.
+ -- VAR_SCOPE: the variable is in the instance record.
+ type Var_Kind is (Var_None, Var_Global, Var_Local, Var_Scope);
+
+ type Var_Type (Kind : Var_Kind := Var_None) is record
+ case Kind is
+ when Var_None =>
+ null;
+ when Var_Global
+ | Var_Local =>
+ E : O_Dnode;
+ when Var_Scope =>
+ I_Field : O_Fnode;
+ I_Scope : Var_Scope_Acc;
+ end case;
+ end record;
+
+ Null_Var : constant Var_Type := (Kind => Var_None);
+
+ type Var_Scope_Kind is (Var_Scope_None,
+ Var_Scope_Ptr,
+ Var_Scope_Decl,
+ Var_Scope_Field,
+ Var_Scope_Field_Ptr);
+
+ type Var_Scope_Type (Kind : Var_Scope_Kind := Var_Scope_None) is record
+ Scope_Type : O_Tnode := O_Tnode_Null;
+
+ case Kind is
+ when Var_Scope_None =>
+ -- Not set, cannot be referenced.
+ null;
+ when Var_Scope_Ptr
+ | Var_Scope_Decl =>
+ -- Instance for entity, architecture, component, subprogram,
+ -- resolver, process, guard function, PSL directive, PSL cover,
+ -- PSL assert, component instantiation elaborator
+ D : O_Dnode;
+ when Var_Scope_Field
+ | Var_Scope_Field_Ptr =>
+ -- For an entity: the architecture.
+ -- For an architecture: ptr to a generate subblock.
+ -- For a subprogram: parent frame
+ Field : O_Fnode;
+ Up_Link : Var_Scope_Acc;
+ end case;
+ end record;
+
+ Null_Var_Scope : constant Var_Scope_Type := (Scope_Type => O_Tnode_Null,
+ Kind => Var_Scope_None);
+
+ end Chap10;
+ use Chap10;
+
+ package Chap1 is
+ -- Declare types for block BLK
+ procedure Start_Block_Decl (Blk : Iir);
+
+ procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration);
+
+ -- Generate code to initialize generics of instance INSTANCE of ENTITY
+ -- using the default values.
+ -- This is used when ENTITY is at the top of a design hierarchy.
+ procedure Translate_Entity_Init (Entity : Iir);
+
+ procedure Translate_Architecture_Body (Arch : Iir);
+
+ -- CONFIG may be one of:
+ -- * configuration_declaration
+ -- * component_configuration
+ procedure Translate_Configuration_Declaration (Config : Iir);
+ end Chap1;
+
+ package Chap2 is
+ -- Subprogram specification being currently translated. This is used
+ -- for the return statement.
+ Current_Subprogram : Iir := Null_Iir;
+
+ procedure Translate_Subprogram_Interfaces (Spec : Iir);
+ procedure Elab_Subprogram_Interfaces (Spec : Iir);
+
+ procedure Translate_Subprogram_Declaration (Spec : Iir);
+ procedure Translate_Subprogram_Body (Subprg : Iir);
+
+ -- Set the identifier prefix with the subprogram identifier and
+ -- overload number if any.
+ procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type);
+
+ procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration);
+ procedure Translate_Package_Body (Decl : Iir_Package_Body);
+ procedure Translate_Package_Instantiation_Declaration (Inst : Iir);
+
+ procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir);
+
+ -- Add info for an interface_package_declaration or a
+ -- package_instantiation_declaration
+ procedure Instantiate_Info_Package (Inst : Iir);
+
+ -- Elaborate packages that DESIGN_UNIT depends on (except std.standard).
+ procedure Elab_Dependence (Design_Unit: Iir_Design_Unit);
+
+ -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to
+ -- it. The names are respectively INSTTYPE and INSTPTR.
+ procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc;
+ Ptr_Type : out O_Tnode);
+
+ -- Subprograms instances.
+ --
+ -- Subprograms declared inside entities, architecture, blocks
+ -- or processes (but not inside packages) may access to data declared
+ -- outside the subprogram (and this with a life longer than the
+ -- subprogram life). These data correspond to constants, variables,
+ -- files, signals or types. However these data are not shared between
+ -- instances of the same entity, architecture... Subprograms instances
+ -- is the way subprograms access to these data.
+ -- One subprogram instance corresponds to a record.
+
+ -- Type to save an old instance builder. Subprograms may have at most
+ -- one instance. If they need severals (for example a protected
+ -- subprogram), the most recent one will have a reference to the
+ -- previous one.
+ type Subprg_Instance_Stack is limited private;
+
+ -- Declare an instance to be added for subprograms.
+ -- DECL is the node for which the instance is created. This is used by
+ -- PUSH_SCOPE.
+ -- PTR_TYPE is a pointer to DECL_TYPE.
+ -- IDENT is an identifier for the interface.
+ -- The previous instance is stored to PREV. It must be restored with
+ -- Pop_Subprg_Instance.
+ -- Add_Subprg_Instance_Interfaces will add an interface of name IDENT
+ -- and type PTR_TYPE for every instance declared by
+ -- PUSH_SUBPRG_INSTANCE.
+ procedure Push_Subprg_Instance (Scope : Var_Scope_Acc;
+ Ptr_Type : O_Tnode;
+ Ident : O_Ident;
+ Prev : out Subprg_Instance_Stack);
+
+ -- Since local subprograms has a direct access to its father interfaces,
+ -- they do not required instances interfaces.
+ -- These procedures are provided to temporarly disable the addition of
+ -- instances interfaces. Use Pop_Subpg_Instance to restore to the
+ -- previous state.
+ procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack);
+
+ -- Revert of the previous subprogram.
+ -- Instances must be removed in opposite order they are added.
+ procedure Pop_Subprg_Instance (Ident : O_Ident;
+ Prev : Subprg_Instance_Stack);
+
+ -- True iff there is currently a subprogram instance.
+ function Has_Current_Subprg_Instance return Boolean;
+
+ -- Contains the subprogram interface for the instance.
+ type Subprg_Instance_Type is private;
+ Null_Subprg_Instance : constant Subprg_Instance_Type;
+
+ -- Add interfaces during the creation of a subprogram.
+ procedure Add_Subprg_Instance_Interfaces
+ (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type);
+
+ -- Add a field in the current factory that reference the current
+ -- instance.
+ procedure Add_Subprg_Instance_Field (Field : out O_Fnode);
+
+ -- Associate values to the instance interface during invocation of a
+ -- subprogram.
+ procedure Add_Subprg_Instance_Assoc
+ (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type);
+
+ -- Get the value to be associated to the instance interface.
+ function Get_Subprg_Instance (Vars : Subprg_Instance_Type)
+ return O_Enode;
+
+ -- True iff VARS is associated with an instance.
+ function Has_Subprg_Instance (Vars : Subprg_Instance_Type)
+ return Boolean;
+
+ -- Assign the instance field FIELD of VAR.
+ procedure Set_Subprg_Instance_Field
+ (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type);
+
+ -- To be called at the beginning and end of a subprogram body creation.
+ -- Call PUSH_SCOPE for the subprogram intances.
+ procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type);
+ procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type);
+
+ -- Call Push_Scope to reference instance from FIELD.
+ procedure Start_Prev_Subprg_Instance_Use_Via_Field
+ (Prev : Subprg_Instance_Stack; Field : O_Fnode);
+ procedure Finish_Prev_Subprg_Instance_Use_Via_Field
+ (Prev : Subprg_Instance_Stack; Field : O_Fnode);
+
+ -- Same as above, but for IIR.
+ procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
+ Subprg : Iir);
+
+ procedure Start_Subprg_Instance_Use (Subprg : Iir);
+ procedure Finish_Subprg_Instance_Use (Subprg : Iir);
+
+ function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type)
+ return Subprg_Instance_Type;
+ private
+ type Subprg_Instance_Type is record
+ Inter : O_Dnode;
+ Inter_Type : O_Tnode;
+ Scope : Var_Scope_Acc;
+ end record;
+ Null_Subprg_Instance : constant Subprg_Instance_Type :=
+ (O_Dnode_Null, O_Tnode_Null, null);
+
+ type Subprg_Instance_Stack is record
+ Scope : Var_Scope_Acc;
+ Ptr_Type : O_Tnode;
+ Ident : O_Ident;
+ end record;
+
+ Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack :=
+ (null, O_Tnode_Null, O_Ident_Nul);
+
+ Current_Subprg_Instance : Subprg_Instance_Stack :=
+ Null_Subprg_Instance_Stack;
+ end Chap2;
+
+ package Chap5 is
+ -- Attribute specification.
+ procedure Translate_Attribute_Specification
+ (Spec : Iir_Attribute_Specification);
+ procedure Elab_Attribute_Specification
+ (Spec : Iir_Attribute_Specification);
+
+ -- Disconnection specification.
+ procedure Elab_Disconnection_Specification
+ (Spec : Iir_Disconnection_Specification);
+
+ -- Elab an unconstrained port.
+ procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir);
+
+ procedure Elab_Generic_Map_Aspect (Mapping : Iir);
+
+ -- There are 4 cases of generic/port map:
+ -- 1) component instantiation
+ -- 2) component configuration (association of a component with an entity
+ -- / architecture)
+ -- 3) block header
+ -- 4) direct (entity + architecture or configuration) instantiation
+ --
+ -- MAPPING is the node containing the generic/port map aspects.
+ procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir);
+ end Chap5;
+
+
+ package Chap8 is
+ procedure Translate_Statements_Chain (First : Iir);
+
+ -- Return true if there is a return statement in the chain.
+ function Translate_Statements_Chain_Has_Return (First : Iir)
+ return Boolean;
+
+ -- Create a case branch for CHOICE.
+ -- Used by case statement and aggregates.
+ procedure Translate_Case_Choice
+ (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block);
+
+ -- Inc or dec by VAL ITERATOR according to DIR.
+ -- Used for loop statements.
+ procedure Gen_Update_Iterator (Iterator : O_Dnode;
+ Dir : Iir_Direction;
+ Val : Unsigned_64;
+ Itype : Iir);
+
+ procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir);
+ end Chap8;
+
+ package Chap9 is
+ procedure Translate_Block_Declarations (Block : Iir; Origin : Iir);
+ procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir);
+ procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir);
+
+ -- Generate code to instantiate an entity.
+ -- ASPECT must be an entity_aspect.
+ -- MAPPING must be a node with get_port/generic_map_aspect_list.
+ -- PARENT is the block in which the instantiation is done.
+ -- CONFIG_OVERRIDE, if set, is the configuration to use; if not set, the
+ -- configuration to use is determined from ASPECT.
+ procedure Translate_Entity_Instantiation
+ (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir);
+
+ end Chap9;
+
+ package Rtis is
+ -- Run-Time Information (RTI) Kind.
+ Ghdl_Rtik : O_Tnode;
+ Ghdl_Rtik_Top : O_Cnode;
+ Ghdl_Rtik_Library : O_Cnode;
+ Ghdl_Rtik_Package : O_Cnode;
+ Ghdl_Rtik_Package_Body : O_Cnode;
+ Ghdl_Rtik_Entity : O_Cnode;
+ Ghdl_Rtik_Architecture : O_Cnode;
+ Ghdl_Rtik_Process : O_Cnode;
+ Ghdl_Rtik_Block : O_Cnode;
+ Ghdl_Rtik_If_Generate : O_Cnode;
+ Ghdl_Rtik_For_Generate : O_Cnode;
+ Ghdl_Rtik_Instance : O_Cnode;
+ Ghdl_Rtik_Constant : O_Cnode;
+ Ghdl_Rtik_Iterator : O_Cnode;
+ Ghdl_Rtik_Variable : O_Cnode;
+ Ghdl_Rtik_Signal : O_Cnode;
+ Ghdl_Rtik_File : O_Cnode;
+ Ghdl_Rtik_Port : O_Cnode;
+ Ghdl_Rtik_Generic : O_Cnode;
+ Ghdl_Rtik_Alias : O_Cnode;
+ Ghdl_Rtik_Guard : O_Cnode;
+ Ghdl_Rtik_Component : O_Cnode;
+ Ghdl_Rtik_Attribute : O_Cnode;
+ Ghdl_Rtik_Type_B1 : O_Cnode;
+ Ghdl_Rtik_Type_E8 : O_Cnode;
+ Ghdl_Rtik_Type_E32 : O_Cnode;
+ Ghdl_Rtik_Type_I32 : O_Cnode;
+ Ghdl_Rtik_Type_I64 : O_Cnode;
+ Ghdl_Rtik_Type_F64 : O_Cnode;
+ Ghdl_Rtik_Type_P32 : O_Cnode;
+ Ghdl_Rtik_Type_P64 : O_Cnode;
+ Ghdl_Rtik_Type_Access : O_Cnode;
+ Ghdl_Rtik_Type_Array : O_Cnode;
+ Ghdl_Rtik_Type_Record : O_Cnode;
+ Ghdl_Rtik_Type_File : O_Cnode;
+ Ghdl_Rtik_Subtype_Scalar : O_Cnode;
+ Ghdl_Rtik_Subtype_Array : O_Cnode;
+ Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode;
+ Ghdl_Rtik_Subtype_Record : O_Cnode;
+ Ghdl_Rtik_Subtype_Access : O_Cnode;
+ Ghdl_Rtik_Type_Protected : O_Cnode;
+ Ghdl_Rtik_Element : O_Cnode;
+ Ghdl_Rtik_Unit64 : O_Cnode;
+ Ghdl_Rtik_Unitptr : O_Cnode;
+ Ghdl_Rtik_Attribute_Transaction : O_Cnode;
+ Ghdl_Rtik_Attribute_Quiet : O_Cnode;
+ Ghdl_Rtik_Attribute_Stable : O_Cnode;
+ Ghdl_Rtik_Psl_Assert : O_Cnode;
+ Ghdl_Rtik_Error : O_Cnode;
+
+ -- RTI types.
+ Ghdl_Rti_Depth : O_Tnode;
+ Ghdl_Rti_U8 : O_Tnode;
+
+ -- Common node.
+ Ghdl_Rti_Common : O_Tnode;
+ Ghdl_Rti_Common_Kind : O_Fnode;
+ Ghdl_Rti_Common_Depth : O_Fnode;
+ Ghdl_Rti_Common_Mode : O_Fnode;
+ Ghdl_Rti_Common_Max_Depth : O_Fnode;
+
+ -- Node accesses and arrays.
+ Ghdl_Rti_Access : O_Tnode;
+ Ghdl_Rti_Array : O_Tnode;
+ Ghdl_Rti_Arr_Acc : O_Tnode;
+
+ -- Instance link.
+ -- This is a structure at the beginning of each entity/architecture
+ -- instance. This allow the run-time to find the parent of an instance.
+ Ghdl_Entity_Link_Type : O_Tnode;
+ -- RTI for this instance.
+ Ghdl_Entity_Link_Rti : O_Fnode;
+ -- RTI of the parent, which has instancied the instance.
+ Ghdl_Entity_Link_Parent : O_Fnode;
+
+ Ghdl_Component_Link_Type : O_Tnode;
+ -- Pointer to a Ghdl_Entity_Link_Type, which is the entity instantiated.
+ Ghdl_Component_Link_Instance : O_Fnode;
+ -- RTI for the component instantiation statement.
+ Ghdl_Component_Link_Stmt : O_Fnode;
+
+ -- Access to Ghdl_Entity_Link_Type.
+ Ghdl_Entity_Link_Acc : O_Tnode;
+ -- Access to a Ghdl_Component_Link_Type.
+ Ghdl_Component_Link_Acc : O_Tnode;
+
+ -- Generate initial rti declarations.
+ procedure Rti_Initialize;
+
+ -- Get address (as Ghdl_Rti_Access) of constant RTI.
+ function New_Rti_Address (Rti : O_Dnode) return O_Cnode;
+
+ -- Generate rtis for a library unit.
+ procedure Generate_Unit (Lib_Unit : Iir);
+
+ -- Generate a constant declaration for SIG; but do not set its value.
+ procedure Generate_Signal_Rti (Sig : Iir);
+
+ -- Generate RTIs for subprogram body BOD.
+ procedure Generate_Subprogram_Body (Bod : Iir);
+
+ -- Generate RTI for LIB. If PUBLIC is FALSE, only generate the
+ -- declaration as external.
+ procedure Generate_Library (Lib : Iir_Library_Declaration;
+ Public : Boolean);
+
+ -- Generate RTI for the top of the hierarchy. Return the maximum number
+ -- of packages.
+ procedure Generate_Top (Nbr_Pkgs : out Natural);
+
+ -- Add two associations to ASSOC to add an rti_context for NODE.
+ procedure Associate_Rti_Context
+ (Assoc : in out O_Assoc_List; Node : Iir);
+ procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List);
+
+ function Get_Context_Rti (Node : Iir) return O_Cnode;
+ function Get_Context_Addr (Node : Iir) return O_Enode;
+ end Rtis;
+
+ type Ortho_Info_Kind is
+ (
+ Kind_Type,
+ Kind_Incomplete_Type,
+ Kind_Index,
+ Kind_Expr,
+ Kind_Subprg,
+ Kind_Object,
+ Kind_Alias,
+ Kind_Iterator,
+ Kind_Interface,
+ Kind_Disconnect,
+ Kind_Process,
+ Kind_Psl_Directive,
+ Kind_Loop,
+ Kind_Block,
+ Kind_Component,
+ Kind_Field,
+ Kind_Package,
+ Kind_Package_Instance,
+ Kind_Config,
+ Kind_Assoc,
+ Kind_Str_Choice,
+ Kind_Design_File,
+ Kind_Library
+ );
+
+ type Ortho_Info_Type_Kind is
+ (
+ Kind_Type_Scalar,
+ Kind_Type_Array,
+ Kind_Type_Record,
+ Kind_Type_File,
+ Kind_Type_Protected
+ );
+ type O_Tnode_Array is array (Object_Kind_Type) of O_Tnode;
+ type O_Fnode_Array is array (Object_Kind_Type) of O_Fnode;
+
+ type Rti_Depth_Type is new Natural range 0 .. 255;
+
+ type Ortho_Info_Type_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar)
+ is record
+ -- For all types:
+ -- This is the maximum depth of RTI, that is the max of the depth of
+ -- the type itself and every types it depends on.
+ Rti_Max_Depth : Rti_Depth_Type;
+
+ case Kind is
+ when Kind_Type_Scalar =>
+ -- For scalar types:
+ -- True if no need to check against low/high bound.
+ Nocheck_Low : Boolean := False;
+ Nocheck_Hi : Boolean := False;
+
+ -- Ortho type for the range record type.
+ Range_Type : O_Tnode;
+
+ -- Ortho type for an access to the range record type.
+ Range_Ptr_Type : O_Tnode;
+
+ -- Tree for the range record declaration.
+ Range_Var : Var_Type;
+
+ -- Fields of TYPE_RANGE_TYPE.
+ Range_Left : O_Fnode;
+ Range_Right : O_Fnode;
+ Range_Dir : O_Fnode;
+ Range_Length : O_Fnode;
+
+ when Kind_Type_Array =>
+ Base_Type : O_Tnode_Array;
+ Base_Ptr_Type : O_Tnode_Array;
+ Bounds_Type : O_Tnode;
+ Bounds_Ptr_Type : O_Tnode;
+
+ Base_Field : O_Fnode_Array;
+ Bounds_Field : O_Fnode_Array;
+
+ -- True if the array bounds are static.
+ Static_Bounds : Boolean;
+
+ -- Variable containing the bounds for a constrained array.
+ Array_Bounds : Var_Type;
+
+ -- Variable containing a 1 length bound for unidimensional
+ -- unconstrained arrays.
+ Array_1bound : Var_Type;
+
+ -- Variable containing the description for each index.
+ Array_Index_Desc : Var_Type;
+
+ when Kind_Type_Record =>
+ -- Variable containing the description for each element.
+ Record_El_Desc : Var_Type;
+
+ when Kind_Type_File =>
+ -- Constant containing the signature of the file.
+ File_Signature : O_Dnode;
+
+ when Kind_Type_Protected =>
+ Prot_Scope : aliased Var_Scope_Type;
+
+ -- Init procedure for the protected type.
+ Prot_Init_Subprg : O_Dnode;
+ Prot_Init_Instance : Chap2.Subprg_Instance_Type;
+ -- Final procedure.
+ Prot_Final_Subprg : O_Dnode;
+ Prot_Final_Instance : Chap2.Subprg_Instance_Type;
+ -- The outer instance, if any.
+ Prot_Subprg_Instance_Field : O_Fnode;
+ -- The LOCK field in the object type
+ Prot_Lock_Field : O_Fnode;
+ end case;
+ end record;
+
+-- Ortho_Info_Type_Scalar_Init : constant Ortho_Info_Type_Type :=
+-- (Kind => Kind_Type_Scalar,
+-- Range_Type => O_Tnode_Null,
+-- Range_Ptr_Type => O_Tnode_Null,
+-- Range_Var => null,
+-- Range_Left => O_Fnode_Null,
+-- Range_Right => O_Fnode_Null,
+-- Range_Dir => O_Fnode_Null,
+-- Range_Length => O_Fnode_Null);
+
+ Ortho_Info_Type_Array_Init : constant Ortho_Info_Type_Type :=
+ (Kind => Kind_Type_Array,
+ Rti_Max_Depth => 0,
+ Base_Type => (O_Tnode_Null, O_Tnode_Null),
+ Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null),
+ Bounds_Type => O_Tnode_Null,
+ Bounds_Ptr_Type => O_Tnode_Null,
+ Base_Field => (O_Fnode_Null, O_Fnode_Null),
+ Bounds_Field => (O_Fnode_Null, O_Fnode_Null),
+ Static_Bounds => False,
+ Array_Bounds => Null_Var,
+ Array_1bound => Null_Var,
+ Array_Index_Desc => Null_Var);
+
+ Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type :=
+ (Kind => Kind_Type_Record,
+ Rti_Max_Depth => 0,
+ Record_El_Desc => Null_Var);
+
+ Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type :=
+ (Kind => Kind_Type_File,
+ Rti_Max_Depth => 0,
+ File_Signature => O_Dnode_Null);
+
+ Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type :=
+ (Kind => Kind_Type_Protected,
+ Rti_Max_Depth => 0,
+ Prot_Scope => Null_Var_Scope,
+ Prot_Init_Subprg => O_Dnode_Null,
+ Prot_Init_Instance => Chap2.Null_Subprg_Instance,
+ Prot_Final_Subprg => O_Dnode_Null,
+ Prot_Subprg_Instance_Field => O_Fnode_Null,
+ Prot_Final_Instance => Chap2.Null_Subprg_Instance,
+ Prot_Lock_Field => O_Fnode_Null);
+
+ -- Mode of the type; roughly speaking, this corresponds to its size
+ -- (for scalars) or its layout (for composite types).
+ -- Used to select library subprograms for signals.
+ type Type_Mode_Type is
+ (
+ -- Unknown mode.
+ Type_Mode_Unknown,
+ -- Boolean type, with 2 elements.
+ Type_Mode_B1,
+ -- Enumeration with at most 256 elements.
+ Type_Mode_E8,
+ -- Enumeration with more than 256 elements.
+ Type_Mode_E32,
+ -- Integer types.
+ Type_Mode_I32,
+ Type_Mode_I64,
+ -- Physical types.
+ Type_Mode_P32,
+ Type_Mode_P64,
+ -- Floating point type.
+ Type_Mode_F64,
+ -- File type.
+ Type_Mode_File,
+ -- Thin access.
+ Type_Mode_Acc,
+
+ -- Fat access.
+ Type_Mode_Fat_Acc,
+
+ -- Record.
+ Type_Mode_Record,
+ -- Protected type
+ Type_Mode_Protected,
+ -- Constrained array type (length is known at compile-time).
+ Type_Mode_Array,
+ -- Fat array type (used for unconstrained array).
+ Type_Mode_Fat_Array);
+
+ subtype Type_Mode_Scalar is Type_Mode_Type
+ range Type_Mode_B1 .. Type_Mode_F64;
+
+ subtype Type_Mode_Non_Composite is Type_Mode_Type
+ range Type_Mode_B1 .. Type_Mode_Fat_Acc;
+
+ -- Composite types, with the vhdl meaning: record and arrays.
+ subtype Type_Mode_Composite is Type_Mode_Type
+ range Type_Mode_Record .. Type_Mode_Fat_Array;
+
+ -- Array types.
+ subtype Type_Mode_Arrays is Type_Mode_Type range
+ Type_Mode_Array .. Type_Mode_Fat_Array;
+
+ -- Thin types, ie types whose length is a scalar.
+ subtype Type_Mode_Thin is Type_Mode_Type
+ range Type_Mode_B1 .. Type_Mode_Acc;
+
+ -- Fat types, ie types whose length is longer than a scalar.
+ subtype Type_Mode_Fat is Type_Mode_Type
+ range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array;
+
+ -- These parameters are passed by value, ie the argument of the subprogram
+ -- is the value of the object.
+ subtype Type_Mode_By_Value is Type_Mode_Type
+ range Type_Mode_B1 .. Type_Mode_Acc;
+
+ -- These parameters are passed by copy, ie a copy of the object is created
+ -- and the reference of the copy is passed. If the object is not
+ -- modified by the subprogram, the object could be passed by reference.
+ subtype Type_Mode_By_Copy is Type_Mode_Type
+ range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc;
+
+ -- The parameters are passed by reference, ie the argument of the
+ -- subprogram is an address to the object.
+ subtype Type_Mode_By_Ref is Type_Mode_Type
+ range Type_Mode_Record .. Type_Mode_Fat_Array;
+
+ -- Additional informations for a resolving function.
+ type Subprg_Resolv_Info is record
+ Resolv_Func : O_Dnode;
+ -- Parameter nodes.
+ Var_Instance : Chap2.Subprg_Instance_Type;
+
+ -- Signals
+ Var_Vals : O_Dnode;
+ -- Driving vector.
+ Var_Vec : O_Dnode;
+ -- Length of Vector.
+ Var_Vlen : O_Dnode;
+ Var_Nbr_Drv : O_Dnode;
+ Var_Nbr_Ports : O_Dnode;
+ end record;
+ type Subprg_Resolv_Info_Acc is access Subprg_Resolv_Info;
+
+ -- Complex types.
+ --
+ -- A complex type is not a VHDL notion, but a translation notion.
+ -- A complex type is a composite type whose size is not known at compile
+ -- type. This happends in VHDL because a bound can be globally static.
+ -- Therefore, the length of an array may not be known at compile type,
+ -- and this propagates to composite types (record and array) if they
+ -- have such an element. This is different from unconstrained arrays.
+ --
+ -- This occurs frequently in VHDL, and could even happen within
+ -- subprograms.
+ --
+ -- Such types are always dynamically allocated (on the stack or on the
+ -- heap). They must be continuous in memory so that they could be copied
+ -- via memcpy/memmove.
+ --
+ -- At runtime, the size of such type is computed. A builder procedure
+ -- is also created to setup inner pointers. This builder procedure should
+ -- be called at initialization, but also after a copy.
+ --
+ -- Example:
+ -- 1) subtype bv_type is bit_vector (l to h);
+ -- variable a : bv_type
+ --
+ -- This is represented by a pointer to an array of bit. No need for
+ -- builder procedure, as the element type is not complex. But there
+ -- is a size variable for the size of bv_type
+ --
+ -- 2) type rec1_type is record
+ -- f1 : integer;
+ -- f2 : bv_type;
+ -- end record;
+ --
+ -- This is represented by a pointer to a record. The 'f2' field is
+ -- an offset to an array of bit. The size of the object is the size
+ -- of the record (with f2 as a pointer) + the size of bv_type.
+ -- The alinment of the object is the maximum alignment of its sub-
+ -- objects: rec1 and bv_type.
+ -- A builder procedure is needed to initialize the 'f2' field.
+ -- The memory layout is:
+ -- +--------------+
+ -- | rec1: f1 |
+ -- | f2 |---+
+ -- +--------------+ |
+ -- | bv_type |<--+
+ -- | ... |
+ -- +--------------+
+ --
+ -- 3) type rec2_type is record
+ -- g1: rec1_type;
+ -- g2: bv_type;
+ -- g3: bv_type;
+ -- end record;
+ --
+ -- This is represented by a pointer to a record. All the three fields
+ -- are offset (relative to rec2). Alignment is the maximum alignment of
+ -- the sub-objects (rec2, rec1, bv_type x 3).
+ -- The memory layout is:
+ -- +--------------+
+ -- | rec2: g1 |---+
+ -- | g2 |---|---+
+ -- | g3 |---|---|---+
+ -- +--------------+ | | |
+ -- | rec1: f1 |<--+ | |
+ -- | f2 |---+ | |
+ -- +--------------+ | | |
+ -- | bv_type (f2) |<--+ | |
+ -- | ... | | |
+ -- +--------------+ | |
+ -- | bv_type (g2) |<------+ |
+ -- | ... | |
+ -- +--------------+ |
+ -- | bv_type (g3) |<----------+
+ -- | ... |
+ -- +--------------+
+ --
+ -- 4) type bv_arr_type is array (natural range <>) of bv_type;
+ -- arr2 : bv_arr_type (1 to 4)
+ --
+ -- This should be represented by a pointer to bv_type.
+ -- The memory layout is:
+ -- +--------------+
+ -- | bv_type (1) |
+ -- | ... |
+ -- +--------------+
+ -- | bv_type (2) |
+ -- | ... |
+ -- +--------------+
+ -- | bv_type (3) |
+ -- | ... |
+ -- +--------------+
+ -- | bv_type (4) |
+ -- | ... |
+ -- +--------------+
+
+ -- Additional info for complex types.
+ type Complex_Type_Info is record
+ -- Variable containing the size of the type.
+ -- This is defined only for types whose size is only known at
+ -- running time (and not a compile-time).
+ Size_Var : Var_Type;
+
+ -- Variable containing the alignment of the type.
+ -- Only defined for recods and for Mode_Value.
+ -- Note: this is not optimal, because the alignment could be computed
+ -- at compile time, but there is no way to do that with ortho (no
+ -- operation on constants). Furthermore, the alignment is independent
+ -- of the instance, so there could be one global variable. But this
+ -- doesn't fit in the whole machinery (in particular, there is no
+ -- easy way to compute it once). As the overhead is very low, no need
+ -- to bother with this issue.
+ Align_Var : Var_Type;
+
+ Builder_Need_Func : Boolean;
+
+ -- Parameters for type builders.
+ -- NOTE: this is only set for types (and *not* for subtypes).
+ Builder_Instance : Chap2.Subprg_Instance_Type;
+ Builder_Base_Param : O_Dnode;
+ Builder_Bound_Param : O_Dnode;
+ Builder_Func : O_Dnode;
+ end record;
+ type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info;
+ type Complex_Type_Info_Acc is access Complex_Type_Arr_Info;
+ procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation
+ (Complex_Type_Arr_Info, Complex_Type_Info_Acc);
+
+ type Assoc_Conv_Info is record
+ -- The subprogram created to do the conversion.
+ Subprg : O_Dnode;
+ -- The local base block
+ Instance_Block : Iir;
+ -- and its address.
+ Instance_Field : O_Fnode;
+ -- The instantiated entity (if any).
+ Instantiated_Entity : Iir;
+ -- and its address.
+ Instantiated_Field : O_Fnode;
+ In_Field : O_Fnode;
+ Out_Field : O_Fnode;
+ Record_Type : O_Tnode;
+ Record_Ptr_Type : O_Tnode;
+ end record;
+
+ type Direct_Driver_Type is record
+ Sig : Iir;
+ Var : Var_Type;
+ end record;
+ type Direct_Driver_Arr is array (Natural range <>) of Direct_Driver_Type;
+ type Direct_Drivers_Acc is access Direct_Driver_Arr;
+
+ type Ortho_Info_Type;
+ type Ortho_Info_Acc is access Ortho_Info_Type;
+
+ type Ortho_Info_Type (Kind : Ortho_Info_Kind) is record
+ case Kind is
+ when Kind_Type =>
+ -- Mode of the type.
+ Type_Mode : Type_Mode_Type := Type_Mode_Unknown;
+
+ -- If true, the type is (still) incomplete.
+ Type_Incomplete : Boolean := False;
+
+ -- For array only. True if the type is constrained with locally
+ -- static bounds. May have non locally-static bounds in some
+ -- of its sub-element (ie being a complex type).
+ Type_Locally_Constrained : Boolean := False;
+
+ -- Additionnal info for complex types.
+ C : Complex_Type_Info_Acc := null;
+
+ -- Ortho node which represents the type.
+ -- Type -> Ortho type
+ -- scalar -> scalar
+ -- record (complex or not) -> record
+ -- constrained non-complex array -> constrained array
+ -- constrained complex array -> the element
+ -- unconstrained array -> fat pointer
+ -- access to unconstrained array -> fat pointer
+ -- access (others) -> access
+ -- file -> file_index_type
+ -- protected -> instance
+ Ortho_Type : O_Tnode_Array;
+
+ -- Ortho pointer to the type. This is always an access to the
+ -- ortho_type.
+ Ortho_Ptr_Type : O_Tnode_Array;
+
+ -- Chain of temporary types to be destroyed at end of scope.
+ Type_Transient_Chain : Iir := Null_Iir;
+
+ -- More info according to the type.
+ T : Ortho_Info_Type_Type;
+
+ -- Run-time information.
+ Type_Rti : O_Dnode := O_Dnode_Null;
+
+ when Kind_Incomplete_Type =>
+ -- The declaration of the incomplete type.
+ Incomplete_Type : Iir;
+ Incomplete_Array : Ortho_Info_Acc;
+
+ when Kind_Index =>
+ -- Field declaration for array dimension.
+ Index_Field : O_Fnode;
+
+ when Kind_Expr =>
+ -- Ortho tree which represents the expression, used for
+ -- enumeration literals.
+ Expr_Node : O_Cnode;
+
+ when Kind_Subprg =>
+ -- True if the function can return a value stored in the secondary
+ -- stack. In this case, the caller must deallocate the area
+ -- allocated by the callee when the value was used.
+ Use_Stack2 : Boolean := False;
+
+ -- Subprogram declaration node.
+ Ortho_Func : O_Dnode;
+
+ -- For a function:
+ -- If the return value is not composite, then this field
+ -- must be O_DNODE_NULL.
+ -- If the return value is a composite type, then the caller must
+ -- give to the callee an area to put the result. This area is
+ -- given via an (hidden to the user) interface. Furthermore,
+ -- the function is translated into a procedure.
+ -- For a procedure:
+ -- If there are copy-out interfaces, they are gathered in a
+ -- record and a pointer to the record is passed to the
+ -- procedure. RES_INTERFACE is the interface for this pointer.
+ Res_Interface : O_Dnode := O_Dnode_Null;
+
+ -- Field in the frame for a pointer to the RESULT structure.
+ Res_Record_Var : Var_Type := Null_Var;
+
+ -- For a subprogram with a result interface:
+ -- Type definition for the record.
+ Res_Record_Type : O_Tnode := O_Tnode_Null;
+ -- Type definition for access to the record.
+ Res_Record_Ptr : O_Tnode := O_Tnode_Null;
+
+ -- Access to the declarations within this subprogram.
+ Subprg_Frame_Scope : aliased Var_Scope_Type;
+
+ -- Instances for the subprograms.
+ Subprg_Instance : Chap2.Subprg_Instance_Type :=
+ Chap2.Null_Subprg_Instance;
+
+ Subprg_Resolv : Subprg_Resolv_Info_Acc := null;
+
+ -- Local identifier number, set by spec, continued by body.
+ Subprg_Local_Id : Local_Identifier_Type;
+
+ -- If set, return should be converted into exit out of the
+ -- SUBPRG_EXIT loop and the value should be assigned to
+ -- SUBPRG_RESULT, if any.
+ Subprg_Exit : O_Snode := O_Snode_Null;
+ Subprg_Result : O_Dnode := O_Dnode_Null;
+
+ when Kind_Object =>
+ -- For constants: set when the object is defined as a constant.
+ Object_Static : Boolean;
+ -- The object itself.
+ Object_Var : Var_Type;
+ -- Direct driver for signal (if any).
+ Object_Driver : Var_Type := Null_Var;
+ -- RTI constant for the object.
+ Object_Rti : O_Dnode := O_Dnode_Null;
+ -- Function to compute the value of object (used for implicit
+ -- guard signal declaration).
+ Object_Function : O_Dnode := O_Dnode_Null;
+
+ when Kind_Alias =>
+ Alias_Var : Var_Type;
+ Alias_Kind : Object_Kind_Type;
+
+ when Kind_Iterator =>
+ Iterator_Var : Var_Type;
+
+ when Kind_Interface =>
+ -- Ortho declaration for the interface. If not null, there is
+ -- a corresponding ortho parameter for the interface. While
+ -- translating nested subprograms (that are unnested),
+ -- Interface_Field may be set to the corresponding field in the
+ -- FRAME record. So:
+ -- Node: not null, Field: null: parameter
+ -- Node: not null, Field: not null: parameter with a copy in
+ -- the FRAME record.
+ -- Node: null, Field: null: not possible
+ -- Node: null, Field: not null: field in RESULT record
+ Interface_Node : O_Dnode := O_Dnode_Null;
+ -- Field of the result record for copy-out arguments of procedure.
+ -- In that case, Interface_Node must be null.
+ Interface_Field : O_Fnode;
+ -- Type of the interface.
+ Interface_Type : O_Tnode;
+
+ when Kind_Disconnect =>
+ -- Variable which contains the time_expression of the
+ -- disconnection specification
+ Disconnect_Var : Var_Type;
+
+ when Kind_Process =>
+ Process_Scope : aliased Var_Scope_Type;
+
+ -- Subprogram for the process.
+ Process_Subprg : O_Dnode;
+
+ -- List of drivers if Flag_Direct_Drivers.
+ Process_Drivers : Direct_Drivers_Acc := null;
+
+ -- RTI for the process.
+ Process_Rti_Const : O_Dnode := O_Dnode_Null;
+
+ when Kind_Psl_Directive =>
+ Psl_Scope : aliased Var_Scope_Type;
+
+ -- Procedure for the state machine.
+ Psl_Proc_Subprg : O_Dnode;
+ -- Procedure for finalization. Handles EOS.
+ Psl_Proc_Final_Subprg : O_Dnode;
+
+ -- Length of the state vector.
+ Psl_Vect_Len : Natural;
+
+ -- Type of the state vector.
+ Psl_Vect_Type : O_Tnode;
+
+ -- State vector variable.
+ Psl_Vect_Var : Var_Type;
+
+ -- Boolean variable (for cover)
+ Psl_Bool_Var : Var_Type;
+
+ -- RTI for the process.
+ Psl_Rti_Const : O_Dnode := O_Dnode_Null;
+
+ when Kind_Loop =>
+ -- Labels for the loop.
+ -- Used for exit/next from while-loop, and to exit from for-loop.
+ Label_Exit : O_Snode;
+ -- Used to next from for-loop, with an exit statment.
+ Label_Next : O_Snode;
+
+ when Kind_Block =>
+ -- Access to declarations of this block.
+ Block_Scope : aliased Var_Scope_Type;
+
+ -- Instance type (ortho record) for declarations contained in the
+ -- block/entity/architecture.
+ Block_Decls_Ptr_Type : O_Tnode;
+
+ -- For Entity: field in the instance type containing link to
+ -- parent.
+ -- For an instantiation: link in the parent block to the instance.
+ Block_Link_Field : O_Fnode;
+
+ -- For an entity: must be o_fnode_null.
+ -- For an architecture: the entity field.
+ -- For a block, a component or a generate block: field in the
+ -- parent instance which contains the declarations for this
+ -- block.
+ Block_Parent_Field : O_Fnode;
+
+ -- For a generate block: field in the block providing a chain to
+ -- the previous block (note: this may not be the parent, but
+ -- is a parent).
+ Block_Origin_Field : O_Fnode;
+ -- For an iterative block: boolean field set when the block
+ -- is configured. This is used to check if the block was already
+ -- configured since index and slice are not compelled to be
+ -- locally static.
+ Block_Configured_Field : O_Fnode;
+
+ -- For iterative generate block: array of instances.
+ Block_Decls_Array_Type : O_Tnode;
+ Block_Decls_Array_Ptr_Type : O_Tnode;
+
+ -- Subprogram which elaborates the block (for entity or arch).
+ Block_Elab_Subprg : O_Dnode;
+ -- Size of the block instance.
+ Block_Instance_Size : O_Dnode;
+
+ -- Only for an entity: procedure that elaborate the packages this
+ -- units depend on. That must be done before elaborating the
+ -- entity and before evaluating default expressions in generics.
+ Block_Elab_Pkg_Subprg : O_Dnode;
+
+ -- RTI constant for the block.
+ Block_Rti_Const : O_Dnode := O_Dnode_Null;
+
+ when Kind_Component =>
+ -- How to access to component interfaces.
+ Comp_Scope : aliased Var_Scope_Type;
+
+ -- Instance for the component.
+ Comp_Ptr_Type : O_Tnode;
+ -- Field containing a pointer to the instance link.
+ Comp_Link : O_Fnode;
+ -- RTI for the component.
+ Comp_Rti_Const : O_Dnode;
+
+ when Kind_Config =>
+ -- Subprogram that configure the block.
+ Config_Subprg : O_Dnode;
+
+ when Kind_Field =>
+ -- Node for a record element declaration.
+ Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null);
+
+ when Kind_Package =>
+ -- Subprogram which elaborate the package spec/body.
+ -- External units should call the body elaborator.
+ -- The spec elaborator is called only from the body elaborator.
+ Package_Elab_Spec_Subprg : O_Dnode;
+ Package_Elab_Body_Subprg : O_Dnode;
+
+ -- Instance for the elaborators.
+ Package_Elab_Spec_Instance : Chap2.Subprg_Instance_Type;
+ Package_Elab_Body_Instance : Chap2.Subprg_Instance_Type;
+
+ -- Variable set to true when the package is elaborated.
+ Package_Elab_Var : Var_Type;
+
+ -- RTI constant for the package.
+ Package_Rti_Const : O_Dnode;
+
+ -- Access to declarations of the spec.
+ Package_Spec_Scope : aliased Var_Scope_Type;
+
+ -- Instance type for uninstantiated package
+ Package_Spec_Ptr_Type : O_Tnode;
+
+ Package_Body_Scope : aliased Var_Scope_Type;
+ Package_Body_Ptr_Type : O_Tnode;
+
+ -- Field to the spec within the body.
+ Package_Spec_Field : O_Fnode;
+
+ -- Local id, set by package declaration, continued by package
+ -- body.
+ Package_Local_Id : Local_Identifier_Type;
+
+ when Kind_Package_Instance =>
+ -- The variables containing the instance. There are two variables
+ -- for interface package: one for the spec, one for the body.
+ -- For package instantiation, only the variable for the body is
+ -- used. The variable for spec is added so that packages with
+ -- package interfaces don't need to know the body of their
+ -- interfaces.
+ Package_Instance_Spec_Var : Var_Type;
+ Package_Instance_Body_Var : Var_Type;
+
+ -- Elaboration procedure for the instance.
+ Package_Instance_Elab_Subprg : O_Dnode;
+
+ Package_Instance_Spec_Scope : aliased Var_Scope_Type;
+ Package_Instance_Body_Scope : aliased Var_Scope_Type;
+
+ when Kind_Assoc =>
+ -- Association informations.
+ Assoc_In : Assoc_Conv_Info;
+ Assoc_Out : Assoc_Conv_Info;
+
+ when Kind_Str_Choice =>
+ -- List of choices, used to sort them.
+ Choice_Chain : Ortho_Info_Acc;
+ -- Association index.
+ Choice_Assoc : Natural;
+ -- Corresponding choice simple expression.
+ Choice_Expr : Iir;
+ -- Corresponding choice.
+ Choice_Parent : Iir;
+
+ when Kind_Design_File =>
+ Design_Filename : O_Dnode;
+
+ when Kind_Library =>
+ Library_Rti_Const : O_Dnode;
+ end case;
+ end record;
+
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => Ortho_Info_Acc, Object => Ortho_Info_Type);
+
+ subtype Type_Info_Acc is Ortho_Info_Acc (Kind_Type);
+ subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type);
+ subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index);
+ subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg);
+ subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object);
+ subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias);
+ subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process);
+ subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive);
+ subtype Loop_Info_Acc is Ortho_Info_Acc (Kind_Loop);
+ subtype Block_Info_Acc is Ortho_Info_Acc (Kind_Block);
+ subtype Comp_Info_Acc is Ortho_Info_Acc (Kind_Component);
+ subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field);
+ subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config);
+ subtype Assoc_Info_Acc is Ortho_Info_Acc (Kind_Assoc);
+ subtype Inter_Info_Acc is Ortho_Info_Acc (Kind_Interface);
+ subtype Design_File_Info_Acc is Ortho_Info_Acc (Kind_Design_File);
+ subtype Library_Info_Acc is Ortho_Info_Acc (Kind_Library);
+
+ package Node_Infos is new GNAT.Table
+ (Table_Component_Type => Ortho_Info_Acc,
+ Table_Index_Type => Iir,
+ Table_Low_Bound => 0,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ procedure Update_Node_Infos
+ is
+ use Nodes;
+ F, L : Iir;
+ begin
+ F := Node_Infos.Last;
+ L := Nodes.Get_Last_Node;
+ Node_Infos.Set_Last (L);
+ Node_Infos.Table (F + 1 .. L) := (others => null);
+ end Update_Node_Infos;
+
+ procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is
+ begin
+ if Node_Infos.Table (Target) /= null then
+ raise Internal_Error;
+ end if;
+ Node_Infos.Table (Target) := Info;
+ end Set_Info;
+
+ procedure Clear_Info (Target : Iir) is
+ begin
+ Node_Infos.Table (Target) := null;
+ end Clear_Info;
+
+ function Get_Info (Target : Iir) return Ortho_Info_Acc is
+ begin
+ return Node_Infos.Table (Target);
+ end Get_Info;
+
+ -- Create an ortho_info field of kind KIND for iir node TARGET, and
+ -- return it.
+ function Add_Info (Target : Iir; Kind : Ortho_Info_Kind)
+ return Ortho_Info_Acc
+ is
+ Res : Ortho_Info_Acc;
+ begin
+ Res := new Ortho_Info_Type (Kind);
+ Set_Info (Target, Res);
+ return Res;
+ end Add_Info;
+
+ procedure Free_Info (Target : Iir)
+ is
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Get_Info (Target);
+ if Info /= null then
+ Unchecked_Deallocation (Info);
+ Clear_Info (Target);
+ end if;
+ end Free_Info;
+
+ procedure Free_Type_Info (Info : in out Type_Info_Acc) is
+ begin
+ if Info.C /= null then
+ Free_Complex_Type_Info (Info.C);
+ end if;
+ Unchecked_Deallocation (Info);
+ end Free_Type_Info;
+
+ procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode)
+ is
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Add_Info (Target, Kind_Expr);
+ Info.Expr_Node := Expr;
+ end Set_Ortho_Expr;
+
+ function Get_Ortho_Expr (Target : Iir) return O_Cnode is
+ begin
+ return Get_Info (Target).Expr_Node;
+ end Get_Ortho_Expr;
+
+ function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type)
+ return O_Tnode is
+ begin
+ return Get_Info (Target).Ortho_Type (Is_Sig);
+ end Get_Ortho_Type;
+
+ function Get_Ortho_Decl (Subprg : Iir) return O_Dnode
+ is
+ begin
+ return Get_Info (Subprg).Ortho_Func;
+ end Get_Ortho_Decl;
+
+ function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode
+ is
+ Info : Subprg_Resolv_Info_Acc;
+ begin
+ Info := Get_Info (Func).Subprg_Resolv;
+ if Info = null then
+ -- Maybe the resolver is not used.
+ return O_Dnode_Null;
+ else
+ return Info.Resolv_Func;
+ end if;
+ end Get_Resolv_Ortho_Decl;
+
+ -- Return true is INFO is a type info for a composite type, ie:
+ -- * a record
+ -- * an array (fat or thin)
+ -- * a fat pointer.
+ function Is_Composite (Info : Type_Info_Acc) return Boolean;
+ pragma Inline (Is_Composite);
+
+ function Is_Composite (Info : Type_Info_Acc) return Boolean is
+ begin
+ return Info.Type_Mode in Type_Mode_Fat;
+ end Is_Composite;
+
+ function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean;
+ pragma Inline (Is_Complex_Type);
+
+ function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is
+ begin
+ return Tinfo.C /= null;
+ end Is_Complex_Type;
+
+ -- In order to simplify the handling of Enode/Lnode, let's introduce
+ -- Mnode (yes, another node).
+ -- An Mnode is a typed union, containing either an Lnode or a Enode.
+ -- See Mstate for a description of the union.
+ -- The real data is contained insisde a record, so that the discriminant
+ -- can be changed.
+ type Mnode;
+
+ -- State of an Mmode.
+ type Mstate is
+ (
+ -- The Mnode contains an Enode, which can be either a value or a
+ -- pointer.
+ -- This Mnode can be used only once.
+ Mstate_E,
+
+ -- The Mnode contains an Lnode representing a value.
+ -- This Lnode can be used only once.
+ Mstate_Lv,
+
+ -- The Mnode contains an Lnode representing a pointer.
+ -- This Lnode can be used only once.
+ Mstate_Lp,
+
+ -- The Mnode contains an Dnode for a variable representing a value.
+ -- This Dnode may be used several times.
+ Mstate_Dv,
+
+ -- The Mnode contains an Dnode for a variable representing a pointer.
+ -- This Dnode may be used several times.
+ Mstate_Dp,
+
+ -- Null Mnode.
+ Mstate_Null,
+
+ -- The Mnode is invalid (such as already used).
+ Mstate_Bad);
+
+ type Mnode1 (State : Mstate := Mstate_Bad) is record
+ -- True if the object is composite (its value cannot be read directly).
+ Comp : Boolean;
+
+ -- Additionnal informations about the objects: kind and type.
+ K : Object_Kind_Type;
+ T : Type_Info_Acc;
+
+ -- Ortho type of the object.
+ Vtype : O_Tnode;
+
+ -- Type for a pointer to the object.
+ Ptype : O_Tnode;
+
+ case State is
+ when Mstate_E =>
+ E : O_Enode;
+ when Mstate_Lv =>
+ Lv : O_Lnode;
+ when Mstate_Lp =>
+ Lp : O_Lnode;
+ when Mstate_Dv =>
+ Dv : O_Dnode;
+ when Mstate_Dp =>
+ Dp : O_Dnode;
+ when Mstate_Bad
+ | Mstate_Null =>
+ null;
+ end case;
+ end record;
+ --pragma Pack (Mnode1);
+
+ type Mnode is record
+ M1 : Mnode1;
+ end record;
+
+ -- Null Mnode.
+ Mnode_Null : constant Mnode := Mnode'(M1 => (State => Mstate_Null,
+ Comp => False,
+ K => Mode_Value,
+ Ptype => O_Tnode_Null,
+ Vtype => O_Tnode_Null,
+ T => null));
+
+
+ -- Object kind of a Mnode
+ function Get_Object_Kind (M : Mnode) return Object_Kind_Type;
+
+ -- Transform VAR to Mnode.
+ function Get_Var
+ (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
+ return Mnode;
+
+ -- Return a stabilized node for M.
+ -- The former M is not usuable anymore.
+ function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode;
+
+ -- Stabilize M.
+ procedure Stabilize (M : in out Mnode);
+
+ -- If M is not stable, create a variable containing the value of M.
+ -- M must be scalar (or access).
+ function Stabilize_Value (M : Mnode) return Mnode;
+
+ -- Create a temporary of type INFO and kind KIND.
+ function Create_Temp (Info : Type_Info_Acc;
+ Kind : Object_Kind_Type := Mode_Value)
+ return Mnode;
+
+ package Chap3 is
+ -- Translate the subtype of an object, since an object can define
+ -- a subtype.
+ -- This can be done only for a declaration.
+ -- DECL must have an identifier and a type.
+ procedure Translate_Object_Subtype
+ (Decl : Iir; With_Vars : Boolean := True);
+ procedure Elab_Object_Subtype (Def : Iir);
+
+ -- Translate the subtype of a literal.
+ -- This can be done not at declaration time, ie no variables are created
+ -- for this subtype.
+ --procedure Translate_Literal_Subtype (Def : Iir);
+
+ -- Translation of a type definition or subtype indication.
+ -- 1. Create corresponding Ortho type.
+ -- 2. Create bounds type
+ -- 3. Create bounds declaration
+ -- 4. Create bounds constructor
+ -- 5. Create type descriptor declaration
+ -- 6. Create type descriptor constructor
+ procedure Translate_Type_Definition
+ (Def : Iir; With_Vars : Boolean := True);
+
+ procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id);
+ procedure Translate_Anonymous_Type_Definition
+ (Def : Iir; Transient : Boolean);
+
+ -- Some expressions may be evaluated several times in different
+ -- contexts. Type info created for these expressions may not be
+ -- shared between these contexts.
+ procedure Destroy_Type_Info (Atype : Iir);
+
+ -- Translate subprograms for types.
+ procedure Translate_Type_Subprograms (Decl : Iir);
+
+ procedure Create_Type_Definition_Type_Range (Def : Iir);
+ function Create_Static_Array_Subtype_Bounds
+ (Def : Iir_Array_Subtype_Definition)
+ return O_Cnode;
+
+ -- Same as Translate_type_definition only for std.standard.boolean and
+ -- std.standard.bit.
+ procedure Translate_Bool_Type_Definition (Def : Iir);
+
+ -- Call lock or unlock on a protected object.
+ procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode);
+
+ procedure Translate_Protected_Type_Body (Bod : Iir);
+ procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir);
+
+ -- Translate_type_definition_Elab do 4 and 6.
+ -- It generates code to do type elaboration.
+ procedure Elab_Type_Declaration (Decl : Iir);
+ procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration);
+
+ -- Builders.
+ -- A complex type is a type whose size is not locally static.
+ --
+ -- The most simple example is an unidimensionnl array whose range
+ -- depends on generics.
+ --
+ -- We call first order complex type any array whose bounds are not
+ -- locally static and whose sub-element size is locally static.
+ --
+ -- First order complex type objects are represented by a pointer to an
+ -- array of sub-element, and the storage area for the array is
+ -- allocated at run-time.
+ --
+ -- Since a sub-element type may be a complex type, a type may be
+ -- complex because one of its sub-element type is complex.
+ -- EG, a record type whose one element is a complex array.
+ --
+ -- A type may be complex either because it is a first order complex
+ -- type (ie an array whose bounds are not locally static) or because
+ -- one of its sub-element type is such a type (this is recursive).
+ --
+ -- We call second order complex type a complex type that is not of first
+ -- order.
+ -- We call third order complex type a second order complex type which is
+ -- an array whose bounds are not locally static.
+ --
+ -- In a complex type, sub-element of first order complex type are
+ -- represented by a pointer.
+ -- Any complex type object (constant, signal, variable, port, generic)
+ -- is represented by a pointer.
+ --
+ -- Creation of a second or third order complex type object consists in
+ -- allocating the memory and building the object.
+ -- Building a object consists in setting internal pointers.
+ --
+ -- A complex type has always a non-null INFO.C, and its size is computed
+ -- during elaboration.
+ --
+ -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC
+ -- is set to TRUE.
+
+ -- Call builder for variable pointed VAR of type VAR_TYPE.
+ procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir);
+
+ -- Functions for fat array.
+ -- Fat array are array whose size is not known at compilation time.
+ -- This corresponds to an unconstrained array or a non locally static
+ -- constrained array.
+ -- A fat array is a structure containing 2 fields:
+ -- * base: a pointer to the data of the array.
+ -- * bounds: a pointer to a structure containing as many fields as
+ -- number of dimensions; these fields are a structure describing the
+ -- range of the dimension.
+
+ -- Index array BASE of type ATYPE with INDEX.
+ -- INDEX must be of type ghdl_index_type, thus no bounds checks are
+ -- performed.
+ function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode)
+ return Mnode;
+
+ -- Same for for slicing.
+ function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode)
+ return Mnode;
+
+ -- Get the length of the array (the number of elements).
+ function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode;
+
+ -- Get the number of elements for bounds BOUNDS. BOUNDS are
+ -- automatically stabilized if necessary.
+ function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode;
+
+ -- Get the number of elements in array ATYPE.
+ function Get_Array_Type_Length (Atype : Iir) return O_Enode;
+
+ -- Get the base of array ARR.
+ function Get_Array_Base (Arr : Mnode) return Mnode;
+
+ -- Get the bounds of array ARR.
+ function Get_Array_Bounds (Arr : Mnode) return Mnode;
+
+ -- Get the range ot ATYPE.
+ function Type_To_Range (Atype : Iir) return Mnode;
+
+ -- Get length of range R.
+ function Range_To_Length (R : Mnode) return Mnode;
+
+ -- Get direction of range R.
+ function Range_To_Dir (R : Mnode) return Mnode;
+
+ -- Get left/right bounds for range R.
+ function Range_To_Left (R : Mnode) return Mnode;
+ function Range_To_Right (R : Mnode) return Mnode;
+
+ -- Get range for dimension DIM (1 based) of array bounds B or type
+ -- ATYPE.
+ function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive)
+ return Mnode;
+
+ -- Get the range of dimension DIM (1 based) of array ARR of type ATYPE.
+ function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive)
+ return Mnode;
+
+ -- Get array bounds for type ATYPE.
+ function Get_Array_Type_Bounds (Atype : Iir) return Mnode;
+
+ -- Deallocate OBJ.
+ procedure Gen_Deallocate (Obj : O_Enode);
+
+ -- Performs deallocation of PARAM (the parameter of a deallocate call).
+ procedure Translate_Object_Deallocation (Param : Iir);
+
+ -- Allocate an object of type OBJ_TYPE and set RES.
+ -- RES must be a stable access of type ortho_ptr_type.
+ -- For an unconstrained array, BOUNDS is a pointer to the boundaries of
+ -- the object, which are copied.
+ procedure Translate_Object_Allocation
+ (Res : in out Mnode;
+ Alloc_Kind : Allocation_Kind;
+ Obj_Type : Iir;
+ Bounds : Mnode);
+
+ -- Copy SRC to DEST.
+ -- Both have the same type, OTYPE.
+ -- Furthermore, arrays are of the same length.
+ procedure Translate_Object_Copy
+ (Dest : Mnode; Src : O_Enode; Obj_Type : Iir);
+
+ -- Get size (in bytes with type ghdl_index_type) of object OBJ.
+ -- For an unconstrained array, OBJ must be really an object, otherwise,
+ -- it may be a null_mnode, created by T2M.
+ function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode;
+
+ -- Allocate the base of a fat array, whose length is determined from
+ -- the bounds.
+ -- RES_PTR is a pointer to the fat pointer (must be a variable that
+ -- can be referenced several times).
+ -- ARR_TYPE is the type of the array.
+ procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind;
+ Res : Mnode;
+ Arr_Type : Iir);
+
+ -- Create the bounds for SUB_TYPE.
+ -- SUB_TYPE is expected to be a non-static, anonymous array type.
+ procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean);
+
+ -- Return TRUE if VALUE is not is the range specified by ATYPE.
+ -- VALUE must be stable.
+ function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode;
+
+ -- Return TRUE if base type of ATYPE is larger than its bounds, ie
+ -- if a value of type ATYPE may be out of range.
+ function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean;
+
+ -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR
+ -- if not from a tree) is not in range specified by ATYPE.
+ procedure Check_Range
+ (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir);
+
+ -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR.
+ function Insert_Scalar_Check
+ (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir)
+ return O_Enode;
+
+ -- The base type of EXPR and the base type of ATYPE must be the same.
+ -- If the type is a scalar type, and if a range check is needed, this
+ -- function inserts the check. Otherwise, it returns VALUE.
+ function Maybe_Insert_Scalar_Check
+ (Value : O_Enode; Expr : Iir; Atype : Iir)
+ return O_Enode;
+
+ -- Return True iff all indexes of L_TYPE and R_TYPE have the same
+ -- length. They must be locally static.
+ function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean;
+
+ -- Check bounds length of L match bounds length of R.
+ -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE
+ -- (resp. R_NODE) are not used (and may be Mnode_Null).
+ -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE)
+ -- must designate the array.
+ procedure Check_Array_Match (L_Type : Iir;
+ L_Node : Mnode;
+ R_Type : Iir;
+ R_Node : Mnode;
+ Loc : Iir);
+
+ -- Create a subtype range to be stored into the location pointed by
+ -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE.
+ -- This is done according to rules 7.2.4 of LRM93, ie:
+ -- direction and left bound of the range is the same of INDEX_TYPE.
+ -- LENGTH and RANGE_PTR are variables. LOC is the location in case of
+ -- error.
+ procedure Create_Range_From_Length
+ (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir);
+
+ end Chap3;
+
+ package Chap4 is
+ -- Translate of a type declaration corresponds to the translation of
+ -- its definition.
+ procedure Translate_Type_Declaration (Decl : Iir);
+ procedure Translate_Anonymous_Type_Declaration (Decl : Iir);
+ procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration);
+ procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration);
+
+ -- Translate declaration DECL, which must not be a subprogram
+ -- specification.
+ procedure Translate_Declaration (Decl : Iir);
+
+ -- Translate declarations, except subprograms spec and bodies.
+ procedure Translate_Declaration_Chain (Parent : Iir);
+
+ -- Translate subprograms in declaration chain of PARENT.
+ procedure Translate_Declaration_Chain_Subprograms (Parent : Iir);
+
+ -- Create subprograms for type/function conversion of signal
+ -- associations.
+ -- ENTITY is the entity instantiated, which can be either
+ -- an entity_declaration (for component configuration or direct
+ -- component instantiation), a component declaration (for a component
+ -- instantiation) or Null_Iir (for a block header).
+ -- BLOCK is the block/architecture containing the instantiation stmt.
+ -- STMT is either the instantiation stmt or the block header.
+ procedure Translate_Association_Subprograms
+ (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir);
+
+ -- Elaborate In/Out_Conversion for ASSOC (signals only).
+ -- NDEST is the data structure to be registered.
+ procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode);
+ procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode);
+
+ -- Create code to elaborate declarations.
+ -- NEED_FINAL is set when at least one declaration needs to be
+ -- finalized (eg: file declaration, protected objects).
+ procedure Elab_Declaration_Chain
+ (Parent : Iir; Need_Final : out Boolean);
+
+ -- Finalize declarations.
+ procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean);
+
+ -- Translate port or generic declarations of PARENT.
+ procedure Translate_Port_Chain (Parent : Iir);
+ procedure Translate_Generic_Chain (Parent : Iir);
+
+ -- Elaborate signal subtypes and allocate the storage for the object.
+ procedure Elab_Signal_Declaration_Storage (Decl : Iir);
+
+ -- Create signal object.
+ -- Note: SIG can be a signal sub-element (used when signals are
+ -- collapsed).
+ -- If CHECK_NULL is TRUE, create the signal only if it was not yet
+ -- created.
+ -- PARENT is used to link the signal to its parent by rti.
+ procedure Elab_Signal_Declaration_Object
+ (Sig : Iir; Parent : Iir; Check_Null : Boolean);
+
+ -- True of SIG has a direct driver.
+ function Has_Direct_Driver (Sig : Iir) return Boolean;
+
+ -- Allocate memory for direct driver if necessary.
+ procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir);
+
+ -- Generate code to create object OBJ and initialize it with value VAL.
+ procedure Elab_Object_Value (Obj : Iir; Value : Iir);
+
+ -- Allocate the storage for OBJ, if necessary.
+ procedure Elab_Object_Storage (Obj : Iir);
+
+ -- Initialize NAME/OBJ with VALUE.
+ procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir);
+
+ -- Get the ortho type for an object of type TINFO.
+ function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type)
+ return O_Tnode;
+
+ -- Allocate (and build) a complex object of type OBJ_TYPE.
+ -- VAR is the object to be allocated.
+ procedure Allocate_Complex_Object (Obj_Type : Iir;
+ Alloc_Kind : Allocation_Kind;
+ Var : in out Mnode);
+
+ --function Translate_Interface_Declaration
+ -- (Decl : Iir; Subprg : Iir) return Tree;
+
+ -- Create a record that describe thes location of an IIR node and
+ -- returns the address of it.
+ function Get_Location (N : Iir) return O_Dnode;
+
+ -- Set default value to OBJ.
+ procedure Init_Object (Obj : Mnode; Obj_Type : Iir);
+ end Chap4;
+
+ package Chap6 is
+ -- Translate NAME.
+ -- RES contains a lnode for the result. This is the object.
+ -- RES can be a tree, so it may be referenced only once.
+ -- SIG is true if RES is a signal object.
+ function Translate_Name (Name : Iir) return Mnode;
+
+ -- Translate signal NAME into its node (SIG) and its direct driver
+ -- node (DRV).
+ procedure Translate_Direct_Driver
+ (Name : Iir; Sig : out Mnode; Drv : out Mnode);
+
+ -- Same as Translate_Name, but only for formal names.
+ -- If SCOPE_TYPE and SCOPE_PARAM are not null, use them for the scope
+ -- of the base name.
+ -- Indeed, for recursive instantiation, NAME can designates the actual
+ -- and the formal.
+-- function Translate_Formal_Name (Scope_Type : O_Tnode;
+-- Scope_Param : O_Lnode;
+-- Name : Iir)
+-- return Mnode;
+
+ -- Get record element EL of PREFIX.
+ function Translate_Selected_Element (Prefix : Mnode;
+ El : Iir_Element_Declaration)
+ return Mnode;
+
+ function Get_Array_Bound_Length (Arr : Mnode;
+ Arr_Type : Iir;
+ Dim : Natural)
+ return O_Enode;
+
+ procedure Gen_Bound_Error (Loc : Iir);
+
+ -- Generate code to emit a program error.
+ Prg_Err_Missing_Return : constant Natural := 1;
+ Prg_Err_Block_Configured : constant Natural := 2;
+ Prg_Err_Dummy_Config : constant Natural := 3;
+ Prg_Err_No_Choice : constant Natural := 4;
+ Prg_Err_Bad_Choice : constant Natural := 5;
+ procedure Gen_Program_Error (Loc : Iir; Code : Natural);
+
+ -- Generate code to emit a failure if COND is TRUE, indicating an
+ -- index violation for dimension DIM of an array. LOC is usually
+ -- the expression which has computed the index and is used only for
+ -- its location.
+ procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural);
+
+ -- Get the deepest range_expression of ATYPE.
+ -- This follows 'range and 'reverse_range.
+ -- Set IS_REVERSE to true if the range must be reversed.
+ procedure Get_Deep_Range_Expression
+ (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean);
+
+ -- Get the offset of INDEX in the range RNG.
+ -- This checks INDEX belongs to the range.
+ -- RANGE_TYPE is the subtype of the array index (or the subtype of RNG).
+ -- For unconstrained ranges, INDEX_EXPR must be NULL_IIR and RANGE_TYPE
+ -- must be set.
+ function Translate_Index_To_Offset (Rng : Mnode;
+ Index : O_Enode;
+ Index_Expr : Iir;
+ Range_Type : Iir;
+ Loc : Iir)
+ return O_Enode;
+ end Chap6;
+
+ package Chap7 is
+ -- Generic function to extract a value from a signal.
+ generic
+ with function Read_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode;
+ function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode;
+
+ -- Extract the effective value of SIG.
+ function Translate_Signal_Effective_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode;
+ function Translate_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode;
+
+ -- Directly set the effective value of SIG with VAL.
+ -- Used only by conversion.
+ procedure Set_Effective_Value
+ (Sig : Mnode; Sig_Type : Iir; Val : Mnode);
+
+ procedure Set_Driving_Value
+ (Sig : Mnode; Sig_Type : Iir; Val : Mnode);
+
+ -- Translate expression EXPR into ortho tree.
+ function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir)
+ return O_Enode;
+
+ -- Translate call to function IMP.
+ -- ASSOC_CHAIN is the chain of a associations for this call.
+ -- OBJ, if not NULL_IIR is the protected object.
+ function Translate_Function_Call
+ (Imp : Iir; Assoc_Chain : Iir; Obj : Iir)
+ return O_Enode;
+
+ -- Translate range and return an lvalue containing the range.
+ -- The node returned can be used only one time.
+ function Translate_Range (Arange : Iir; Range_Type : Iir)
+ return O_Lnode;
+
+ -- Translate range expression EXPR and store the result into the node
+ -- pointed by RES_PTR, of type RANGE_TYPE.
+ procedure Translate_Range_Ptr
+ (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir);
+ function Translate_Static_Range (Arange : Iir; Range_Type : Iir)
+ return O_Cnode;
+
+ -- Same as Translate_Range_Ptr, but for a discrete range (ie: ARANGE
+ -- can be a discrete subtype indication).
+ procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir);
+
+ -- Return TRUE iff constant declaration DECL can be staticly defined.
+ -- This is of course true if its expression is a locally static literal,
+ -- but can be true in a few cases for aggregates.
+ -- This function belongs to Translation, since it is defined along
+ -- with the translate_static_aggregate procedure.
+ function Is_Static_Constant (Decl : Iir_Constant_Declaration)
+ return Boolean;
+
+ -- Translate the static expression EXPR into an ortho expression whose
+ -- type must be RES_TYPE. Therefore, an implicite conversion might
+ -- occurs.
+ function Translate_Static_Expression (Expr : Iir; Res_Type : Iir)
+ return O_Cnode;
+ function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode)
+ return O_Cnode;
+
+ -- Convert (if necessary) EXPR of type EXPR_TYPE to type ATYPE.
+ function Translate_Implicit_Conv
+ (Expr : O_Enode;
+ Expr_Type : Iir;
+ Atype : Iir;
+ Is_Sig : Object_Kind_Type;
+ Loc : Iir)
+ return O_Enode;
+
+ function Translate_Type_Conversion
+ (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return O_Enode;
+
+ -- Convert range EXPR into ortho tree.
+ -- If RANGE_TYPE /= NULL_IIR, convert bounds to RANGE_TYPE.
+ --function Translate_Range (Expr : Iir; Range_Type : Iir) return O_Enode;
+ function Translate_Static_Range_Left
+ (Expr : Iir; Range_Type : Iir := Null_Iir)
+ return O_Cnode;
+ function Translate_Static_Range_Right
+ (Expr : Iir; Range_Type : Iir := Null_Iir)
+ return O_Cnode;
+ function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode;
+ function Translate_Static_Range_Length (Expr : Iir) return O_Cnode;
+
+ -- These functions evaluates left bound/right bound/length of the
+ -- range expression EXPR.
+ function Translate_Range_Expression_Left (Expr : Iir;
+ Range_Type : Iir := Null_Iir)
+ return O_Enode;
+ function Translate_Range_Expression_Right (Expr : Iir;
+ Range_Type : Iir := Null_Iir)
+ return O_Enode;
+ function Translate_Range_Expression_Length (Expr : Iir) return O_Enode;
+
+ -- Get the length of any range expression (ie maybe an attribute).
+ function Translate_Range_Length (Expr : Iir) return O_Enode;
+
+ -- Assign AGGR to TARGET of type TARGET_TYPE.
+ procedure Translate_Aggregate
+ (Target : Mnode; Target_Type : Iir; Aggr : Iir);
+
+ -- Translate implicit functions defined by a type.
+ type Implicit_Subprogram_Infos is private;
+ procedure Init_Implicit_Subprogram_Infos
+ (Infos : out Implicit_Subprogram_Infos);
+ procedure Translate_Implicit_Subprogram
+ (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos);
+
+ -- Assign EXPR to TARGET. LOC is the location used to report errors.
+ -- FIXME: do the checks.
+ procedure Translate_Assign
+ (Target : Mnode; Expr : Iir; Target_Type : Iir);
+ procedure Translate_Assign
+ (Target : Mnode;
+ Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir);
+
+ -- Find the declaration of the predefined function IMP in type
+ -- definition BASE_TYPE.
+ function Find_Predefined_Function
+ (Base_Type : Iir; Imp : Iir_Predefined_Functions)
+ return Iir;
+
+ function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode)
+ return O_Enode;
+ private
+ type Implicit_Subprogram_Infos is record
+ Arr_Eq_Info : Subprg_Info_Acc;
+ Rec_Eq_Info : Subprg_Info_Acc;
+ Arr_Cmp_Info : Subprg_Info_Acc;
+ Arr_Concat_Info : Subprg_Info_Acc;
+ Arr_Shl_Info : Subprg_Info_Acc;
+ Arr_Sha_Info : Subprg_Info_Acc;
+ Arr_Rot_Info : Subprg_Info_Acc;
+ end record;
+ end Chap7;
+
+ package Chap14 is
+ function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode;
+
+ -- Read signal value FIELD of signal SIG.
+ function Get_Signal_Value_Field
+ (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode)
+ return O_Lnode;
+
+ function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) return O_Lnode;
+
+ function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir)
+ return O_Enode;
+ function Translate_Low_Array_Attribute (Expr : Iir) return O_Enode;
+ function Translate_High_Array_Attribute (Expr : Iir) return O_Enode;
+ function Translate_Range_Array_Attribute (Expr : Iir) return O_Lnode;
+ function Translate_Right_Array_Attribute (Expr : Iir) return O_Enode;
+ function Translate_Left_Array_Attribute (Expr : Iir) return O_Enode;
+ function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode;
+
+ function Translate_High_Low_Type_Attribute
+ (Atype : Iir; Is_High : Boolean) return O_Enode;
+
+ -- Return the value of the left bound/right bound/direction of scalar
+ -- type ATYPE.
+ function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode;
+ function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode;
+ function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode;
+
+ function Translate_Val_Attribute (Attr : Iir) return O_Enode;
+ function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir)
+ return O_Enode;
+
+ function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode;
+
+ function Translate_Image_Attribute (Attr : Iir) return O_Enode;
+ function Translate_Value_Attribute (Attr : Iir) return O_Enode;
+
+ function Translate_Event_Attribute (Attr : Iir) return O_Enode;
+ function Translate_Active_Attribute (Attr : Iir) return O_Enode;
+ function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode;
+
+ function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode)
+ return O_Enode;
+
+ function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode;
+
+ function Translate_Driving_Attribute (Attr : Iir) return O_Enode;
+
+ function Translate_Path_Instance_Name_Attribute (Attr : Iir)
+ return O_Enode;
+ end Chap14;
+
+ package Helpers is
+ -- Return the value of field FIELD of lnode L that is contains
+ -- a pointer to a record.
+ -- This is equivalent to:
+ -- new_value (new_selected_element (new_access_element (new_value (l)),
+ -- field))
+ function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
+ return O_Enode;
+ function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
+ return O_Lnode;
+
+ function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode;
+
+ -- Equivalent to new_access_element (new_value (l))
+ function New_Acc_Value (L : O_Lnode) return O_Lnode;
+
+ -- Copy a fat pointer.
+ -- D and S are stabilized fat pointers.
+ procedure Copy_Fat_Pointer (D : Mnode; S: Mnode);
+
+ -- Generate code to initialize a ghdl_index_type variable V to 0.
+ procedure Init_Var (V : O_Dnode);
+
+ -- Generate code to increment/decrement a ghdl_index_type variable V.
+ procedure Inc_Var (V : O_Dnode);
+ procedure Dec_Var (V : O_Dnode);
+
+ -- Generate code to exit from loop LABEL iff COND is true.
+ procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode);
+
+ -- Create a uniq identifier.
+ subtype Uniq_Identifier_String is String (1 .. 11);
+ function Create_Uniq_Identifier return Uniq_Identifier_String;
+ function Create_Uniq_Identifier return O_Ident;
+
+ -- Create a region for temporary variables.
+ procedure Open_Temp;
+ -- Create a temporary variable.
+ function Create_Temp (Atype : O_Tnode) return O_Dnode;
+ -- Create a temporary variable of ATYPE and initialize it with VALUE.
+ function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode)
+ return O_Dnode;
+ -- Create a temporary variable of ATYPE and initialize it with the
+ -- address of NAME.
+ function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode)
+ return O_Dnode;
+ -- Create a mark in the temporary region for the stack2.
+ -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known
+ -- stack2 can be released.
+ procedure Create_Temp_Stack2_Mark;
+ -- Add ATYPE in the chain of types to be destroyed at the end of the
+ -- temp scope.
+ procedure Add_Transient_Type_In_Temp (Atype : Iir);
+ -- Close the temporary region.
+ procedure Close_Temp;
+
+ -- Like Open_Temp, but will never create a declare region. To be used
+ -- only within a subprogram, to use the declare region of the
+ -- subprogram.
+ procedure Open_Local_Temp;
+ -- Destroy transient types created in a temporary region.
+ procedure Destroy_Local_Transient_Types;
+ procedure Close_Local_Temp;
+
+ -- Return TRUE if stack2 will be released. Used for fine-tuning only
+ -- (return statement).
+ function Has_Stack2_Mark return Boolean;
+ -- Manually release stack2. Used for fine-tuning only.
+ procedure Stack2_Release;
+
+ -- Free all old temp.
+ -- Used only to free memory.
+ procedure Free_Old_Temp;
+
+ -- Return a ghdl_index_type literal for NUM.
+ function New_Index_Lit (Num : Unsigned_64) return O_Cnode;
+
+ -- Create a constant (of name ID) for string STR.
+ -- Append a NUL terminator (to make interfaces with C easier).
+ function Create_String (Str : String; Id : O_Ident) return O_Dnode;
+
+ function Create_String (Str : String; Id : O_Ident; Storage : O_Storage)
+ return O_Dnode;
+
+ function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage)
+ return O_Dnode;
+
+ function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode;
+
+ procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode);
+
+ -- Allocate SIZE bytes aligned on the biggest alignment and return a
+ -- pointer of type PTYPE.
+ function Gen_Alloc
+ (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode)
+ return O_Enode;
+
+ -- Allocate on the heap LENGTH bytes aligned on the biggest alignment,
+ -- and returns a pointer of type PTYPE.
+ --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode;
+
+ -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE
+ -- on each non composite type.
+ -- There is a generic parameter DATA which may be updated
+ -- before indexing an array by UPDATE_DATA_ARRAY.
+ generic
+ type Data_Type is private;
+ type Composite_Data_Type is private;
+ with procedure Do_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Data_Type);
+
+ -- This function should extract the base of DATA.
+ with function Prepare_Data_Array (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Data_Type)
+ return Composite_Data_Type;
+
+ -- This function should index DATA.
+ with function Update_Data_Array (Data : Composite_Data_Type;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Data_Type;
+
+ -- This function is called at the end of a record process.
+ with procedure Finish_Data_Array (Data : in out Composite_Data_Type);
+
+ -- This function should stabilize DATA.
+ with function Prepare_Data_Record (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Data_Type)
+ return Composite_Data_Type;
+
+ -- This function should extract field EL of DATA.
+ with function Update_Data_Record (Data : Composite_Data_Type;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Data_Type;
+
+ -- This function is called at the end of a record process.
+ with procedure Finish_Data_Record (Data : in out Composite_Data_Type);
+
+ procedure Foreach_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Data_Type);
+
+ -- Call a procedure (DATA_TYPE) for each signal of TARG.
+ procedure Register_Signal
+ (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode);
+
+ -- Call PROC for each scalar signal of list LIST.
+ procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode);
+
+ -- Often used subprograms for Foreach_non_composite
+ -- when DATA_TYPE is o_enode.
+ function Gen_Oenode_Prepare_Data_Composite
+ (Targ: Mnode; Targ_Type : Iir; Val : O_Enode)
+ return Mnode;
+ function Gen_Oenode_Update_Data_Array (Val : Mnode;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return O_Enode;
+ function Gen_Oenode_Update_Data_Record
+ (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return O_Enode;
+ procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode);
+
+ type Hexstr_Type is array (Integer range 0 .. 15) of Character;
+ N2hex : constant Hexstr_Type := "0123456789abcdef";
+
+ function Get_Line_Number (Target: Iir) return Natural;
+
+ procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List;
+ Line : Natural);
+ private
+ end Helpers;
+ use Helpers;
+
+ function Get_Type_Info (M : Mnode) return Type_Info_Acc is
+ begin
+ return M.M1.T;
+ end Get_Type_Info;
+
+ function Get_Object_Kind (M : Mnode) return Object_Kind_Type is
+ begin
+ return M.M1.K;
+ end Get_Object_Kind;
+
+ function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_E,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, E => E,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end E2M;
+
+ function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Lv,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Lv => L,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end Lv2M;
+
+ function Lv2M (L : O_Lnode;
+ Comp : Boolean;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode;
+ T : Type_Info_Acc; Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Lv,
+ Comp => Comp,
+ K => Kind, T => T, Lv => L,
+ Vtype => Vtype, Ptype => Ptype));
+ end Lv2M;
+
+ function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Lp,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Lp => L,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end Lp2M;
+
+ function Lp2M (L : O_Lnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Lp,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Lp => L,
+ Vtype => Vtype, Ptype => Ptype));
+ end Lp2M;
+
+ function Lv2M (L : O_Lnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Lv,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Lv => L,
+ Vtype => Vtype, Ptype => Ptype));
+ end Lv2M;
+
+ function Dv2M (D : O_Dnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Dv,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Dv => D,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end Dv2M;
+
+ function Dv2M (D : O_Dnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Dv,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Dv => D,
+ Vtype => Vtype,
+ Ptype => Ptype));
+ end Dv2M;
+
+ function Dp2M (D : O_Dnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Dp,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Dp => D,
+ Vtype => Vtype, Ptype => Ptype));
+ end Dp2M;
+
+ function Dp2M (D : O_Dnode;
+ T : Type_Info_Acc;
+ Kind : Object_Kind_Type)
+ return Mnode is
+ begin
+ return Mnode'(M1 => (State => Mstate_Dp,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T, Dp => D,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end Dp2M;
+
+ function M2Lv (M : Mnode) return O_Lnode is
+ begin
+ case M.M1.State is
+ when Mstate_E =>
+ case Get_Type_Info (M).Type_Mode is
+ when Type_Mode_Thin =>
+ -- Scalar to var is not possible.
+ -- FIXME: This is not coherent with the fact that this
+ -- conversion is possible when M is stabilized.
+ raise Internal_Error;
+ when Type_Mode_Fat =>
+ return New_Access_Element (M.M1.E);
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ when Mstate_Lp =>
+ return New_Acc_Value (M.M1.Lp);
+ when Mstate_Lv =>
+ return M.M1.Lv;
+ when Mstate_Dp =>
+ return New_Acc_Value (New_Obj (M.M1.Dp));
+ when Mstate_Dv =>
+ return New_Obj (M.M1.Dv);
+ when Mstate_Null
+ | Mstate_Bad =>
+ raise Internal_Error;
+ end case;
+ end M2Lv;
+
+ function M2Lp (M : Mnode) return O_Lnode is
+ begin
+ case M.M1.State is
+ when Mstate_E =>
+ raise Internal_Error;
+ when Mstate_Lp =>
+ return M.M1.Lp;
+ when Mstate_Dp =>
+ return New_Obj (M.M1.Dp);
+ when Mstate_Lv =>
+ if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then
+ return New_Obj
+ (Create_Temp_Init (M.M1.Ptype,
+ New_Address (M.M1.Lv, M.M1.Ptype)));
+ else
+ raise Internal_Error;
+ end if;
+ when Mstate_Dv
+ | Mstate_Null
+ | Mstate_Bad =>
+ raise Internal_Error;
+ end case;
+ end M2Lp;
+
+ function M2Dp (M : Mnode) return O_Dnode is
+ begin
+ case M.M1.State is
+ when Mstate_Dp =>
+ return M.M1.Dp;
+ when Mstate_Dv =>
+ return Create_Temp_Init
+ (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype));
+
+ when others =>
+ raise Internal_Error;
+ end case;
+ end M2Dp;
+
+ function M2Dv (M : Mnode) return O_Dnode is
+ begin
+ case M.M1.State is
+ when Mstate_Dv =>
+ return M.M1.Dv;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end M2Dv;
+
+ function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode
+ is
+ T : Type_Info_Acc;
+ begin
+ T := Get_Info (Atype);
+ return Mnode'(M1 => (State => Mstate_Null,
+ Comp => T.Type_Mode in Type_Mode_Fat,
+ K => Kind, T => T,
+ Vtype => T.Ortho_Type (Kind),
+ Ptype => T.Ortho_Ptr_Type (Kind)));
+ end T2M;
+
+ function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode
+ is
+ D : O_Dnode;
+ K : Object_Kind_Type;
+ begin
+ K := M.M1.K;
+ case M.M1.State is
+ when Mstate_E =>
+ if M.M1.Comp then
+ D := Create_Temp_Init (M.M1.Ptype, M.M1.E);
+ return Mnode'(M1 => (State => Mstate_Dp,
+ Comp => M.M1.Comp,
+ K => K, T => M.M1.T, Dp => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+ else
+ D := Create_Temp_Init (M.M1.Vtype, M.M1.E);
+ return Mnode'(M1 => (State => Mstate_Dv,
+ Comp => M.M1.Comp,
+ K => K, T => M.M1.T, Dv => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+ end if;
+ when Mstate_Lp =>
+ D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp));
+ return Mnode'(M1 => (State => Mstate_Dp,
+ Comp => M.M1.Comp,
+ K => K, T => M.M1.T, Dp => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+ when Mstate_Lv =>
+ if M.M1.Ptype = O_Tnode_Null then
+ if not Can_Copy then
+ raise Internal_Error;
+ end if;
+ D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv));
+ return Mnode'(M1 => (State => Mstate_Dv,
+ Comp => M.M1.Comp,
+ K => K, T => M.M1.T, Dv => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+
+ else
+ D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv);
+ return Mnode'(M1 => (State => Mstate_Dp,
+ Comp => M.M1.Comp,
+ K => K, T => M.M1.T, Dp => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+ end if;
+ when Mstate_Dp
+ | Mstate_Dv =>
+ return M;
+ when Mstate_Bad
+ | Mstate_Null =>
+ raise Internal_Error;
+ end case;
+ end Stabilize;
+
+ procedure Stabilize (M : in out Mnode) is
+ begin
+ M := Stabilize (M);
+ end Stabilize;
+
+ function Stabilize_Value (M : Mnode) return Mnode
+ is
+ D : O_Dnode;
+ E : O_Enode;
+ begin
+ -- M must be scalar or access.
+ if M.M1.Comp then
+ raise Internal_Error;
+ end if;
+ case M.M1.State is
+ when Mstate_E =>
+ E := M.M1.E;
+ when Mstate_Lp =>
+ E := New_Value (New_Acc_Value (M.M1.Lp));
+ when Mstate_Lv =>
+ E := New_Value (M.M1.Lv);
+ when Mstate_Dp
+ | Mstate_Dv =>
+ return M;
+ when Mstate_Bad
+ | Mstate_Null =>
+ raise Internal_Error;
+ end case;
+
+ D := Create_Temp_Init (M.M1.Vtype, E);
+ return Mnode'(M1 => (State => Mstate_Dv,
+ Comp => M.M1.Comp,
+ K => M.M1.K, T => M.M1.T, Dv => D,
+ Vtype => M.M1.Vtype, Ptype => M.M1.Ptype));
+ end Stabilize_Value;
+
+ function M2E (M : Mnode) return O_Enode is
+ begin
+ case M.M1.State is
+ when Mstate_E =>
+ return M.M1.E;
+ when Mstate_Lp =>
+ case M.M1.T.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_Thin =>
+ return New_Value (New_Acc_Value (M.M1.Lp));
+ when Type_Mode_Fat =>
+ return New_Value (M.M1.Lp);
+ end case;
+ when Mstate_Dp =>
+ case M.M1.T.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_Thin =>
+ return New_Value (New_Acc_Value (New_Obj (M.M1.Dp)));
+ when Type_Mode_Fat =>
+ return New_Value (New_Obj (M.M1.Dp));
+ end case;
+ when Mstate_Lv =>
+ case M.M1.T.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_Thin =>
+ return New_Value (M.M1.Lv);
+ when Type_Mode_Fat =>
+ return New_Address (M.M1.Lv, M.M1.Ptype);
+ end case;
+ when Mstate_Dv =>
+ case M.M1.T.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_Thin =>
+ return New_Value (New_Obj (M.M1.Dv));
+ when Type_Mode_Fat =>
+ return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype);
+ end case;
+ when Mstate_Bad
+ | Mstate_Null =>
+ raise Internal_Error;
+ end case;
+ end M2E;
+
+ function M2Addr (M : Mnode) return O_Enode is
+ begin
+ case M.M1.State is
+ when Mstate_Lp =>
+ return New_Value (M.M1.Lp);
+ when Mstate_Dp =>
+ return New_Value (New_Obj (M.M1.Dp));
+ when Mstate_Lv =>
+ return New_Address (M.M1.Lv, M.M1.Ptype);
+ when Mstate_Dv =>
+ return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype);
+ when Mstate_E =>
+ if M.M1.Comp then
+ return M.M1.E;
+ else
+ raise Internal_Error;
+ end if;
+ when Mstate_Bad
+ | Mstate_Null =>
+ raise Internal_Error;
+ end case;
+ end M2Addr;
+
+-- function Is_Null (M : Mnode) return Boolean is
+-- begin
+-- return M.M1.State = Mstate_Null;
+-- end Is_Null;
+
+ function Is_Stable (M : Mnode) return Boolean is
+ begin
+ case M.M1.State is
+ when Mstate_Dp
+ | Mstate_Dv =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Stable;
+
+-- function Varv2M
+-- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
+-- return Mnode is
+-- begin
+-- return Lv2M (Get_Var (Var), Vtype, Mode);
+-- end Varv2M;
+
+ function Varv2M (Var : Var_Type;
+ Var_Type : Type_Info_Acc;
+ Mode : Object_Kind_Type;
+ Vtype : O_Tnode;
+ Ptype : O_Tnode)
+ return Mnode is
+ begin
+ return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype);
+ end Varv2M;
+
+ -- Convert a Lnode for a sub object to an MNODE.
+ function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
+ return Mnode is
+ begin
+ case Vtype.Type_Mode is
+ when Type_Mode_Scalar
+ | Type_Mode_Acc
+ | Type_Mode_File
+ | Type_Mode_Fat_Array
+ | Type_Mode_Fat_Acc =>
+ return Lv2M (L, Vtype, Mode);
+ when Type_Mode_Array
+ | Type_Mode_Record
+ | Type_Mode_Protected =>
+ if Is_Complex_Type (Vtype) then
+ return Lp2M (L, Vtype, Mode);
+ else
+ return Lv2M (L, Vtype, Mode);
+ end if;
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ end Lo2M;
+
+ function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
+ return Mnode is
+ begin
+ case Vtype.Type_Mode is
+ when Type_Mode_Scalar
+ | Type_Mode_Acc
+ | Type_Mode_File
+ | Type_Mode_Fat_Array
+ | Type_Mode_Fat_Acc =>
+ return Dv2M (D, Vtype, Mode);
+ when Type_Mode_Array
+ | Type_Mode_Record
+ | Type_Mode_Protected =>
+ if Is_Complex_Type (Vtype) then
+ return Dp2M (D, Vtype, Mode);
+ else
+ return Dv2M (D, Vtype, Mode);
+ end if;
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ end Lo2M;
+
+ function Get_Var
+ (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type)
+ return Mnode
+ is
+ L : O_Lnode;
+ D : O_Dnode;
+ Stable : Boolean;
+ begin
+ -- FIXME: there may be Vv2M and Vp2M.
+ Stable := Is_Var_Stable (Var);
+ if Stable then
+ D := Get_Var_Label (Var);
+ else
+ L := Get_Var (Var);
+ end if;
+ case Vtype.Type_Mode is
+ when Type_Mode_Scalar
+ | Type_Mode_Acc
+ | Type_Mode_File
+ | Type_Mode_Fat_Array
+ | Type_Mode_Fat_Acc =>
+ if Stable then
+ return Dv2M (D, Vtype, Mode);
+ else
+ return Lv2M (L, Vtype, Mode);
+ end if;
+ when Type_Mode_Array
+ | Type_Mode_Record
+ | Type_Mode_Protected =>
+ if Is_Complex_Type (Vtype) then
+ if Stable then
+ return Dp2M (D, Vtype, Mode);
+ else
+ return Lp2M (L, Vtype, Mode);
+ end if;
+ else
+ if Stable then
+ return Dv2M (D, Vtype, Mode);
+ else
+ return Lv2M (L, Vtype, Mode);
+ end if;
+ end if;
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ end Get_Var;
+
+ function Create_Temp (Info : Type_Info_Acc;
+ Kind : Object_Kind_Type := Mode_Value)
+ return Mnode is
+ begin
+ if Is_Complex_Type (Info)
+ and then Info.Type_Mode /= Type_Mode_Fat_Array
+ then
+ -- For a complex and constrained object, we just allocate
+ -- a pointer to the object.
+ return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind);
+ else
+ return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind);
+ end if;
+ end Create_Temp;
+
+ function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type
+ is
+ use Name_Table;
+ Attr : Iir_Attribute_Value;
+ Spec : Iir_Attribute_Specification;
+ Attr_Decl : Iir;
+ Expr : Iir;
+ begin
+ -- Look for 'FOREIGN.
+ Attr := Get_Attribute_Value_Chain (Decl);
+ while Attr /= Null_Iir loop
+ Spec := Get_Attribute_Specification (Attr);
+ Attr_Decl := Get_Attribute_Designator (Spec);
+ exit when Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign;
+ Attr := Get_Chain (Attr);
+ end loop;
+ if Attr = Null_Iir then
+ -- Not found.
+ raise Internal_Error;
+ end if;
+ Spec := Get_Attribute_Specification (Attr);
+ Expr := Get_Expression (Spec);
+ case Get_Kind (Expr) is
+ when Iir_Kind_String_Literal =>
+ declare
+ Ptr : String_Fat_Acc;
+ begin
+ Ptr := Get_String_Fat_Acc (Expr);
+ Name_Length := Natural (Get_String_Length (Expr));
+ for I in 1 .. Name_Length loop
+ Name_Buffer (I) := Ptr (Nat32 (I));
+ end loop;
+ end;
+ when Iir_Kind_Simple_Aggregate =>
+ declare
+ List : Iir_List;
+ El : Iir;
+ begin
+ List := Get_Simple_Aggregate_List (Expr);
+ Name_Length := 0;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Get_Kind (El) /= Iir_Kind_Enumeration_Literal then
+ raise Internal_Error;
+ end if;
+ Name_Length := Name_Length + 1;
+ Name_Buffer (Name_Length) :=
+ Character'Val (Get_Enum_Pos (El));
+ end loop;
+ end;
+ when Iir_Kind_Bit_String_Literal =>
+ Error_Msg_Sem
+ ("value of FOREIGN attribute cannot be a bit string", Expr);
+ Name_Length := 0;
+ when others =>
+ if Get_Expr_Staticness (Expr) /= Locally then
+ Error_Msg_Sem
+ ("value of FOREIGN attribute must be locally static", Expr);
+ Name_Length := 0;
+ else
+ raise Internal_Error;
+ end if;
+ end case;
+
+ if Name_Length = 0 then
+ return Foreign_Bad;
+ end if;
+
+ -- Only 'VHPIDIRECT' is recognized.
+ if Name_Length >= 10
+ and then Name_Buffer (1 .. 10) = "VHPIDIRECT"
+ then
+ declare
+ P : Natural;
+ Sf, Sl : Natural;
+ Lf, Ll : Natural;
+ begin
+ P := 11;
+
+ -- Skip spaces.
+ while P <= Name_Length and then Name_Buffer (P) = ' ' loop
+ P := P + 1;
+ end loop;
+ if P > Name_Length then
+ Error_Msg_Sem
+ ("missing subprogram/library name after VHPIDIRECT", Spec);
+ end if;
+ -- Extract library.
+ Lf := P;
+ while P < Name_Length and then Name_Buffer (P) /= ' ' loop
+ P := P + 1;
+ end loop;
+ Ll := P;
+ -- Extract subprogram.
+ P := P + 1;
+ while P <= Name_Length and then Name_Buffer (P) = ' ' loop
+ P := P + 1;
+ end loop;
+ Sf := P;
+ while P < Name_Length and then Name_Buffer (P) /= ' ' loop
+ P := P + 1;
+ end loop;
+ Sl := P;
+ if P < Name_Length then
+ Error_Msg_Sem ("garbage at end of VHPIDIRECT", Spec);
+ end if;
+
+ -- Accept empty library.
+ if Sf > Name_Length then
+ Sf := Lf;
+ Sl := Ll;
+ Lf := 0;
+ Ll := 0;
+ end if;
+
+ return Foreign_Info_Type'
+ (Kind => Foreign_Vhpidirect,
+ Lib_First => Lf,
+ Lib_Last => Ll,
+ Subprg_First => Sf,
+ Subprg_Last => Sl);
+ end;
+ elsif Name_Length = 14
+ and then Name_Buffer (1 .. 14) = "GHDL intrinsic"
+ then
+ return Foreign_Info_Type'(Kind => Foreign_Intrinsic);
+ else
+ Error_Msg_Sem
+ ("value of 'FOREIGN attribute does not begin with VHPIDIRECT",
+ Spec);
+ return Foreign_Bad;
+ end if;
+ end Translate_Foreign_Id;
+
+ package body Helpers is
+ function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
+ return O_Enode is
+ begin
+ return New_Value
+ (New_Selected_Element (New_Access_Element (New_Value (L)), Field));
+ end New_Value_Selected_Acc_Value;
+
+ function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode)
+ return O_Lnode is
+ begin
+ return New_Selected_Element
+ (New_Access_Element (New_Value (L)), Field);
+ end New_Selected_Acc_Value;
+
+ function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode
+ is
+ begin
+ return New_Indexed_Element (New_Access_Element (New_Value (L)), I);
+ end New_Indexed_Acc_Value;
+
+ function New_Acc_Value (L : O_Lnode) return O_Lnode is
+ begin
+ return New_Access_Element (New_Value (L));
+ end New_Acc_Value;
+
+ procedure Copy_Fat_Pointer (D : Mnode; S: Mnode)
+ is
+ begin
+ New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)),
+ M2Addr (Chap3.Get_Array_Base (S)));
+ New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)),
+ M2Addr (Chap3.Get_Array_Bounds (S)));
+ end Copy_Fat_Pointer;
+
+ procedure Inc_Var (V : O_Dnode) is
+ begin
+ New_Assign_Stmt (New_Obj (V),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (V),
+ New_Lit (Ghdl_Index_1)));
+ end Inc_Var;
+
+ procedure Dec_Var (V : O_Dnode) is
+ begin
+ New_Assign_Stmt (New_Obj (V),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (V),
+ New_Lit (Ghdl_Index_1)));
+ end Dec_Var;
+
+ procedure Init_Var (V : O_Dnode) is
+ begin
+ New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0));
+ end Init_Var;
+
+ procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode)
+ is
+ If_Blk : O_If_Block;
+ begin
+ Start_If_Stmt (If_Blk, Cond);
+ New_Exit_Stmt (Label);
+ Finish_If_Stmt (If_Blk);
+ end Gen_Exit_When;
+
+ Uniq_Id : Natural := 0;
+
+ function Create_Uniq_Identifier return Uniq_Identifier_String
+ is
+ Str : Uniq_Identifier_String;
+ Val : Natural;
+ begin
+ Str (1 .. 3) := "_UI";
+ Val := Uniq_Id;
+ Uniq_Id := Uniq_Id + 1;
+ for I in reverse 4 .. 11 loop
+ Str (I) := N2hex (Val mod 16);
+ Val := Val / 16;
+ end loop;
+ return Str;
+ end Create_Uniq_Identifier;
+
+ function Create_Uniq_Identifier return O_Ident is
+ begin
+ return Get_Identifier (Create_Uniq_Identifier);
+ end Create_Uniq_Identifier;
+
+ -- Create a temporary variable.
+ type Temp_Level_Type;
+ type Temp_Level_Acc is access Temp_Level_Type;
+ type Temp_Level_Type is record
+ Prev : Temp_Level_Acc;
+ Level : Natural;
+ Id : Natural;
+ Emitted : Boolean;
+ Stack2_Mark : O_Dnode;
+ Transient_Types : Iir;
+ end record;
+ -- Current level.
+ Temp_Level : Temp_Level_Acc := null;
+
+ -- List of unused temp_level_type structures. To be faster, they are
+ -- never deallocated.
+ Old_Level : Temp_Level_Acc := null;
+
+ -- If set, emit comments for open_temp/close_temp.
+ Flag_Debug_Temp : constant Boolean := False;
+
+ procedure Open_Temp
+ is
+ L : Temp_Level_Acc;
+ begin
+ if Old_Level /= null then
+ L := Old_Level;
+ Old_Level := L.Prev;
+ else
+ L := new Temp_Level_Type;
+ end if;
+ L.all := (Prev => Temp_Level,
+ Level => 0,
+ Id => 0,
+ Emitted => False,
+ Stack2_Mark => O_Dnode_Null,
+ Transient_Types => Null_Iir);
+ if Temp_Level /= null then
+ L.Level := Temp_Level.Level + 1;
+ end if;
+ Temp_Level := L;
+ if Flag_Debug_Temp then
+ New_Debug_Comment_Stmt
+ ("Open_Temp level " & Natural'Image (L.Level));
+ end if;
+ end Open_Temp;
+
+ procedure Open_Local_Temp is
+ begin
+ Open_Temp;
+ Temp_Level.Emitted := True;
+ end Open_Local_Temp;
+
+ procedure Add_Transient_Type_In_Temp (Atype : Iir)
+ is
+ Type_Info : Type_Info_Acc;
+ begin
+ Type_Info := Get_Info (Atype);
+ Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types;
+ Temp_Level.Transient_Types := Atype;
+ end Add_Transient_Type_In_Temp;
+
+ procedure Release_Transient_Types (Chain : in out Iir) is
+ N_Atype : Iir;
+ begin
+ while Chain /= Null_Iir loop
+ N_Atype := Get_Info (Chain).Type_Transient_Chain;
+ Chap3.Destroy_Type_Info (Chain);
+ Chain := N_Atype;
+ end loop;
+ end Release_Transient_Types;
+
+ procedure Destroy_Local_Transient_Types is
+ begin
+ Release_Transient_Types (Temp_Level.Transient_Types);
+ end Destroy_Local_Transient_Types;
+
+ function Has_Stack2_Mark return Boolean is
+ begin
+ return Temp_Level.Stack2_Mark /= O_Dnode_Null;
+ end Has_Stack2_Mark;
+
+ procedure Stack2_Release
+ is
+ Constr : O_Assoc_List;
+ begin
+ if Temp_Level.Stack2_Mark /= O_Dnode_Null then
+ Start_Association (Constr, Ghdl_Stack2_Release);
+ New_Association (Constr,
+ New_Value (New_Obj (Temp_Level.Stack2_Mark)));
+ New_Procedure_Call (Constr);
+ Temp_Level.Stack2_Mark := O_Dnode_Null;
+ end if;
+ end Stack2_Release;
+
+ procedure Close_Temp
+ is
+ L : Temp_Level_Acc;
+ begin
+ if Temp_Level = null then
+ -- OPEN_TEMP was not called.
+ raise Internal_Error;
+ end if;
+ if Flag_Debug_Temp then
+ New_Debug_Comment_Stmt
+ ("Close_Temp level " & Natural'Image (Temp_Level.Level));
+ end if;
+
+ if Temp_Level.Stack2_Mark /= O_Dnode_Null then
+ Stack2_Release;
+ end if;
+ if Temp_Level.Emitted then
+ Finish_Declare_Stmt;
+ end if;
+
+ -- Destroy transcient types.
+ Release_Transient_Types (Temp_Level.Transient_Types);
+
+ -- Unlink temp_level.
+ L := Temp_Level;
+ Temp_Level := L.Prev;
+ L.Prev := Old_Level;
+ Old_Level := L;
+ end Close_Temp;
+
+ procedure Close_Local_Temp is
+ begin
+ Temp_Level.Emitted := False;
+ Close_Temp;
+ end Close_Local_Temp;
+
+ procedure Free_Old_Temp
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Temp_Level_Type, Temp_Level_Acc);
+ T : Temp_Level_Acc;
+ begin
+ if Temp_Level /= null then
+ raise Internal_Error;
+ end if;
+ loop
+ T := Old_Level;
+ exit when T = null;
+ Old_Level := Old_Level.Prev;
+ Free (T);
+ end loop;
+ end Free_Old_Temp;
+
+ procedure Create_Temp_Stack2_Mark
+ is
+ Constr : O_Assoc_List;
+ begin
+ if Temp_Level.Stack2_Mark /= O_Dnode_Null then
+ -- Only the first mark in a region is registred.
+ -- The release operation frees the memory allocated after the
+ -- first mark.
+ return;
+ end if;
+ Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type);
+ Start_Association (Constr, Ghdl_Stack2_Mark);
+ New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark),
+ New_Function_Call (Constr));
+ end Create_Temp_Stack2_Mark;
+
+ function Create_Temp (Atype : O_Tnode) return O_Dnode
+ is
+ Str : String (1 .. 12);
+ Val : Natural;
+ Res : O_Dnode;
+ P : Natural;
+ begin
+ if Temp_Level = null then
+ -- OPEN_TEMP was never called.
+ raise Internal_Error;
+ -- This is an hack, just to allow array subtype to array type
+ -- conversion.
+ --New_Var_Decl
+ -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype);
+ --return Res;
+ else
+ if not Temp_Level.Emitted then
+ Temp_Level.Emitted := True;
+ Start_Declare_Stmt;
+ end if;
+ end if;
+ Val := Temp_Level.Id;
+ Temp_Level.Id := Temp_Level.Id + 1;
+ P := Str'Last;
+ loop
+ Str (P) := Character'Val (Val mod 10 + Character'Pos ('0'));
+ Val := Val / 10;
+ P := P - 1;
+ exit when Val = 0;
+ end loop;
+ Str (P) := '_';
+ P := P - 1;
+ Val := Temp_Level.Level;
+ loop
+ Str (P) := Character'Val (Val mod 10 + Character'Pos ('0'));
+ Val := Val / 10;
+ P := P - 1;
+ exit when Val = 0;
+ end loop;
+ Str (P) := 'T';
+ --Str (12) := Nul;
+ New_Var_Decl
+ (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype);
+ return Res;
+ end Create_Temp;
+
+ function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode)
+ return O_Dnode
+ is
+ Res : O_Dnode;
+ begin
+ Res := Create_Temp (Atype);
+ New_Assign_Stmt (New_Obj (Res), Value);
+ return Res;
+ end Create_Temp_Init;
+
+ function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode)
+ return O_Dnode is
+ begin
+ return Create_Temp_Init (Atype, New_Address (Name, Atype));
+ end Create_Temp_Ptr;
+
+ -- Return a ghdl_index_type literal for NUM.
+ function New_Index_Lit (Num : Unsigned_64) return O_Cnode is
+ begin
+ return New_Unsigned_Literal (Ghdl_Index_Type, Num);
+ end New_Index_Lit;
+
+ -- Convert NAME into a STRING_CST.
+ -- Append a NUL terminator (to make interfaces with C easier).
+ function Create_String_Type (Str : String) return O_Tnode is
+ begin
+ return New_Constrained_Array_Type
+ (Chararray_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Str'Length + 1)));
+ end Create_String_Type;
+
+ procedure Create_String_Value
+ (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String)
+ is
+ Res : O_Cnode;
+ List : O_Array_Aggr_List;
+ begin
+ Start_Const_Value (Const);
+ Start_Array_Aggr (List, Const_Type);
+ for I in Str'Range loop
+ New_Array_Aggr_El
+ (List,
+ New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I))));
+ end loop;
+ New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0));
+ Finish_Array_Aggr (List, Res);
+ Finish_Const_Value (Const, Res);
+ end Create_String_Value;
+
+ function Create_String (Str : String; Id : O_Ident) return O_Dnode
+ is
+ Atype : O_Tnode;
+ Const : O_Dnode;
+ begin
+ Atype := Create_String_Type (Str);
+ New_Const_Decl (Const, Id, O_Storage_Private, Atype);
+ Create_String_Value (Const, Atype, Str);
+ return Const;
+ end Create_String;
+
+ function Create_String (Str : String; Id : O_Ident; Storage : O_Storage)
+ return O_Dnode
+ is
+ Atype : O_Tnode;
+ Const : O_Dnode;
+ begin
+ Atype := Create_String_Type (Str);
+ New_Const_Decl (Const, Id, Storage, Atype);
+ if Storage /= O_Storage_External then
+ Create_String_Value (Const, Atype, Str);
+ end if;
+ return Const;
+ end Create_String;
+
+ function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage)
+ return O_Dnode
+ is
+ use Name_Table;
+ begin
+ if Name_Table.Is_Character (Str) then
+ raise Internal_Error;
+ end if;
+ Image (Str);
+ return Create_String (Name_Buffer (1 .. Name_Length), Id, Storage);
+ end Create_String;
+
+ function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode
+ is
+ Str_Cst : O_Dnode;
+ Str_Len : O_Cnode;
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Str_Cst := Create_String (Str, Id);
+ Str_Len := New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Str'Length));
+ Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node);
+ New_Record_Aggr_El (List, Str_Len);
+ New_Record_Aggr_El (List, New_Global_Address (Str_Cst,
+ Char_Ptr_Type));
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Create_String_Len;
+
+ procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode)
+ is
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Ghdl_Memcpy);
+ New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type));
+ New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type));
+ New_Association (Constr, Length);
+ New_Procedure_Call (Constr);
+ end Gen_Memcpy;
+
+-- function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode
+-- is
+-- Constr : O_Assoc_List;
+-- begin
+-- Start_Association (Constr, Ghdl_Malloc);
+-- New_Association (Constr, Length);
+-- return New_Convert_Ov (New_Function_Call (Constr), Ptype);
+-- end Gen_Malloc;
+
+ function Gen_Alloc
+ (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode)
+ return O_Enode
+ is
+ Constr : O_Assoc_List;
+ begin
+ case Kind is
+ when Alloc_Heap =>
+ Start_Association (Constr, Ghdl_Malloc);
+ New_Association (Constr, Size);
+ return New_Convert_Ov (New_Function_Call (Constr), Ptype);
+ when Alloc_System =>
+ Start_Association (Constr, Ghdl_Malloc0);
+ New_Association (Constr, Size);
+ return New_Convert_Ov (New_Function_Call (Constr), Ptype);
+ when Alloc_Stack =>
+ return New_Alloca (Ptype, Size);
+ when Alloc_Return =>
+ Start_Association (Constr, Ghdl_Stack2_Allocate);
+ New_Association (Constr, Size);
+ return New_Convert_Ov (New_Function_Call (Constr), Ptype);
+ end case;
+ end Gen_Alloc;
+
+ procedure Foreach_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Data_Type)
+ is
+ Type_Info : Type_Info_Acc;
+ begin
+ Type_Info := Get_Info (Targ_Type);
+ case Type_Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ Do_Non_Composite (Targ, Targ_Type, Data);
+ when Type_Mode_Fat_Array
+ | Type_Mode_Array =>
+ declare
+ Var_Array : Mnode;
+ Var_Base : Mnode;
+ Var_Length : O_Dnode;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ Sub_Data : Data_Type;
+ Composite_Data : Composite_Data_Type;
+ begin
+ Open_Temp;
+ Var_Array := Stabilize (Targ);
+ Var_Length := Create_Temp (Ghdl_Index_Type);
+ Var_Base := Stabilize (Chap3.Get_Array_Base (Var_Array));
+ New_Assign_Stmt
+ (New_Obj (Var_Length),
+ Chap3.Get_Array_Length (Var_Array, Targ_Type));
+ Composite_Data :=
+ Prepare_Data_Array (Var_Array, Targ_Type, Data);
+ if True then
+ Var_I := Create_Temp (Ghdl_Index_Type);
+ else
+ New_Var_Decl
+ (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ end if;
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label, New_Compare_Op (ON_Ge,
+ New_Value (New_Obj (Var_I)),
+ New_Value (New_Obj (Var_Length)),
+ Ghdl_Bool_Type));
+ Sub_Data := Update_Data_Array
+ (Composite_Data, Targ_Type, Var_I);
+ Foreach_Non_Composite
+ (Chap3.Index_Base (Var_Base, Targ_Type,
+ New_Value (New_Obj (Var_I))),
+ Get_Element_Subtype (Targ_Type),
+ Sub_Data);
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Data_Array (Composite_Data);
+ Close_Temp;
+ end;
+ when Type_Mode_Record =>
+ declare
+ Var_Record : Mnode;
+ Sub_Data : Data_Type;
+ Composite_Data : Composite_Data_Type;
+ List : Iir_List;
+ El : Iir_Element_Declaration;
+ begin
+ Open_Temp;
+ Var_Record := Stabilize (Targ);
+ Composite_Data :=
+ Prepare_Data_Record (Var_Record, Targ_Type, Data);
+ List := Get_Elements_Declaration_List
+ (Get_Base_Type (Targ_Type));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Sub_Data := Update_Data_Record
+ (Composite_Data, Targ_Type, El);
+ Foreach_Non_Composite
+ (Chap6.Translate_Selected_Element (Var_Record, El),
+ Get_Type (El),
+ Sub_Data);
+ end loop;
+ Finish_Data_Record (Composite_Data);
+ Close_Temp;
+ end;
+ when others =>
+ Error_Kind ("foreach_non_composite/"
+ & Type_Mode_Type'Image (Type_Info.Type_Mode),
+ Targ_Type);
+ end case;
+ end Foreach_Non_Composite;
+
+ procedure Register_Non_Composite_Signal (Targ : Mnode;
+ Targ_Type : Iir;
+ Proc : O_Dnode)
+ is
+ pragma Unreferenced (Targ_Type);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Proc);
+ New_Association
+ (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
+ New_Procedure_Call (Constr);
+ end Register_Non_Composite_Signal;
+
+ function Register_Update_Data_Array
+ (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ_Type);
+ pragma Unreferenced (Index);
+ begin
+ return Data;
+ end Register_Update_Data_Array;
+
+ function Register_Prepare_Data_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : O_Dnode)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ);
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Data;
+ end Register_Prepare_Data_Composite;
+
+ function Register_Update_Data_Record
+ (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ_Type);
+ pragma Unreferenced (El);
+ begin
+ return Data;
+ end Register_Update_Data_Record;
+
+ procedure Register_Finish_Data_Composite (D : in out O_Dnode)
+ is
+ pragma Unreferenced (D);
+ begin
+ null;
+ end Register_Finish_Data_Composite;
+
+ procedure Register_Signal_1 is new Foreach_Non_Composite
+ (Data_Type => O_Dnode,
+ Composite_Data_Type => O_Dnode,
+ Do_Non_Composite => Register_Non_Composite_Signal,
+ Prepare_Data_Array => Register_Prepare_Data_Composite,
+ Update_Data_Array => Register_Update_Data_Array,
+ Finish_Data_Array => Register_Finish_Data_Composite,
+ Prepare_Data_Record => Register_Prepare_Data_Composite,
+ Update_Data_Record => Register_Update_Data_Record,
+ Finish_Data_Record => Register_Finish_Data_Composite);
+
+ procedure Register_Signal (Targ : Mnode;
+ Targ_Type : Iir;
+ Proc : O_Dnode)
+ renames Register_Signal_1;
+
+ procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode)
+ is
+ El : Iir;
+ Sig : Mnode;
+ begin
+ if List = Null_Iir_List then
+ return;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Open_Temp;
+ Sig := Chap6.Translate_Name (El);
+ Register_Signal (Sig, Get_Type (El), Proc);
+ Close_Temp;
+ end loop;
+ end Register_Signal_List;
+
+ function Gen_Oenode_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Val : O_Enode)
+ return Mnode
+ is
+ pragma Unreferenced (Targ);
+ Res : Mnode;
+ Type_Info : Type_Info_Acc;
+ begin
+ Type_Info := Get_Info (Targ_Type);
+ Res := E2M (Val, Type_Info, Mode_Value);
+ case Type_Info.Type_Mode is
+ when Type_Mode_Array
+ | Type_Mode_Fat_Array =>
+ Res := Chap3.Get_Array_Base (Res);
+ when Type_Mode_Record =>
+ Res := Stabilize (Res);
+ when others =>
+ -- Not a composite type!
+ raise Internal_Error;
+ end case;
+ return Res;
+ end Gen_Oenode_Prepare_Data_Composite;
+
+ function Gen_Oenode_Update_Data_Array (Val : Mnode;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return O_Enode
+ is
+ begin
+ return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)));
+ end Gen_Oenode_Update_Data_Array;
+
+ function Gen_Oenode_Update_Data_Record
+ (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return O_Enode
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return M2E (Chap6.Translate_Selected_Element (Val, El));
+ end Gen_Oenode_Update_Data_Record;
+
+ procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Gen_Oenode_Finish_Data_Composite;
+
+ function Get_Line_Number (Target: Iir) return Natural
+ is
+ Line, Col: Natural;
+ Name : Name_Id;
+ begin
+ Files_Map.Location_To_Position
+ (Get_Location (Target), Name, Line, Col);
+ return Line;
+ end Get_Line_Number;
+
+ procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List;
+ Line : Natural) is
+ begin
+ New_Association (Assoc,
+ New_Lit (New_Global_Address (Current_Filename_Node,
+ Char_Ptr_Type)));
+ New_Association (Assoc, New_Lit (New_Signed_Literal
+ (Ghdl_I32_Type, Integer_64 (Line))));
+ end Assoc_Filename_Line;
+ end Helpers;
+
+ package body Chap1 is
+ procedure Start_Block_Decl (Blk : Iir)
+ is
+ Info : constant Block_Info_Acc := Get_Info (Blk);
+ begin
+ Chap2.Declare_Inst_Type_And_Ptr
+ (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type);
+ end Start_Block_Decl;
+
+ procedure Translate_Entity_Init (Entity : Iir)
+ is
+ El : Iir;
+ El_Type : Iir;
+ begin
+ Push_Local_Factory;
+
+ -- Generics.
+ El := Get_Generic_Chain (Entity);
+ while El /= Null_Iir loop
+ Open_Temp;
+ Chap4.Elab_Object_Value (El, Get_Default_Value (El));
+ Close_Temp;
+ El := Get_Chain (El);
+ end loop;
+
+ -- Ports.
+ El := Get_Port_Chain (Entity);
+ while El /= Null_Iir loop
+ Open_Temp;
+ El_Type := Get_Type (El);
+ if not Is_Fully_Constrained_Type (El_Type) then
+ Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El));
+ end if;
+ Chap4.Elab_Signal_Declaration_Storage (El);
+ Chap4.Elab_Signal_Declaration_Object (El, Entity, False);
+ Close_Temp;
+
+ El := Get_Chain (El);
+ end loop;
+
+ Pop_Local_Factory;
+ end Translate_Entity_Init;
+
+ procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration)
+ is
+ Info : Block_Info_Acc;
+ Interface_List : O_Inter_List;
+ Instance : Chap2.Subprg_Instance_Type;
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ Info := Add_Info (Entity, Kind_Block);
+ Chap1.Start_Block_Decl (Entity);
+ Push_Instance_Factory (Info.Block_Scope'Access);
+
+ -- Entity link (RTI and pointer to parent).
+ Info.Block_Link_Field := Add_Instance_Factory_Field
+ (Wki_Rti, Rtis.Ghdl_Entity_Link_Type);
+
+ -- generics, ports.
+ Chap4.Translate_Generic_Chain (Entity);
+ Chap4.Translate_Port_Chain (Entity);
+
+ Chap9.Translate_Block_Declarations (Entity, Entity);
+
+ Pop_Instance_Factory (Info.Block_Scope'Access);
+
+ Chap2.Push_Subprg_Instance (Info.Block_Scope'Access,
+ Info.Block_Decls_Ptr_Type,
+ Wki_Instance,
+ Prev_Subprg_Instance);
+
+ -- Entity elaborator.
+ Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"),
+ Global_Storage);
+ Chap2.Add_Subprg_Instance_Interfaces (Interface_List, Instance);
+ Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg);
+
+ -- Entity dependences elaborator.
+ Start_Procedure_Decl (Interface_List, Create_Identifier ("PKG_ELAB"),
+ Global_Storage);
+ Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Pkg_Subprg);
+
+ -- Generate RTI.
+ if Flag_Rti then
+ Rtis.Generate_Unit (Entity);
+ end if;
+
+ if Global_Storage = O_Storage_External then
+ -- Entity declaration subprograms.
+ Chap4.Translate_Declaration_Chain_Subprograms (Entity);
+ else
+ -- Entity declaration and process subprograms.
+ Chap9.Translate_Block_Subprograms (Entity, Entity);
+
+ -- Package elaborator Body.
+ Start_Subprogram_Body (Info.Block_Elab_Pkg_Subprg);
+ Push_Local_Factory;
+ New_Debug_Line_Stmt (Get_Line_Number (Entity));
+ Chap2.Elab_Dependence (Get_Design_Unit (Entity));
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ -- Elaborator Body.
+ Start_Subprogram_Body (Info.Block_Elab_Subprg);
+ Push_Local_Factory;
+ Chap2.Start_Subprg_Instance_Use (Instance);
+ New_Debug_Line_Stmt (Get_Line_Number (Entity));
+
+ Chap9.Elab_Block_Declarations (Entity, Entity);
+ Chap2.Finish_Subprg_Instance_Use (Instance);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ -- Default value if any.
+ if False then --Is_Entity_Declaration_Top (Entity) then
+ declare
+ Init_Subprg : O_Dnode;
+ begin
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier ("_INIT"),
+ Global_Storage);
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Interface_List, Instance);
+ Finish_Subprogram_Decl (Interface_List, Init_Subprg);
+
+ Start_Subprogram_Body (Init_Subprg);
+ Chap2.Start_Subprg_Instance_Use (Instance);
+ Translate_Entity_Init (Entity);
+ Chap2.Finish_Subprg_Instance_Use (Instance);
+ Finish_Subprogram_Body;
+ end;
+ end if;
+ end if;
+ Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+ end Translate_Entity_Declaration;
+
+ -- Push scope for architecture ARCH via INSTANCE, and for its
+ -- entity via the entity field of the instance.
+ procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode)
+ is
+ Arch_Info : constant Block_Info_Acc := Get_Info (Arch);
+ Entity : constant Iir := Get_Entity (Arch);
+ Entity_Info : constant Block_Info_Acc := Get_Info (Entity);
+ begin
+ Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance);
+ Set_Scope_Via_Field (Entity_Info.Block_Scope,
+ Arch_Info.Block_Parent_Field,
+ Arch_Info.Block_Scope'Access);
+ end Push_Architecture_Scope;
+
+ -- Pop scopes created by Push_Architecture_Scope.
+ procedure Pop_Architecture_Scope (Arch : Iir)
+ is
+ Arch_Info : constant Block_Info_Acc := Get_Info (Arch);
+ Entity : constant Iir := Get_Entity (Arch);
+ Entity_Info : constant Block_Info_Acc := Get_Info (Entity);
+ begin
+ Clear_Scope (Entity_Info.Block_Scope);
+ Clear_Scope (Arch_Info.Block_Scope);
+ end Pop_Architecture_Scope;
+
+ procedure Translate_Architecture_Body (Arch : Iir)
+ is
+ Entity : constant Iir := Get_Entity (Arch);
+ Entity_Info : constant Block_Info_Acc := Get_Info (Entity);
+ Info : Block_Info_Acc;
+ Interface_List : O_Inter_List;
+ Constr : O_Assoc_List;
+ Instance : O_Dnode;
+ Var_Arch_Instance : O_Dnode;
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ if Get_Foreign_Flag (Arch) then
+ Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch);
+ end if;
+
+ Info := Add_Info (Arch, Kind_Block);
+ Start_Block_Decl (Arch);
+ Push_Instance_Factory (Info.Block_Scope'Access);
+
+ -- We cannot use Add_Scope_Field here, because the entity is not a
+ -- child scope of the architecture.
+ Info.Block_Parent_Field := Add_Instance_Factory_Field
+ (Get_Identifier ("ENTITY"),
+ Get_Scope_Type (Entity_Info.Block_Scope));
+
+ Chap9.Translate_Block_Declarations (Arch, Arch);
+
+ Pop_Instance_Factory (Info.Block_Scope'Access);
+
+ -- Declare the constant containing the size of the instance.
+ New_Const_Decl
+ (Info.Block_Instance_Size, Create_Identifier ("INSTSIZE"),
+ Global_Storage, Ghdl_Index_Type);
+ if Global_Storage /= O_Storage_External then
+ Start_Const_Value (Info.Block_Instance_Size);
+ Finish_Const_Value
+ (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope));
+ end if;
+
+ -- Elaborator.
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier ("ELAB"), Global_Storage);
+ New_Interface_Decl
+ (Interface_List, Instance, Wki_Instance,
+ Entity_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg);
+
+ -- Generate RTI.
+ if Flag_Rti then
+ Rtis.Generate_Unit (Arch);
+ end if;
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ -- Create process subprograms.
+ Chap2.Push_Subprg_Instance (Info.Block_Scope'Access,
+ Info.Block_Decls_Ptr_Type,
+ Wki_Instance,
+ Prev_Subprg_Instance);
+ Set_Scope_Via_Field (Entity_Info.Block_Scope,
+ Info.Block_Parent_Field,
+ Info.Block_Scope'Access);
+
+ Chap9.Translate_Block_Subprograms (Arch, Arch);
+
+ Clear_Scope (Entity_Info.Block_Scope);
+ Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+
+ -- Elaborator body.
+ Start_Subprogram_Body (Info.Block_Elab_Subprg);
+ Push_Local_Factory;
+
+ -- Create a variable for the architecture instance (with the right
+ -- type, instead of the entity instance type).
+ New_Var_Decl (Var_Arch_Instance, Wki_Arch_Instance,
+ O_Storage_Local, Info.Block_Decls_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Arch_Instance),
+ New_Convert_Ov (New_Value (New_Obj (Instance)),
+ Info.Block_Decls_Ptr_Type));
+
+ -- Set RTI.
+ if Flag_Rti then
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Selected_Acc_Value (New_Obj (Instance),
+ Entity_Info.Block_Link_Field),
+ Rtis.Ghdl_Entity_Link_Rti),
+ New_Unchecked_Address (New_Obj (Info.Block_Rti_Const),
+ Rtis.Ghdl_Rti_Access));
+ end if;
+
+ -- Call entity elaborators.
+ Start_Association (Constr, Entity_Info.Block_Elab_Subprg);
+ New_Association (Constr, New_Value (New_Obj (Instance)));
+ New_Procedure_Call (Constr);
+
+ Push_Architecture_Scope (Arch, Var_Arch_Instance);
+
+ New_Debug_Line_Stmt (Get_Line_Number (Arch));
+ Chap2.Elab_Dependence (Get_Design_Unit (Arch));
+
+ Chap9.Elab_Block_Declarations (Arch, Arch);
+ --Chap6.Leave_Simple_Name (Ghdl_Leave_Architecture);
+
+ Pop_Architecture_Scope (Arch);
+
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_Architecture_Body;
+
+ procedure Translate_Component_Configuration_Decl
+ (Cfg : Iir; Blk : Iir; Base_Block : Iir; Num : in out Iir_Int32)
+ is
+ Inter_List : O_Inter_List;
+ Comp : Iir_Component_Declaration;
+ Comp_Info : Comp_Info_Acc;
+ Info : Config_Info_Acc;
+ Instance : O_Dnode;
+ Mark, Mark2 : Id_Mark_Type;
+
+ Base_Info : Block_Info_Acc;
+ Base_Instance : O_Dnode;
+
+ Block : Iir_Block_Configuration;
+ Binding : Iir_Binding_Indication;
+ Entity_Aspect : Iir;
+ Conf_Override : Iir;
+ Conf_Info : Config_Info_Acc;
+ begin
+ -- Incremental binding.
+ if Get_Nbr_Elements (Get_Instantiation_List (Cfg)) = 0 then
+ -- This component configuration applies to no component
+ -- instantiation, so it is not translated.
+ return;
+ end if;
+
+ Binding := Get_Binding_Indication (Cfg);
+ if Binding = Null_Iir then
+ -- This is an unbound component configuration, since this is a
+ -- no-op, it is not translated.
+ return;
+ end if;
+
+ Entity_Aspect := Get_Entity_Aspect (Binding);
+
+ Comp := Get_Named_Entity (Get_Component_Name (Cfg));
+ Comp_Info := Get_Info (Comp);
+
+ if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then
+ Block := Get_Block_Configuration (Cfg);
+ else
+ Block := Null_Iir;
+ end if;
+
+ Push_Identifier_Prefix (Mark, Get_Identifier (Comp), Num);
+ Num := Num + 1;
+
+ if Block /= Null_Iir then
+ Push_Identifier_Prefix (Mark2, "CONFIG");
+ Translate_Configuration_Declaration (Cfg);
+ Pop_Identifier_Prefix (Mark2);
+ Conf_Override := Cfg;
+ Conf_Info := Get_Info (Cfg);
+ Clear_Info (Cfg);
+ else
+ Conf_Info := null;
+ Conf_Override := Null_Iir;
+ end if;
+ Info := Add_Info (Cfg, Kind_Config);
+
+ Base_Info := Get_Info (Base_Block);
+
+ Chap4.Translate_Association_Subprograms
+ (Binding, Blk, Base_Block,
+ Get_Entity_From_Entity_Aspect (Entity_Aspect));
+
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier, O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Comp_Info.Comp_Ptr_Type);
+ New_Interface_Decl (Inter_List, Base_Instance, Get_Identifier ("BLK"),
+ Base_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Config_Subprg);
+
+ -- Extract the entity/architecture.
+
+ Start_Subprogram_Body (Info.Config_Subprg);
+ Push_Local_Factory;
+
+ if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then
+ Push_Architecture_Scope (Base_Block, Base_Instance);
+ else
+ Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance);
+ end if;
+
+ Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance);
+
+ if Conf_Info /= null then
+ Clear_Info (Cfg);
+ Set_Info (Cfg, Conf_Info);
+ end if;
+ Chap9.Translate_Entity_Instantiation
+ (Entity_Aspect, Binding, Comp, Conf_Override);
+ if Conf_Info /= null then
+ Clear_Info (Cfg);
+ Set_Info (Cfg, Info);
+ end if;
+
+ Clear_Scope (Comp_Info.Comp_Scope);
+
+ if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then
+ Pop_Architecture_Scope (Base_Block);
+ else
+ Clear_Scope (Base_Info.Block_Scope);
+ end if;
+
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Component_Configuration_Decl;
+
+ -- Create subprogram specifications for each configuration_specification
+ -- in BLOCK_CONFIG and its sub-blocks.
+ -- BLOCK is the block being configured (initially the architecture),
+ -- BASE_BLOCK is the root block giving the instance (initially the
+ -- architecture)
+ -- NUM is an integer used to generate uniq names.
+ procedure Translate_Block_Configuration_Decls
+ (Block_Config : Iir_Block_Configuration;
+ Block : Iir;
+ Base_Block : Iir;
+ Num : in out Iir_Int32)
+ is
+ El : Iir;
+ begin
+ El := Get_Configuration_Item_Chain (Block_Config);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Specification =>
+ Translate_Component_Configuration_Decl
+ (El, Block, Base_Block, Num);
+ when Iir_Kind_Block_Configuration =>
+ declare
+ Mark : Id_Mark_Type;
+ Base_Info : constant Block_Info_Acc :=
+ Get_Info (Base_Block);
+ Blk : constant Iir := Get_Block_From_Block_Specification
+ (Get_Block_Specification (El));
+ Blk_Info : constant Block_Info_Acc := Get_Info (Blk);
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Blk));
+ case Get_Kind (Blk) is
+ when Iir_Kind_Generate_Statement =>
+ Set_Scope_Via_Field_Ptr
+ (Base_Info.Block_Scope,
+ Blk_Info.Block_Origin_Field,
+ Blk_Info.Block_Scope'Access);
+ Translate_Block_Configuration_Decls
+ (El, Blk, Blk, Num);
+ Clear_Scope (Base_Info.Block_Scope);
+ when Iir_Kind_Block_Statement =>
+ Translate_Block_Configuration_Decls
+ (El, Blk, Base_Block, Num);
+ when others =>
+ Error_Kind
+ ("translate_block_configuration_decls(2)", Blk);
+ end case;
+ Pop_Identifier_Prefix (Mark);
+ end;
+ when others =>
+ Error_Kind ("translate_block_configuration_decls(1)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Block_Configuration_Decls;
+
+ procedure Translate_Component_Configuration_Call
+ (Cfg : Iir; Base_Block : Iir; Block_Info : Block_Info_Acc)
+ is
+ Cfg_Info : Config_Info_Acc;
+ Base_Info : Block_Info_Acc;
+ begin
+ if Get_Binding_Indication (Cfg) = Null_Iir then
+ -- Unbound component configuration, nothing to do.
+ return;
+ end if;
+
+ Cfg_Info := Get_Info (Cfg);
+ Base_Info := Get_Info (Base_Block);
+
+ -- Call the subprogram for the instantiation list.
+ declare
+ List : Iir_List;
+ El : Iir;
+ begin
+ List := Get_Instantiation_List (Cfg);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ El := Get_Named_Entity (El);
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ declare
+ Assoc : O_Assoc_List;
+ Info : constant Block_Info_Acc := Get_Info (El);
+ Comp_Info : constant Comp_Info_Acc :=
+ Get_Info (Get_Named_Entity
+ (Get_Instantiated_Unit (El)));
+ V : O_Lnode;
+ begin
+ -- The component is really a component and not a
+ -- direct instance.
+ Start_Association (Assoc, Cfg_Info.Config_Subprg);
+ V := Get_Instance_Ref (Block_Info.Block_Scope);
+ V := New_Selected_Element (V, Info.Block_Link_Field);
+ New_Association
+ (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type));
+ V := Get_Instance_Ref (Base_Info.Block_Scope);
+ New_Association
+ (Assoc,
+ New_Address (V, Base_Info.Block_Decls_Ptr_Type));
+ New_Procedure_Call (Assoc);
+ end;
+ when others =>
+ Error_Kind ("translate_component_configuration", El);
+ end case;
+ end loop;
+ end;
+ end Translate_Component_Configuration_Call;
+
+ procedure Translate_Block_Configuration_Calls
+ (Block_Config : Iir_Block_Configuration;
+ Base_Block : Iir;
+ Base_Info : Block_Info_Acc);
+
+ procedure Translate_Generate_Block_Configuration_Calls
+ (Block_Config : Iir_Block_Configuration;
+ Parent_Info : Block_Info_Acc)
+ is
+ Spec : constant Iir := Get_Block_Specification (Block_Config);
+ Block : constant Iir := Get_Block_From_Block_Specification (Spec);
+ Info : constant Block_Info_Acc := Get_Info (Block);
+ Scheme : constant Iir := Get_Generation_Scheme (Block);
+
+ Type_Info : Type_Info_Acc;
+ Iter_Type : Iir;
+
+ -- Generate a call for a iterative generate block whose index is
+ -- INDEX.
+ -- FAILS is true if it is an error if the block is already
+ -- configured.
+ procedure Gen_Subblock_Call (Index : O_Enode; Fails : Boolean)
+ is
+ Var_Inst : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Open_Temp;
+ Var_Inst := Create_Temp (Info.Block_Decls_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Inst),
+ New_Address (New_Indexed_Element
+ (New_Acc_Value
+ (New_Selected_Element
+ (Get_Instance_Ref (Parent_Info.Block_Scope),
+ Info.Block_Parent_Field)),
+ Index),
+ Info.Block_Decls_Ptr_Type));
+ -- Configure only if not yet configured.
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ New_Value_Selected_Acc_Value
+ (New_Obj (Var_Inst),
+ Info.Block_Configured_Field),
+ New_Lit (Ghdl_Bool_False_Node),
+ Ghdl_Bool_Type));
+ -- Mark the block as configured.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var_Inst),
+ Info.Block_Configured_Field),
+ New_Lit (Ghdl_Bool_True_Node));
+ Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst);
+ Translate_Block_Configuration_Calls (Block_Config, Block, Info);
+ Clear_Scope (Info.Block_Scope);
+
+ if Fails then
+ New_Else_Stmt (If_Blk);
+ -- Already configured.
+ Chap6.Gen_Program_Error
+ (Block_Config, Chap6.Prg_Err_Block_Configured);
+ end if;
+
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end Gen_Subblock_Call;
+
+ procedure Apply_To_All_Others_Blocks (Is_All : Boolean)
+ is
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ begin
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op
+ (ON_Eq,
+ New_Value (New_Obj (Var_I)),
+ New_Value
+ (New_Selected_Element
+ (Get_Var (Get_Info (Iter_Type).T.Range_Var),
+ Type_Info.T.Range_Length)),
+ Ghdl_Bool_Type));
+ -- Selected_name is for default configurations, so
+ -- program should not fail if a block is already
+ -- configured but continue silently.
+ Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All);
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+ end Apply_To_All_Others_Blocks;
+ begin
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Iter_Type := Get_Type (Scheme);
+ Type_Info := Get_Info (Get_Base_Type (Iter_Type));
+ case Get_Kind (Spec) is
+ when Iir_Kind_Generate_Statement
+ | Iir_Kind_Simple_Name =>
+ Apply_To_All_Others_Blocks (True);
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Index_List : constant Iir_List := Get_Index_List (Spec);
+ Rng : Mnode;
+ begin
+ if Index_List = Iir_List_Others then
+ Apply_To_All_Others_Blocks (False);
+ else
+ Open_Temp;
+ Rng := Stabilize (Chap3.Type_To_Range (Iter_Type));
+ Gen_Subblock_Call
+ (Chap6.Translate_Index_To_Offset
+ (Rng,
+ Chap7.Translate_Expression
+ (Get_Nth_Element (Index_List, 0), Iter_Type),
+ Scheme, Iter_Type, Spec),
+ True);
+ Close_Temp;
+ end if;
+ end;
+ when Iir_Kind_Slice_Name =>
+ declare
+ Rng : Mnode;
+ Slice : O_Dnode;
+ Slice_Ptr : O_Dnode;
+ Left, Right : O_Dnode;
+ Index : O_Dnode;
+ High : O_Dnode;
+ If_Blk : O_If_Block;
+ Label : O_Snode;
+ begin
+ Open_Temp;
+ Rng := Stabilize (Chap3.Type_To_Range (Iter_Type));
+ Slice := Create_Temp (Type_Info.T.Range_Type);
+ Slice_Ptr := Create_Temp_Ptr
+ (Type_Info.T.Range_Ptr_Type, New_Obj (Slice));
+ Chap7.Translate_Discrete_Range_Ptr
+ (Slice_Ptr, Get_Suffix (Spec));
+ Left := Create_Temp_Init
+ (Ghdl_Index_Type,
+ Chap6.Translate_Index_To_Offset
+ (Rng,
+ New_Value (New_Selected_Element
+ (New_Obj (Slice), Type_Info.T.Range_Left)),
+ Spec, Iter_Type, Spec));
+ Right := Create_Temp_Init
+ (Ghdl_Index_Type,
+ Chap6.Translate_Index_To_Offset
+ (Rng,
+ New_Value (New_Selected_Element
+ (New_Obj (Slice),
+ Type_Info.T.Range_Right)),
+ Spec, Iter_Type, Spec));
+ Index := Create_Temp (Ghdl_Index_Type);
+ High := Create_Temp (Ghdl_Index_Type);
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Rng)),
+ New_Value
+ (New_Selected_Element
+ (New_Obj (Slice),
+ Type_Info.T.Range_Dir)),
+ Ghdl_Bool_Type));
+ -- Same direction, so left to right.
+ New_Assign_Stmt (New_Obj (Index),
+ New_Value (New_Obj (Left)));
+ New_Assign_Stmt (New_Obj (High),
+ New_Value (New_Obj (Right)));
+ New_Else_Stmt (If_Blk);
+ -- Opposite direction, so right to left.
+ New_Assign_Stmt (New_Obj (Index),
+ New_Value (New_Obj (Right)));
+ New_Assign_Stmt (New_Obj (High),
+ New_Value (New_Obj (Left)));
+ Finish_If_Stmt (If_Blk);
+
+ -- Loop.
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label, New_Compare_Op (ON_Gt,
+ New_Value (New_Obj (Index)),
+ New_Value (New_Obj (High)),
+ Ghdl_Bool_Type));
+ Open_Temp;
+ Gen_Subblock_Call (New_Value (New_Obj (Index)), True);
+ Close_Temp;
+ Inc_Var (Index);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ end;
+ when others =>
+ Error_Kind
+ ("translate_generate_block_configuration_calls", Spec);
+ end case;
+ else
+ -- Conditional generate statement.
+ declare
+ Var : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ -- Configure the block only if it was created.
+ Open_Temp;
+ Var := Create_Temp_Init
+ (Info.Block_Decls_Ptr_Type,
+ New_Value (New_Selected_Element
+ (Get_Instance_Ref (Parent_Info.Block_Scope),
+ Info.Block_Parent_Field)));
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op
+ (ON_Neq,
+ New_Obj_Value (Var),
+ New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)),
+ Ghdl_Bool_Type));
+ Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var);
+ Translate_Block_Configuration_Calls (Block_Config, Block, Info);
+ Clear_Scope (Info.Block_Scope);
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end;
+ end if;
+ end Translate_Generate_Block_Configuration_Calls;
+
+ procedure Translate_Block_Configuration_Calls
+ (Block_Config : Iir_Block_Configuration;
+ Base_Block : Iir;
+ Base_Info : Block_Info_Acc)
+ is
+ El : Iir;
+ begin
+ El := Get_Configuration_Item_Chain (Block_Config);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Specification =>
+ Translate_Component_Configuration_Call
+ (El, Base_Block, Base_Info);
+ when Iir_Kind_Block_Configuration =>
+ declare
+ Block : constant Iir := Strip_Denoting_Name
+ (Get_Block_Specification (El));
+ begin
+ if Get_Kind (Block) = Iir_Kind_Block_Statement then
+ Translate_Block_Configuration_Calls
+ (El, Base_Block, Get_Info (Block));
+ else
+ Translate_Generate_Block_Configuration_Calls
+ (El, Base_Info);
+ end if;
+ end;
+ when others =>
+ Error_Kind ("translate_block_configuration_calls(2)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Block_Configuration_Calls;
+
+ procedure Translate_Configuration_Declaration (Config : Iir)
+ is
+ Block_Config : constant Iir_Block_Configuration :=
+ Get_Block_Configuration (Config);
+ Arch : constant Iir_Architecture_Body :=
+ Get_Block_Specification (Block_Config);
+ Arch_Info : constant Block_Info_Acc := Get_Info (Arch);
+ Interface_List : O_Inter_List;
+ Config_Info : Config_Info_Acc;
+ Instance : O_Dnode;
+ Num : Iir_Int32;
+ Final : Boolean;
+ begin
+ if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then
+ Chap4.Translate_Declaration_Chain (Config);
+ end if;
+
+ Config_Info := Add_Info (Config, Kind_Config);
+
+ -- Configurator.
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier, Global_Storage);
+ New_Interface_Decl (Interface_List, Instance, Wki_Instance,
+ Arch_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, Config_Info.Config_Subprg);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ -- Declare subprograms for configuration.
+ Num := 0;
+ Translate_Block_Configuration_Decls (Block_Config, Arch, Arch, Num);
+
+ -- Body.
+ Start_Subprogram_Body (Config_Info.Config_Subprg);
+ Push_Local_Factory;
+
+ Push_Architecture_Scope (Arch, Instance);
+
+ if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Config, Final);
+ Close_Temp;
+ if Final then
+ raise Internal_Error;
+ end if;
+ end if;
+
+ Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info);
+
+ Pop_Architecture_Scope (Arch);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_Configuration_Declaration;
+ end Chap1;
+
+ package body Chap2 is
+ procedure Elab_Package (Spec : Iir_Package_Declaration);
+
+ type Name_String_Xlat_Array is array (Name_Id range <>) of
+ String (1 .. 4);
+ Operator_String_Xlat : constant
+ Name_String_Xlat_Array (Std_Names.Name_Id_Operators) :=
+ (Std_Names.Name_Op_Equality => "OPEq",
+ Std_Names.Name_Op_Inequality => "OPNe",
+ Std_Names.Name_Op_Less => "OPLt",
+ Std_Names.Name_Op_Less_Equal => "OPLe",
+ Std_Names.Name_Op_Greater => "OPGt",
+ Std_Names.Name_Op_Greater_Equal => "OPGe",
+ Std_Names.Name_Op_Plus => "OPPl",
+ Std_Names.Name_Op_Minus => "OPMi",
+ Std_Names.Name_Op_Mul => "OPMu",
+ Std_Names.Name_Op_Div => "OPDi",
+ Std_Names.Name_Op_Exp => "OPEx",
+ Std_Names.Name_Op_Concatenation => "OPCc",
+ Std_Names.Name_Op_Condition => "OPCd",
+ Std_Names.Name_Op_Match_Equality => "OPQe",
+ Std_Names.Name_Op_Match_Inequality => "OPQi",
+ Std_Names.Name_Op_Match_Less => "OPQL",
+ Std_Names.Name_Op_Match_Less_Equal => "OPQl",
+ Std_Names.Name_Op_Match_Greater => "OPQG",
+ Std_Names.Name_Op_Match_Greater_Equal => "OPQg");
+
+ -- Set the identifier prefix with the subprogram identifier and
+ -- overload number if any.
+ procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type)
+ is
+ Id : Name_Id;
+ begin
+ -- FIXME: name_shift_operators, name_logical_operators,
+ -- name_word_operators, name_mod, name_rem
+ Id := Get_Identifier (Spec);
+ if Id in Std_Names.Name_Id_Operators then
+ Push_Identifier_Prefix
+ (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec));
+ else
+ Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec));
+ end if;
+ end Push_Subprg_Identifier;
+
+ procedure Translate_Subprogram_Interfaces (Spec : Iir)
+ is
+ Inter : Iir;
+ Mark : Id_Mark_Type;
+ begin
+ -- Set the identifier prefix with the subprogram identifier and
+ -- overload number if any.
+ Push_Subprg_Identifier (Spec, Mark);
+
+ -- Translate interface types.
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ Chap3.Translate_Object_Subtype (Inter);
+ Inter := Get_Chain (Inter);
+ end loop;
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Subprogram_Interfaces;
+
+ procedure Elab_Subprogram_Interfaces (Spec : Iir)
+ is
+ Inter : Iir;
+ begin
+ -- Translate interface types.
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ Chap3.Elab_Object_Subtype (Get_Type (Inter));
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Elab_Subprogram_Interfaces;
+
+
+ -- Return the type of a subprogram interface.
+ -- Return O_Tnode_Null if the parameter is passed through the
+ -- interface record.
+ function Translate_Interface_Type (Inter : Iir) return O_Tnode
+ is
+ Mode : Object_Kind_Type;
+ Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter));
+ begin
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ Mode := Mode_Value;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ Mode := Mode_Signal;
+ when others =>
+ Error_Kind ("translate_interface_type", Inter);
+ end case;
+ case Tinfo.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_By_Value =>
+ return Tinfo.Ortho_Type (Mode);
+ when Type_Mode_By_Copy
+ | Type_Mode_By_Ref =>
+ return Tinfo.Ortho_Ptr_Type (Mode);
+ end case;
+ end Translate_Interface_Type;
+
+ procedure Translate_Subprogram_Declaration (Spec : Iir)
+ is
+ Info : constant Subprg_Info_Acc := Get_Info (Spec);
+ Is_Func : constant Boolean :=
+ Get_Kind (Spec) = Iir_Kind_Function_Declaration;
+ Inter : Iir;
+ Inter_Type : Iir;
+ Arg_Info : Ortho_Info_Acc;
+ Tinfo : Type_Info_Acc;
+ Interface_List : O_Inter_List;
+ Has_Result_Record : Boolean;
+ El_List : O_Element_List;
+ Mark : Id_Mark_Type;
+ Rtype : Iir;
+ Id : O_Ident;
+ Storage : O_Storage;
+ Foreign : Foreign_Info_Type := Foreign_Bad;
+ begin
+ -- Set the identifier prefix with the subprogram identifier and
+ -- overload number if any.
+ Push_Subprg_Identifier (Spec, Mark);
+
+ if Get_Foreign_Flag (Spec) then
+ -- Special handling for foreign subprograms.
+ Foreign := Translate_Foreign_Id (Spec);
+ case Foreign.Kind is
+ when Foreign_Unknown =>
+ Id := Create_Identifier;
+ when Foreign_Intrinsic =>
+ Id := Create_Identifier;
+ when Foreign_Vhpidirect =>
+ Id := Get_Identifier
+ (Name_Table.Name_Buffer (Foreign.Subprg_First
+ .. Foreign.Subprg_Last));
+ end case;
+ Storage := O_Storage_External;
+ else
+ Id := Create_Identifier;
+ Storage := Global_Storage;
+ end if;
+
+ if Is_Func then
+ -- If the result of a function is a composite type for ortho,
+ -- the result is allocated by the caller and an access to it is
+ -- given to the function.
+ Rtype := Get_Return_Type (Spec);
+ Info.Use_Stack2 := False;
+ Tinfo := Get_Info (Rtype);
+
+ if Is_Composite (Tinfo) then
+ Start_Procedure_Decl (Interface_List, Id, Storage);
+ New_Interface_Decl
+ (Interface_List, Info.Res_Interface,
+ Get_Identifier ("RESULT"),
+ Tinfo.Ortho_Ptr_Type (Mode_Value));
+ -- Furthermore, if the result type is unconstrained, the
+ -- function will allocate it on a secondary stack.
+ if not Is_Fully_Constrained_Type (Rtype) then
+ Info.Use_Stack2 := True;
+ end if;
+ else
+ -- Normal function.
+ Start_Function_Decl
+ (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value));
+ Info.Res_Interface := O_Dnode_Null;
+ end if;
+ else
+ -- Create info for each interface of the procedure.
+ -- For parameters passed via copy and that needs a copy-out,
+ -- gather them in a record. An access to the record is then
+ -- passed to the procedure.
+ Has_Result_Record := False;
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ Arg_Info := Add_Info (Inter, Kind_Interface);
+ Inter_Type := Get_Type (Inter);
+ Tinfo := Get_Info (Inter_Type);
+ if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
+ and then Get_Mode (Inter) in Iir_Out_Modes
+ and then Tinfo.Type_Mode not in Type_Mode_By_Ref
+ and then Tinfo.Type_Mode /= Type_Mode_File
+ then
+ -- This interface is done via the result record.
+ -- Note: file passed through variables are vhdl87 files,
+ -- which are initialized at elaboration and thus
+ -- behave like an IN parameter.
+ if not Has_Result_Record then
+ -- Create the record.
+ Start_Record_Type (El_List);
+ Has_Result_Record := True;
+ end if;
+ -- Add a field to the record.
+ New_Record_Field (El_List, Arg_Info.Interface_Field,
+ Create_Identifier_Without_Prefix (Inter),
+ Tinfo.Ortho_Type (Mode_Value));
+ else
+ Arg_Info.Interface_Field := O_Fnode_Null;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ if Has_Result_Record then
+ -- Declare the record type and an access to the record.
+ Finish_Record_Type (El_List, Info.Res_Record_Type);
+ New_Type_Decl (Create_Identifier ("RESTYPE"),
+ Info.Res_Record_Type);
+ Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type);
+ New_Type_Decl (Create_Identifier ("RESPTR"),
+ Info.Res_Record_Ptr);
+ else
+ Info.Res_Interface := O_Dnode_Null;
+ end if;
+
+ Start_Procedure_Decl (Interface_List, Id, Storage);
+
+ if Has_Result_Record then
+ -- Add the record parameter.
+ New_Interface_Decl (Interface_List, Info.Res_Interface,
+ Get_Identifier ("RESULT"),
+ Info.Res_Record_Ptr);
+ end if;
+ end if;
+
+ -- Instance parameter if any.
+ if not Get_Foreign_Flag (Spec) then
+ Chap2.Create_Subprg_Instance (Interface_List, Spec);
+ end if;
+
+ -- Translate interfaces.
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ if Is_Func then
+ -- Create the info.
+ Arg_Info := Add_Info (Inter, Kind_Interface);
+ Arg_Info.Interface_Field := O_Fnode_Null;
+ else
+ -- The info was already created (just above)
+ Arg_Info := Get_Info (Inter);
+ end if;
+
+ if Arg_Info.Interface_Field = O_Fnode_Null then
+ -- Not via the RESULT parameter.
+ Arg_Info.Interface_Type := Translate_Interface_Type (Inter);
+ New_Interface_Decl
+ (Interface_List, Arg_Info.Interface_Node,
+ Create_Identifier_Without_Prefix (Inter),
+ Arg_Info.Interface_Type);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func);
+
+ -- Call the hook for foreign subprograms.
+ if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then
+ Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func);
+ end if;
+
+ Save_Local_Identifier (Info.Subprg_Local_Id);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Subprogram_Declaration;
+
+ -- Return TRUE iff subprogram specification SPEC is translated in an
+ -- ortho function.
+ function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean
+ is
+ begin
+ if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
+ return False;
+ end if;
+ if Get_Info (Spec).Res_Interface /= O_Dnode_Null then
+ return False;
+ end if;
+ return True;
+ end Is_Subprogram_Ortho_Function;
+
+ -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely
+ -- (or even implicitely by translation) a subprogram.
+ function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean
+ is
+ Decl : Iir;
+ Atype : Iir;
+ begin
+ Decl := Get_Declaration_Chain (Subprg_Body);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ -- The declaration preceed the body.
+ raise Internal_Error;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ Atype := Get_Type_Definition (Decl);
+ case Iir_Kinds_Type_And_Subtype_Definition
+ (Get_Kind (Atype)) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ null;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when Iir_Kind_File_Type_Definition =>
+ return True;
+ when Iir_Kind_Protected_Type_Declaration =>
+ raise Internal_Error;
+ when Iir_Kinds_Composite_Type_Definition =>
+ -- At least for "=".
+ return True;
+ when Iir_Kind_Incomplete_Type_Definition =>
+ null;
+ end case;
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ return False;
+ end Has_Nested_Subprograms;
+
+ procedure Translate_Subprogram_Body (Subprg : Iir)
+ is
+ Spec : constant Iir := Get_Subprogram_Specification (Subprg);
+ Info : constant Ortho_Info_Acc := Get_Info (Spec);
+
+ Old_Subprogram : Iir;
+ Mark : Id_Mark_Type;
+ Final : Boolean;
+ Is_Ortho_Func : Boolean;
+
+ -- Set for a public method. In this case, the lock must be acquired
+ -- and retained.
+ Is_Prot : Boolean := False;
+
+ -- True if the body has local (nested) subprograms.
+ Has_Nested : Boolean;
+
+ Frame_Ptr_Type : O_Tnode;
+ Upframe_Field : O_Fnode;
+
+ Frame : O_Dnode;
+ Frame_Ptr : O_Dnode;
+
+ Has_Return : Boolean;
+
+ Prev_Subprg_Instances : Chap2.Subprg_Instance_Stack;
+ begin
+ -- Do not translate body for foreign subprograms.
+ if Get_Foreign_Flag (Spec) then
+ return;
+ end if;
+
+ -- Check if there are nested subprograms to unnest. In that case,
+ -- a frame record is created, which is less efficient than the
+ -- use of local variables.
+ if Flag_Unnest_Subprograms then
+ Has_Nested := Has_Nested_Subprograms (Subprg);
+ else
+ Has_Nested := False;
+ end if;
+
+ -- Set the identifier prefix with the subprogram identifier and
+ -- overload number if any.
+ Push_Subprg_Identifier (Spec, Mark);
+ Restore_Local_Identifier (Info.Subprg_Local_Id);
+
+ if Has_Nested then
+ -- Unnest subprograms.
+ -- Create an instance for the local declarations.
+ Push_Instance_Factory (Info.Subprg_Frame_Scope'Access);
+ Add_Subprg_Instance_Field (Upframe_Field);
+
+ if Info.Res_Record_Ptr /= O_Tnode_Null then
+ Info.Res_Record_Var :=
+ Create_Var (Create_Var_Identifier ("RESULT"),
+ Info.Res_Record_Ptr);
+ end if;
+
+ -- Create fields for parameters.
+ -- FIXME: do it only if they are referenced in nested
+ -- subprograms.
+ declare
+ Inter : Iir;
+ Inter_Info : Inter_Info_Acc;
+ begin
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ Inter_Info := Get_Info (Inter);
+ if Inter_Info.Interface_Node /= O_Dnode_Null then
+ Inter_Info.Interface_Field :=
+ Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (Inter),
+ Inter_Info.Interface_Type);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end;
+
+ Chap4.Translate_Declaration_Chain (Subprg);
+ Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access);
+
+ New_Type_Decl (Create_Identifier ("_FRAMETYPE"),
+ Get_Scope_Type (Info.Subprg_Frame_Scope));
+ Declare_Scope_Acc
+ (Info.Subprg_Frame_Scope,
+ Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type);
+
+ Rtis.Generate_Subprogram_Body (Subprg);
+
+ -- Local frame
+ Chap2.Push_Subprg_Instance
+ (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type,
+ Wki_Upframe, Prev_Subprg_Instances);
+ -- Link to previous frame
+ Chap2.Start_Prev_Subprg_Instance_Use_Via_Field
+ (Prev_Subprg_Instances, Upframe_Field);
+
+ Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
+
+ -- Link to previous frame
+ Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field
+ (Prev_Subprg_Instances, Upframe_Field);
+ -- Local frame
+ Chap2.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances);
+ end if;
+
+ -- Create the body
+
+ Start_Subprogram_Body (Info.Ortho_Func);
+
+ Start_Subprg_Instance_Use (Spec);
+
+ -- Variables will be created on the stack.
+ Push_Local_Factory;
+
+ -- Code has access to local (and outer) variables.
+ -- FIXME: this is not necessary if Has_Nested is set
+ Chap2.Clear_Subprg_Instance (Prev_Subprg_Instances);
+
+ -- There is a local scope for temporaries.
+ Open_Local_Temp;
+
+ if not Has_Nested then
+ Chap4.Translate_Declaration_Chain (Subprg);
+ Rtis.Generate_Subprogram_Body (Subprg);
+ Chap4.Translate_Declaration_Chain_Subprograms (Subprg);
+ else
+ New_Var_Decl (Frame, Wki_Frame, O_Storage_Local,
+ Get_Scope_Type (Info.Subprg_Frame_Scope));
+
+ New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"),
+ O_Storage_Local, Frame_Ptr_Type);
+ New_Assign_Stmt (New_Obj (Frame_Ptr),
+ New_Address (New_Obj (Frame), Frame_Ptr_Type));
+
+ -- FIXME: use direct reference (ie Frame instead of Frame_Ptr)
+ Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr);
+
+ -- Set UPFRAME.
+ Chap2.Set_Subprg_Instance_Field
+ (Frame_Ptr, Upframe_Field, Info.Subprg_Instance);
+
+ if Info.Res_Record_Type /= O_Tnode_Null then
+ -- Initialize the RESULT field
+ New_Assign_Stmt (Get_Var (Info.Res_Record_Var),
+ New_Obj_Value (Info.Res_Interface));
+ -- Do not reference the RESULT field in the subprogram body,
+ -- directly reference the RESULT parameter.
+ -- FIXME: has a flag (see below for parameters).
+ Info.Res_Record_Var := Null_Var;
+ end if;
+
+ -- Copy parameters to FRAME.
+ declare
+ Inter : Iir;
+ Inter_Info : Inter_Info_Acc;
+ begin
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ Inter_Info := Get_Info (Inter);
+ if Inter_Info.Interface_Node /= O_Dnode_Null then
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Frame),
+ Inter_Info.Interface_Field),
+ New_Obj_Value (Inter_Info.Interface_Node));
+
+ -- Forget the reference to the field in FRAME, so that
+ -- this subprogram will directly reference the parameter
+ -- (and not its copy in the FRAME).
+ Inter_Info.Interface_Field := O_Fnode_Null;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end;
+ end if;
+
+ -- Init out parameters passed by value/copy.
+ declare
+ Inter : Iir;
+ Inter_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ begin
+ Inter := Get_Interface_Declaration_Chain (Spec);
+ while Inter /= Null_Iir loop
+ if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration
+ and then Get_Mode (Inter) = Iir_Out_Mode
+ then
+ Inter_Type := Get_Type (Inter);
+ Type_Info := Get_Info (Inter_Type);
+ if (Type_Info.Type_Mode in Type_Mode_By_Value
+ or Type_Info.Type_Mode in Type_Mode_By_Copy)
+ and then Type_Info.Type_Mode /= Type_Mode_File
+ then
+ Chap4.Init_Object
+ (Chap6.Translate_Name (Inter), Inter_Type);
+ end if;
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ end;
+
+ Chap4.Elab_Declaration_Chain (Subprg, Final);
+
+ -- If finalization is required, create a dummy loop around the
+ -- body and convert returns into exit out of this loop.
+ -- If the subprogram is a function, also create a variable for the
+ -- result.
+ Is_Prot := Is_Subprogram_Method (Spec);
+ if Final or Is_Prot then
+ if Is_Prot then
+ -- Lock the object.
+ Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
+ Ghdl_Protected_Enter);
+ end if;
+ Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec);
+ if Is_Ortho_Func then
+ New_Var_Decl
+ (Info.Subprg_Result, Get_Identifier ("RESULT"),
+ O_Storage_Local,
+ Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value));
+ end if;
+ Start_Loop_Stmt (Info.Subprg_Exit);
+ end if;
+
+ Old_Subprogram := Current_Subprogram;
+ Current_Subprogram := Spec;
+ Has_Return := Chap8.Translate_Statements_Chain_Has_Return
+ (Get_Sequential_Statement_Chain (Subprg));
+ Current_Subprogram := Old_Subprogram;
+
+ if Final or Is_Prot then
+ -- Create a barrier to catch missing return statement.
+ if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then
+ New_Exit_Stmt (Info.Subprg_Exit);
+ else
+ if not Has_Return then
+ -- Missing return
+ Chap6.Gen_Program_Error
+ (Subprg, Chap6.Prg_Err_Missing_Return);
+ end if;
+ end if;
+ Finish_Loop_Stmt (Info.Subprg_Exit);
+ Chap4.Final_Declaration_Chain (Subprg, False);
+
+ if Is_Prot then
+ -- Unlock the object.
+ Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec),
+ Ghdl_Protected_Leave);
+ end if;
+ if Is_Ortho_Func then
+ New_Return_Stmt (New_Obj_Value (Info.Subprg_Result));
+ end if;
+ else
+ if Get_Kind (Spec) = Iir_Kind_Function_Declaration
+ and then not Has_Return
+ then
+ -- Missing return
+ Chap6.Gen_Program_Error
+ (Subprg, Chap6.Prg_Err_Missing_Return);
+ end if;
+ end if;
+
+ if Has_Nested then
+ Clear_Scope (Info.Subprg_Frame_Scope);
+ end if;
+
+ Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances);
+ Close_Local_Temp;
+ Pop_Local_Factory;
+
+ Finish_Subprg_Instance_Use (Spec);
+
+ Finish_Subprogram_Body;
+
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Subprogram_Body;
+
+ procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration)
+ is
+ Header : constant Iir := Get_Package_Header (Decl);
+ Info : Ortho_Info_Acc;
+ Interface_List : O_Inter_List;
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ Info := Add_Info (Decl, Kind_Package);
+
+ -- Translate declarations.
+ if Is_Uninstantiated_Package (Decl) then
+ -- Create an instance for the spec.
+ Push_Instance_Factory (Info.Package_Spec_Scope'Access);
+ Chap4.Translate_Generic_Chain (Header);
+ Chap4.Translate_Declaration_Chain (Decl);
+ Info.Package_Elab_Var := Create_Var
+ (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
+ Pop_Instance_Factory (Info.Package_Spec_Scope'Access);
+
+ -- Name the spec instance and create a pointer.
+ New_Type_Decl (Create_Identifier ("SPECINSTTYPE"),
+ Get_Scope_Type (Info.Package_Spec_Scope));
+ Declare_Scope_Acc (Info.Package_Spec_Scope,
+ Create_Identifier ("SPECINSTPTR"),
+ Info.Package_Spec_Ptr_Type);
+
+ -- Create an instance and its pointer for the body.
+ Chap2.Declare_Inst_Type_And_Ptr
+ (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type);
+
+ -- Each subprogram has a body instance argument.
+ Chap2.Push_Subprg_Instance
+ (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
+ Wki_Instance, Prev_Subprg_Instance);
+ else
+ Chap4.Translate_Declaration_Chain (Decl);
+ Info.Package_Elab_Var := Create_Var
+ (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type);
+ end if;
+
+ -- Translate subprograms declarations.
+ Chap4.Translate_Declaration_Chain_Subprograms (Decl);
+
+ -- Declare elaborator for the body.
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage);
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Interface_List, Info.Package_Elab_Body_Instance);
+ Finish_Subprogram_Decl
+ (Interface_List, Info.Package_Elab_Body_Subprg);
+
+ if Is_Uninstantiated_Package (Decl) then
+ Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+
+ -- The spec elaborator has a spec instance argument.
+ Chap2.Push_Subprg_Instance
+ (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type,
+ Wki_Instance, Prev_Subprg_Instance);
+ end if;
+
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage);
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Interface_List, Info.Package_Elab_Spec_Instance);
+ Finish_Subprogram_Decl
+ (Interface_List, Info.Package_Elab_Spec_Subprg);
+
+ if Flag_Rti then
+ -- Generate RTI.
+ Rtis.Generate_Unit (Decl);
+ end if;
+
+ if Global_Storage = O_Storage_Public then
+ -- Create elaboration procedure for the spec
+ Elab_Package (Decl);
+ end if;
+
+ if Is_Uninstantiated_Package (Decl) then
+ Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+ end if;
+ Save_Local_Identifier (Info.Package_Local_Id);
+ end Translate_Package_Declaration;
+
+ procedure Translate_Package_Body (Decl : Iir_Package_Body)
+ is
+ Spec : constant Iir_Package_Declaration := Get_Package (Decl);
+ Info : constant Ortho_Info_Acc := Get_Info (Spec);
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ -- Translate declarations.
+ if Is_Uninstantiated_Package (Spec) then
+ Push_Instance_Factory (Info.Package_Body_Scope'Access);
+ Info.Package_Spec_Field := Add_Instance_Factory_Field
+ (Get_Identifier ("SPEC"),
+ Get_Scope_Type (Info.Package_Spec_Scope));
+
+ Chap4.Translate_Declaration_Chain (Decl);
+
+ Pop_Instance_Factory (Info.Package_Body_Scope'Access);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+ else
+ -- May be called during elaboration to generate RTI.
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id);
+
+ Chap4.Translate_Declaration_Chain (Decl);
+ end if;
+
+ if Flag_Rti then
+ Rtis.Generate_Unit (Decl);
+ end if;
+
+ if Is_Uninstantiated_Package (Spec) then
+ Chap2.Push_Subprg_Instance
+ (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type,
+ Wki_Instance, Prev_Subprg_Instance);
+ Set_Scope_Via_Field (Info.Package_Spec_Scope,
+ Info.Package_Spec_Field,
+ Info.Package_Body_Scope'Access);
+ end if;
+
+ Chap4.Translate_Declaration_Chain_Subprograms (Decl);
+
+ if Is_Uninstantiated_Package (Spec) then
+ Clear_Scope (Info.Package_Spec_Scope);
+ Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance);
+ end if;
+
+ Elab_Package_Body (Spec, Decl);
+ end Translate_Package_Body;
+
+ procedure Elab_Package (Spec : Iir_Package_Declaration)
+ is
+ Info : constant Ortho_Info_Acc := Get_Info (Spec);
+ Final : Boolean;
+ Constr : O_Assoc_List;
+ pragma Unreferenced (Final);
+ begin
+ Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg);
+ Push_Local_Factory;
+ Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
+
+ Elab_Dependence (Get_Design_Unit (Spec));
+
+ if not Is_Uninstantiated_Package (Spec)
+ and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit
+ then
+ -- Register the top level package. This is done dynamically, as
+ -- we know only during elaboration that the design depends on a
+ -- package (a package maybe referenced by an entity which is never
+ -- instantiated due to generate statements).
+ Start_Association (Constr, Ghdl_Rti_Add_Package);
+ New_Association
+ (Constr,
+ New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const)));
+ New_Procedure_Call (Constr);
+ end if;
+
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Spec, Final);
+ Close_Temp;
+
+ Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Elab_Package;
+
+ procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir)
+ is
+ Info : constant Ortho_Info_Acc := Get_Info (Spec);
+ If_Blk : O_If_Block;
+ Constr : O_Assoc_List;
+ Final : Boolean;
+ begin
+ Start_Subprogram_Body (Info.Package_Elab_Body_Subprg);
+ Push_Local_Factory;
+ Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
+
+ if Is_Uninstantiated_Package (Spec) then
+ Set_Scope_Via_Field (Info.Package_Spec_Scope,
+ Info.Package_Spec_Field,
+ Info.Package_Body_Scope'Access);
+ end if;
+
+ -- If the package was already elaborated, return now,
+ -- else mark the package as elaborated.
+ Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var)));
+ New_Return_Stmt;
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt (Get_Var (Info.Package_Elab_Var),
+ New_Lit (Ghdl_Bool_True_Node));
+ Finish_If_Stmt (If_Blk);
+
+ -- Elab Spec.
+ Start_Association (Constr, Info.Package_Elab_Spec_Subprg);
+ Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance);
+ New_Procedure_Call (Constr);
+
+ if Bod /= Null_Iir then
+ Elab_Dependence (Get_Design_Unit (Bod));
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Bod, Final);
+ Close_Temp;
+ end if;
+
+ if Is_Uninstantiated_Package (Spec) then
+ Clear_Scope (Info.Package_Spec_Scope);
+ end if;
+
+ Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Elab_Package_Body;
+
+ procedure Instantiate_Iir_Info (N : Iir);
+
+ procedure Instantiate_Iir_Chain_Info (Chain : Iir)
+ is
+ N : Iir;
+ begin
+ N := Chain;
+ while N /= Null_Iir loop
+ Instantiate_Iir_Info (N);
+ N := Get_Chain (N);
+ end loop;
+ end Instantiate_Iir_Chain_Info;
+
+ procedure Instantiate_Iir_List_Info (L : Iir_List)
+ is
+ El : Iir;
+ begin
+ case L is
+ when Null_Iir_List
+ | Iir_List_All
+ | Iir_List_Others =>
+ return;
+ when others =>
+ for I in Natural loop
+ El := Get_Nth_Element (L, I);
+ exit when El = Null_Iir;
+ Instantiate_Iir_Info (El);
+ end loop;
+ end case;
+ end Instantiate_Iir_List_Info;
+
+ procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is
+ begin
+ case Src.Kind is
+ when Kind_Type =>
+ Dest.all := (Kind => Kind_Type,
+ Type_Mode => Src.Type_Mode,
+ Type_Incomplete => Src.Type_Incomplete,
+ Type_Locally_Constrained =>
+ Src.Type_Locally_Constrained,
+ C => null,
+ Ortho_Type => Src.Ortho_Type,
+ Ortho_Ptr_Type => Src.Ortho_Ptr_Type,
+ Type_Transient_Chain => Null_Iir,
+ T => Src.T,
+ Type_Rti => Src.Type_Rti);
+ pragma Assert (Src.C = null);
+ pragma Assert (Src.Type_Transient_Chain = Null_Iir);
+ when Kind_Object =>
+ pragma Assert (Src.Object_Driver = Null_Var);
+ pragma Assert (Src.Object_Function = O_Dnode_Null);
+ Dest.all :=
+ (Kind => Kind_Object,
+ Object_Static => Src.Object_Static,
+ Object_Var => Instantiate_Var (Src.Object_Var),
+ Object_Driver => Null_Var,
+ Object_Rti => Src.Object_Rti,
+ Object_Function => O_Dnode_Null);
+ when Kind_Subprg =>
+ Dest.Subprg_Frame_Scope :=
+ Instantiate_Var_Scope (Src.Subprg_Frame_Scope);
+ Dest.all :=
+ (Kind => Kind_Subprg,
+ Use_Stack2 => Src.Use_Stack2,
+ Ortho_Func => Src.Ortho_Func,
+ Res_Interface => Src.Res_Interface,
+ Res_Record_Var => Instantiate_Var (Src.Res_Record_Var),
+ Res_Record_Type => Src.Res_Record_Type,
+ Res_Record_Ptr => Src.Res_Record_Ptr,
+ Subprg_Frame_Scope => Dest.Subprg_Frame_Scope,
+ Subprg_Instance => Instantiate_Subprg_Instance
+ (Src.Subprg_Instance),
+ Subprg_Resolv => null,
+ Subprg_Local_Id => Src.Subprg_Local_Id,
+ Subprg_Exit => Src.Subprg_Exit,
+ Subprg_Result => Src.Subprg_Result);
+ when Kind_Interface =>
+ Dest.all := (Kind => Kind_Interface,
+ Interface_Node => Src.Interface_Node,
+ Interface_Field => Src.Interface_Field,
+ Interface_Type => Src.Interface_Type);
+ when Kind_Index =>
+ Dest.all := (Kind => Kind_Index,
+ Index_Field => Src.Index_Field);
+ when Kind_Expr =>
+ Dest.all := (Kind => Kind_Expr,
+ Expr_Node => Src.Expr_Node);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Copy_Info;
+
+ procedure Instantiate_Iir_Info (N : Iir) is
+ begin
+ -- Nothing to do for null node.
+ if N = Null_Iir then
+ return;
+ end if;
+
+ declare
+ use Nodes_Meta;
+ Kind : constant Iir_Kind := Get_Kind (N);
+ Fields : constant Fields_Array := Get_Fields (Kind);
+ F : Fields_Enum;
+ Orig : constant Iir := Sem_Inst.Get_Origin (N);
+ pragma Assert (Orig /= Null_Iir);
+ Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig);
+ Info : Ortho_Info_Acc;
+ begin
+ if Orig_Info /= null then
+ Info := Add_Info (N, Orig_Info.Kind);
+
+ Copy_Info (Info, Orig_Info);
+
+ case Info.Kind is
+ when Kind_Subprg =>
+ Push_Instantiate_Var_Scope
+ (Info.Subprg_Frame_Scope'Access,
+ Orig_Info.Subprg_Frame_Scope'Access);
+ when others =>
+ null;
+ end case;
+ end if;
+
+ for I in Fields'Range loop
+ F := Fields (I);
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Instantiate_Iir_Info (Get_Iir (N, F));
+ when Attr_Ref =>
+ null;
+ when Attr_Maybe_Ref =>
+ if not Get_Is_Ref (N) then
+ Instantiate_Iir_Info (Get_Iir (N, F));
+ end if;
+ when Attr_Chain =>
+ Instantiate_Iir_Chain_Info (Get_Iir (N, F));
+ when Attr_Chain_Next =>
+ null;
+ when Attr_Of_Ref =>
+ raise Internal_Error;
+ end case;
+ when Type_Iir_List =>
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Instantiate_Iir_List_Info (Get_Iir_List (N, F));
+ when Attr_Ref
+ | Attr_Of_Ref =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Type_PSL_NFA
+ | Type_PSL_Node =>
+ -- TODO
+ raise Internal_Error;
+ when Type_Date_Type
+ | Type_Date_State_Type
+ | Type_Time_Stamp_Id =>
+ -- Can this happen ?
+ raise Internal_Error;
+ when Type_String_Id
+ | Type_Source_Ptr
+ | Type_Base_Type
+ | Type_Iir_Constraint
+ | Type_Iir_Mode
+ | Type_Iir_Index32
+ | Type_Iir_Int64
+ | Type_Boolean
+ | Type_Iir_Staticness
+ | Type_Iir_All_Sensitized
+ | Type_Iir_Signal_Kind
+ | Type_Tri_State_Type
+ | Type_Iir_Pure_State
+ | Type_Iir_Delay_Mechanism
+ | Type_Iir_Lexical_Layout_Type
+ | Type_Iir_Predefined_Functions
+ | Type_Iir_Direction
+ | Type_Location_Type
+ | Type_Iir_Int32
+ | Type_Int32
+ | Type_Iir_Fp64
+ | Type_Token_Type
+ | Type_Name_Id =>
+ null;
+ end case;
+ end loop;
+
+ if Info /= null then
+ case Info.Kind is
+ when Kind_Subprg =>
+ Pop_Instantiate_Var_Scope
+ (Info.Subprg_Frame_Scope'Access);
+ when others =>
+ null;
+ end case;
+ end if;
+ end;
+ end Instantiate_Iir_Info;
+
+ procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir)
+ is
+ Inter : Iir;
+ Orig : Iir;
+ Orig_Info : Ortho_Info_Acc;
+ Info : Ortho_Info_Acc;
+ begin
+ Inter := Chain;
+ while Inter /= Null_Iir loop
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Constant_Declaration =>
+ Orig := Sem_Inst.Get_Origin (Inter);
+ Orig_Info := Get_Info (Orig);
+
+ Info := Add_Info (Inter, Orig_Info.Kind);
+ Copy_Info (Info, Orig_Info);
+
+ when Iir_Kind_Interface_Package_Declaration =>
+ null;
+
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Inter := Get_Chain (Inter);
+ end loop;
+ end Instantiate_Iir_Generic_Chain_Info;
+
+ -- Add info for an interface_package_declaration or a
+ -- package_instantiation_declaration
+ procedure Instantiate_Info_Package (Inst : Iir)
+ is
+ Spec : constant Iir :=
+ Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
+ Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec);
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Add_Info (Inst, Kind_Package_Instance);
+
+ -- Create the info instances.
+ Push_Instantiate_Var_Scope
+ (Info.Package_Instance_Spec_Scope'Access,
+ Pkg_Info.Package_Spec_Scope'Access);
+ Push_Instantiate_Var_Scope
+ (Info.Package_Instance_Body_Scope'Access,
+ Pkg_Info.Package_Body_Scope'Access);
+ Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst));
+ Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst));
+ Pop_Instantiate_Var_Scope
+ (Info.Package_Instance_Body_Scope'Access);
+ Pop_Instantiate_Var_Scope
+ (Info.Package_Instance_Spec_Scope'Access);
+ end Instantiate_Info_Package;
+
+ procedure Translate_Package_Instantiation_Declaration (Inst : Iir)
+ is
+ Spec : constant Iir :=
+ Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst));
+ Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec);
+ Info : Ortho_Info_Acc;
+ Interface_List : O_Inter_List;
+ Constr : O_Assoc_List;
+ begin
+ Instantiate_Info_Package (Inst);
+ Info := Get_Info (Inst);
+
+ -- FIXME: if the instantiation occurs within a package declaration,
+ -- the variable must be declared extern (and public in the body).
+ Info.Package_Instance_Body_Var := Create_Var
+ (Create_Var_Identifier (Inst),
+ Get_Scope_Type (Pkg_Info.Package_Body_Scope));
+
+ -- FIXME: this is correct only for global instantiation, and only if
+ -- there is only one.
+ Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope,
+ Get_Var_Label (Info.Package_Instance_Body_Var));
+ Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope,
+ Pkg_Info.Package_Spec_Field,
+ Info.Package_Instance_Body_Scope'Access);
+
+ -- Declare elaboration procedure
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier ("ELAB"), Global_Storage);
+ -- Chap2.Add_Subprg_Instance_Interfaces
+ -- (Interface_List, Info.Package_Instance_Elab_Instance);
+ Finish_Subprogram_Decl
+ (Interface_List, Info.Package_Instance_Elab_Subprg);
+
+ if Global_Storage /= O_Storage_Public then
+ return;
+ end if;
+
+ -- Elaborator:
+ Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg);
+ -- Chap2.Start_Subprg_Instance_Use
+ -- (Info.Package_Instance_Elab_Instance);
+
+ Elab_Dependence (Get_Design_Unit (Inst));
+
+ Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
+ Get_Var_Label (Info.Package_Instance_Body_Var));
+ Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope,
+ Pkg_Info.Package_Spec_Field,
+ Pkg_Info.Package_Body_Scope'Access);
+ Chap5.Elab_Generic_Map_Aspect (Inst);
+ Clear_Scope (Pkg_Info.Package_Spec_Scope);
+ Clear_Scope (Pkg_Info.Package_Body_Scope);
+
+ -- Call the elaborator of the generic. The generic must be
+ -- temporary associated with the instance variable.
+ Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg);
+ Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope,
+ Get_Var_Label (Info.Package_Instance_Body_Var));
+ Add_Subprg_Instance_Assoc
+ (Constr, Pkg_Info.Package_Elab_Body_Instance);
+ Clear_Scope (Pkg_Info.Package_Body_Scope);
+ New_Procedure_Call (Constr);
+
+ -- Chap2.Finish_Subprg_Instance_Use
+ -- (Info.Package_Instance_Elab_Instance);
+ Finish_Subprogram_Body;
+ end Translate_Package_Instantiation_Declaration;
+
+ procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration)
+ is
+ Info : Ortho_Info_Acc;
+ If_Blk : O_If_Block;
+ Constr : O_Assoc_List;
+ begin
+ -- Std.Standard is pre-elaborated.
+ if Pkg = Standard_Package then
+ return;
+ end if;
+
+ -- Nothing to do for uninstantiated package.
+ if Is_Uninstantiated_Package (Pkg) then
+ return;
+ end if;
+
+ -- Call the package elaborator only if not already elaborated.
+ Info := Get_Info (Pkg);
+ Start_If_Stmt
+ (If_Blk,
+ New_Monadic_Op (ON_Not,
+ New_Value (Get_Var (Info.Package_Elab_Var))));
+ -- Elaborates only non-elaborated packages.
+ Start_Association (Constr, Info.Package_Elab_Body_Subprg);
+ New_Procedure_Call (Constr);
+ Finish_If_Stmt (If_Blk);
+ end Elab_Dependence_Package;
+
+ procedure Elab_Dependence_Package_Instantiation (Pkg : Iir)
+ is
+ Info : constant Ortho_Info_Acc := Get_Info (Pkg);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Info.Package_Instance_Elab_Subprg);
+ New_Procedure_Call (Constr);
+ end Elab_Dependence_Package_Instantiation;
+
+ procedure Elab_Dependence (Design_Unit: Iir_Design_Unit)
+ is
+ Depend_List: Iir_Design_Unit_List;
+ Design: Iir;
+ Library_Unit: Iir;
+ begin
+ Depend_List := Get_Dependence_List (Design_Unit);
+
+ for I in Natural loop
+ Design := Get_Nth_Element (Depend_List, I);
+ exit when Design = Null_Iir;
+ if Get_Kind (Design) = Iir_Kind_Design_Unit then
+ Library_Unit := Get_Library_Unit (Design);
+ case Get_Kind (Library_Unit) is
+ when Iir_Kind_Package_Declaration =>
+ Elab_Dependence_Package (Library_Unit);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Elab_Dependence_Package_Instantiation (Library_Unit);
+ when Iir_Kind_Entity_Declaration =>
+ -- FIXME: architecture already elaborates its entity.
+ null;
+ when Iir_Kind_Configuration_Declaration =>
+ null;
+ when Iir_Kind_Architecture_Body =>
+ null;
+ when Iir_Kind_Package_Body =>
+ -- A package instantiation depends on the body.
+ null;
+ when others =>
+ Error_Kind ("elab_dependence", Library_Unit);
+ end case;
+ end if;
+ end loop;
+ end Elab_Dependence;
+
+ procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc;
+ Ptr_Type : out O_Tnode) is
+ begin
+ Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE"));
+ Declare_Scope_Acc
+ (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type);
+ end Declare_Inst_Type_And_Ptr;
+
+ procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is
+ begin
+ Prev := Current_Subprg_Instance;
+ Current_Subprg_Instance := Null_Subprg_Instance_Stack;
+ end Clear_Subprg_Instance;
+
+ procedure Push_Subprg_Instance (Scope : Var_Scope_Acc;
+ Ptr_Type : O_Tnode;
+ Ident : O_Ident;
+ Prev : out Subprg_Instance_Stack)
+ is
+ begin
+ Prev := Current_Subprg_Instance;
+ Current_Subprg_Instance := (Scope => Scope,
+ Ptr_Type => Ptr_Type,
+ Ident => Ident);
+ end Push_Subprg_Instance;
+
+ function Has_Current_Subprg_Instance return Boolean is
+ begin
+ return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null;
+ end Has_Current_Subprg_Instance;
+
+ procedure Pop_Subprg_Instance (Ident : O_Ident;
+ Prev : Subprg_Instance_Stack)
+ is
+ begin
+ if Is_Equal (Current_Subprg_Instance.Ident, Ident) then
+ Current_Subprg_Instance := Prev;
+ else
+ -- POP does not match with a push.
+ raise Internal_Error;
+ end if;
+ end Pop_Subprg_Instance;
+
+ procedure Add_Subprg_Instance_Interfaces
+ (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type)
+ is
+ begin
+ if Has_Current_Subprg_Instance then
+ Vars.Scope := Current_Subprg_Instance.Scope;
+ Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type;
+ New_Interface_Decl
+ (Interfaces, Vars.Inter,
+ Current_Subprg_Instance.Ident,
+ Current_Subprg_Instance.Ptr_Type);
+ else
+ Vars := Null_Subprg_Instance;
+ end if;
+ end Add_Subprg_Instance_Interfaces;
+
+ procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is
+ begin
+ if Has_Current_Subprg_Instance then
+ Field := Add_Instance_Factory_Field
+ (Current_Subprg_Instance.Ident,
+ Current_Subprg_Instance.Ptr_Type);
+ else
+ Field := O_Fnode_Null;
+ end if;
+ end Add_Subprg_Instance_Field;
+
+ function Has_Subprg_Instance (Vars : Subprg_Instance_Type)
+ return Boolean is
+ begin
+ return Vars.Inter /= O_Dnode_Null;
+ end Has_Subprg_Instance;
+
+ function Get_Subprg_Instance (Vars : Subprg_Instance_Type)
+ return O_Enode is
+ begin
+ pragma Assert (Has_Subprg_Instance (Vars));
+ return New_Address (Get_Instance_Ref (Vars.Scope.all),
+ Vars.Inter_Type);
+ end Get_Subprg_Instance;
+
+ procedure Add_Subprg_Instance_Assoc
+ (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is
+ begin
+ if Has_Subprg_Instance (Vars) then
+ New_Association (Assocs, Get_Subprg_Instance (Vars));
+ end if;
+ end Add_Subprg_Instance_Assoc;
+
+ procedure Set_Subprg_Instance_Field
+ (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type)
+ is
+ begin
+ if Has_Subprg_Instance (Vars) then
+ New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field),
+ New_Obj_Value (Vars.Inter));
+ end if;
+ end Set_Subprg_Instance_Field;
+
+ procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is
+ begin
+ if Has_Subprg_Instance (Vars) then
+ Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter);
+ end if;
+ end Start_Subprg_Instance_Use;
+
+ procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is
+ begin
+ if Has_Subprg_Instance (Vars) then
+ Clear_Scope (Vars.Scope.all);
+ end if;
+ end Finish_Subprg_Instance_Use;
+
+ procedure Start_Prev_Subprg_Instance_Use_Via_Field
+ (Prev : Subprg_Instance_Stack; Field : O_Fnode) is
+ begin
+ if Field /= O_Fnode_Null then
+ Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field,
+ Current_Subprg_Instance.Scope);
+ end if;
+ end Start_Prev_Subprg_Instance_Use_Via_Field;
+
+ procedure Finish_Prev_Subprg_Instance_Use_Via_Field
+ (Prev : Subprg_Instance_Stack; Field : O_Fnode) is
+ begin
+ if Field /= O_Fnode_Null then
+ Clear_Scope (Prev.Scope.all);
+ end if;
+ end Finish_Prev_Subprg_Instance_Use_Via_Field;
+
+ procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List;
+ Subprg : Iir)
+ is
+ begin
+ Add_Subprg_Instance_Interfaces
+ (Interfaces, Get_Info (Subprg).Subprg_Instance);
+ end Create_Subprg_Instance;
+
+ procedure Start_Subprg_Instance_Use (Subprg : Iir) is
+ begin
+ Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance);
+ end Start_Subprg_Instance_Use;
+
+ procedure Finish_Subprg_Instance_Use (Subprg : Iir) is
+ begin
+ Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance);
+ end Finish_Subprg_Instance_Use;
+
+ function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type)
+ return Subprg_Instance_Type is
+ begin
+ return Subprg_Instance_Type'
+ (Inter => Inst.Inter,
+ Inter_Type => Inst.Inter_Type,
+ Scope => Instantiated_Var_Scope (Inst.Scope));
+ end Instantiate_Subprg_Instance;
+ end Chap2;
+
+ package body Chap3 is
+ function Create_Static_Type_Definition_Type_Range (Def : Iir)
+ return O_Cnode;
+ procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode);
+
+ -- For scalar subtypes: creates info from the base type.
+ procedure Create_Subtype_Info_From_Type (Def : Iir;
+ Subtype_Info : Type_Info_Acc;
+ Base_Info : Type_Info_Acc);
+
+ -- Finish a type definition: declare the type, define and declare a
+ -- pointer to the type.
+ procedure Finish_Type_Definition
+ (Info : Type_Info_Acc; Completion : Boolean := False)
+ is
+ begin
+ -- Declare the type.
+ if not Completion then
+ New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value));
+ end if;
+
+ -- Create an access to the type and declare it.
+ Info.Ortho_Ptr_Type (Mode_Value) :=
+ New_Access_Type (Info.Ortho_Type (Mode_Value));
+ New_Type_Decl (Create_Identifier ("PTR"),
+ Info.Ortho_Ptr_Type (Mode_Value));
+
+ -- Signal type.
+ if Info.Type_Mode in Type_Mode_Scalar then
+ Info.Ortho_Type (Mode_Signal) :=
+ New_Access_Type (Info.Ortho_Type (Mode_Value));
+ end if;
+ if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then
+ New_Type_Decl (Create_Identifier ("SIG"),
+ Info.Ortho_Type (Mode_Signal));
+ end if;
+
+ -- Signal pointer type.
+ if Info.Type_Mode in Type_Mode_Composite
+ and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null
+ then
+ Info.Ortho_Ptr_Type (Mode_Signal) :=
+ New_Access_Type (Info.Ortho_Type (Mode_Signal));
+ New_Type_Decl (Create_Identifier ("SIGPTR"),
+ Info.Ortho_Ptr_Type (Mode_Signal));
+ else
+ Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null;
+ end if;
+ end Finish_Type_Definition;
+
+ procedure Create_Size_Var (Def : Iir)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ begin
+ Info.C := new Complex_Type_Arr_Info;
+ Info.C (Mode_Value).Size_Var := Create_Var
+ (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type);
+ if Get_Has_Signal_Flag (Def) then
+ Info.C (Mode_Signal).Size_Var := Create_Var
+ (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type);
+ end if;
+ end Create_Size_Var;
+
+ -- A builder set internal fields of object pointed by BASE_PTR, using
+ -- memory from BASE_PTR and returns a pointer to the next memory byte
+ -- to be used.
+ procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc;
+ Name : Name_Id;
+ Kind : Object_Kind_Type)
+ is
+ Interface_List : O_Inter_List;
+ Ident : O_Ident;
+ Ptype : O_Tnode;
+ begin
+ case Kind is
+ when Mode_Value =>
+ Ident := Create_Identifier (Name, "_BUILDER");
+ when Mode_Signal =>
+ Ident := Create_Identifier (Name, "_SIGBUILDER");
+ end case;
+ -- FIXME: return the same type as its first parameter ???
+ Start_Function_Decl
+ (Interface_List, Ident, Global_Storage, Ghdl_Index_Type);
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Interface_List, Info.C (Kind).Builder_Instance);
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Ptype := Info.T.Base_Ptr_Type (Kind);
+ when Type_Mode_Record =>
+ Ptype := Info.Ortho_Ptr_Type (Kind);
+ when others =>
+ raise Internal_Error;
+ end case;
+ New_Interface_Decl
+ (Interface_List, Info.C (Kind).Builder_Base_Param,
+ Get_Identifier ("base_ptr"), Ptype);
+ -- Add parameter for array bounds.
+ if Info.Type_Mode = Type_Mode_Fat_Array then
+ New_Interface_Decl
+ (Interface_List, Info.C (Kind).Builder_Bound_Param,
+ Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type);
+ end if;
+ Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func);
+ end Create_Builder_Subprogram_Decl;
+
+ function Gen_Call_Type_Builder (Var_Ptr : O_Dnode;
+ Var_Type : Iir;
+ Kind : Object_Kind_Type)
+ return O_Enode
+ is
+ Tinfo : constant Type_Info_Acc := Get_Info (Var_Type);
+ Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type));
+ Assoc : O_Assoc_List;
+ begin
+ -- Build the field
+ Start_Association (Assoc, Binfo.C (Kind).Builder_Func);
+ Chap2.Add_Subprg_Instance_Assoc
+ (Assoc, Binfo.C (Kind).Builder_Instance);
+
+ case Tinfo.Type_Mode is
+ when Type_Mode_Record
+ | Type_Mode_Array =>
+ New_Association (Assoc, New_Obj_Value (Var_Ptr));
+ when Type_Mode_Fat_Array =>
+ -- Note: a fat array can only be at the top of a complex type;
+ -- the bounds must have been set.
+ New_Association
+ (Assoc, New_Value_Selected_Acc_Value
+ (New_Obj (Var_Ptr), Tinfo.T.Base_Field (Kind)));
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ if Tinfo.Type_Mode in Type_Mode_Arrays then
+ declare
+ Arr : Mnode;
+ begin
+ case Type_Mode_Arrays (Tinfo.Type_Mode) is
+ when Type_Mode_Array =>
+ Arr := T2M (Var_Type, Kind);
+ when Type_Mode_Fat_Array =>
+ Arr := Dp2M (Var_Ptr, Tinfo, Kind);
+ end case;
+ New_Association
+ (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr)));
+ end;
+ end if;
+
+ return New_Function_Call (Assoc);
+ end Gen_Call_Type_Builder;
+
+ procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir)
+ is
+ Mem : O_Dnode;
+ V : Mnode;
+ begin
+ Open_Temp;
+ V := Stabilize (Var);
+ Mem := Create_Temp (Ghdl_Index_Type);
+ New_Assign_Stmt
+ (New_Obj (Mem),
+ Gen_Call_Type_Builder (M2Dp (V), Var_Type, Get_Object_Kind (Var)));
+ Close_Temp;
+ end Gen_Call_Type_Builder;
+
+ ------------------
+ -- Enumeration --
+ ------------------
+
+ function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal)
+ return O_Ident
+ is
+ El_Str : String (1 .. 4);
+ Id : Name_Id;
+ N : Integer;
+ C : Character;
+ begin
+ Id := Get_Identifier (Lit);
+ if Name_Table.Is_Character (Id) then
+ C := Name_Table.Get_Character (Id);
+ El_Str (1) := 'C';
+ case C is
+ when 'A' .. 'Z'
+ | 'a' .. 'z'
+ | '0' .. '9' =>
+ El_Str (2) := '_';
+ El_Str (3) := C;
+ when others =>
+ N := Character'Pos (Name_Table.Get_Character (Id));
+ El_Str (2) := N2hex (N / 16);
+ El_Str (3) := N2hex (N mod 16);
+ end case;
+ return Get_Identifier (El_Str (1 .. 3));
+ else
+ return Create_Identifier_Without_Prefix (Lit);
+ end if;
+ end Translate_Enumeration_Literal;
+
+ procedure Translate_Enumeration_Type
+ (Def : Iir_Enumeration_Type_Definition)
+ is
+ El_List : Iir_List;
+ El : Iir_Enumeration_Literal;
+ Constr : O_Enum_List;
+ Lit_Name : O_Ident;
+ Val : O_Cnode;
+ Info : Type_Info_Acc;
+ Nbr : Natural;
+ Size : Natural;
+ begin
+ El_List := Get_Enumeration_Literal_List (Def);
+ Nbr := Get_Nbr_Elements (El_List);
+ if Nbr <= 256 then
+ Size := 8;
+ else
+ Size := 32;
+ end if;
+ Start_Enum_Type (Constr, Size);
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+
+ Lit_Name := Translate_Enumeration_Literal (El);
+ New_Enum_Literal (Constr, Lit_Name, Val);
+ Set_Ortho_Expr (El, Val);
+ end loop;
+ Info := Get_Info (Def);
+ Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value));
+ if Nbr <= 256 then
+ Info.Type_Mode := Type_Mode_E8;
+ else
+ Info.Type_Mode := Type_Mode_E32;
+ end if;
+ -- Enumerations are always in their range.
+ Info.T.Nocheck_Low := True;
+ Info.T.Nocheck_Hi := True;
+ Finish_Type_Definition (Info);
+ end Translate_Enumeration_Type;
+
+ procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ El_List : Iir_List;
+ True_Lit, False_Lit : Iir_Enumeration_Literal;
+ False_Node, True_Node : O_Cnode;
+ begin
+ Info := Get_Info (Def);
+ El_List := Get_Enumeration_Literal_List (Def);
+ if Get_Nbr_Elements (El_List) /= 2 then
+ raise Internal_Error;
+ end if;
+ False_Lit := Get_Nth_Element (El_List, 0);
+ True_Lit := Get_Nth_Element (El_List, 1);
+ New_Boolean_Type
+ (Info.Ortho_Type (Mode_Value),
+ Translate_Enumeration_Literal (False_Lit), False_Node,
+ Translate_Enumeration_Literal (True_Lit), True_Node);
+ Info.Type_Mode := Type_Mode_B1;
+ Set_Ortho_Expr (False_Lit, False_Node);
+ Set_Ortho_Expr (True_Lit, True_Node);
+ Info.T.Nocheck_Low := True;
+ Info.T.Nocheck_Hi := True;
+ Finish_Type_Definition (Info);
+ end Translate_Bool_Type;
+
+ ---------------
+ -- Integer --
+ ---------------
+
+ -- Return the number of bits (32 or 64) required to represent the
+ -- (integer or physical) type definition DEF.
+ type Type_Precision is (Precision_32, Precision_64);
+ function Get_Type_Precision (Def : Iir) return Type_Precision
+ is
+ St : Iir;
+ L, H : Iir;
+ Lv, Hv : Iir_Int64;
+ begin
+ St := Get_Subtype_Definition (Get_Type_Declarator (Def));
+ Get_Low_High_Limit (Get_Range_Constraint (St), L, H);
+ Lv := Get_Value (L);
+ Hv := Get_Value (H);
+ if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then
+ return Precision_32;
+ else
+ if Flag_Only_32b then
+ Error_Msg_Sem
+ ("range of " & Disp_Node (Get_Type_Declarator (St))
+ & " is too large", St);
+ return Precision_32;
+ end if;
+ return Precision_64;
+ end if;
+ end Get_Type_Precision;
+
+ procedure Translate_Integer_Type
+ (Def : Iir_Integer_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Info (Def);
+ case Get_Type_Precision (Def) is
+ when Precision_32 =>
+ Info.Ortho_Type (Mode_Value) := New_Signed_Type (32);
+ Info.Type_Mode := Type_Mode_I32;
+ when Precision_64 =>
+ Info.Ortho_Type (Mode_Value) := New_Signed_Type (64);
+ Info.Type_Mode := Type_Mode_I64;
+ end case;
+ -- Integers are always in their ranges.
+ Info.T.Nocheck_Low := True;
+ Info.T.Nocheck_Hi := True;
+
+ Finish_Type_Definition (Info);
+ end Translate_Integer_Type;
+
+ ----------------------
+ -- Floating types --
+ ----------------------
+
+ procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ begin
+ -- FIXME: should check precision
+ Info := Get_Info (Def);
+ Info.Type_Mode := Type_Mode_F64;
+ Info.Ortho_Type (Mode_Value) := New_Float_Type;
+ -- Reals are always in their ranges.
+ Info.T.Nocheck_Low := True;
+ Info.T.Nocheck_Hi := True;
+
+ Finish_Type_Definition (Info);
+ end Translate_Floating_Type;
+
+ ----------------
+ -- Physical --
+ ----------------
+
+ procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Info (Def);
+ case Get_Type_Precision (Def) is
+ when Precision_32 =>
+ Info.Ortho_Type (Mode_Value) := New_Signed_Type (32);
+ Info.Type_Mode := Type_Mode_P32;
+ when Precision_64 =>
+ Info.Ortho_Type (Mode_Value) := New_Signed_Type (64);
+ Info.Type_Mode := Type_Mode_P64;
+ end case;
+ -- Phyiscals are always in their ranges.
+ Info.T.Nocheck_Low := True;
+ Info.T.Nocheck_Hi := True;
+
+ Finish_Type_Definition (Info);
+ end Translate_Physical_Type;
+
+ procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition)
+ is
+ Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value);
+ Unit : Iir;
+ Info : Object_Info_Acc;
+ begin
+ Unit := Get_Unit_Chain (Def);
+ while Unit /= Null_Iir loop
+ Info := Add_Info (Unit, Kind_Object);
+ Info.Object_Var :=
+ Create_Var (Create_Var_Identifier (Unit), Phy_Type);
+ Unit := Get_Chain (Unit);
+ end loop;
+ end Translate_Physical_Units;
+
+ ------------
+ -- File --
+ ------------
+
+ procedure Translate_File_Type (Def : Iir_File_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Info (Def);
+ Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type;
+ Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type;
+ Info.Type_Mode := Type_Mode_File;
+ end Translate_File_Type;
+
+ function Get_File_Signature_Length (Def : Iir) return Natural is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ return 1;
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ return 2
+ + Get_File_Signature_Length (Get_Element_Subtype (Def));
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir;
+ Res : Natural;
+ List : Iir_List;
+ begin
+ Res := 2;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Res := Res + Get_File_Signature_Length (Get_Type (El));
+ end loop;
+ return Res;
+ end;
+ when others =>
+ Error_Kind ("get_file_signature_length", Def);
+ end case;
+ end Get_File_Signature_Length;
+
+ procedure Get_File_Signature (Def : Iir;
+ Res : in out String;
+ Off : in out Natural)
+ is
+ Scalar_Map : constant array (Type_Mode_Scalar) of Character
+ := "beEiIpPF";
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode);
+ Off := Off + 1;
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ Res (Off) := '[';
+ Off := Off + 1;
+ Get_File_Signature (Get_Element_Subtype (Def), Res, Off);
+ Res (Off) := ']';
+ Off := Off + 1;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ declare
+ El : Iir;
+ List : Iir_List;
+ begin
+ Res (Off) := '<';
+ Off := Off + 1;
+ List := Get_Elements_Declaration_List (Get_Base_Type (Def));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Get_File_Signature (Get_Type (El), Res, Off);
+ end loop;
+ Res (Off) := '>';
+ Off := Off + 1;
+ end;
+ when others =>
+ Error_Kind ("get_file_signature", Def);
+ end case;
+ end Get_File_Signature;
+
+ procedure Create_File_Type_Var (Def : Iir_File_Type_Definition)
+ is
+ Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def));
+ Info : Type_Info_Acc;
+ begin
+ if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then
+ return;
+ end if;
+ declare
+ Len : constant Natural := Get_File_Signature_Length (Type_Name);
+ Sig : String (1 .. Len + 2);
+ Off : Natural := Sig'First;
+ begin
+ Get_File_Signature (Type_Name, Sig, Off);
+ Sig (Len + 1) := '.';
+ Sig (Len + 2) := Character'Val (10);
+ Info := Get_Info (Def);
+ Info.T.File_Signature := Create_String
+ (Sig, Create_Identifier ("FILESIG"), Global_Storage);
+ end;
+ end Create_File_Type_Var;
+
+ -------------
+ -- Array --
+ -------------
+
+ function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is
+ begin
+ if Get_Has_Signal_Flag (Def) then
+ return Mode_Signal;
+ else
+ return Mode_Value;
+ end if;
+ end Type_To_Last_Object_Kind;
+
+ procedure Create_Array_Fat_Pointer
+ (Info : Type_Info_Acc; Kind : Object_Kind_Type)
+ is
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field
+ (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"),
+ Info.T.Base_Ptr_Type (Kind));
+ New_Record_Field
+ (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"),
+ Info.T.Bounds_Ptr_Type);
+ Finish_Record_Type (Constr, Info.Ortho_Type (Kind));
+ end Create_Array_Fat_Pointer;
+
+ procedure Translate_Incomplete_Array_Type
+ (Def : Iir_Array_Type_Definition)
+ is
+ Arr_Info : Incomplete_Type_Info_Acc;
+ Info : Type_Info_Acc;
+ begin
+ Arr_Info := Get_Info (Def);
+ if Arr_Info.Incomplete_Array /= null then
+ -- This (incomplete) array type was already translated.
+ -- This is the case for a second access type definition to this
+ -- still incomplete array type.
+ return;
+ end if;
+ Info := new Ortho_Info_Type (Kind_Type);
+ Info.Type_Mode := Type_Mode_Fat_Array;
+ Info.Type_Incomplete := True;
+ Arr_Info.Incomplete_Array := Info;
+
+ Info.T := Ortho_Info_Type_Array_Init;
+ Info.T.Bounds_Type := O_Tnode_Null;
+
+ Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type);
+ New_Type_Decl (Create_Identifier ("BOUNDP"),
+ Info.T.Bounds_Ptr_Type);
+
+ Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null);
+ New_Type_Decl (Create_Identifier ("BASEP"),
+ Info.T.Base_Ptr_Type (Mode_Value));
+
+ Create_Array_Fat_Pointer (Info, Mode_Value);
+
+ New_Type_Decl
+ (Create_Identifier, Info.Ortho_Type (Mode_Value));
+ end Translate_Incomplete_Array_Type;
+
+ -- Declare the bounds types for DEF.
+ procedure Translate_Array_Type_Bounds
+ (Def : Iir_Array_Type_Definition;
+ Info : Type_Info_Acc;
+ Complete : Boolean)
+ is
+ Indexes_List : constant Iir_List :=
+ Get_Index_Subtype_Definition_List (Def);
+ Constr : O_Element_List;
+ Dim : String (1 .. 8);
+ N : Natural;
+ P : Natural;
+ Index : Iir;
+ Index_Info : Index_Info_Acc;
+ Index_Type_Mark : Iir;
+ begin
+ Start_Record_Type (Constr);
+ for I in Natural loop
+ Index_Type_Mark := Get_Nth_Element (Indexes_List, I);
+ exit when Index_Type_Mark = Null_Iir;
+ Index := Get_Index_Type (Index_Type_Mark);
+
+ -- Index comes from a type mark.
+ pragma Assert (not Is_Anonymous_Type_Definition (Index));
+
+ Index_Info := Add_Info (Index_Type_Mark, Kind_Index);
+
+ -- Build the name
+ N := I + 1;
+ P := Dim'Last;
+ loop
+ Dim (P) := Character'Val (Character'Pos ('0') + N mod 10);
+ P := P - 1;
+ N := N / 10;
+ exit when N = 0;
+ end loop;
+ P := P - 3;
+ Dim (P .. P + 3) := "dim_";
+
+ New_Record_Field (Constr, Index_Info.Index_Field,
+ Get_Identifier (Dim (P .. Dim'Last)),
+ Get_Info (Get_Base_Type (Index)).T.Range_Type);
+ end loop;
+ Finish_Record_Type (Constr, Info.T.Bounds_Type);
+ New_Type_Decl (Create_Identifier ("BOUND"),
+ Info.T.Bounds_Type);
+ if Complete then
+ Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type);
+ else
+ Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type);
+ New_Type_Decl (Create_Identifier ("BOUNDP"),
+ Info.T.Bounds_Ptr_Type);
+ end if;
+ end Translate_Array_Type_Bounds;
+
+ procedure Translate_Array_Type_Base
+ (Def : Iir_Array_Type_Definition;
+ Info : Type_Info_Acc;
+ Complete : Boolean)
+ is
+ El_Type : Iir;
+ El_Tinfo : Type_Info_Acc;
+ Id, Idptr : O_Ident;
+ begin
+ El_Type := Get_Element_Subtype (Def);
+ Translate_Type_Definition (El_Type, True);
+ El_Tinfo := Get_Info (El_Type);
+
+ if Is_Complex_Type (El_Tinfo) then
+ if El_Tinfo.Type_Mode = Type_Mode_Array then
+ Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type;
+ Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type;
+ else
+ Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type;
+ Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type;
+ end if;
+ else
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ case Kind is
+ when Mode_Value =>
+ -- For the values.
+ Id := Create_Identifier ("BASE");
+ if not Complete then
+ Idptr := Create_Identifier ("BASEP");
+ else
+ Idptr := O_Ident_Nul;
+ end if;
+ when Mode_Signal =>
+ -- For the signals
+ Id := Create_Identifier ("SIGBASE");
+ Idptr := Create_Identifier ("SIGBASEP");
+ end case;
+ Info.T.Base_Type (Kind) :=
+ New_Array_Type (El_Tinfo.Ortho_Type (Kind),
+ Ghdl_Index_Type);
+ New_Type_Decl (Id, Info.T.Base_Type (Kind));
+ if Is_Equal (Idptr, O_Ident_Nul) then
+ Finish_Access_Type (Info.T.Base_Ptr_Type (Kind),
+ Info.T.Base_Type (Kind));
+ else
+ Info.T.Base_Ptr_Type (Kind) :=
+ New_Access_Type (Info.T.Base_Type (Kind));
+ New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind));
+ end if;
+ end loop;
+ end if;
+ end Translate_Array_Type_Base;
+
+ -- For unidimensional arrays: create a constant bounds whose length
+ -- is 1, for concatenation with element.
+ procedure Translate_Static_Unidimensional_Array_Length_One
+ (Def : Iir_Array_Type_Definition)
+ is
+ Indexes : constant Iir_List := Get_Index_Subtype_List (Def);
+ Index_Type : Iir;
+ Index_Base_Type : Iir;
+ Constr : O_Record_Aggr_List;
+ Constr1 : O_Record_Aggr_List;
+ Arr_Info : Type_Info_Acc;
+ Tinfo : Type_Info_Acc;
+ Irange : Iir;
+ Res1 : O_Cnode;
+ Res : O_Cnode;
+ begin
+ if Get_Nbr_Elements (Indexes) /= 1 then
+ -- Not a one-dimensional array.
+ return;
+ end if;
+ Index_Type := Get_Index_Type (Indexes, 0);
+ Arr_Info := Get_Info (Def);
+ if Get_Type_Staticness (Index_Type) = Locally then
+ if Global_Storage /= O_Storage_External then
+ Index_Base_Type := Get_Base_Type (Index_Type);
+ Tinfo := Get_Info (Index_Base_Type);
+ Irange := Get_Range_Constraint (Index_Type);
+ Start_Record_Aggr (Constr, Arr_Info.T.Bounds_Type);
+ Start_Record_Aggr (Constr1, Tinfo.T.Range_Type);
+ New_Record_Aggr_El
+ (Constr1,
+ Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type));
+ New_Record_Aggr_El
+ (Constr1,
+ Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type));
+ New_Record_Aggr_El
+ (Constr1, Chap7.Translate_Static_Range_Dir (Irange));
+ New_Record_Aggr_El
+ (Constr1, Ghdl_Index_1);
+ Finish_Record_Aggr (Constr1, Res1);
+ New_Record_Aggr_El (Constr, Res1);
+ Finish_Record_Aggr (Constr, Res);
+ else
+ Res := O_Cnode_Null;
+ end if;
+ Arr_Info.T.Array_1bound := Create_Global_Const
+ (Create_Identifier ("BR1"),
+ Arr_Info.T.Bounds_Type, Global_Storage, Res);
+ else
+ Arr_Info.T.Array_1bound := Create_Var
+ (Create_Var_Identifier ("BR1"),
+ Arr_Info.T.Bounds_Type, Global_Storage);
+ end if;
+ end Translate_Static_Unidimensional_Array_Length_One;
+
+ procedure Translate_Dynamic_Unidimensional_Array_Length_One
+ (Def : Iir_Array_Type_Definition)
+ is
+ Indexes : constant Iir_List := Get_Index_Subtype_List (Def);
+ Index_Type : Iir;
+ Arr_Info : Type_Info_Acc;
+ Bound1, Rng : Mnode;
+ begin
+ if Get_Nbr_Elements (Indexes) /= 1 then
+ return;
+ end if;
+ Index_Type := Get_Index_Type (Indexes, 0);
+ if Get_Type_Staticness (Index_Type) = Locally then
+ return;
+ end if;
+ Arr_Info := Get_Info (Def);
+ Open_Temp;
+ Bound1 := Varv2M (Arr_Info.T.Array_1bound, Arr_Info, Mode_Value,
+ Arr_Info.T.Bounds_Type, Arr_Info.T.Bounds_Ptr_Type);
+ Bound1 := Bounds_To_Range (Bound1, Def, 1);
+ Stabilize (Bound1);
+ Rng := Type_To_Range (Index_Type);
+ Stabilize (Rng);
+ New_Assign_Stmt (M2Lv (Range_To_Dir (Bound1)),
+ M2E (Range_To_Dir (Rng)));
+ New_Assign_Stmt (M2Lv (Range_To_Left (Bound1)),
+ M2E (Range_To_Left (Rng)));
+ New_Assign_Stmt (M2Lv (Range_To_Right (Bound1)),
+ M2E (Range_To_Left (Rng)));
+ New_Assign_Stmt (M2Lv (Range_To_Length (Bound1)),
+ New_Lit (Ghdl_Index_1));
+ Close_Temp;
+ end Translate_Dynamic_Unidimensional_Array_Length_One;
+
+ procedure Translate_Array_Type_Definition
+ (Def : Iir_Array_Type_Definition)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ -- If true, INFO was already partially filled, by a previous access
+ -- type definition to this incomplete array type.
+ Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array;
+ El_Tinfo : Type_Info_Acc;
+ begin
+ if not Completion then
+ Info.Type_Mode := Type_Mode_Fat_Array;
+ Info.T := Ortho_Info_Type_Array_Init;
+ end if;
+ Translate_Array_Type_Base (Def, Info, Completion);
+ Translate_Array_Type_Bounds (Def, Info, Completion);
+ Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+ if not Completion then
+ Create_Array_Fat_Pointer (Info, Mode_Value);
+ end if;
+ if Get_Has_Signal_Flag (Def) then
+ Create_Array_Fat_Pointer (Info, Mode_Signal);
+ end if;
+ Finish_Type_Definition (Info, Completion);
+
+ Translate_Static_Unidimensional_Array_Length_One (Def);
+
+ El_Tinfo := Get_Info (Get_Element_Subtype (Def));
+ if Is_Complex_Type (El_Tinfo) then
+ -- This is a complex type.
+ Info.C := new Complex_Type_Arr_Info;
+ -- No size variable for unconstrained array type.
+ for Mode in Object_Kind_Type loop
+ Info.C (Mode).Size_Var := Null_Var;
+ Info.C (Mode).Builder_Need_Func :=
+ El_Tinfo.C (Mode).Builder_Need_Func;
+ end loop;
+ end if;
+ Info.Type_Incomplete := False;
+ end Translate_Array_Type_Definition;
+
+ -- Get the length of DEF, ie the number of elements.
+ -- If the length is not statically defined, returns -1.
+ function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition)
+ return Iir_Int64
+ is
+ Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def);
+ Index : Iir;
+ Len : Iir_Int64;
+ begin
+ -- Check if the bounds of the array are locally static.
+ Len := 1;
+ for I in Natural loop
+ Index := Get_Index_Type (Indexes_List, I);
+ exit when Index = Null_Iir;
+
+ if Get_Type_Staticness (Index) /= Locally then
+ return -1;
+ end if;
+ Len := Len * Eval_Discrete_Type_Length (Index);
+ end loop;
+ return Len;
+ end Get_Array_Subtype_Length;
+
+ procedure Translate_Array_Subtype_Definition
+ (Def : Iir_Array_Subtype_Definition)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ Binfo : constant Type_Info_Acc := Get_Info (Base_Type);
+
+ Len : Iir_Int64;
+
+ Id : O_Ident;
+ begin
+ -- Note: info of indexes subtype are not created!
+
+ Len := Get_Array_Subtype_Length (Def);
+ Info.Type_Mode := Type_Mode_Array;
+ Info.Type_Locally_Constrained := (Len >= 0);
+ if Is_Complex_Type (Binfo)
+ or else not Info.Type_Locally_Constrained
+ then
+ -- This is a complex type as the size is not known at compile
+ -- time.
+ Info.Ortho_Type := Binfo.T.Base_Ptr_Type;
+ Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type;
+
+ Create_Size_Var (Def);
+
+ for Mode in Object_Kind_Type loop
+ Info.C (Mode).Builder_Need_Func :=
+ Is_Complex_Type (Binfo)
+ and then Binfo.C (Mode).Builder_Need_Func;
+ end loop;
+ else
+ -- Length is known. Create a constrained array.
+ Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+ Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type;
+ for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ case I is
+ when Mode_Value =>
+ Id := Create_Identifier;
+ when Mode_Signal =>
+ Id := Create_Identifier ("SIG");
+ end case;
+ Info.Ortho_Type (I) := New_Constrained_Array_Type
+ (Binfo.T.Base_Type (I),
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len)));
+ New_Type_Decl (Id, Info.Ortho_Type (I));
+ end loop;
+ end if;
+ end Translate_Array_Subtype_Definition;
+
+ procedure Translate_Array_Subtype_Element_Subtype
+ (Def : Iir_Array_Subtype_Definition)
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Def);
+ Type_Mark : constant Iir := Get_Denoted_Type_Mark (Def);
+ Tm_El_Type : Iir;
+ begin
+ if Type_Mark = Null_Iir then
+ -- Array subtype for constained array definition. Same element
+ -- subtype as the base type.
+ return;
+ end if;
+
+ Tm_El_Type := Get_Element_Subtype (Type_Mark);
+ if El_Type = Tm_El_Type then
+ -- Same element subtype as the type mark.
+ return;
+ end if;
+
+ case Get_Kind (El_Type) is
+ when Iir_Kinds_Scalar_Subtype_Definition =>
+ declare
+ El_Info : Ortho_Info_Acc;
+ begin
+ El_Info := Add_Info (El_Type, Kind_Type);
+ Create_Subtype_Info_From_Type
+ (El_Type, El_Info, Get_Info (Tm_El_Type));
+ end;
+ when others =>
+ Error_Kind ("translate_array_subtype_element_subtype", El_Type);
+ end case;
+ end Translate_Array_Subtype_Element_Subtype;
+
+ function Create_Static_Array_Subtype_Bounds
+ (Def : Iir_Array_Subtype_Definition)
+ return O_Cnode
+ is
+ Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def);
+ Baseinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def));
+ Index : Iir;
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Start_Record_Aggr (List, Baseinfo.T.Bounds_Type);
+ for I in Natural loop
+ Index := Get_Index_Type (Indexes_List, I);
+ exit when Index = Null_Iir;
+ New_Record_Aggr_El
+ (List, Create_Static_Type_Definition_Type_Range (Index));
+ end loop;
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Create_Static_Array_Subtype_Bounds;
+
+ procedure Create_Array_Subtype_Bounds
+ (Def : Iir_Array_Subtype_Definition; Target : O_Lnode)
+ is
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ Baseinfo : constant Type_Info_Acc := Get_Info (Base_Type);
+ Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def);
+ Indexes_Def_List : constant Iir_List :=
+ Get_Index_Subtype_Definition_List (Base_Type);
+ Index : Iir;
+ Targ : Mnode;
+ begin
+ Targ := Lv2M (Target, True,
+ Baseinfo.T.Bounds_Type,
+ Baseinfo.T.Bounds_Ptr_Type,
+ null, Mode_Value);
+ Open_Temp;
+ if Get_Nbr_Elements (Indexes_List) > 1 then
+ Targ := Stabilize (Targ);
+ end if;
+ for I in Natural loop
+ Index := Get_Index_Type (Indexes_List, I);
+ exit when Index = Null_Iir;
+ declare
+ Index_Type : constant Iir := Get_Base_Type (Index);
+ Index_Info : constant Type_Info_Acc := Get_Info (Index_Type);
+ Base_Index_Info : constant Index_Info_Acc :=
+ Get_Info (Get_Nth_Element (Indexes_Def_List, I));
+ D : O_Dnode;
+ begin
+ Open_Temp;
+ D := Create_Temp_Ptr
+ (Index_Info.T.Range_Ptr_Type,
+ New_Selected_Element (M2Lv (Targ),
+ Base_Index_Info.Index_Field));
+ Chap7.Translate_Discrete_Range_Ptr (D, Index);
+ Close_Temp;
+ end;
+ end loop;
+ Close_Temp;
+ end Create_Array_Subtype_Bounds;
+
+ -- Get staticness of the array bounds.
+ function Get_Array_Bounds_Staticness (Def : Iir) return Iir_Staticness
+ is
+ List : constant Iir_List := Get_Index_Subtype_List (Def);
+ Idx_Type : Iir;
+ begin
+ for I in Natural loop
+ Idx_Type := Get_Index_Type (List, I);
+ exit when Idx_Type = Null_Iir;
+ if Get_Type_Staticness (Idx_Type) /= Locally then
+ return Globally;
+ end if;
+ end loop;
+ return Locally;
+ end Get_Array_Bounds_Staticness;
+
+ -- Create a variable containing the bounds for array subtype DEF.
+ procedure Create_Array_Subtype_Bounds_Var
+ (Def : Iir; Elab_Now : Boolean)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Base_Info : Type_Info_Acc;
+ Val : O_Cnode;
+ begin
+ if Info.T.Array_Bounds /= Null_Var then
+ return;
+ end if;
+ Base_Info := Get_Info (Get_Base_Type (Def));
+ case Get_Array_Bounds_Staticness (Def) is
+ when None
+ | Globally =>
+ Info.T.Static_Bounds := False;
+ Info.T.Array_Bounds := Create_Var
+ (Create_Var_Identifier ("STB"), Base_Info.T.Bounds_Type);
+ if Elab_Now then
+ Create_Array_Subtype_Bounds
+ (Def, Get_Var (Info.T.Array_Bounds));
+ end if;
+ when Locally =>
+ Info.T.Static_Bounds := True;
+ if Global_Storage = O_Storage_External then
+ -- Do not create the value of the type desc, since it
+ -- is never dereferenced in a static type desc.
+ Val := O_Cnode_Null;
+ else
+ Val := Create_Static_Array_Subtype_Bounds (Def);
+ end if;
+ Info.T.Array_Bounds := Create_Global_Const
+ (Create_Identifier ("STB"),
+ Base_Info.T.Bounds_Type, Global_Storage, Val);
+
+ when Unknown =>
+ raise Internal_Error;
+ end case;
+ end Create_Array_Subtype_Bounds_Var;
+
+ procedure Create_Array_Type_Builder
+ (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param;
+ Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param;
+ Var_Off : O_Dnode;
+ Var_Mem : O_Dnode;
+ Var_Length : O_Dnode;
+ El_Type : Iir;
+ El_Info : Type_Info_Acc;
+ Label : O_Snode;
+ begin
+ Start_Subprogram_Body (Info.C (Kind).Builder_Func);
+ Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+
+ -- Compute length of the array.
+ New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local,
+ Ghdl_Index_Type);
+ New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local,
+ Info.T.Base_Ptr_Type (Kind));
+ New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local,
+ Ghdl_Index_Type);
+
+ El_Type := Get_Element_Subtype (Def);
+ El_Info := Get_Info (El_Type);
+
+ New_Assign_Stmt
+ (New_Obj (Var_Length),
+ New_Dyadic_Op (ON_Mul_Ov,
+ New_Value (Get_Var (El_Info.C (Kind).Size_Var)),
+ Get_Bounds_Length (Dp2M (Bound, Info,
+ Mode_Value,
+ Info.T.Bounds_Type,
+ Info.T.Bounds_Ptr_Type),
+ Def)));
+
+ -- Find the innermost non-array element.
+ while El_Info.Type_Mode = Type_Mode_Array loop
+ El_Type := Get_Element_Subtype (El_Type);
+ El_Info := Get_Info (El_Type);
+ end loop;
+
+ -- Set each index of the array.
+ Init_Var (Var_Off);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Off),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+
+ New_Assign_Stmt
+ (New_Obj (Var_Mem),
+ New_Unchecked_Address
+ (New_Slice (New_Access_Element
+ (New_Convert_Ov (New_Obj_Value (Base),
+ Char_Ptr_Type)),
+ Chararray_Type,
+ New_Obj_Value (Var_Off)),
+ Info.T.Base_Ptr_Type (Kind)));
+
+ New_Assign_Stmt
+ (New_Obj (Var_Off),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Off),
+ Gen_Call_Type_Builder (Var_Mem, El_Type, Kind)));
+ Finish_Loop_Stmt (Label);
+
+ New_Return_Stmt (New_Obj_Value (Var_Off));
+
+ Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+ Finish_Subprogram_Body;
+ end Create_Array_Type_Builder;
+
+ --------------
+ -- record --
+ --------------
+
+ -- Get the alignment mask for *ortho* type ATYPE.
+ function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is
+ begin
+ return New_Dyadic_Op
+ (ON_Sub_Ov,
+ New_Lit (New_Alignof (Atype, Ghdl_Index_Type)),
+ New_Lit (Ghdl_Index_1));
+ end Get_Type_Alignmask;
+
+ -- Get the alignment mask for type INFO (Mode_Value).
+ function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is
+ begin
+ if Is_Complex_Type (Info) then
+ if Info.Type_Mode /= Type_Mode_Record then
+ raise Internal_Error;
+ end if;
+ return New_Value (Get_Var (Info.C (Mode_Value).Align_Var));
+ else
+ return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value));
+ end if;
+ end Get_Type_Alignmask;
+
+ -- Align VALUE (of unsigned type) for type ATYPE.
+ -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the
+ -- alignment for ATYPE in bytes.
+ function Realign (Value : O_Enode; Atype : Iir) return O_Enode
+ is
+ Tinfo : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ return New_Dyadic_Op
+ (ON_And,
+ New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Tinfo)),
+ New_Monadic_Op (ON_Not, Get_Type_Alignmask (Tinfo)));
+ end Realign;
+
+ function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is
+ begin
+ return New_Dyadic_Op
+ (ON_And,
+ New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)),
+ New_Monadic_Op (ON_Not, New_Obj_Value (Mask)));
+ end Realign;
+
+ -- Find the innermost non-array element.
+ function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir
+ is
+ Res : Iir := Atype;
+ begin
+ while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop
+ Res := Get_Element_Subtype (Res);
+ end loop;
+ return Res;
+ end Get_Innermost_Non_Array_Element;
+
+ procedure Translate_Record_Type (Def : Iir_Record_Type_Definition)
+ is
+ El_List : O_Element_List;
+ List : Iir_List;
+ El : Iir_Element_Declaration;
+ Info : Type_Info_Acc;
+ Field_Info : Ortho_Info_Acc;
+ El_Type : Iir;
+ El_Tinfo : Type_Info_Acc;
+ El_Tnode : O_Tnode;
+
+ -- True if a size variable will be created since the size of
+ -- the record is not known at compile-time.
+ Need_Size : Boolean;
+
+ Mark : Id_Mark_Type;
+ begin
+ Info := Get_Info (Def);
+ Need_Size := False;
+ List := Get_Elements_Declaration_List (Def);
+
+ -- First, translate the anonymous type of the elements.
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ El_Type := Get_Type (El);
+ if Get_Info (El_Type) = null then
+ Push_Identifier_Prefix (Mark, Get_Identifier (El));
+ Translate_Type_Definition (El_Type);
+ Pop_Identifier_Prefix (Mark);
+ end if;
+ if not Need_Size and then Is_Complex_Type (Get_Info (El_Type)) then
+ Need_Size := True;
+ end if;
+ Field_Info := Add_Info (El, Kind_Field);
+ end loop;
+
+ -- Then create the record type.
+ Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ Start_Record_Type (El_List);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Field_Info := Get_Info (El);
+ El_Tinfo := Get_Info (Get_Type (El));
+ if Is_Complex_Type (El_Tinfo) then
+ -- Always use an offset for a complex type.
+ El_Tnode := Ghdl_Index_Type;
+ else
+ El_Tnode := El_Tinfo.Ortho_Type (Kind);
+ end if;
+
+ New_Record_Field (El_List, Field_Info.Field_Node (Kind),
+ Create_Identifier_Without_Prefix (El),
+ El_Tnode);
+ end loop;
+ Finish_Record_Type (El_List, Info.Ortho_Type (Kind));
+ end loop;
+ Info.Type_Mode := Type_Mode_Record;
+ Finish_Type_Definition (Info);
+
+ if Need_Size then
+ Create_Size_Var (Def);
+ Info.C (Mode_Value).Align_Var := Create_Var
+ (Create_Var_Identifier ("ALIGNMSK"), Ghdl_Index_Type);
+ Info.C (Mode_Value).Builder_Need_Func := True;
+ Info.C (Mode_Signal).Builder_Need_Func := True;
+ end if;
+ end Translate_Record_Type;
+
+ procedure Create_Record_Type_Builder
+ (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param;
+ List : Iir_List;
+ El : Iir_Element_Declaration;
+
+ Off_Var : O_Dnode;
+ Ptr_Var : O_Dnode;
+ Off_Val : O_Enode;
+ El_Type : Iir;
+ Inner_Type : Iir;
+ El_Tinfo : Type_Info_Acc;
+ begin
+ Start_Subprogram_Body (Info.C (Kind).Builder_Func);
+ Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+
+ New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local,
+ Ghdl_Index_Type);
+
+ -- Reserve memory for the record, ie:
+ -- OFF = SIZEOF (record).
+ New_Assign_Stmt
+ (New_Obj (Off_Var),
+ New_Lit (New_Sizeof (Info.Ortho_Type (Kind),
+ Ghdl_Index_Type)));
+
+ -- Set memory for each complex element.
+ List := Get_Elements_Declaration_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ El_Type := Get_Type (El);
+ El_Tinfo := Get_Info (El_Type);
+ if Is_Complex_Type (El_Tinfo) then
+ -- Complex type.
+
+ -- Align on the innermost array element (which should be
+ -- a record) for Mode_Value. No need to align for signals,
+ -- as all non-composite elements are accesses.
+ Inner_Type := Get_Innermost_Non_Array_Element (El_Type);
+ Off_Val := New_Obj_Value (Off_Var);
+ if Kind = Mode_Value then
+ Off_Val := Realign (Off_Val, Inner_Type);
+ end if;
+ New_Assign_Stmt (New_Obj (Off_Var), Off_Val);
+
+ -- Set the offset.
+ New_Assign_Stmt
+ (New_Selected_Element (New_Acc_Value (New_Obj (Base)),
+ Get_Info (El).Field_Node (Kind)),
+ New_Obj_Value (Off_Var));
+
+ if El_Tinfo.C (Kind).Builder_Need_Func then
+ -- This type needs a builder, call it.
+ Start_Declare_Stmt;
+ New_Var_Decl
+ (Ptr_Var, Get_Identifier ("var_ptr"),
+ O_Storage_Local, El_Tinfo.Ortho_Ptr_Type (Kind));
+
+ New_Assign_Stmt
+ (New_Obj (Ptr_Var),
+ M2E (Chap6.Translate_Selected_Element
+ (Dp2M (Base, Info, Kind), El)));
+
+ New_Assign_Stmt
+ (New_Obj (Off_Var),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Off_Var),
+ Gen_Call_Type_Builder
+ (Ptr_Var, El_Type, Kind)));
+
+ Finish_Declare_Stmt;
+ else
+ -- Allocate memory.
+ New_Assign_Stmt
+ (New_Obj (Off_Var),
+ New_Dyadic_Op
+ (ON_Add_Ov,
+ New_Obj_Value (Off_Var),
+ New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var))));
+ end if;
+ end if;
+ end loop;
+ New_Return_Stmt (New_Value (Get_Var (Info.C (Kind).Size_Var)));
+ Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+ Finish_Subprogram_Body;
+ end Create_Record_Type_Builder;
+
+ --------------
+ -- Access --
+ --------------
+ procedure Translate_Access_Type (Def : Iir_Access_Type_Definition)
+ is
+ D_Type : constant Iir := Get_Designated_Type (Def);
+ D_Info : constant Ortho_Info_Acc := Get_Info (D_Type);
+ Def_Info : constant Type_Info_Acc := Get_Info (Def);
+ Dtype : O_Tnode;
+ Arr_Info : Type_Info_Acc;
+ begin
+ if not Is_Fully_Constrained_Type (D_Type) then
+ -- An access type to an unconstrained type definition is a fat
+ -- pointer.
+ Def_Info.Type_Mode := Type_Mode_Fat_Acc;
+ if D_Info.Kind = Kind_Incomplete_Type then
+ Translate_Incomplete_Array_Type (D_Type);
+ Arr_Info := D_Info.Incomplete_Array;
+ Def_Info.Ortho_Type := Arr_Info.Ortho_Type;
+ Def_Info.T := Arr_Info.T;
+ else
+ Def_Info.Ortho_Type := D_Info.Ortho_Type;
+ Def_Info.T := D_Info.T;
+ end if;
+ Def_Info.Ortho_Ptr_Type (Mode_Value) :=
+ New_Access_Type (Def_Info.Ortho_Type (Mode_Value));
+ New_Type_Decl (Create_Identifier ("PTR"),
+ Def_Info.Ortho_Ptr_Type (Mode_Value));
+ else
+ -- Otherwise, it is a thin pointer.
+ Def_Info.Type_Mode := Type_Mode_Acc;
+ -- No access types for signals.
+ Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+
+ if D_Info.Kind = Kind_Incomplete_Type then
+ Dtype := O_Tnode_Null;
+ elsif Is_Complex_Type (D_Info) then
+ -- FIXME: clean here when the ortho_type of a array
+ -- complex_type is correctly set (not a pointer).
+ Def_Info.Ortho_Type (Mode_Value) :=
+ D_Info.Ortho_Ptr_Type (Mode_Value);
+ Finish_Type_Definition (Def_Info, True);
+ return;
+ elsif D_Info.Type_Mode in Type_Mode_Arrays then
+ -- The designated type cannot be a sub array inside ortho.
+ -- FIXME: lift this restriction.
+ Dtype := D_Info.T.Base_Type (Mode_Value);
+ else
+ Dtype := D_Info.Ortho_Type (Mode_Value);
+ end if;
+ Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype);
+ Finish_Type_Definition (Def_Info);
+ end if;
+ end Translate_Access_Type;
+
+ ------------------------
+ -- Incomplete types --
+ ------------------------
+ procedure Translate_Incomplete_Type (Def : Iir)
+ is
+-- Ftype : Iir;
+-- Info : Type_Info_Acc;
+ Info : Incomplete_Type_Info_Acc;
+ Ctype : Iir;
+ begin
+ if Get_Nbr_Elements (Get_Incomplete_Type_List (Def)) = 0 then
+ -- FIXME:
+ -- This is a work-around for dummy incomplete type (ie incomplete
+ -- types not used before the full type declaration).
+ return;
+ end if;
+ Ctype := Get_Type (Get_Type_Declarator (Def));
+ Info := Add_Info (Ctype, Kind_Incomplete_Type);
+ Info.Incomplete_Type := Def;
+ Info.Incomplete_Array := null;
+ end Translate_Incomplete_Type;
+
+ -- CTYPE is the type which has been completed.
+ procedure Translate_Complete_Type
+ (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir)
+ is
+ List : Iir_List;
+ Atype : Iir;
+ Def_Info : Type_Info_Acc;
+ C_Info : Type_Info_Acc;
+ Dtype : O_Tnode;
+ begin
+ C_Info := Get_Info (Ctype);
+ List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type);
+ for I in Natural loop
+ Atype := Get_Nth_Element (List, I);
+ exit when Atype = Null_Iir;
+ if Get_Kind (Atype) /= Iir_Kind_Access_Type_Definition then
+ raise Internal_Error;
+ end if;
+ Def_Info := Get_Info (Atype);
+ case C_Info.Type_Mode is
+ when Type_Mode_Arrays =>
+ Dtype := C_Info.T.Base_Type (Mode_Value);
+ when others =>
+ Dtype := C_Info.Ortho_Type (Mode_Value);
+ end case;
+ Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype);
+ end loop;
+ Unchecked_Deallocation (Incomplete_Info);
+ end Translate_Complete_Type;
+
+ -----------------
+ -- protected --
+ -----------------
+
+ procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Mark : Id_Mark_Type;
+ begin
+ New_Uncomplete_Record_Type (Info.Ortho_Type (Mode_Value));
+ New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value));
+
+ Info.Ortho_Ptr_Type (Mode_Value) :=
+ New_Access_Type (Info.Ortho_Type (Mode_Value));
+ New_Type_Decl (Create_Identifier ("PTR"),
+ Info.Ortho_Ptr_Type (Mode_Value));
+
+ Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+ Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null;
+
+ Info.Type_Mode := Type_Mode_Protected;
+
+ -- A protected type is a complex type, as its size is not known
+ -- at definition point (will be known at body declaration).
+ Info.C := new Complex_Type_Arr_Info;
+ Info.C (Mode_Value).Builder_Need_Func := False;
+
+ -- This is just use to set overload number on subprograms, and to
+ -- translate interfaces.
+ Push_Identifier_Prefix
+ (Mark, Get_Identifier (Get_Type_Declarator (Def)));
+ Chap4.Translate_Declaration_Chain (Def);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Protected_Type;
+
+ procedure Translate_Protected_Type_Subprograms
+ (Def : Iir_Protected_Type_Declaration)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ El : Iir;
+ Inter_List : O_Inter_List;
+ Mark : Id_Mark_Type;
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ Push_Identifier_Prefix
+ (Mark, Get_Identifier (Get_Type_Declarator (Def)));
+
+ -- Init.
+ Start_Function_Decl
+ (Inter_List, Create_Identifier ("INIT"), Global_Storage,
+ Info.Ortho_Ptr_Type (Mode_Value));
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Inter_List, Info.T.Prot_Init_Instance);
+ Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg);
+
+ -- Use the object as instance.
+ Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access,
+ Info.Ortho_Ptr_Type (Mode_Value),
+ Wki_Obj,
+ Prev_Subprg_Instance);
+
+ -- Final.
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier ("FINI"), Global_Storage);
+ Chap2.Add_Subprg_Instance_Interfaces
+ (Inter_List, Info.T.Prot_Final_Instance);
+ Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Subprg);
+
+ -- Methods.
+ El := Get_Declaration_Chain (Def);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- Translate only if used.
+ if Get_Info (El) /= null then
+ Chap2.Translate_Subprogram_Declaration (El);
+ end if;
+ when others =>
+ Error_Kind ("translate_protected_type_subprograms", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance);
+
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Protected_Type_Subprograms;
+
+ procedure Translate_Protected_Type_Body (Bod : Iir)
+ is
+ Decl : constant Iir_Protected_Type_Declaration :=
+ Get_Protected_Type_Declaration (Bod);
+ Info : constant Type_Info_Acc := Get_Info (Decl);
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Bod));
+
+ -- Create the object type
+ Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access);
+ -- First, the previous instance.
+ Chap2.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field);
+ -- Then the object lock
+ Info.T.Prot_Lock_Field := Add_Instance_Factory_Field
+ (Get_Identifier ("LOCK"), Ghdl_Ptr_Type);
+
+ -- Translate declarations.
+ Chap4.Translate_Declaration_Chain (Bod);
+
+ Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access);
+ Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope);
+
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Protected_Type_Body;
+
+ procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Type_Def);
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Proc);
+ New_Association
+ (Assoc,
+ New_Unchecked_Address
+ (New_Selected_Element
+ (Get_Instance_Ref (Info.T.Prot_Scope),
+ Info.T.Prot_Lock_Field),
+ Ghdl_Ptr_Type));
+ New_Procedure_Call (Assoc);
+ end Call_Ghdl_Protected_Procedure;
+
+ procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir)
+ is
+ Mark : Id_Mark_Type;
+ Decl : constant Iir := Get_Protected_Type_Declaration (Bod);
+ Info : constant Type_Info_Acc := Get_Info (Decl);
+ Final : Boolean;
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Bod));
+
+ -- Subprograms of BOD.
+ Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access,
+ Info.Ortho_Ptr_Type (Mode_Value),
+ Wki_Obj,
+ Prev_Subprg_Instance);
+ Chap2.Start_Prev_Subprg_Instance_Use_Via_Field
+ (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field);
+
+ Chap4.Translate_Declaration_Chain_Subprograms (Bod);
+
+ Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field
+ (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field);
+ Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance);
+
+ Pop_Identifier_Prefix (Mark);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ -- Init subprogram
+ declare
+ Var_Obj : O_Dnode;
+ begin
+ Start_Subprogram_Body (Info.T.Prot_Init_Subprg);
+ Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
+ New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local,
+ Info.Ortho_Ptr_Type (Mode_Value));
+
+ -- Allocate the object
+ New_Assign_Stmt
+ (New_Obj (Var_Obj),
+ Gen_Alloc (Alloc_System,
+ New_Lit (New_Sizeof (Info.Ortho_Type (Mode_Value),
+ Ghdl_Index_Type)),
+ Info.Ortho_Ptr_Type (Mode_Value)));
+
+ Chap2.Set_Subprg_Instance_Field
+ (Var_Obj, Info.T.Prot_Subprg_Instance_Field,
+ Info.T.Prot_Init_Instance);
+
+ Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj);
+
+ -- Create lock.
+ Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init);
+
+ -- Elaborate fields.
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Bod, Final);
+ Close_Temp;
+
+ Clear_Scope (Info.T.Prot_Scope);
+
+ New_Return_Stmt (New_Obj_Value (Var_Obj));
+ Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance);
+
+ Finish_Subprogram_Body;
+ end;
+
+ -- Fini subprogram
+ begin
+ Start_Subprogram_Body (Info.T.Prot_Final_Subprg);
+ Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
+
+ -- Deallocate fields.
+ if Final or True then
+ Chap4.Final_Declaration_Chain (Bod, True);
+ end if;
+
+ -- Destroy lock.
+ Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini);
+
+ Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance);
+ Finish_Subprogram_Body;
+ end;
+ end Translate_Protected_Type_Body_Subprograms;
+
+ ---------------
+ -- Scalars --
+ ---------------
+
+ -- Create a type_range structure.
+ procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode)
+ is
+ T_Info : Type_Info_Acc;
+ Base_Type : Iir;
+ Expr : Iir;
+ V : O_Dnode;
+ begin
+ Base_Type := Get_Base_Type (Def);
+ T_Info := Get_Info (Base_Type);
+ Expr := Get_Range_Constraint (Def);
+ Open_Temp;
+ V := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, Target);
+ Chap7.Translate_Range_Ptr (V, Expr, Def);
+ Close_Temp;
+ end Create_Scalar_Type_Range;
+
+ function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is
+ begin
+ return Chap7.Translate_Static_Range (Get_Range_Constraint (Def),
+ Get_Base_Type (Def));
+ end Create_Static_Scalar_Type_Range;
+
+ procedure Create_Scalar_Type_Range_Type
+ (Def : Iir; With_Length : Boolean)
+ is
+ Constr : O_Element_List;
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Get_Info (Def);
+ Start_Record_Type (Constr);
+ New_Record_Field
+ (Constr, Info.T.Range_Left, Wki_Left,
+ Info.Ortho_Type (Mode_Value));
+ New_Record_Field
+ (Constr, Info.T.Range_Right, Wki_Right,
+ Info.Ortho_Type (Mode_Value));
+ New_Record_Field
+ (Constr, Info.T.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node);
+ if With_Length then
+ New_Record_Field
+ (Constr, Info.T.Range_Length, Wki_Length, Ghdl_Index_Type);
+ else
+ Info.T.Range_Length := O_Fnode_Null;
+ end if;
+ Finish_Record_Type (Constr, Info.T.Range_Type);
+ New_Type_Decl (Create_Identifier ("TRT"), Info.T.Range_Type);
+ Info.T.Range_Ptr_Type := New_Access_Type (Info.T.Range_Type);
+ New_Type_Decl (Create_Identifier ("TRPTR"),
+ Info.T.Range_Ptr_Type);
+ end Create_Scalar_Type_Range_Type;
+
+ function Create_Static_Type_Definition_Type_Range (Def : Iir)
+ return O_Cnode
+ is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kinds_Scalar_Subtype_Definition =>
+ return Create_Static_Scalar_Type_Range (Def);
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ return Create_Static_Array_Subtype_Bounds (Def);
+
+ when Iir_Kind_Array_Type_Definition =>
+ return O_Cnode_Null;
+
+ when others =>
+ Error_Kind ("create_static_type_definition_type_range", Def);
+ end case;
+ end Create_Static_Type_Definition_Type_Range;
+
+ procedure Create_Type_Definition_Type_Range (Def : Iir)
+ is
+ Target : O_Lnode;
+ Info : Type_Info_Acc;
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kinds_Scalar_Subtype_Definition =>
+ Target := Get_Var (Get_Info (Def).T.Range_Var);
+ Create_Scalar_Type_Range (Def, Target);
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ if Get_Constraint_State (Def) = Fully_Constrained then
+ Info := Get_Info (Def);
+ if not Info.T.Static_Bounds then
+ Target := Get_Var (Info.T.Array_Bounds);
+ Create_Array_Subtype_Bounds (Def, Target);
+ end if;
+ end if;
+
+ when Iir_Kind_Array_Type_Definition =>
+ declare
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (Def);
+ Index : Iir;
+ begin
+ for I in Natural loop
+ Index := Get_Index_Type (Index_List, I);
+ exit when Index = Null_Iir;
+ if Is_Anonymous_Type_Definition (Index) then
+ Create_Type_Definition_Type_Range (Index);
+ end if;
+ end loop;
+ end;
+ Translate_Dynamic_Unidimensional_Array_Length_One (Def);
+ return;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Protected_Type_Declaration =>
+ return;
+
+ when others =>
+ Error_Kind ("create_type_definition_type_range", Def);
+ end case;
+ end Create_Type_Definition_Type_Range;
+
+ -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low
+ -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of
+ -- DEF.
+ function Is_Equal_Limit (Lit : Iir;
+ Is_Hi : Boolean;
+ Def : Iir;
+ Mode : Type_Mode_Type) return Boolean
+ is
+ begin
+ case Mode is
+ when Type_Mode_B1 =>
+ declare
+ V : Iir_Int32;
+ begin
+ V := Iir_Int32 (Eval_Pos (Lit));
+ if Is_Hi then
+ return V = 1;
+ else
+ return V = 0;
+ end if;
+ end;
+ when Type_Mode_E8 =>
+ declare
+ V : Iir_Int32;
+ Base_Type : Iir;
+ begin
+ V := Iir_Int32 (Eval_Pos (Lit));
+ if Is_Hi then
+ Base_Type := Get_Base_Type (Def);
+ return V = Iir_Int32
+ (Get_Nbr_Elements
+ (Get_Enumeration_Literal_List (Base_Type))) - 1;
+ else
+ return V = 0;
+ end if;
+ end;
+ when Type_Mode_I32 =>
+ declare
+ V : Iir_Int32;
+ begin
+ V := Iir_Int32 (Get_Value (Lit));
+ if Is_Hi then
+ return V = Iir_Int32'Last;
+ else
+ return V = Iir_Int32'First;
+ end if;
+ end;
+ when Type_Mode_P32 =>
+ declare
+ V : Iir_Int32;
+ begin
+ V := Iir_Int32 (Get_Physical_Value (Lit));
+ if Is_Hi then
+ return V = Iir_Int32'Last;
+ else
+ return V = Iir_Int32'First;
+ end if;
+ end;
+ when Type_Mode_I64 =>
+ declare
+ V : Iir_Int64;
+ begin
+ V := Get_Value (Lit);
+ if Is_Hi then
+ return V = Iir_Int64'Last;
+ else
+ return V = Iir_Int64'First;
+ end if;
+ end;
+ when Type_Mode_P64 =>
+ declare
+ V : Iir_Int64;
+ begin
+ V := Get_Physical_Value (Lit);
+ if Is_Hi then
+ return V = Iir_Int64'Last;
+ else
+ return V = Iir_Int64'First;
+ end if;
+ end;
+ when Type_Mode_F64 =>
+ declare
+ V : Iir_Fp64;
+ begin
+ V := Get_Fp_Value (Lit);
+ if Is_Hi then
+ return V = Iir_Fp64'Last;
+ else
+ return V = Iir_Fp64'First;
+ end if;
+ end;
+ when others =>
+ Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode),
+ Lit);
+ end case;
+ end Is_Equal_Limit;
+
+ -- For scalar subtypes: creates info from the base type.
+ procedure Create_Subtype_Info_From_Type (Def : Iir;
+ Subtype_Info : Type_Info_Acc;
+ Base_Info : Type_Info_Acc)
+ is
+ Rng : Iir;
+ Lo, Hi : Iir;
+ begin
+ Subtype_Info.Ortho_Type := Base_Info.Ortho_Type;
+ Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type;
+ Subtype_Info.Type_Mode := Base_Info.Type_Mode;
+ Subtype_Info.T := Base_Info.T;
+
+ Rng := Get_Range_Constraint (Def);
+ if Get_Expr_Staticness (Rng) /= Locally then
+ -- Bounds are not known.
+ -- Do the checks.
+ Subtype_Info.T.Nocheck_Hi := False;
+ Subtype_Info.T.Nocheck_Low := False;
+ else
+ -- Bounds are locally static.
+ Get_Low_High_Limit (Rng, Lo, Hi);
+ Subtype_Info.T.Nocheck_Hi :=
+ Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode);
+ Subtype_Info.T.Nocheck_Low :=
+ Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode);
+ end if;
+ end Create_Subtype_Info_From_Type;
+
+ procedure Create_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ List : constant Iir_List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Def));
+ El : Iir_Element_Declaration;
+ El_Type : Iir;
+ El_Tinfo : Type_Info_Acc;
+ Inner_Type : Iir;
+ Inner_Tinfo : Type_Info_Acc;
+ Res : O_Enode;
+ Align_Var : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Open_Temp;
+
+ -- Start with the size of the 'base' record, that
+ -- contains all non-complex types and an offset for
+ -- each complex types.
+ Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type));
+
+ -- Start with alignment of the record.
+ -- ALIGN = ALIGNOF (record)
+ if Kind = Mode_Value then
+ Align_Var := Create_Temp (Ghdl_Index_Type);
+ New_Assign_Stmt
+ (New_Obj (Align_Var),
+ Get_Type_Alignmask (Info.Ortho_Type (Kind)));
+ end if;
+
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ El_Type := Get_Type (El);
+ El_Tinfo := Get_Info (El_Type);
+ if Is_Complex_Type (El_Tinfo) then
+ Inner_Type := Get_Innermost_Non_Array_Element (El_Type);
+
+ -- Align (only for Mode_Value) the size,
+ -- and add the size of the element.
+ if Kind = Mode_Value then
+ Inner_Tinfo := Get_Info (Inner_Type);
+ -- If alignmask (Inner_Type) > alignmask then
+ -- alignmask = alignmask (Inner_type);
+ -- end if;
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Gt,
+ Get_Type_Alignmask (Inner_Tinfo),
+ New_Obj_Value (Align_Var),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Obj (Align_Var), Get_Type_Alignmask (Inner_Tinfo));
+ Finish_If_Stmt (If_Blk);
+ Res := Realign (Res, Inner_Type);
+ end if;
+ Res := New_Dyadic_Op
+ (ON_Add_Ov,
+ New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)),
+ Res);
+ end if;
+ end loop;
+ if Kind = Mode_Value then
+ Res := Realign (Res, Align_Var);
+ end if;
+ New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res);
+ Close_Temp;
+ end Create_Record_Size_Var;
+
+ procedure Create_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ El_Type : constant Iir := Get_Element_Subtype (Def);
+ Res : O_Enode;
+ begin
+ Res := New_Dyadic_Op
+ (ON_Mul_Ov,
+ Get_Array_Type_Length (Def),
+ Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type));
+ New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res);
+ end Create_Array_Size_Var;
+
+ procedure Create_Type_Definition_Size_Var (Def : Iir)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ begin
+ if not Is_Complex_Type (Info) then
+ return;
+ end if;
+
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ if Info.C (Kind).Size_Var /= Null_Var then
+ case Info.Type_Mode is
+ when Type_Mode_Non_Composite
+ | Type_Mode_Fat_Array
+ | Type_Mode_Unknown
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ when Type_Mode_Record =>
+ Create_Record_Size_Var (Def, Kind);
+ when Type_Mode_Array =>
+ Create_Array_Size_Var (Def, Kind);
+ end case;
+ end if;
+ end loop;
+ end Create_Type_Definition_Size_Var;
+
+ procedure Create_Type_Range_Var (Def : Iir)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Base_Info : Type_Info_Acc;
+ Val : O_Cnode;
+ Suffix : String (1 .. 3) := "xTR";
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kinds_Subtype_Definition =>
+ Suffix (1) := 'S'; -- "STR";
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Suffix (1) := 'B'; -- "BTR";
+ when others =>
+ raise Internal_Error;
+ end case;
+ Base_Info := Get_Info (Get_Base_Type (Def));
+ case Get_Type_Staticness (Def) is
+ when None
+ | Globally =>
+ Info.T.Range_Var := Create_Var
+ (Create_Var_Identifier (Suffix), Base_Info.T.Range_Type);
+ when Locally =>
+ if Global_Storage = O_Storage_External then
+ -- Do not create the value of the type desc, since it
+ -- is never dereferenced in a static type desc.
+ Val := O_Cnode_Null;
+ else
+ Val := Create_Static_Type_Definition_Type_Range (Def);
+ end if;
+ Info.T.Range_Var := Create_Global_Const
+ (Create_Identifier (Suffix),
+ Base_Info.T.Range_Type, Global_Storage, Val);
+ when Unknown =>
+ raise Internal_Error;
+ end case;
+ end Create_Type_Range_Var;
+
+
+ -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF
+ -- (of course, this is a noop if DEF is not a composite type).
+ generic
+ with procedure Handle_A_Subtype (Atype : Iir);
+ procedure Handle_Anonymous_Subtypes (Def : Iir);
+
+ procedure Handle_Anonymous_Subtypes (Def : Iir) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Asub : Iir;
+ begin
+ Asub := Get_Element_Subtype (Def);
+ if Is_Anonymous_Type_Definition (Asub) then
+ Handle_A_Subtype (Asub);
+ end if;
+ end;
+ when Iir_Kind_Record_Type_Definition =>
+ declare
+ El : Iir;
+ Asub : Iir;
+ List : Iir_List;
+ begin
+ List := Get_Elements_Declaration_List (Def);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Asub := Get_Type (El);
+ if Is_Anonymous_Type_Definition (Asub) then
+ Handle_A_Subtype (Asub);
+ end if;
+ end loop;
+ end;
+ when others =>
+ null;
+ end case;
+ end Handle_Anonymous_Subtypes;
+
+ -- Note: boolean types are translated by translate_bool_type_definition!
+ procedure Translate_Type_Definition
+ (Def : Iir; With_Vars : Boolean := True)
+ is
+ Info : Ortho_Info_Acc;
+ Base_Info : Type_Info_Acc;
+ Base_Type : Iir;
+ Complete_Info : Incomplete_Type_Info_Acc;
+ begin
+ -- Handle the special case of incomplete type.
+ if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then
+ Translate_Incomplete_Type (Def);
+ return;
+ end if;
+
+ -- If the definition is already translated, return now.
+ Info := Get_Info (Def);
+ if Info /= null then
+ if Info.Kind = Kind_Type then
+ -- The subtype was already translated.
+ return;
+ end if;
+ if Info.Kind = Kind_Incomplete_Type then
+ -- Type is being completed.
+ Complete_Info := Info;
+ Clear_Info (Def);
+ if Complete_Info.Incomplete_Array /= null then
+ Info := Complete_Info.Incomplete_Array;
+ Set_Info (Def, Info);
+ Unchecked_Deallocation (Complete_Info);
+ else
+ Info := Add_Info (Def, Kind_Type);
+ end if;
+ else
+ raise Internal_Error;
+ end if;
+ else
+ Complete_Info := null;
+ Info := Add_Info (Def, Kind_Type);
+ end if;
+
+ Base_Type := Get_Base_Type (Def);
+ Base_Info := Get_Info (Base_Type);
+
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Translate_Enumeration_Type (Def);
+ Create_Scalar_Type_Range_Type (Def, True);
+ Create_Type_Range_Var (Def);
+ --Create_Type_Desc_Var (Def);
+
+ when Iir_Kind_Integer_Type_Definition =>
+ Translate_Integer_Type (Def);
+ Create_Scalar_Type_Range_Type (Def, True);
+
+ when Iir_Kind_Physical_Type_Definition =>
+ Translate_Physical_Type (Def);
+ Create_Scalar_Type_Range_Type (Def, False);
+ if With_Vars and Get_Type_Staticness (Def) /= Locally then
+ Translate_Physical_Units (Def);
+ else
+ Info.T.Range_Var := Null_Var;
+ end if;
+
+ when Iir_Kind_Floating_Type_Definition =>
+ Translate_Floating_Type (Def);
+ Create_Scalar_Type_Range_Type (Def, False);
+
+ when Iir_Kinds_Scalar_Subtype_Definition =>
+ Create_Subtype_Info_From_Type (Def, Info, Base_Info);
+ if With_Vars then
+ Create_Type_Range_Var (Def);
+ else
+ Info.T.Range_Var := Null_Var;
+ end if;
+
+ when Iir_Kind_Array_Type_Definition =>
+ declare
+ El_Type : Iir;
+ Mark : Id_Mark_Type;
+ begin
+ El_Type := Get_Element_Subtype (Def);
+ if Get_Info (El_Type) = null then
+ Push_Identifier_Prefix (Mark, "ET");
+ Translate_Type_Definition (El_Type);
+ Pop_Identifier_Prefix (Mark);
+ end if;
+ end;
+ Translate_Array_Type_Definition (Def);
+
+ when Iir_Kind_Array_Subtype_Definition =>
+ if Get_Index_Constraint_Flag (Def) then
+ if Base_Info = null or else Base_Info.Type_Incomplete then
+ declare
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, "BT");
+ Translate_Type_Definition (Base_Type);
+ Pop_Identifier_Prefix (Mark);
+ Base_Info := Get_Info (Base_Type);
+ end;
+ end if;
+ Translate_Array_Subtype_Definition (Def);
+ Info.T := Base_Info.T;
+ --Info.Type_Range_Type := Base_Info.Type_Range_Type;
+ if With_Vars then
+ Create_Array_Subtype_Bounds_Var (Def, False);
+ end if;
+ else
+ -- An unconstrained array subtype. Use same infos as base
+ -- type.
+ Free_Info (Def);
+ Set_Info (Def, Base_Info);
+ end if;
+ Translate_Array_Subtype_Element_Subtype (Def);
+
+ when Iir_Kind_Record_Type_Definition =>
+ Translate_Record_Type (Def);
+ Info.T := Ortho_Info_Type_Record_Init;
+
+ when Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ Free_Info (Def);
+ Set_Info (Def, Base_Info);
+
+ when Iir_Kind_Access_Type_Definition =>
+ declare
+ Dtype : constant Iir := Get_Designated_Type (Def);
+ begin
+ -- Translate the subtype
+ if Is_Anonymous_Type_Definition (Dtype) then
+ Translate_Type_Definition (Dtype);
+ end if;
+ Translate_Access_Type (Def);
+ end;
+
+ when Iir_Kind_File_Type_Definition =>
+ Translate_File_Type (Def);
+ Info.T := Ortho_Info_Type_File_Init;
+ if With_Vars then
+ Create_File_Type_Var (Def);
+ end if;
+
+ when Iir_Kind_Protected_Type_Declaration =>
+ Translate_Protected_Type (Def);
+ Info.T := Ortho_Info_Type_Prot_Init;
+
+ when others =>
+ Error_Kind ("translate_type_definition", Def);
+ end case;
+
+ if Complete_Info /= null then
+ Translate_Complete_Type (Complete_Info, Def);
+ end if;
+ end Translate_Type_Definition;
+
+ procedure Translate_Bool_Type_Definition (Def : Iir)
+ is
+ Info : Type_Info_Acc;
+ begin
+ -- If the definition is already translated, return now.
+ Info := Get_Info (Def);
+ if Info /= null then
+ raise Internal_Error;
+ end if;
+
+ Info := Add_Info (Def, Kind_Type);
+
+ if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then
+ raise Internal_Error;
+ end if;
+ Translate_Bool_Type (Def);
+
+ -- This is usually done in translate_type_definition, but boolean
+ -- types are not handled by translate_type_definition.
+ Create_Scalar_Type_Range_Type (Def, True);
+ end Translate_Bool_Type_Definition;
+
+ procedure Translate_Type_Subprograms (Decl : Iir)
+ is
+ Def : Iir;
+ Tinfo : Type_Info_Acc;
+ Id : Name_Id;
+ begin
+ Def := Get_Type_Definition (Decl);
+
+ if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then
+ -- Also elaborate the base type, iff DEF and its BASE_TYPE have
+ -- been declared by the same type declarator. This avoids several
+ -- elaboration of the same type.
+ Def := Get_Base_Type (Def);
+ if Get_Type_Declarator (Def) /= Decl then
+ -- Can this happen ??
+ raise Internal_Error;
+ end if;
+ elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then
+ return;
+ end if;
+
+ if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then
+ Translate_Protected_Type_Subprograms (Def);
+ end if;
+
+ Tinfo := Get_Info (Def);
+ if not Is_Complex_Type (Tinfo)
+ or else Tinfo.C (Mode_Value).Builder_Need_Func = False
+ then
+ return;
+ end if;
+
+ -- Declare subprograms.
+ Id := Get_Identifier (Decl);
+ Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value);
+ if Get_Has_Signal_Flag (Def) then
+ Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal);
+ end if;
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ -- Define subprograms.
+ case Get_Kind (Def) is
+ when Iir_Kind_Array_Type_Definition =>
+ Create_Array_Type_Builder (Def, Mode_Value);
+ if Get_Has_Signal_Flag (Def) then
+ Create_Array_Type_Builder (Def, Mode_Signal);
+ end if;
+ when Iir_Kind_Record_Type_Definition =>
+ Create_Record_Type_Builder (Def, Mode_Value);
+ if Get_Has_Signal_Flag (Def) then
+ Create_Record_Type_Builder (Def, Mode_Signal);
+ end if;
+ when others =>
+ Error_Kind ("translate_type_subprograms", Def);
+ end case;
+ end Translate_Type_Subprograms;
+
+ -- Initialize the objects related to a type (type range and type
+ -- descriptor).
+ procedure Elab_Type_Definition (Def : Iir);
+ procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes
+ (Handle_A_Subtype => Elab_Type_Definition);
+ procedure Elab_Type_Definition (Def : Iir) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Incomplete_Type_Definition =>
+ -- Nothing to do.
+ return;
+ when Iir_Kind_Protected_Type_Declaration =>
+ -- Elaboration subprograms interfaces.
+ declare
+ Final : Boolean;
+ begin
+ Chap4.Elab_Declaration_Chain (Def, Final);
+ if Final then
+ raise Internal_Error;
+ end if;
+ end;
+ return;
+ when others =>
+ null;
+ end case;
+
+ if Get_Type_Staticness (Def) = Locally then
+ return;
+ end if;
+
+ Elab_Type_Definition_Depend (Def);
+
+ Create_Type_Definition_Type_Range (Def);
+ Create_Type_Definition_Size_Var (Def);
+ end Elab_Type_Definition;
+
+ procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id)
+ is
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Id);
+ Chap3.Translate_Type_Definition (Def);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Named_Type_Definition;
+
+ procedure Translate_Anonymous_Type_Definition
+ (Def : Iir; Transient : Boolean)
+ is
+ Mark : Id_Mark_Type;
+ Type_Info : Type_Info_Acc;
+ begin
+ Type_Info := Get_Info (Def);
+ if Type_Info /= null then
+ return;
+ end if;
+ Push_Identifier_Prefix_Uniq (Mark);
+ Chap3.Translate_Type_Definition (Def, False);
+ if Transient then
+ Add_Transient_Type_In_Temp (Def);
+ end if;
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Anonymous_Type_Definition;
+
+ procedure Destroy_Type_Info (Atype : Iir)
+ is
+ Type_Info : Type_Info_Acc;
+ begin
+ Type_Info := Get_Info (Atype);
+ Free_Type_Info (Type_Info);
+ Clear_Info (Atype);
+ end Destroy_Type_Info;
+
+ procedure Translate_Object_Subtype (Decl : Iir;
+ With_Vars : Boolean := True)
+ is
+ Mark : Id_Mark_Type;
+ Mark2 : Id_Mark_Type;
+ Def : Iir;
+ begin
+ Def := Get_Type (Decl);
+ if Is_Anonymous_Type_Definition (Def) then
+ Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ Push_Identifier_Prefix (Mark2, "OT");
+ Chap3.Translate_Type_Definition (Def, With_Vars);
+ Pop_Identifier_Prefix (Mark2);
+ Pop_Identifier_Prefix (Mark);
+ end if;
+ end Translate_Object_Subtype;
+
+ procedure Elab_Object_Subtype (Def : Iir) is
+ begin
+ if Is_Anonymous_Type_Definition (Def) then
+ Elab_Type_Definition (Def);
+ end if;
+ end Elab_Object_Subtype;
+
+ procedure Elab_Type_Declaration (Decl : Iir)
+ is
+ begin
+ Elab_Type_Definition (Get_Type_Definition (Decl));
+ end Elab_Type_Declaration;
+
+ procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration)
+ is
+ begin
+ Elab_Type_Definition (Get_Type (Decl));
+ end Elab_Subtype_Declaration;
+
+ function Get_Thin_Array_Length (Atype : Iir) return O_Cnode
+ is
+ Indexes_List : constant Iir_List := Get_Index_Subtype_List (Atype);
+ Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List);
+ Index : Iir;
+ Val : Iir_Int64;
+ Rng : Iir;
+ begin
+ Val := 1;
+ for I in 0 .. Nbr_Dim - 1 loop
+ Index := Get_Index_Type (Indexes_List, I);
+ Rng := Get_Range_Constraint (Index);
+ Val := Val * Eval_Discrete_Range_Length (Rng);
+ end loop;
+ return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val));
+ end Get_Thin_Array_Length;
+
+ function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive)
+ return Mnode
+ is
+ Indexes_List : constant Iir_List :=
+ Get_Index_Subtype_Definition_List (Get_Base_Type (Atype));
+ Index_Type_Mark : constant Iir :=
+ Get_Nth_Element (Indexes_List, Dim - 1);
+ Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark);
+ Base_Index_Info : constant Index_Info_Acc :=
+ Get_Info (Index_Type_Mark);
+ Iinfo : constant Type_Info_Acc :=
+ Get_Info (Get_Base_Type (Index_Type));
+ begin
+ return Lv2M (New_Selected_Element (M2Lv (B),
+ Base_Index_Info.Index_Field),
+ Iinfo,
+ Get_Object_Kind (B),
+ Iinfo.T.Range_Type,
+ Iinfo.T.Range_Ptr_Type);
+ end Bounds_To_Range;
+
+ function Type_To_Range (Atype : Iir) return Mnode
+ is
+ Info : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ return Varv2M (Info.T.Range_Var, Info, Mode_Value,
+ Info.T.Range_Type, Info.T.Range_Ptr_Type);
+ end Type_To_Range;
+
+ function Range_To_Length (R : Mnode) return Mnode
+ is
+ Tinfo : constant Type_Info_Acc := Get_Type_Info (R);
+ begin
+ return Lv2M (New_Selected_Element (M2Lv (R),
+ Tinfo.T.Range_Length),
+ Tinfo,
+ Mode_Value);
+ end Range_To_Length;
+
+ function Range_To_Dir (R : Mnode) return Mnode
+ is
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Type_Info (R);
+ return Lv2M (New_Selected_Element (M2Lv (R),
+ Tinfo.T.Range_Dir),
+ Tinfo,
+ Mode_Value);
+ end Range_To_Dir;
+
+ function Range_To_Left (R : Mnode) return Mnode
+ is
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Type_Info (R);
+ return Lv2M (New_Selected_Element (M2Lv (R),
+ Tinfo.T.Range_Left),
+ Tinfo,
+ Mode_Value);
+ end Range_To_Left;
+
+ function Range_To_Right (R : Mnode) return Mnode
+ is
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Type_Info (R);
+ return Lv2M (New_Selected_Element (M2Lv (R),
+ Tinfo.T.Range_Right),
+ Tinfo,
+ Mode_Value);
+ end Range_To_Right;
+
+ function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode
+ is
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ raise Internal_Error;
+ when Type_Mode_Array =>
+ return Varv2M (Info.T.Array_Bounds,
+ Info, Mode_Value,
+ Info.T.Bounds_Type,
+ Info.T.Bounds_Ptr_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Array_Type_Bounds;
+
+ function Get_Array_Type_Bounds (Atype : Iir) return Mnode is
+ begin
+ return Get_Array_Type_Bounds (Get_Info (Atype));
+ end Get_Array_Type_Bounds;
+
+ function Get_Array_Bounds (Arr : Mnode) return Mnode
+ is
+ Info : constant Type_Info_Acc := Get_Type_Info (Arr);
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Array
+ | Type_Mode_Fat_Acc =>
+ declare
+ Kind : Object_Kind_Type;
+ begin
+ Kind := Get_Object_Kind (Arr);
+ return Lp2M
+ (New_Selected_Element (M2Lv (Arr),
+ Info.T.Bounds_Field (Kind)),
+ Info,
+ Mode_Value,
+ Info.T.Bounds_Type,
+ Info.T.Bounds_Ptr_Type);
+ end;
+ when Type_Mode_Array =>
+ return Get_Array_Type_Bounds (Info);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Array_Bounds;
+
+ function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive)
+ return Mnode is
+ begin
+ return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim);
+ end Get_Array_Range;
+
+ function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Atype);
+ Index_List : constant Iir_List := Get_Index_Subtype_List (Atype);
+ Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List);
+ Dim_Length : O_Enode;
+ Res : O_Enode;
+ Bounds_Stable : Mnode;
+ begin
+ if Type_Info.Type_Locally_Constrained then
+ return New_Lit (Get_Thin_Array_Length (Atype));
+ end if;
+
+ if Nbr_Dim > 1 then
+ Bounds_Stable := Stabilize (Bounds);
+ else
+ Bounds_Stable := Bounds;
+ end if;
+
+ for Dim in 1 .. Nbr_Dim loop
+ Dim_Length :=
+ M2E (Range_To_Length
+ (Bounds_To_Range (Bounds_Stable, Atype, Dim)));
+ if Dim = 1 then
+ Res := Dim_Length;
+ else
+ Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length);
+ end if;
+ end loop;
+ return Res;
+ end Get_Bounds_Length;
+
+ function Get_Array_Type_Length (Atype : Iir) return O_Enode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ if Type_Info.Type_Locally_Constrained then
+ return New_Lit (Get_Thin_Array_Length (Atype));
+ else
+ return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype);
+ end if;
+ end Get_Array_Type_Length;
+
+ function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ if Type_Info.Type_Locally_Constrained then
+ return New_Lit (Get_Thin_Array_Length (Atype));
+ else
+ return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype);
+ end if;
+ end Get_Array_Length;
+
+ function Get_Array_Base (Arr : Mnode) return Mnode
+ is
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Type_Info (Arr);
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Array
+ | Type_Mode_Fat_Acc =>
+ declare
+ Kind : Object_Kind_Type;
+ begin
+ Kind := Get_Object_Kind (Arr);
+ return Lp2M
+ (New_Selected_Element (M2Lv (Arr),
+ Info.T.Base_Field (Kind)),
+ Info,
+ Get_Object_Kind (Arr),
+ Info.T.Base_Type (Kind),
+ Info.T.Base_Ptr_Type (Kind));
+ end;
+ when Type_Mode_Array =>
+ return Arr;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Array_Base;
+
+ function Reindex_Complex_Array
+ (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc)
+ return Mnode
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Atype);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Base);
+ begin
+ pragma Assert (Is_Complex_Type (El_Tinfo));
+ return
+ E2M
+ (New_Unchecked_Address
+ (New_Slice
+ (New_Access_Element
+ (New_Convert_Ov (M2E (Base), Char_Ptr_Type)),
+ Chararray_Type,
+ New_Dyadic_Op (ON_Mul_Ov,
+ New_Value
+ (Get_Var (El_Tinfo.C (Kind).Size_Var)),
+ Index)),
+ El_Tinfo.Ortho_Ptr_Type (Kind)),
+ Res_Info, Kind);
+ end Reindex_Complex_Array;
+
+ function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode)
+ return Mnode
+ is
+ El_Type : constant Iir := Get_Element_Subtype (Atype);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Base);
+ begin
+ if Is_Complex_Type (El_Tinfo) then
+ return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo);
+ else
+ return Lv2M (New_Indexed_Element (M2Lv (Base), Index),
+ El_Tinfo, Kind);
+ end if;
+ end Index_Base;
+
+ function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode)
+ return Mnode
+ is
+ T_Info : constant Type_Info_Acc := Get_Info (Atype);
+ El_Type : constant Iir := Get_Element_Subtype (Atype);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Base);
+ begin
+ if Is_Complex_Type (El_Tinfo) then
+ return Reindex_Complex_Array (Base, Atype, Index, T_Info);
+ else
+ return Lv2M (New_Slice (M2Lv (Base),
+ T_Info.T.Base_Type (Kind),
+ Index),
+ False,
+ T_Info.T.Base_Type (Kind),
+ T_Info.T.Base_Ptr_Type (Kind),
+ T_Info, Kind);
+ end if;
+ end Slice_Base;
+
+ procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind;
+ Res : Mnode;
+ Arr_Type : Iir)
+ is
+ Dinfo : constant Type_Info_Acc :=
+ Get_Info (Get_Base_Type (Arr_Type));
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Res);
+ Length : O_Enode;
+ begin
+ -- Compute array size.
+ Length := Get_Object_Size (Res, Arr_Type);
+ -- Allocate the storage for the elements.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Res)),
+ Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind)));
+
+ if Is_Complex_Type (Dinfo)
+ and then Dinfo.C (Kind).Builder_Need_Func
+ then
+ Open_Temp;
+ -- Build the type.
+ Chap3.Gen_Call_Type_Builder (Res, Arr_Type);
+ Close_Temp;
+ end if;
+ end Allocate_Fat_Array_Base;
+
+ procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean)
+ is
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix_Uniq (Mark);
+ if Get_Info (Sub_Type) = null then
+ -- Minimal subtype creation.
+ Translate_Type_Definition (Sub_Type, False);
+ if Transient then
+ Add_Transient_Type_In_Temp (Sub_Type);
+ end if;
+ end if;
+ -- Force creation of variables.
+ Chap3.Create_Array_Subtype_Bounds_Var (Sub_Type, True);
+ Chap3.Create_Type_Definition_Size_Var (Sub_Type);
+ Pop_Identifier_Prefix (Mark);
+ end Create_Array_Subtype;
+
+ -- Copy SRC to DEST.
+ -- Both have the same type, OTYPE.
+ procedure Translate_Object_Copy (Dest : Mnode;
+ Src : O_Enode;
+ Obj_Type : Iir)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Obj_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Dest);
+ D : Mnode;
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Scalar
+ | Type_Mode_Acc
+ | Type_Mode_File =>
+ -- Scalar or thin pointer.
+ New_Assign_Stmt (M2Lv (Dest), Src);
+ when Type_Mode_Fat_Acc =>
+ -- a fat pointer.
+ D := Stabilize (Dest);
+ Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind)));
+ when Type_Mode_Fat_Array =>
+ -- a fat array.
+ D := Stabilize (Dest);
+ Gen_Memcpy (M2Addr (Get_Array_Base (D)),
+ M2Addr (Get_Array_Base (E2M (Src, Info, Kind))),
+ Get_Object_Size (D, Obj_Type));
+ when Type_Mode_Array
+ | Type_Mode_Record =>
+ D := Stabilize (Dest);
+ Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (D, Obj_Type));
+ when Type_Mode_Unknown
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Object_Copy;
+
+ function Get_Object_Size (Obj : Mnode; Obj_Type : Iir)
+ return O_Enode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Obj);
+ begin
+ if Is_Complex_Type (Type_Info)
+ and then Type_Info.C (Kind).Size_Var /= Null_Var
+ then
+ return New_Value (Get_Var (Type_Info.C (Kind).Size_Var));
+ end if;
+ case Type_Info.Type_Mode is
+ when Type_Mode_Non_Composite
+ | Type_Mode_Array
+ | Type_Mode_Record =>
+ return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind),
+ Ghdl_Index_Type));
+ when Type_Mode_Fat_Array =>
+ declare
+ El_Type : Iir;
+ El_Tinfo : Type_Info_Acc;
+ Obj_Bt : Iir;
+ Sz : O_Enode;
+ begin
+ Obj_Bt := Get_Base_Type (Obj_Type);
+ El_Type := Get_Element_Subtype (Obj_Bt);
+ El_Tinfo := Get_Info (El_Type);
+ -- See create_type_definition_size_var.
+ Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type);
+ if Is_Complex_Type (El_Tinfo) then
+ Sz := New_Dyadic_Op
+ (ON_Add_Ov,
+ Sz,
+ New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind),
+ Ghdl_Index_Type)));
+ end if;
+ return New_Dyadic_Op
+ (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz);
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Object_Size;
+
+ procedure Translate_Object_Allocation
+ (Res : in out Mnode;
+ Alloc_Kind : Allocation_Kind;
+ Obj_Type : Iir;
+ Bounds : Mnode)
+ is
+ Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Res);
+ begin
+ if Dinfo.Type_Mode = Type_Mode_Fat_Array then
+ -- Allocate memory for bounds.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ Gen_Alloc (Alloc_Kind,
+ New_Lit (New_Sizeof (Dinfo.T.Bounds_Type,
+ Ghdl_Index_Type)),
+ Dinfo.T.Bounds_Ptr_Type));
+
+ -- Copy bounds to the allocated area.
+ Gen_Memcpy
+ (M2Addr (Chap3.Get_Array_Bounds (Res)),
+ M2Addr (Bounds),
+ New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type)));
+
+ -- Allocate base.
+ Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type);
+ else
+ New_Assign_Stmt
+ (M2Lp (Res),
+ Gen_Alloc
+ (Alloc_Kind,
+ Chap3.Get_Object_Size (T2M (Obj_Type, Kind),
+ Obj_Type),
+ Dinfo.Ortho_Ptr_Type (Kind)));
+
+ if Is_Complex_Type (Dinfo)
+ and then Dinfo.C (Kind).Builder_Need_Func
+ then
+ Open_Temp;
+ -- Build the type.
+ Chap3.Gen_Call_Type_Builder (Res, Obj_Type);
+ Close_Temp;
+ end if;
+
+ end if;
+ end Translate_Object_Allocation;
+
+ procedure Gen_Deallocate (Obj : O_Enode)
+ is
+ Assocs : O_Assoc_List;
+ begin
+ Start_Association (Assocs, Ghdl_Deallocate);
+ New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type));
+ New_Procedure_Call (Assocs);
+ end Gen_Deallocate;
+
+ -- Performs deallocation of PARAM (the parameter of a deallocate call).
+ procedure Translate_Object_Deallocation (Param : Iir)
+ is
+ -- Performs deallocation of field FIELD of type FTYPE of PTR.
+ -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE).
+ -- Here, deallocate means freeing memory and clearing to null.
+ procedure Deallocate_1
+ (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode)
+ is
+ L : O_Lnode;
+ begin
+ for I in 0 .. 1 loop
+ L := M2Lv (Ptr);
+ if Field /= O_Fnode_Null then
+ L := New_Selected_Element (L, Field);
+ end if;
+ case I is
+ when 0 =>
+ -- Call deallocator.
+ Gen_Deallocate (New_Value (L));
+ when 1 =>
+ -- set the value to 0.
+ New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype)));
+ end case;
+ end loop;
+ end Deallocate_1;
+
+ Param_Type : Iir;
+ Val : Mnode;
+ Info : Type_Info_Acc;
+ Binfo : Type_Info_Acc;
+ begin
+ -- Compute parameter
+ Val := Chap6.Translate_Name (Param);
+ if Get_Object_Kind (Val) = Mode_Signal then
+ raise Internal_Error;
+ end if;
+ Stabilize (Val);
+ Param_Type := Get_Type (Param);
+ Info := Get_Info (Param_Type);
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Acc =>
+ -- This is a fat pointer.
+ -- Deallocate base and bounds.
+ Binfo := Get_Info (Get_Designated_Type (Param_Type));
+ Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value),
+ Binfo.T.Base_Ptr_Type (Mode_Value));
+ Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value),
+ Binfo.T.Bounds_Ptr_Type);
+ when Type_Mode_Acc =>
+ -- This is a thin pointer.
+ Deallocate_1 (Val, O_Fnode_Null,
+ Info.Ortho_Type (Mode_Value));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Translate_Object_Deallocation;
+
+ function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode
+ is
+ Constr : Iir;
+ Info : Type_Info_Acc;
+
+ function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode
+ is
+ L, H : O_Enode;
+ begin
+ if not Info.T.Nocheck_Low then
+ L := New_Compare_Op
+ (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type);
+ end if;
+ if not Info.T.Nocheck_Hi then
+ H := New_Compare_Op
+ (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type);
+ end if;
+ if Info.T.Nocheck_Hi then
+ if Info.T.Nocheck_Low then
+ -- Should not happen!
+ return New_Lit (Ghdl_Bool_False_Node);
+ else
+ return L;
+ end if;
+ else
+ if Info.T.Nocheck_Low then
+ return H;
+ else
+ return New_Dyadic_Op (ON_Or, L, H);
+ end if;
+ end if;
+ end Gen_Compare;
+
+ function Gen_Compare_To return O_Enode is
+ begin
+ return Gen_Compare
+ (Chap14.Translate_Left_Type_Attribute (Atype),
+ Chap14.Translate_Right_Type_Attribute (Atype));
+ end Gen_Compare_To;
+
+ function Gen_Compare_Downto return O_Enode is
+ begin
+ return Gen_Compare
+ (Chap14.Translate_Right_Type_Attribute (Atype),
+ Chap14.Translate_Left_Type_Attribute (Atype));
+ end Gen_Compare_Downto;
+
+ --Low, High : Iir;
+ Var_Res : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Constr := Get_Range_Constraint (Atype);
+ Info := Get_Info (Atype);
+
+ if Get_Kind (Constr) = Iir_Kind_Range_Expression then
+ -- Constraint is a range expression, therefore, direction is
+ -- known.
+ if Get_Expr_Staticness (Constr) = Locally then
+ -- Range constraint is locally static
+ -- FIXME: check low and high if they are not limits...
+ --Low := Get_Low_Limit (Constr);
+ --High := Get_High_Limit (Constr);
+ null;
+ end if;
+ case Get_Direction (Constr) is
+ when Iir_To =>
+ return Gen_Compare_To;
+ when Iir_Downto =>
+ return Gen_Compare_Downto;
+ end case;
+ end if;
+
+ -- Range constraint is not static
+ -- full check (lot's of code ?).
+ Var_Res := Create_Temp (Ghdl_Bool_Type);
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ Chap14.Translate_Dir_Type_Attribute (Atype),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ -- To.
+ New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To);
+ New_Else_Stmt (If_Blk);
+ -- Downto
+ New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto);
+ Finish_If_Stmt (If_Blk);
+ return New_Obj_Value (Var_Res);
+ end Not_In_Range;
+
+ function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean
+ is
+ Info : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then
+ return False;
+ end if;
+ if Expr /= Null_Iir and then Get_Type (Expr) = Atype then
+ return False;
+ end if;
+ return True;
+ end Need_Range_Check;
+
+ procedure Check_Range
+ (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir)
+ is
+ If_Blk : O_If_Block;
+ begin
+ if not Need_Range_Check (Expr, Atype) then
+ return;
+ end if;
+
+ if Expr /= Null_Iir
+ and then Get_Expr_Staticness (Expr) = Locally
+ and then Get_Type_Staticness (Atype) = Locally
+ then
+ if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then
+ Chap6.Gen_Bound_Error (Loc);
+ end if;
+ else
+ Open_Temp;
+ Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype));
+ Chap6.Gen_Bound_Error (Loc);
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end if;
+ end Check_Range;
+
+ function Insert_Scalar_Check
+ (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir)
+ return O_Enode
+ is
+ Var : O_Dnode;
+ begin
+ Var := Create_Temp_Init
+ (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value);
+ Check_Range (Var, Expr, Atype, Loc);
+ return New_Obj_Value (Var);
+ end Insert_Scalar_Check;
+
+ function Maybe_Insert_Scalar_Check
+ (Value : O_Enode; Expr : Iir; Atype : Iir)
+ return O_Enode
+ is
+ Expr_Type : constant Iir := Get_Type (Expr);
+ begin
+ -- pragma Assert (Base_Type = Get_Base_Type (Atype));
+ if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition
+ and then Need_Range_Check (Expr, Atype)
+ then
+ return Insert_Scalar_Check (Value, Expr, Atype, Expr);
+ else
+ return Value;
+ end if;
+ end Maybe_Insert_Scalar_Check;
+
+ function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean
+ is
+ L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type);
+ R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type);
+ L_El : Iir;
+ R_El : Iir;
+ begin
+ for I in Natural loop
+ L_El := Get_Index_Type (L_Indexes, I);
+ R_El := Get_Index_Type (R_Indexes, I);
+ exit when L_El = Null_Iir and R_El = Null_Iir;
+ if Eval_Discrete_Type_Length (L_El)
+ /= Eval_Discrete_Type_Length (R_El)
+ then
+ return False;
+ end if;
+ end loop;
+ return True;
+ end Locally_Array_Match;
+
+ procedure Check_Array_Match (L_Type : Iir;
+ L_Node : Mnode;
+ R_Type : Iir;
+ R_Node : Mnode;
+ Loc : Iir)
+ is
+ L_Tinfo, R_Tinfo : Type_Info_Acc;
+ begin
+ L_Tinfo := Get_Info (L_Type);
+ R_Tinfo := Get_Info (R_Type);
+ -- FIXME: optimize for a statically bounded array of a complex type.
+ if L_Tinfo.Type_Mode = Type_Mode_Array
+ and then L_Tinfo.Type_Locally_Constrained
+ and then R_Tinfo.Type_Mode = Type_Mode_Array
+ and then R_Tinfo.Type_Locally_Constrained
+ then
+ -- Both left and right are thin array.
+ -- Check here the length are the same.
+ if not Locally_Array_Match (L_Type, R_Type) then
+ Chap6.Gen_Bound_Error (Loc);
+ end if;
+ else
+ -- Check length match.
+ declare
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (L_Type);
+ Index : Iir;
+ Cond : O_Enode;
+ Sub_Cond : O_Enode;
+ begin
+ for I in Natural loop
+ Index := Get_Nth_Element (Index_List, I);
+ exit when Index = Null_Iir;
+ Sub_Cond := New_Compare_Op
+ (ON_Neq,
+ M2E (Range_To_Length
+ (Get_Array_Range (L_Node, L_Type, I + 1))),
+ M2E (Range_To_Length
+ (Get_Array_Range (R_Node, R_Type, I + 1))),
+ Ghdl_Bool_Type);
+ if I = 0 then
+ Cond := Sub_Cond;
+ else
+ Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond);
+ end if;
+ end loop;
+ Chap6.Check_Bound_Error (Cond, Loc, 0);
+ end;
+ end if;
+ end Check_Array_Match;
+
+ procedure Create_Range_From_Array_Attribute_And_Length
+ (Array_Attr : Iir; Length : O_Dnode; Range_Ptr : O_Dnode)
+ is
+ Attr_Kind : Iir_Kind;
+ Arr_Rng : Mnode;
+ Iinfo : Type_Info_Acc;
+
+ Res : Mnode;
+
+ Dir : O_Enode;
+ Diff : O_Dnode;
+ Left_Bound : Mnode;
+ If_Blk : O_If_Block;
+ If_Blk1 : O_If_Block;
+ begin
+ Open_Temp;
+ Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr);
+ Iinfo := Get_Type_Info (Arr_Rng);
+ Stabilize (Arr_Rng);
+
+ Res := Dp2M (Range_Ptr, Iinfo, Mode_Value);
+
+ -- Length.
+ New_Assign_Stmt (M2Lv (Range_To_Length (Arr_Rng)),
+ New_Obj_Value (Length));
+
+ -- Direction.
+ Attr_Kind := Get_Kind (Array_Attr);
+ Dir := M2E (Range_To_Dir (Arr_Rng));
+ case Attr_Kind is
+ when Iir_Kind_Range_Array_Attribute =>
+ New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir);
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Eq,
+ Dir,
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt
+ (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node));
+ Finish_If_Stmt (If_Blk);
+ when others =>
+ Error_Kind ("Create_Range_From_Array_Attribute_And_Length",
+ Array_Attr);
+ end case;
+
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Length),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ -- Null range.
+ case Attr_Kind is
+ when Iir_Kind_Range_Array_Attribute =>
+ New_Assign_Stmt (M2Lv (Range_To_Left (Res)),
+ M2E (Range_To_Right (Arr_Rng)));
+ New_Assign_Stmt (M2Lv (Range_To_Right (Res)),
+ M2E (Range_To_Left (Arr_Rng)));
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ New_Assign_Stmt (M2Lv (Range_To_Left (Res)),
+ M2E (Range_To_Left (Arr_Rng)));
+ New_Assign_Stmt (M2Lv (Range_To_Right (Res)),
+ M2E (Range_To_Right (Arr_Rng)));
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ New_Else_Stmt (If_Blk);
+
+ -- LEFT.
+ case Attr_Kind is
+ when Iir_Kind_Range_Array_Attribute =>
+ Left_Bound := Range_To_Left (Arr_Rng);
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Left_Bound := Range_To_Right (Arr_Rng);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Stabilize (Left_Bound);
+ New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound));
+
+ -- RIGHT.
+ Diff := Create_Temp_Init
+ (Iinfo.Ortho_Type (Mode_Value),
+ New_Convert_Ov
+ (New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Length),
+ New_Lit (Ghdl_Index_1)),
+ Iinfo.Ortho_Type (Mode_Value)));
+
+ Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq,
+ M2E (Range_To_Dir (Res)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (M2Lv (Range_To_Right (Res)),
+ New_Dyadic_Op (ON_Add_Ov,
+ M2E (Left_Bound),
+ New_Obj_Value (Diff)));
+ New_Else_Stmt (If_Blk1);
+ New_Assign_Stmt (M2Lv (Range_To_Right (Res)),
+ New_Dyadic_Op (ON_Sub_Ov,
+ M2E (Left_Bound),
+ New_Obj_Value (Diff)));
+ Finish_If_Stmt (If_Blk1);
+
+ -- FIXME: check right bounds is inside bounds.
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end Create_Range_From_Array_Attribute_And_Length;
+
+ procedure Create_Range_From_Length
+ (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir)
+ is
+ Iinfo : constant Type_Info_Acc := Get_Info (Index_Type);
+ Range_Constr : constant Iir := Get_Range_Constraint (Index_Type);
+ Op : ON_Op_Kind;
+ Diff : O_Enode;
+ Left_Bound : O_Enode;
+ Var_Right : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then
+ Create_Range_From_Array_Attribute_And_Length
+ (Range_Constr, Length, Range_Ptr);
+ return;
+ end if;
+
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_Right, Get_Identifier ("right_bound"),
+ O_Storage_Local, Iinfo.Ortho_Type (Mode_Value));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Length),
+ New_Obj_Value (Length));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Dir),
+ New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr)));
+
+ case Get_Direction (Range_Constr) is
+ when Iir_To =>
+ Op := ON_Add_Ov;
+ when Iir_Downto =>
+ Op := ON_Sub_Ov;
+ end case;
+
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Length),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ -- Null range.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left),
+ Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right),
+ Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type));
+
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left),
+ Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type));
+ Left_Bound := Chap7.Translate_Range_Expression_Left
+ (Range_Constr, Index_Type);
+ Diff := New_Convert_Ov
+ (New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Length),
+ New_Lit (Ghdl_Index_1)),
+ Iinfo.Ortho_Type (Mode_Value));
+ New_Assign_Stmt (New_Obj (Var_Right),
+ New_Dyadic_Op (Op, Left_Bound, Diff));
+
+ -- Check the right bounds is inside the bounds of the index type.
+ Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc);
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right),
+ New_Obj_Value (Var_Right));
+ Finish_If_Stmt (If_Blk);
+ Finish_Declare_Stmt;
+ end Create_Range_From_Length;
+ end Chap3;
+
+ package body Chap4 is
+ -- Get the ortho type for an object of mode MODE.
+ function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type)
+ return O_Tnode is
+ begin
+ if Is_Complex_Type (Tinfo) then
+ case Tinfo.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ return Tinfo.Ortho_Type (Kind);
+ when Type_Mode_Record
+ | Type_Mode_Array
+ | Type_Mode_Protected =>
+ -- For a complex type, use a pointer.
+ return Tinfo.Ortho_Ptr_Type (Kind);
+ when others =>
+ raise Internal_Error;
+ end case;
+ else
+ return Tinfo.Ortho_Type (Kind);
+ end if;
+ end Get_Object_Type;
+
+ procedure Create_Object (El : Iir)
+ is
+ Obj_Type : O_Tnode;
+ Info : Object_Info_Acc;
+ Tinfo : Type_Info_Acc;
+ Def : Iir;
+ Val : Iir;
+ Storage : O_Storage;
+ Deferred : Iir;
+ begin
+ Def := Get_Type (El);
+ Val := Get_Default_Value (El);
+
+ -- Be sure the object type was translated.
+ if Get_Kind (El) = Iir_Kind_Constant_Declaration
+ and then Get_Deferred_Declaration_Flag (El) = False
+ and then Get_Deferred_Declaration (El) /= Null_Iir
+ then
+ -- This is a full constant declaration which complete a previous
+ -- incomplete constant declaration.
+ --
+ -- Do not create the subtype of this full constant declaration,
+ -- since it was already created by the deferred declaration.
+ -- Use the type of the deferred declaration.
+ Deferred := Get_Deferred_Declaration (El);
+ Def := Get_Type (Deferred);
+ Info := Get_Info (Deferred);
+ Set_Info (El, Info);
+ else
+ Chap3.Translate_Object_Subtype (El);
+ Info := Add_Info (El, Kind_Object);
+ end if;
+
+ Tinfo := Get_Info (Def);
+ Obj_Type := Get_Object_Type (Tinfo, Mode_Value);
+
+ case Get_Kind (El) is
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Constant_Declaration =>
+ Info.Object_Var :=
+ Create_Var (Create_Var_Identifier (El), Obj_Type);
+ when Iir_Kind_Constant_Declaration =>
+ if Get_Deferred_Declaration (El) /= Null_Iir then
+ -- This is a full constant declaration (in a body) of a
+ -- deferred constant declaration (in a package).
+ Storage := O_Storage_Public;
+ else
+ Storage := Global_Storage;
+ end if;
+ if Info.Object_Var = Null_Var then
+ -- Not a full constant declaration (ie a value for an
+ -- already declared constant).
+ -- Must create the declaration.
+ if Chap7.Is_Static_Constant (El) then
+ Info.Object_Static := True;
+ Info.Object_Var := Create_Global_Const
+ (Create_Identifier (El), Obj_Type, Global_Storage,
+ O_Cnode_Null);
+ else
+ Info.Object_Static := False;
+ Info.Object_Var := Create_Var
+ (Create_Var_Identifier (El),
+ Obj_Type, Global_Storage);
+ end if;
+ end if;
+ if Get_Deferred_Declaration (El) = Null_Iir
+ and then Info.Object_Static
+ and then Storage /= O_Storage_External
+ then
+ -- Deferred constant are never considered as locally static.
+ -- FIXME: to be improved ?
+
+ -- open_temp/close_temp only required for transient types.
+ Open_Temp;
+ Define_Global_Const
+ (Info.Object_Var,
+ Chap7.Translate_Static_Expression (Val, Def));
+ Close_Temp;
+ end if;
+ when others =>
+ Error_Kind ("create_objet", El);
+ end case;
+ end Create_Object;
+
+ procedure Create_Signal (Decl : Iir)
+ is
+ Sig_Type_Def : constant Iir := Get_Type (Decl);
+ Sig_Type : O_Tnode;
+ Type_Info : Type_Info_Acc;
+ Info : Ortho_Info_Acc;
+ begin
+ Chap3.Translate_Object_Subtype (Decl);
+
+ Type_Info := Get_Info (Sig_Type_Def);
+ Sig_Type := Get_Object_Type (Type_Info, Mode_Signal);
+ pragma Assert (Sig_Type /= O_Tnode_Null);
+
+ Info := Add_Info (Decl, Kind_Object);
+
+ Info.Object_Var :=
+ Create_Var (Create_Var_Identifier (Decl), Sig_Type);
+
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Rtis.Generate_Signal_Rti (Decl);
+ when Iir_Kind_Guard_Signal_Declaration =>
+ -- No name created for guard signal.
+ null;
+ when others =>
+ Error_Kind ("create_signal", Decl);
+ end case;
+ end Create_Signal;
+
+ procedure Create_Implicit_Signal (Decl : Iir)
+ is
+ Sig_Type : O_Tnode;
+ Type_Info : Type_Info_Acc;
+ Info : Ortho_Info_Acc;
+ Sig_Type_Def : Iir;
+ begin
+ Sig_Type_Def := Get_Type (Decl);
+ -- This has been disabled since DECL can have an anonymous subtype,
+ -- and DECL has no identifiers, which causes translate_object_subtype
+ -- to crash.
+ -- Note: DECL can only be a iir_kind_delayed_attribute.
+ --Chap3.Translate_Object_Subtype (Decl);
+ Type_Info := Get_Info (Sig_Type_Def);
+ Sig_Type := Type_Info.Ortho_Type (Mode_Signal);
+ if Sig_Type = O_Tnode_Null then
+ raise Internal_Error;
+ end if;
+
+ Info := Add_Info (Decl, Kind_Object);
+
+ Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type);
+ end Create_Implicit_Signal;
+
+ procedure Create_File_Object (El : Iir_File_Declaration)
+ is
+ Obj_Type : O_Tnode;
+ Info : Ortho_Info_Acc;
+ Obj_Type_Def : Iir;
+ begin
+ Obj_Type_Def := Get_Type (El);
+ Obj_Type := Get_Ortho_Type (Obj_Type_Def, Mode_Value);
+
+ Info := Add_Info (El, Kind_Object);
+
+ Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type);
+ end Create_File_Object;
+
+ procedure Create_Package_Interface (Inter : Iir)
+ is
+ Info : Ortho_Info_Acc;
+ Pkg : constant Iir := Get_Named_Entity
+ (Get_Uninstantiated_Package_Name (Inter));
+ Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg);
+ begin
+ Chap2.Instantiate_Info_Package (Inter);
+ Info := Get_Info (Inter);
+
+ -- The spec
+ Info.Package_Instance_Spec_Var :=
+ Create_Var (Create_Var_Identifier (Inter, "SPEC", 0),
+ Pkg_Info.Package_Spec_Ptr_Type);
+ Set_Scope_Via_Var_Ptr
+ (Info.Package_Instance_Spec_Scope,
+ Info.Package_Instance_Spec_Var);
+
+ -- The body
+ Info.Package_Instance_Body_Var :=
+ Create_Var (Create_Var_Identifier (Inter, "BODY", 0),
+ Pkg_Info.Package_Body_Ptr_Type);
+ Set_Scope_Via_Var_Ptr
+ (Info.Package_Instance_Body_Scope,
+ Info.Package_Instance_Body_Var);
+ end Create_Package_Interface;
+
+ procedure Allocate_Complex_Object (Obj_Type : Iir;
+ Alloc_Kind : Allocation_Kind;
+ Var : in out Mnode)
+ is
+ Type_Info : constant Type_Info_Acc := Get_Type_Info (Var);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Var);
+ Targ : Mnode;
+ begin
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ -- Cannot allocate unconstrained object (since size is unknown).
+ raise Internal_Error;
+ end if;
+
+ if not Is_Complex_Type (Type_Info) then
+ -- Object is not complex.
+ return;
+ end if;
+
+ if Type_Info.C (Kind).Builder_Need_Func
+ and then not Is_Stable (Var)
+ then
+ Targ := Create_Temp (Type_Info, Kind);
+ else
+ Targ := Var;
+ end if;
+
+ -- Allocate variable.
+ New_Assign_Stmt
+ (M2Lp (Targ),
+ Gen_Alloc (Alloc_Kind,
+ Chap3.Get_Object_Size (Var, Obj_Type),
+ Type_Info.Ortho_Ptr_Type (Kind)));
+
+ if Type_Info.C (Kind).Builder_Need_Func then
+ -- Build the type.
+ Chap3.Gen_Call_Type_Builder (Targ, Obj_Type);
+ if not Is_Stable (Var) then
+ New_Assign_Stmt (M2Lp (Var), M2Addr (Targ));
+ Var := Targ;
+ end if;
+ end if;
+ end Allocate_Complex_Object;
+
+ -- Note : OBJ can be a tree.
+ -- FIXME: should use translate_aggregate_others.
+ procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir)
+ is
+ Sobj : Mnode;
+
+ -- Type of the object.
+ Type_Info : Type_Info_Acc;
+
+ -- Iterator for the elements.
+ Index : O_Dnode;
+
+ Upper_Limit : O_Enode;
+ Upper_Var : O_Dnode;
+
+ Label : O_Snode;
+ begin
+ Type_Info := Get_Info (Obj_Type);
+
+ -- Iterate on all elements of the object.
+ Open_Temp;
+
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ Sobj := Stabilize (Obj);
+ else
+ Sobj := Obj;
+ end if;
+ Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type);
+
+ if Type_Info.Type_Mode /= Type_Mode_Array then
+ Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit);
+ else
+ Upper_Var := O_Dnode_Null;
+ end if;
+
+ Index := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Index);
+ Start_Loop_Stmt (Label);
+ if Upper_Var /= O_Dnode_Null then
+ Upper_Limit := New_Obj_Value (Upper_Var);
+ end if;
+ Gen_Exit_When (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Index), Upper_Limit,
+ Ghdl_Bool_Type));
+ Init_Object (Chap3.Index_Base (Chap3.Get_Array_Base (Sobj),
+ Obj_Type,
+ New_Obj_Value (Index)),
+ Get_Element_Subtype (Obj_Type));
+ Inc_Var (Index);
+ Finish_Loop_Stmt (Label);
+
+ Close_Temp;
+ end Init_Array_Object;
+
+ procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir)
+ is
+ Assoc : O_Assoc_List;
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Info (Obj_Type);
+
+ -- Call the initializer.
+ Start_Association (Assoc, Info.T.Prot_Init_Subprg);
+ Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance);
+ -- Use of M2Lp is a little bit fragile (not sure we get the
+ -- variable, but should work: we didn't stabilize it).
+ New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc));
+ end Init_Protected_Object;
+
+ procedure Fini_Protected_Object (Decl : Iir)
+ is
+ Obj : Mnode;
+ Assoc : O_Assoc_List;
+ Info : Type_Info_Acc;
+ begin
+ Info := Get_Info (Get_Type (Decl));
+
+ Obj := Chap6.Translate_Name (Decl);
+ -- Call the Finalizator.
+ Start_Association (Assoc, Info.T.Prot_Final_Subprg);
+ New_Association (Assoc, M2E (Obj));
+ New_Procedure_Call (Assoc);
+ end Fini_Protected_Object;
+
+ procedure Init_Object (Obj : Mnode; Obj_Type : Iir)
+ is
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Type_Info (Obj);
+ case Tinfo.Type_Mode is
+ when Type_Mode_Scalar =>
+ New_Assign_Stmt
+ (M2Lv (Obj), Chap14.Translate_Left_Type_Attribute (Obj_Type));
+ when Type_Mode_Acc =>
+ New_Assign_Stmt
+ (M2Lv (Obj),
+ New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value))));
+ when Type_Mode_Fat_Acc =>
+ declare
+ Dinfo : Type_Info_Acc;
+ Sobj : Mnode;
+ begin
+ Open_Temp;
+ Sobj := Stabilize (Obj);
+ Dinfo := Get_Info (Get_Designated_Type (Obj_Type));
+ New_Assign_Stmt
+ (New_Selected_Element (M2Lv (Sobj),
+ Dinfo.T.Bounds_Field (Mode_Value)),
+ New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type)));
+ New_Assign_Stmt
+ (New_Selected_Element (M2Lv (Sobj),
+ Dinfo.T.Base_Field (Mode_Value)),
+ New_Lit (New_Null_Access
+ (Dinfo.T.Base_Ptr_Type (Mode_Value))));
+ Close_Temp;
+ end;
+ when Type_Mode_Arrays =>
+ Init_Array_Object (Obj, Obj_Type);
+ when Type_Mode_Record =>
+ declare
+ Sobj : Mnode;
+ El : Iir_Element_Declaration;
+ List : Iir_List;
+ begin
+ Open_Temp;
+ Sobj := Stabilize (Obj);
+ List := Get_Elements_Declaration_List
+ (Get_Base_Type (Obj_Type));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Init_Object (Chap6.Translate_Selected_Element (Sobj, El),
+ Get_Type (El));
+ end loop;
+ Close_Temp;
+ end;
+ when Type_Mode_Protected =>
+ Init_Protected_Object (Obj, Obj_Type);
+ when Type_Mode_Unknown
+ | Type_Mode_File =>
+ raise Internal_Error;
+ end case;
+ end Init_Object;
+
+ procedure Elab_Object_Storage (Obj : Iir)
+ is
+ Obj_Type : constant Iir := Get_Type (Obj);
+ Obj_Info : constant Object_Info_Acc := Get_Info (Obj);
+
+ Name_Node : Mnode;
+
+ Type_Info : Type_Info_Acc;
+ Alloc_Kind : Allocation_Kind;
+ begin
+ -- Elaborate subtype.
+ Chap3.Elab_Object_Subtype (Obj_Type);
+
+ Type_Info := Get_Info (Obj_Type);
+
+ -- FIXME: the object type may be a fat array!
+ -- FIXME: fat array + aggregate ?
+
+ if Type_Info.Type_Mode = Type_Mode_Protected then
+ -- Protected object will be created by its INIT function.
+ return;
+ end if;
+
+ if Is_Complex_Type (Type_Info)
+ and then Type_Info.Type_Mode /= Type_Mode_Fat_Array
+ then
+ -- FIXME: avoid allocation if the value is a string and
+ -- the object is a constant
+ Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value);
+ Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
+ Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node);
+ end if;
+ end Elab_Object_Storage;
+
+ -- Generate code to create object OBJ and initialize it with value VAL.
+ procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir)
+ is
+ Obj_Type : constant Iir := Get_Type (Obj);
+ Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type);
+ Obj_Info : constant Object_Info_Acc := Get_Info (Obj);
+
+ Name_Node : Mnode;
+ Value_Node : O_Enode;
+
+ Alloc_Kind : Allocation_Kind;
+ begin
+ -- Elaborate subtype.
+ Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var);
+
+ -- Note: no temporary variable region is created, as the allocation
+ -- may be performed on the stack.
+
+ if Value = Null_Iir then
+ -- Performs default initialization.
+ Open_Temp;
+ Init_Object (Name, Obj_Type);
+ Close_Temp;
+ elsif Get_Kind (Value) = Iir_Kind_Aggregate then
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ -- Allocate.
+ declare
+ Aggr_Type : Iir;
+ begin
+ Aggr_Type := Get_Type (Value);
+ Chap3.Create_Array_Subtype (Aggr_Type, True);
+ Name_Node := Stabilize (Name);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Name_Node)),
+ M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type)));
+ Chap3.Allocate_Fat_Array_Base
+ (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type));
+ end;
+ else
+ Name_Node := Name;
+ end if;
+ Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value);
+ else
+ Value_Node := Chap7.Translate_Expression (Value, Obj_Type);
+
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ declare
+ S : Mnode;
+ begin
+ Name_Node := Stabilize (Name);
+ S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value));
+
+ if Get_Kind (Value) = Iir_Kind_String_Literal
+ and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration
+ then
+ -- No need to allocate space for the object.
+ Copy_Fat_Pointer (Name_Node, S);
+ else
+ Chap3.Translate_Object_Allocation
+ (Name_Node, Alloc_Kind, Obj_Type,
+ Chap3.Get_Array_Bounds (S));
+ Chap3.Translate_Object_Copy
+ (Name_Node, M2Addr (S), Obj_Type);
+ end if;
+ end;
+ else
+ Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type);
+ end if;
+ Destroy_Local_Transient_Types;
+ end if;
+ end Elab_Object_Init;
+
+ -- Generate code to create object OBJ and initialize it with value VAL.
+ procedure Elab_Object_Value (Obj : Iir; Value : Iir)
+ is
+ Name : Mnode;
+ begin
+ Elab_Object_Storage (Obj);
+ Name := Get_Var (Get_Info (Obj).Object_Var,
+ Get_Info (Get_Type (Obj)), Mode_Value);
+ Elab_Object_Init (Name, Obj, Value);
+ end Elab_Object_Value;
+
+ -- Create code to elaborate OBJ.
+ procedure Elab_Object (Obj : Iir)
+ is
+ Value : Iir;
+ Obj1 : Iir;
+ begin
+ -- A locally static constant is pre-elaborated.
+ -- (only constant can be locally static).
+ if Get_Expr_Staticness (Obj) = Locally
+ and then Get_Deferred_Declaration (Obj) = Null_Iir
+ then
+ return;
+ end if;
+
+ -- Set default value.
+ if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then
+ if Get_Info (Obj).Object_Static then
+ return;
+ end if;
+ if Get_Deferred_Declaration_Flag (Obj) then
+ -- No code generation for a deferred constant.
+ return;
+ end if;
+ Obj1 := Get_Deferred_Declaration (Obj);
+ if Obj1 = Null_Iir then
+ Obj1 := Obj;
+ end if;
+ else
+ Obj1 := Obj;
+ end if;
+
+ New_Debug_Line_Stmt (Get_Line_Number (Obj));
+
+ -- Still use the default value of the not deferred constant.
+ -- FIXME: what about composite types.
+ Value := Get_Default_Value (Obj);
+ Elab_Object_Value (Obj1, Value);
+ end Elab_Object;
+
+ procedure Fini_Object (Obj : Iir)
+ is
+ Obj_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ begin
+ Obj_Type := Get_Type (Obj);
+ Type_Info := Get_Info (Obj_Type);
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ declare
+ V : Mnode;
+ begin
+ Open_Temp;
+ V := Chap6.Translate_Name (Obj);
+ Stabilize (V);
+ Chap3.Gen_Deallocate
+ (New_Value (M2Lp (Chap3.Get_Array_Bounds (V))));
+ Chap3.Gen_Deallocate
+ (New_Value (M2Lp (Chap3.Get_Array_Base (V))));
+ Close_Temp;
+ end;
+ elsif Is_Complex_Type (Type_Info) then
+ Chap3.Gen_Deallocate
+ (New_Value (M2Lp (Chap6.Translate_Name (Obj))));
+ end if;
+ end Fini_Object;
+
+ function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode
+ is
+ Info : constant Type_Info_Acc := Get_Info (Sig_Type);
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ -- Note: here we discard SIG...
+ return New_Lit (Ghdl_Index_1);
+ when Type_Mode_Arrays =>
+ declare
+ Len : O_Dnode;
+ If_Blk : O_If_Block;
+ Ssig : Mnode;
+ begin
+ Ssig := Stabilize (Sig);
+ Len := Create_Temp_Init
+ (Ghdl_Index_Type,
+ Chap3.Get_Array_Length (Ssig, Sig_Type));
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Neq,
+ New_Obj_Value (Len),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Obj (Len),
+ New_Dyadic_Op
+ (ON_Mul_Ov,
+ New_Obj_Value (Len),
+ Get_Nbr_Signals
+ (Chap3.Index_Base
+ (Chap3.Get_Array_Base (Ssig), Sig_Type,
+ New_Lit (Ghdl_Index_0)),
+ Get_Element_Subtype (Sig_Type))));
+ Finish_If_Stmt (If_Blk);
+
+ return New_Obj_Value (Len);
+ end;
+ when Type_Mode_Record =>
+ declare
+ List : Iir_List;
+ El : Iir;
+ Res : O_Enode;
+ E : O_Enode;
+ Sig_El : Mnode;
+ Ssig : Mnode;
+ begin
+ List :=
+ Get_Elements_Declaration_List (Get_Base_Type (Sig_Type));
+ Ssig := Stabilize (Sig);
+ Res := O_Enode_Null;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Sig_El := Chap6.Translate_Selected_Element (Ssig, El);
+ E := Get_Nbr_Signals (Sig_El, Get_Type (El));
+ if Res /= O_Enode_Null then
+ Res := New_Dyadic_Op (ON_Add_Ov, Res, E);
+ else
+ Res := E;
+ end if;
+ end loop;
+ if Res = O_Enode_Null then
+ -- Empty records.
+ Res := New_Lit (Ghdl_Index_0);
+ end if;
+ return Res;
+ end;
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Get_Nbr_Signals;
+
+ -- Get the leftest signal of SIG.
+ -- The leftest signal of
+ -- a scalar signal is itself,
+ -- an array signal is the leftest,
+ -- a record signal is the first element.
+ function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir)
+ return Mnode
+ is
+ Res : Mnode;
+ Res_Type : Iir;
+ Info : Type_Info_Acc;
+ begin
+ Res := Sig;
+ Res_Type := Sig_Type;
+ loop
+ Info := Get_Type_Info (Res);
+ case Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ return Res;
+ when Type_Mode_Arrays =>
+ Res := Chap3.Index_Base
+ (Chap3.Get_Array_Base (Res), Res_Type,
+ New_Lit (Ghdl_Index_0));
+ Res_Type := Get_Element_Subtype (Res_Type);
+ when Type_Mode_Record =>
+ declare
+ Element : Iir;
+ begin
+ Element := Get_First_Element
+ (Get_Elements_Declaration_List
+ (Get_Base_Type (Res_Type)));
+ Res := Chap6.Translate_Selected_Element (Res, Element);
+ Res_Type := Get_Type (Element);
+ end;
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ end Get_Leftest_Signal;
+
+ -- Add func and instance.
+ procedure Add_Associations_For_Resolver
+ (Assoc : in out O_Assoc_List; Func_Decl : Iir)
+ is
+ Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl);
+ Resolv_Info : constant Subprg_Resolv_Info_Acc :=
+ Func_Info.Subprg_Resolv;
+ Val : O_Enode;
+ begin
+ New_Association
+ (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func,
+ Ghdl_Ptr_Type)));
+ if Chap2.Has_Subprg_Instance (Resolv_Info.Var_Instance) then
+ Val := New_Convert_Ov
+ (Chap2.Get_Subprg_Instance (Resolv_Info.Var_Instance),
+ Ghdl_Ptr_Type);
+ else
+ Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type));
+ end if;
+ New_Association (Assoc, Val);
+ end Add_Associations_For_Resolver;
+
+ type O_If_Block_Acc is access O_If_Block;
+
+ type Elab_Signal_Data is record
+ -- Default value of the signal.
+ Val : Mnode;
+ -- If statement for a block of signals.
+ If_Stmt : O_If_Block_Acc;
+ -- True if the default value is set.
+ Has_Val : Boolean;
+ -- True if a resolution function was already attached.
+ Already_Resolved : Boolean;
+ -- True if the signal may already have been created.
+ Check_Null : Boolean;
+ end record;
+
+ procedure Elab_Signal_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Elab_Signal_Data)
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type);
+ Create_Subprg : O_Dnode;
+ Conv : O_Tnode;
+ Res : O_Enode;
+ Assoc : O_Assoc_List;
+ Init_Val : O_Enode;
+ -- For the resolution function (if any).
+ Func : Iir;
+ If_Stmt : O_If_Block;
+ Targ_Ptr : O_Dnode;
+ begin
+ if Data.Check_Null then
+ Targ_Ptr := Create_Temp_Init
+ (Ghdl_Signal_Ptr_Ptr,
+ New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr));
+ Start_If_Stmt
+ (If_Stmt,
+ New_Compare_Op (ON_Eq,
+ New_Value (New_Acc_Value (New_Obj (Targ_Ptr))),
+ New_Lit (New_Null_Access (Ghdl_Signal_Ptr)),
+ Ghdl_Bool_Type));
+ end if;
+
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Create_Subprg := Ghdl_Create_Signal_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Create_Subprg := Ghdl_Create_Signal_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Create_Subprg := Ghdl_Create_Signal_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Create_Subprg := Ghdl_Create_Signal_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Create_Subprg := Ghdl_Create_Signal_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Create_Subprg := Ghdl_Create_Signal_F64;
+ Conv := Ghdl_Real_Type;
+ when others =>
+ Error_Kind ("elab_signal_non_composite", Targ_Type);
+ end case;
+
+ if Data.Has_Val then
+ Init_Val := M2E (Data.Val);
+ else
+ Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type);
+ end if;
+
+ Start_Association (Assoc, Create_Subprg);
+ New_Association (Assoc, New_Convert_Ov (Init_Val, Conv));
+
+ if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then
+ Func := Has_Resolution_Function (Targ_Type);
+ else
+ Func := Null_Iir;
+ end if;
+ if Func /= Null_Iir and then not Data.Already_Resolved then
+ Add_Associations_For_Resolver (Assoc, Func);
+ else
+ New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type)));
+ New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type)));
+ end if;
+
+ Res := New_Function_Call (Assoc);
+
+ if Data.Check_Null then
+ New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res);
+ Finish_If_Stmt (If_Stmt);
+ else
+ New_Assign_Stmt
+ (M2Lv (Targ),
+ New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal)));
+ end if;
+ end Elab_Signal_Non_Composite;
+
+ function Elab_Signal_Prepare_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data)
+ return Elab_Signal_Data
+ is
+ Assoc : O_Assoc_List;
+ Func : Iir;
+ Res : Elab_Signal_Data;
+ begin
+ Res := Data;
+ if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then
+ Func := Has_Resolution_Function (Targ_Type);
+ if Func /= Null_Iir and then not Data.Already_Resolved then
+ if Data.Check_Null then
+ Res.If_Stmt := new O_If_Block;
+ Start_If_Stmt
+ (Res.If_Stmt.all,
+ New_Compare_Op
+ (ON_Eq,
+ New_Convert_Ov (M2E (Get_Leftest_Signal (Targ,
+ Targ_Type)),
+ Ghdl_Signal_Ptr),
+ New_Lit (New_Null_Access (Ghdl_Signal_Ptr)),
+ Ghdl_Bool_Type));
+ --Res.Check_Null := False;
+ end if;
+ -- Add resolver.
+ Start_Association (Assoc, Ghdl_Signal_Create_Resolution);
+ Add_Associations_For_Resolver (Assoc, Func);
+ New_Association
+ (Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type));
+ New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type));
+ New_Procedure_Call (Assoc);
+ Res.Already_Resolved := True;
+ end if;
+ end if;
+ if Data.Has_Val then
+ if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then
+ Res.Val := Stabilize (Data.Val);
+ else
+ Res.Val := Chap3.Get_Array_Base (Data.Val);
+ end if;
+ end if;
+ return Res;
+ end Elab_Signal_Prepare_Composite;
+
+ procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data)
+ is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => O_If_Block, Name => O_If_Block_Acc);
+ begin
+ if Data.If_Stmt /= null then
+ Finish_If_Stmt (Data.If_Stmt.all);
+ Free (Data.If_Stmt);
+ end if;
+ end Elab_Signal_Finish_Composite;
+
+ function Elab_Signal_Update_Array (Data : Elab_Signal_Data;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Elab_Signal_Data
+ is
+ begin
+ if not Data.Has_Val then
+ return Data;
+ else
+ return Elab_Signal_Data'
+ (Val => Chap3.Index_Base (Data.Val, Targ_Type,
+ New_Obj_Value (Index)),
+ Has_Val => True,
+ If_Stmt => null,
+ Already_Resolved => Data.Already_Resolved,
+ Check_Null => Data.Check_Null);
+ end if;
+ end Elab_Signal_Update_Array;
+
+ function Elab_Signal_Update_Record (Data : Elab_Signal_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Elab_Signal_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ if not Data.Has_Val then
+ return Data;
+ else
+ return Elab_Signal_Data'
+ (Val => Chap6.Translate_Selected_Element (Data.Val, El),
+ Has_Val => True,
+ If_Stmt => null,
+ Already_Resolved => Data.Already_Resolved,
+ Check_Null => Data.Check_Null);
+ end if;
+ end Elab_Signal_Update_Record;
+
+ procedure Elab_Signal is new Foreach_Non_Composite
+ (Data_Type => Elab_Signal_Data,
+ Composite_Data_Type => Elab_Signal_Data,
+ Do_Non_Composite => Elab_Signal_Non_Composite,
+ Prepare_Data_Array => Elab_Signal_Prepare_Composite,
+ Update_Data_Array => Elab_Signal_Update_Array,
+ Finish_Data_Array => Elab_Signal_Finish_Composite,
+ Prepare_Data_Record => Elab_Signal_Prepare_Composite,
+ Update_Data_Record => Elab_Signal_Update_Record,
+ Finish_Data_Record => Elab_Signal_Finish_Composite);
+
+ -- Elaborate signal subtypes and allocate the storage for the object.
+ procedure Elab_Signal_Declaration_Storage (Decl : Iir)
+ is
+ Sig_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ Name_Node : Mnode;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Decl));
+
+ Open_Temp;
+
+ Sig_Type := Get_Type (Decl);
+ Chap3.Elab_Object_Subtype (Sig_Type);
+ Type_Info := Get_Info (Sig_Type);
+
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ Name_Node := Chap6.Translate_Name (Decl);
+ Name_Node := Stabilize (Name_Node);
+ Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type);
+ elsif Is_Complex_Type (Type_Info) then
+ Name_Node := Chap6.Translate_Name (Decl);
+ Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node);
+ end if;
+
+ Close_Temp;
+ end Elab_Signal_Declaration_Storage;
+
+ function Has_Direct_Driver (Sig : Iir) return Boolean
+ is
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Get_Info (Get_Object_Prefix (Sig));
+ return Info.Kind = Kind_Object
+ and then Info.Object_Driver /= Null_Var;
+ end Has_Direct_Driver;
+
+ procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir)
+ is
+ Sig_Type : constant Iir := Get_Type (Decl);
+ Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl);
+ Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type);
+ Name_Node : Mnode;
+ begin
+ Open_Temp;
+
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ Name_Node := Get_Var (Sig_Info.Object_Driver,
+ Type_Info, Mode_Value);
+ Name_Node := Stabilize (Name_Node);
+ -- Copy bounds from signal.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Name_Node)),
+ M2Addr (Chap3.Get_Array_Bounds (Chap6.Translate_Name (Decl))));
+ -- Allocate base.
+ Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type);
+ elsif Is_Complex_Type (Type_Info) then
+ Name_Node := Get_Var (Sig_Info.Object_Driver,
+ Type_Info, Mode_Value);
+ Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node);
+ end if;
+
+ Close_Temp;
+ end Elab_Direct_Driver_Declaration_Storage;
+
+ -- Create signal object.
+ -- Note: SIG can be a signal sub-element (used when signals are
+ -- collapsed).
+ -- If CHECK_NULL is TRUE, create the signal only if it was not yet
+ -- created.
+ procedure Elab_Signal_Declaration_Object
+ (Sig : Iir; Parent : Iir; Check_Null : Boolean)
+ is
+ Decl : constant Iir := Strip_Denoting_Name (Sig);
+ Sig_Type : constant Iir := Get_Type (Sig);
+ Base_Decl : constant Iir := Get_Object_Prefix (Sig);
+ Name_Node : Mnode;
+ Val : Iir;
+ Data : Elab_Signal_Data;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Sig));
+
+ Open_Temp;
+
+ -- Set the name of the signal.
+ declare
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Ghdl_Signal_Name_Rti);
+ New_Association
+ (Assoc,
+ New_Lit (New_Global_Unchecked_Address
+ (Get_Info (Base_Decl).Object_Rti,
+ Rtis.Ghdl_Rti_Access)));
+ Rtis.Associate_Rti_Context (Assoc, Parent);
+ New_Procedure_Call (Assoc);
+ end;
+
+ Name_Node := Chap6.Translate_Name (Decl);
+ if Get_Object_Kind (Name_Node) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+
+ if Decl = Base_Decl then
+ Data.Already_Resolved := False;
+ Data.Check_Null := Check_Null;
+ Val := Get_Default_Value (Base_Decl);
+ if Val = Null_Iir then
+ Data.Has_Val := False;
+ else
+ Data.Has_Val := True;
+ Data.Val := E2M (Chap7.Translate_Expression (Val, Sig_Type),
+ Get_Info (Sig_Type),
+ Mode_Value);
+ end if;
+ else
+ -- Sub signal.
+ -- Do not add resolver.
+ -- Do not use default value.
+ Data.Already_Resolved := True;
+ Data.Has_Val := False;
+ Data.Check_Null := False;
+ end if;
+ Elab_Signal (Name_Node, Sig_Type, Data);
+
+ Close_Temp;
+ end Elab_Signal_Declaration_Object;
+
+ procedure Elab_Signal_Declaration
+ (Decl : Iir; Parent : Iir; Check_Null : Boolean)
+ is
+ begin
+ Elab_Signal_Declaration_Storage (Decl);
+ Elab_Signal_Declaration_Object (Decl, Parent, Check_Null);
+ end Elab_Signal_Declaration;
+
+ procedure Elab_Signal_Attribute (Decl : Iir)
+ is
+ Assoc : O_Assoc_List;
+ Dtype : Iir;
+ Type_Info : Type_Info_Acc;
+ Info : Object_Info_Acc;
+ Prefix : Iir;
+ Prefix_Node : Mnode;
+ Res : O_Enode;
+ Val : O_Enode;
+ Param : Iir;
+ Subprg : O_Dnode;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Decl));
+
+ Info := Get_Info (Decl);
+ Dtype := Get_Type (Decl);
+ Type_Info := Get_Info (Dtype);
+ -- Create the signal (with the time)
+ case Get_Kind (Decl) is
+ when Iir_Kind_Stable_Attribute =>
+ Subprg := Ghdl_Create_Stable_Signal;
+ when Iir_Kind_Quiet_Attribute =>
+ Subprg := Ghdl_Create_Quiet_Signal;
+ when Iir_Kind_Transaction_Attribute =>
+ Subprg := Ghdl_Create_Transaction_Signal;
+ when others =>
+ Error_Kind ("elab_signal_attribute", Decl);
+ end case;
+ Start_Association (Assoc, Subprg);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute =>
+ Param := Get_Parameter (Decl);
+ if Param = Null_Iir then
+ Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0));
+ else
+ Val := Chap7.Translate_Expression (Param);
+ end if;
+ New_Association (Assoc, Val);
+ when others =>
+ null;
+ end case;
+ Res := New_Convert_Ov (New_Function_Call (Assoc),
+ Type_Info.Ortho_Type (Mode_Signal));
+ New_Assign_Stmt (Get_Var (Info.Object_Var), Res);
+
+ -- Register all signals this depends on.
+ Prefix := Get_Prefix (Decl);
+ Prefix_Node := Chap6.Translate_Name (Prefix);
+ Register_Signal (Prefix_Node, Get_Type (Prefix),
+ Ghdl_Signal_Attribute_Register_Prefix);
+ end Elab_Signal_Attribute;
+
+ type Delayed_Signal_Data is record
+ Pfx : Mnode;
+ Param : Iir;
+ end record;
+
+ procedure Create_Delayed_Signal_Noncomposite
+ (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data)
+ is
+ pragma Unreferenced (Targ_Type);
+ Assoc : O_Assoc_List;
+ Type_Info : Type_Info_Acc;
+ Val : O_Enode;
+ begin
+ Start_Association (Assoc, Ghdl_Create_Delayed_Signal);
+ New_Association
+ (Assoc,
+ New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr));
+ if Data.Param = Null_Iir then
+ Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0));
+ else
+ Val := Chap7.Translate_Expression (Data.Param);
+ end if;
+ New_Association (Assoc, Val);
+ Type_Info := Get_Type_Info (Targ);
+ New_Assign_Stmt
+ (M2Lv (Targ),
+ New_Convert_Ov (New_Function_Call (Assoc),
+ Type_Info.Ortho_Type (Mode_Signal)));
+ end Create_Delayed_Signal_Noncomposite;
+
+ function Create_Delayed_Signal_Prepare_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data)
+ return Delayed_Signal_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ Res : Delayed_Signal_Data;
+ begin
+ Res.Param := Data.Param;
+ if Get_Type_Info (Targ).Type_Mode = Type_Mode_Record then
+ Res.Pfx := Stabilize (Data.Pfx);
+ else
+ Res.Pfx := Chap3.Get_Array_Base (Data.Pfx);
+ end if;
+ return Res;
+ end Create_Delayed_Signal_Prepare_Composite;
+
+ function Create_Delayed_Signal_Update_Data_Array
+ (Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode)
+ return Delayed_Signal_Data
+ is
+ begin
+ return Delayed_Signal_Data'
+ (Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type,
+ New_Obj_Value (Index)),
+ Param => Data.Param);
+ end Create_Delayed_Signal_Update_Data_Array;
+
+ function Create_Delayed_Signal_Update_Data_Record
+ (Data : Delayed_Signal_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Delayed_Signal_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Delayed_Signal_Data'
+ (Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El),
+ Param => Data.Param);
+ end Create_Delayed_Signal_Update_Data_Record;
+
+ procedure Create_Delayed_Signal_Finish_Data_Composite
+ (Data : in out Delayed_Signal_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Create_Delayed_Signal_Finish_Data_Composite;
+
+ procedure Create_Delayed_Signal is new Foreach_Non_Composite
+ (Data_Type => Delayed_Signal_Data,
+ Composite_Data_Type => Delayed_Signal_Data,
+ Do_Non_Composite => Create_Delayed_Signal_Noncomposite,
+ Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite,
+ Update_Data_Array => Create_Delayed_Signal_Update_Data_Array,
+ Finish_Data_Array => Create_Delayed_Signal_Finish_Data_Composite,
+ Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite,
+ Update_Data_Record => Create_Delayed_Signal_Update_Data_Record,
+ Finish_Data_Record => Create_Delayed_Signal_Finish_Data_Composite);
+
+ procedure Elab_Signal_Delayed_Attribute (Decl : Iir)
+ is
+ Name_Node : Mnode;
+ Sig_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ Pfx_Node : Mnode;
+ Data: Delayed_Signal_Data;
+ begin
+ Name_Node := Chap6.Translate_Name (Decl);
+ Sig_Type := Get_Type (Decl);
+ Type_Info := Get_Info (Sig_Type);
+
+ if Is_Complex_Type (Type_Info) then
+ Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node);
+ -- We cannot stabilize NAME_NODE, since Allocate_Complex_Object
+ -- assign it.
+ Name_Node := Chap6.Translate_Name (Decl);
+ end if;
+
+ Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl));
+ Data := Delayed_Signal_Data'(Pfx => Pfx_Node,
+ Param => Get_Parameter (Decl));
+
+ Create_Delayed_Signal (Name_Node, Get_Type (Decl), Data);
+ end Elab_Signal_Delayed_Attribute;
+
+ procedure Elab_File_Declaration (Decl : Iir_File_Declaration)
+ is
+ Constr : O_Assoc_List;
+ Name : Mnode;
+ File_Name : Iir;
+ Open_Kind : Iir;
+ Mode_Val : O_Enode;
+ Str : O_Enode;
+ Is_Text : Boolean;
+ Info : Type_Info_Acc;
+ begin
+ -- Elaborate the file.
+ Name := Chap6.Translate_Name (Decl);
+ if Get_Object_Kind (Name) /= Mode_Value then
+ raise Internal_Error;
+ end if;
+ Is_Text := Get_Text_File_Flag (Get_Type (Decl));
+ if Is_Text then
+ Start_Association (Constr, Ghdl_Text_File_Elaborate);
+ else
+ Start_Association (Constr, Ghdl_File_Elaborate);
+ Info := Get_Info (Get_Type (Decl));
+ if Info.T.File_Signature /= O_Dnode_Null then
+ New_Association
+ (Constr, New_Address (New_Obj (Info.T.File_Signature),
+ Char_Ptr_Type));
+ else
+ New_Association (Constr,
+ New_Lit (New_Null_Access (Char_Ptr_Type)));
+ end if;
+ end if;
+ New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr));
+
+ -- If file_open_information is present, open the file.
+ File_Name := Get_File_Logical_Name (Decl);
+ if File_Name = Null_Iir then
+ return;
+ end if;
+ Open_Temp;
+ Name := Chap6.Translate_Name (Decl);
+ Open_Kind := Get_File_Open_Kind (Decl);
+ if Open_Kind /= Null_Iir then
+ Mode_Val := New_Convert_Ov
+ (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type);
+ else
+ case Get_Mode (Decl) is
+ when Iir_In_Mode =>
+ Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0));
+ when Iir_Out_Mode =>
+ Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ Str := Chap7.Translate_Expression (File_Name, String_Type_Definition);
+
+ if Is_Text then
+ Start_Association (Constr, Ghdl_Text_File_Open);
+ else
+ Start_Association (Constr, Ghdl_File_Open);
+ end if;
+ New_Association (Constr, M2E (Name));
+ New_Association (Constr, Mode_Val);
+ New_Association (Constr, Str);
+ New_Procedure_Call (Constr);
+ Close_Temp;
+ end Elab_File_Declaration;
+
+ procedure Final_File_Declaration (Decl : Iir_File_Declaration)
+ is
+ Constr : O_Assoc_List;
+ Name : Mnode;
+ Is_Text : Boolean;
+ begin
+ Is_Text := Get_Text_File_Flag (Get_Type (Decl));
+
+ Open_Temp;
+ Name := Chap6.Translate_Name (Decl);
+ Stabilize (Name);
+
+ -- LRM 3.4.1 File Operations
+ -- An implicit call to FILE_CLOSE exists in a subprogram body for
+ -- every file object declared in the corresponding subprogram
+ -- declarative part. Each such call associates a unique file object
+ -- with the formal parameter F and is called whenever the
+ -- corresponding subprogram completes its execution.
+ if Is_Text then
+ Start_Association (Constr, Ghdl_Text_File_Close);
+ else
+ Start_Association (Constr, Ghdl_File_Close);
+ end if;
+ New_Association (Constr, M2E (Name));
+ New_Procedure_Call (Constr);
+
+ if Is_Text then
+ Start_Association (Constr, Ghdl_Text_File_Finalize);
+ else
+ Start_Association (Constr, Ghdl_File_Finalize);
+ end if;
+ New_Association (Constr, M2E (Name));
+ New_Procedure_Call (Constr);
+
+ Close_Temp;
+ end Final_File_Declaration;
+
+ procedure Translate_Type_Declaration (Decl : Iir)
+ is
+ begin
+ Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl),
+ Get_Identifier (Decl));
+ end Translate_Type_Declaration;
+
+ procedure Translate_Anonymous_Type_Declaration (Decl : Iir)
+ is
+ Mark : Id_Mark_Type;
+ Mark1 : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ Push_Identifier_Prefix (Mark1, "BT");
+ Chap3.Translate_Type_Definition (Get_Type_Definition (Decl));
+ Pop_Identifier_Prefix (Mark1);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Anonymous_Type_Declaration;
+
+ procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration)
+ is
+ begin
+ Chap3.Translate_Named_Type_Definition (Get_Type (Decl),
+ Get_Identifier (Decl));
+ end Translate_Subtype_Declaration;
+
+ procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration)
+ is
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl));
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Bool_Type_Declaration;
+
+ procedure Translate_Object_Alias_Declaration
+ (Decl : Iir_Object_Alias_Declaration)
+ is
+ Decl_Type : Iir;
+ Info : Alias_Info_Acc;
+ Tinfo : Type_Info_Acc;
+ Atype : O_Tnode;
+ begin
+ Decl_Type := Get_Type (Decl);
+
+ Chap3.Translate_Named_Type_Definition
+ (Decl_Type, Get_Identifier (Decl));
+
+ Info := Add_Info (Decl, Kind_Alias);
+ case Get_Kind (Get_Object_Prefix (Decl)) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ Info.Alias_Kind := Mode_Signal;
+ when others =>
+ Info.Alias_Kind := Mode_Value;
+ end case;
+
+ Tinfo := Get_Info (Decl_Type);
+ case Tinfo.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ -- create an object.
+ -- At elaboration: copy base from name, copy bounds from type,
+ -- check for matching bounds.
+ Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind);
+ when Type_Mode_Array
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc =>
+ -- Create an object pointer.
+ -- At elaboration: copy base from name.
+ Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind);
+ when Type_Mode_Scalar =>
+ case Info.Alias_Kind is
+ when Mode_Signal =>
+ Atype := Tinfo.Ortho_Type (Mode_Signal);
+ when Mode_Value =>
+ Atype := Tinfo.Ortho_Ptr_Type (Mode_Value);
+ end case;
+ when Type_Mode_Record =>
+ -- Create an object pointer.
+ -- At elaboration: copy base from name.
+ Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Info.Alias_Var := Create_Var (Create_Var_Identifier (Decl), Atype);
+ end Translate_Object_Alias_Declaration;
+
+ procedure Elab_Object_Alias_Declaration
+ (Decl : Iir_Object_Alias_Declaration)
+ is
+ Decl_Type : Iir;
+ Name : Iir;
+ Name_Node : Mnode;
+ Alias_Node : Mnode;
+ Alias_Info : Alias_Info_Acc;
+ Name_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Kind : Object_Kind_Type;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Decl));
+
+ Decl_Type := Get_Type (Decl);
+ Tinfo := Get_Info (Decl_Type);
+
+ Alias_Info := Get_Info (Decl);
+ Chap3.Elab_Object_Subtype (Decl_Type);
+ Name := Get_Name (Decl);
+ Name_Type := Get_Type (Name);
+ Name_Node := Chap6.Translate_Name (Name);
+ Kind := Get_Object_Kind (Name_Node);
+
+ case Tinfo.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Open_Temp;
+ Stabilize (Name_Node);
+ Alias_Node := Stabilize
+ (Get_Var (Alias_Info.Alias_Var,
+ Tinfo, Alias_Info.Alias_Kind));
+ Copy_Fat_Pointer (Alias_Node, Name_Node);
+ Close_Temp;
+ when Type_Mode_Array =>
+ Open_Temp;
+ Stabilize (Name_Node);
+ New_Assign_Stmt
+ (Get_Var (Alias_Info.Alias_Var),
+ M2E (Chap3.Get_Array_Base (Name_Node)));
+ Chap3.Check_Array_Match (Decl_Type, T2M (Decl_Type, Kind),
+ Name_Type, Name_Node,
+ Decl);
+ Close_Temp;
+ when Type_Mode_Acc
+ | Type_Mode_Fat_Acc =>
+ New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var),
+ M2Addr (Name_Node));
+ when Type_Mode_Scalar =>
+ case Alias_Info.Alias_Kind is
+ when Mode_Value =>
+ New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var),
+ M2Addr (Name_Node));
+ when Mode_Signal =>
+ New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var),
+ M2E (Name_Node));
+ end case;
+ when Type_Mode_Record =>
+ Open_Temp;
+ Stabilize (Name_Node);
+ New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var),
+ M2Addr (Name_Node));
+ Close_Temp;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Elab_Object_Alias_Declaration;
+
+ procedure Translate_Port_Chain (Parent : Iir)
+ is
+ Port : Iir;
+ begin
+ Port := Get_Port_Chain (Parent);
+ while Port /= Null_Iir loop
+ Create_Signal (Port);
+ Port := Get_Chain (Port);
+ end loop;
+ end Translate_Port_Chain;
+
+ procedure Translate_Generic_Chain (Parent : Iir)
+ is
+ Decl : Iir;
+ begin
+ Decl := Get_Generic_Chain (Parent);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kinds_Interface_Object_Declaration =>
+ Create_Object (Decl);
+ when Iir_Kind_Interface_Package_Declaration =>
+ Create_Package_Interface (Decl);
+ when others =>
+ Error_Kind ("translate_generic_chain", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Translate_Generic_Chain;
+
+ -- Create instance record for a component.
+ procedure Translate_Component_Declaration (Decl : Iir)
+ is
+ Mark : Id_Mark_Type;
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Add_Info (Decl, Kind_Component);
+ Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ Push_Instance_Factory (Info.Comp_Scope'Access);
+
+ Info.Comp_Link := Add_Instance_Factory_Field
+ (Wki_Instance, Rtis.Ghdl_Component_Link_Type);
+
+ -- Generic and ports.
+ Translate_Generic_Chain (Decl);
+ Translate_Port_Chain (Decl);
+
+ Pop_Instance_Factory (Info.Comp_Scope'Access);
+ New_Type_Decl (Create_Identifier ("_COMPTYPE"),
+ Get_Scope_Type (Info.Comp_Scope));
+ Info.Comp_Ptr_Type := New_Access_Type
+ (Get_Scope_Type (Info.Comp_Scope));
+ New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Component_Declaration;
+
+ procedure Translate_Declaration (Decl : Iir)
+ is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Configuration_Specification =>
+ null;
+ when Iir_Kind_Disconnection_Specification =>
+ null;
+
+ when Iir_Kind_Component_Declaration =>
+ Chap4.Translate_Component_Declaration (Decl);
+ when Iir_Kind_Type_Declaration =>
+ Chap4.Translate_Type_Declaration (Decl);
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Chap4.Translate_Anonymous_Type_Declaration (Decl);
+ when Iir_Kind_Subtype_Declaration =>
+ Chap4.Translate_Subtype_Declaration (Decl);
+
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ raise Internal_Error;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+
+ --when Iir_Kind_Implicit_Function_Declaration =>
+ --when Iir_Kind_Signal_Declaration
+ -- | Iir_Kind_Interface_Signal_Declaration =>
+ -- Chap4.Create_Object (Decl);
+
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration =>
+ Create_Object (Decl);
+
+ when Iir_Kind_Signal_Declaration =>
+ Create_Signal (Decl);
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ Translate_Object_Alias_Declaration (Decl);
+
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_File_Declaration =>
+ Create_File_Object (Decl);
+
+ when Iir_Kind_Attribute_Declaration =>
+ -- Useless as attribute declarations have a type mark.
+ Chap3.Translate_Object_Subtype (Decl);
+
+ when Iir_Kind_Attribute_Specification =>
+ Chap5.Translate_Attribute_Specification (Decl);
+
+ when Iir_Kinds_Signal_Attribute =>
+ Chap4.Create_Implicit_Signal (Decl);
+
+ when Iir_Kind_Guard_Signal_Declaration =>
+ Create_Signal (Decl);
+
+ when Iir_Kind_Group_Template_Declaration =>
+ null;
+ when Iir_Kind_Group_Declaration =>
+ null;
+
+ when others =>
+ Error_Kind ("translate_declaration", Decl);
+ end case;
+ end Translate_Declaration;
+
+ procedure Translate_Resolution_Function (Func : Iir)
+ is
+ -- Type of the resolution function parameter.
+ El_Type : Iir;
+ El_Info : Type_Info_Acc;
+ Finfo : constant Subprg_Info_Acc := Get_Info (Func);
+ Interface_List : O_Inter_List;
+ Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv;
+ Id : O_Ident;
+ Itype : O_Tnode;
+ Unused_Instance : O_Dnode;
+ begin
+ if Rinfo = null then
+ -- Not a resolution function
+ return;
+ end if;
+
+ -- Declare the procedure.
+ Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV");
+ Start_Procedure_Decl (Interface_List, Id, Global_Storage);
+
+ -- The instance.
+ if Chap2.Has_Current_Subprg_Instance then
+ Chap2.Add_Subprg_Instance_Interfaces (Interface_List,
+ Rinfo.Var_Instance);
+ else
+ -- Create a dummy instance parameter
+ New_Interface_Decl (Interface_List, Unused_Instance,
+ Wki_Instance, Ghdl_Ptr_Type);
+ Rinfo.Var_Instance := Chap2.Null_Subprg_Instance;
+ end if;
+
+ -- The signal.
+ El_Type := Get_Type (Get_Interface_Declaration_Chain (Func));
+ El_Type := Get_Element_Subtype (El_Type);
+ El_Info := Get_Info (El_Type);
+ -- FIXME: create a function for getting the type of an interface.
+ case El_Info.Type_Mode is
+ when Type_Mode_Thin =>
+ Itype := El_Info.Ortho_Type (Mode_Signal);
+ when Type_Mode_Fat =>
+ Itype := El_Info.Ortho_Ptr_Type (Mode_Signal);
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ New_Interface_Decl
+ (Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype);
+
+ New_Interface_Decl
+ (Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"),
+ Ghdl_Bool_Array_Ptr);
+ New_Interface_Decl
+ (Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"),
+ Ghdl_Index_Type);
+ New_Interface_Decl
+ (Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"),
+ Ghdl_Index_Type);
+ New_Interface_Decl
+ (Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"),
+ Ghdl_Index_Type);
+
+ Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func);
+ end Translate_Resolution_Function;
+
+ type Read_Source_Kind is (Read_Port, Read_Driver);
+ type Read_Source_Data is record
+ Sig : Mnode;
+ Drv_Index : O_Dnode;
+ Kind : Read_Source_Kind;
+ end record;
+
+ procedure Read_Source_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data)
+ is
+ Assoc : O_Assoc_List;
+ Targ_Info : Type_Info_Acc;
+ E : O_Enode;
+ begin
+ Targ_Info := Get_Info (Targ_Type);
+ case Data.Kind is
+ when Read_Port =>
+ Start_Association (Assoc, Ghdl_Signal_Read_Port);
+ when Read_Driver =>
+ Start_Association (Assoc, Ghdl_Signal_Read_Driver);
+ end case;
+
+ New_Association
+ (Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Obj_Value (Data.Drv_Index));
+ E := New_Convert_Ov (New_Function_Call (Assoc),
+ Targ_Info.Ortho_Ptr_Type (Mode_Value));
+ New_Assign_Stmt (M2Lv (Targ),
+ New_Value (New_Access_Element (E)));
+ end Read_Source_Non_Composite;
+
+ function Read_Source_Prepare_Data_Array
+ (Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data)
+ return Read_Source_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Data;
+ end Read_Source_Prepare_Data_Array;
+
+ function Read_Source_Prepare_Data_Record
+ (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data)
+ return Read_Source_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Read_Source_Data'(Sig => Stabilize (Data.Sig),
+ Drv_Index => Data.Drv_Index,
+ Kind => Data.Kind);
+ end Read_Source_Prepare_Data_Record;
+
+ function Read_Source_Update_Data_Array
+ (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode)
+ return Read_Source_Data
+ is
+ begin
+ return Read_Source_Data'
+ (Sig => Chap3.Index_Base (Data.Sig, Targ_Type,
+ New_Obj_Value (Index)),
+ Drv_Index => Data.Drv_Index,
+ Kind => Data.Kind);
+ end Read_Source_Update_Data_Array;
+
+ function Read_Source_Update_Data_Record
+ (Data : Read_Source_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Read_Source_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Read_Source_Data'
+ (Sig => Chap6.Translate_Selected_Element (Data.Sig, El),
+ Drv_Index => Data.Drv_Index,
+ Kind => Data.Kind);
+ end Read_Source_Update_Data_Record;
+
+ procedure Read_Source_Finish_Data_Composite
+ (Data : in out Read_Source_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Read_Source_Finish_Data_Composite;
+
+ procedure Read_Signal_Source is new Foreach_Non_Composite
+ (Data_Type => Read_Source_Data,
+ Composite_Data_Type => Read_Source_Data,
+ Do_Non_Composite => Read_Source_Non_Composite,
+ Prepare_Data_Array => Read_Source_Prepare_Data_Array,
+ Update_Data_Array => Read_Source_Update_Data_Array,
+ Finish_Data_Array => Read_Source_Finish_Data_Composite,
+ Prepare_Data_Record => Read_Source_Prepare_Data_Record,
+ Update_Data_Record => Read_Source_Update_Data_Record,
+ Finish_Data_Record => Read_Source_Finish_Data_Composite);
+
+ procedure Translate_Resolution_Function_Body (Func : Iir)
+ is
+ -- Type of the resolution function parameter.
+ Arr_Type : Iir;
+ Base_Type : Iir;
+ Base_Info : Type_Info_Acc;
+ Index_Info : Index_Info_Acc;
+
+ -- Type of parameter element.
+ El_Type : Iir;
+ El_Info : Type_Info_Acc;
+
+ -- Type of the function return value.
+ Ret_Type : Iir;
+ Ret_Info : Type_Info_Acc;
+
+ -- Type and info of the array index.
+ Index_Type : Iir;
+ Index_Tinfo : Type_Info_Acc;
+
+ -- Local variables.
+ Var_I : O_Dnode;
+ Var_J : O_Dnode;
+ Var_Length : O_Dnode;
+ Var_Res : O_Dnode;
+
+ Vals : Mnode;
+ Res : Mnode;
+
+ If_Blk : O_If_Block;
+ Label : O_Snode;
+
+ V : Mnode;
+
+ Var_Bound : O_Dnode;
+ Var_Range_Ptr : O_Dnode;
+ Var_Array : O_Dnode;
+ Finfo : constant Subprg_Info_Acc := Get_Info (Func);
+ Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv;
+ Assoc : O_Assoc_List;
+
+ Data : Read_Source_Data;
+ begin
+ if Rinfo = null then
+ -- No resolver for this function
+ return;
+ end if;
+
+ Ret_Type := Get_Return_Type (Func);
+ Ret_Info := Get_Info (Ret_Type);
+
+ Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func));
+ Base_Type := Get_Base_Type (Arr_Type);
+ Index_Info := Get_Info
+ (Get_First_Element (Get_Index_Subtype_Definition_List (Base_Type)));
+ Base_Info := Get_Info (Base_Type);
+
+ El_Type := Get_Element_Subtype (Arr_Type);
+ El_Info := Get_Info (El_Type);
+
+ Index_Type := Get_Index_Type (Arr_Type, 0);
+ Index_Tinfo := Get_Info (Index_Type);
+
+ Start_Subprogram_Body (Rinfo.Resolv_Func);
+ if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then
+ Chap2.Start_Subprg_Instance_Use (Rinfo.Var_Instance);
+ end if;
+ Push_Local_Factory;
+
+ -- A signal.
+
+ New_Var_Decl
+ (Var_Res, Get_Identifier ("res"),
+ O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value));
+
+ -- I, J.
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_J, Get_Identifier ("J"),
+ O_Storage_Local, Ghdl_Index_Type);
+
+ -- Length.
+ New_Var_Decl
+ (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type);
+
+ New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local,
+ Base_Info.T.Bounds_Type);
+ New_Var_Decl (Var_Array, Get_Identifier ("ARRAY"), O_Storage_Local,
+ Base_Info.Ortho_Type (Mode_Value));
+
+ New_Var_Decl (Var_Range_Ptr, Get_Identifier ("RANGE_PTR"),
+ O_Storage_Local, Index_Tinfo.T.Range_Ptr_Type);
+
+ Open_Temp;
+
+ case El_Info.Type_Mode is
+ when Type_Mode_Thin =>
+ Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal);
+ when Type_Mode_Fat =>
+ Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal);
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+
+ -- * length := vec_len + nports;
+ New_Assign_Stmt (New_Obj (Var_Length),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Rinfo.Var_Vlen),
+ New_Obj_Value (Rinfo.Var_Nbr_Ports)));
+
+ -- * range_ptr := BOUND.dim_1'address;
+ New_Assign_Stmt
+ (New_Obj (Var_Range_Ptr),
+ New_Address (New_Selected_Element (New_Obj (Var_Bound),
+ Index_Info.Index_Field),
+ Index_Tinfo.T.Range_Ptr_Type));
+
+ -- Create range from length
+ Chap3.Create_Range_From_Length
+ (Index_Type, Var_Length, Var_Range_Ptr, Func);
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Var_Array),
+ Base_Info.T.Bounds_Field (Mode_Value)),
+ New_Address (New_Obj (Var_Bound), Base_Info.T.Bounds_Ptr_Type));
+
+ -- Allocate the array.
+ Chap3.Allocate_Fat_Array_Base
+ (Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type);
+
+ -- Fill the array
+ -- 1. From ports.
+ -- * I := 0;
+ Init_Var (Var_I);
+ -- * loop
+ Start_Loop_Stmt (Label);
+ -- * exit when I = nports;
+ Gen_Exit_When (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Rinfo.Var_Nbr_Ports),
+ Ghdl_Bool_Type));
+ -- fill array[i]
+ V := Chap3.Index_Base
+ (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)),
+ Base_Type, New_Obj_Value (Var_I));
+ Data := Read_Source_Data'(Vals, Var_I, Read_Port);
+ Read_Signal_Source (V, El_Type, Data);
+
+ -- * I := I + 1;
+ Inc_Var (Var_I);
+ -- * end loop;
+ Finish_Loop_Stmt (Label);
+
+ -- 2. From drivers.
+ -- * J := 0;
+ -- * loop
+ -- * exit when j = var_max;
+ -- * if vec[j] then
+ --
+ -- * ptr := get_signal_driver (sig, j);
+ -- * array[i].XXX := *ptr
+ --
+ -- * i := i + 1;
+ -- * end if;
+ -- * J := J + 1;
+ -- * end loop;
+ Init_Var (Var_J);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_J),
+ New_Obj_Value (Rinfo.Var_Nbr_Drv),
+ Ghdl_Bool_Type));
+ Start_If_Stmt
+ (If_Blk,
+ New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec),
+ New_Obj_Value (Var_J))));
+
+ V := Chap3.Index_Base
+ (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)),
+ Base_Type, New_Obj_Value (Var_I));
+ Data := Read_Source_Data'(Vals, Var_J, Read_Driver);
+ Read_Signal_Source (V, El_Type, Data);
+
+ Inc_Var (Var_I);
+ Finish_If_Stmt (If_Blk);
+
+ Inc_Var (Var_J);
+ Finish_Loop_Stmt (Label);
+
+ if Finfo.Res_Interface /= O_Dnode_Null then
+ Res := Lo2M (Var_Res, Ret_Info, Mode_Value);
+ if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then
+ Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res);
+ end if;
+ end if;
+
+ -- Call the resolution function.
+ if Finfo.Use_Stack2 then
+ Create_Temp_Stack2_Mark;
+ end if;
+
+ Start_Association (Assoc, Finfo.Ortho_Func);
+ if Finfo.Res_Interface /= O_Dnode_Null then
+ New_Association (Assoc, M2E (Res));
+ end if;
+ Chap2.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance);
+ New_Association
+ (Assoc, New_Address (New_Obj (Var_Array),
+ Base_Info.Ortho_Ptr_Type (Mode_Value)));
+
+ if Finfo.Res_Interface = O_Dnode_Null then
+ Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value);
+ else
+ New_Procedure_Call (Assoc);
+ end if;
+
+ if El_Type /= Ret_Type then
+ Res := E2M
+ (Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type,
+ Mode_Value, Func),
+ El_Info, Mode_Value);
+ end if;
+ Chap7.Set_Driving_Value (Vals, El_Type, Res);
+
+ Close_Temp;
+ Pop_Local_Factory;
+ if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then
+ Chap2.Finish_Subprg_Instance_Use (Rinfo.Var_Instance);
+ end if;
+ Finish_Subprogram_Body;
+ end Translate_Resolution_Function_Body;
+
+ procedure Translate_Declaration_Chain (Parent : Iir)
+ is
+ Info : Subprg_Info_Acc;
+ El : Iir;
+ begin
+ El := Get_Declaration_Chain (Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ -- Translate interfaces.
+ if (not Flag_Discard_Unused or else Get_Use_Flag (El))
+ and then not Is_Second_Subprogram_Specification (El)
+ then
+ Info := Add_Info (El, Kind_Subprg);
+ Chap2.Translate_Subprogram_Interfaces (El);
+ if Get_Kind (El) = Iir_Kind_Function_Declaration then
+ if Get_Resolution_Function_Flag (El) then
+ Info.Subprg_Resolv := new Subprg_Resolv_Info;
+ end if;
+ end if;
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when others =>
+ Translate_Declaration (El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Declaration_Chain;
+
+ procedure Translate_Declaration_Chain_Subprograms (Parent : Iir)
+ is
+ El : Iir;
+ Infos : Chap7.Implicit_Subprogram_Infos;
+ begin
+ El := Get_Declaration_Chain (Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ -- Translate only if used.
+ if Get_Info (El) /= null then
+ Chap2.Translate_Subprogram_Declaration (El);
+ Translate_Resolution_Function (El);
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ -- Do not translate body if generating only specs (for
+ -- subprograms in an entity).
+ if Global_Storage /= O_Storage_External
+ and then
+ (not Flag_Discard_Unused
+ or else
+ Get_Use_Flag (Get_Subprogram_Specification (El)))
+ then
+ Chap2.Translate_Subprogram_Body (El);
+ Translate_Resolution_Function_Body
+ (Get_Subprogram_Specification (El));
+ end if;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ Chap3.Translate_Type_Subprograms (El);
+ Chap7.Init_Implicit_Subprogram_Infos (Infos);
+ when Iir_Kind_Protected_Type_Body =>
+ Chap3.Translate_Protected_Type_Body (El);
+ Chap3.Translate_Protected_Type_Body_Subprograms (El);
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ if Flag_Discard_Unused_Implicit
+ and then not Get_Use_Flag (El)
+ then
+ case Get_Implicit_Definition (El) is
+ when Iir_Predefined_Array_Equality
+ | Iir_Predefined_Array_Greater
+ | Iir_Predefined_Record_Equality =>
+ -- Used implicitly in case statement or other
+ -- predefined equality.
+ Chap7.Translate_Implicit_Subprogram (El, Infos);
+ when others =>
+ null;
+ end case;
+ else
+ Chap7.Translate_Implicit_Subprogram (El, Infos);
+ end if;
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Declaration_Chain_Subprograms;
+
+ procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean)
+ is
+ Decl : Iir;
+ begin
+ Decl := Get_Declaration_Chain (Parent);
+ Need_Final := False;
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Component_Declaration =>
+ null;
+ when Iir_Kind_Configuration_Specification =>
+ null;
+ when Iir_Kind_Disconnection_Specification =>
+ Chap5.Elab_Disconnection_Specification (Decl);
+
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ Chap3.Elab_Type_Declaration (Decl);
+ when Iir_Kind_Subtype_Declaration =>
+ Chap3.Elab_Subtype_Declaration (Decl);
+
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+
+ --when Iir_Kind_Signal_Declaration =>
+ -- Chap1.Elab_Signal (Decl);
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration =>
+ Elab_Object (Decl);
+ if Get_Kind (Get_Type (Decl))
+ = Iir_Kind_Protected_Type_Declaration
+ then
+ Need_Final := True;
+ end if;
+
+ when Iir_Kind_Signal_Declaration =>
+ Elab_Signal_Declaration (Decl, Parent, False);
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ Elab_Object_Alias_Declaration (Decl);
+
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_File_Declaration =>
+ Elab_File_Declaration (Decl);
+ Need_Final := True;
+
+ when Iir_Kind_Attribute_Declaration =>
+ Chap3.Elab_Object_Subtype (Get_Type (Decl));
+
+ when Iir_Kind_Attribute_Specification =>
+ Chap5.Elab_Attribute_Specification (Decl);
+
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ if Get_Info (Decl) /= null then
+ Chap2.Elab_Subprogram_Interfaces (Decl);
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ Elab_Signal_Attribute (Decl);
+
+ when Iir_Kind_Delayed_Attribute =>
+ Elab_Signal_Delayed_Attribute (Decl);
+
+ when Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+
+ when others =>
+ Error_Kind ("elab_declaration_chain", Decl);
+ end case;
+
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Elab_Declaration_Chain;
+
+ procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean)
+ is
+ Decl : Iir;
+ begin
+ Decl := Get_Declaration_Chain (Parent);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_File_Declaration =>
+ Final_File_Declaration (Decl);
+ when Iir_Kind_Variable_Declaration =>
+ if Get_Kind (Get_Type (Decl))
+ = Iir_Kind_Protected_Type_Declaration
+ then
+ Fini_Protected_Object (Decl);
+ end if;
+ if Deallocate then
+ Fini_Object (Decl);
+ end if;
+ when Iir_Kind_Constant_Declaration =>
+ if Deallocate then
+ Fini_Object (Decl);
+ end if;
+ when others =>
+ null;
+ end case;
+
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Final_Declaration_Chain;
+
+ type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out);
+
+ -- Create subprogram for an association conversion.
+ -- STMT is the statement/block_header containing the association.
+ -- BLOCK is the architecture/block containing the instance.
+ -- ASSOC is the association and MODE the conversion to work on.
+ -- CONV_INFO is the result place holder.
+ -- BASE_BLOCK is the base architecture/block containing the instance.
+ -- ENTITY is the entity/component instantiated (null for block_stmt)
+ procedure Translate_Association_Subprogram
+ (Stmt : Iir;
+ Block : Iir;
+ Assoc : Iir;
+ Mode : Conv_Mode;
+ Conv_Info : in out Assoc_Conv_Info;
+ Base_Block : Iir;
+ Entity : Iir)
+ is
+ Formal : constant Iir := Get_Formal (Assoc);
+ Actual : constant Iir := Get_Actual (Assoc);
+
+ Mark2, Mark3 : Id_Mark_Type;
+ Inter_List : O_Inter_List;
+ In_Type, Out_Type : Iir;
+ In_Info, Out_Info : Type_Info_Acc;
+ Itype : O_Tnode;
+ El_List : O_Element_List;
+ Block_Info : constant Block_Info_Acc := Get_Info (Base_Block);
+ Stmt_Info : Block_Info_Acc;
+ Entity_Info : Ortho_Info_Acc;
+ Var_Data : O_Dnode;
+
+ -- Variables for body.
+ E : O_Enode;
+ V : O_Dnode;
+ V1 : O_Lnode;
+ V_Out : Mnode;
+ R : O_Enode;
+ Constr : O_Assoc_List;
+ Subprg_Info : Subprg_Info_Acc;
+ Res : Mnode;
+ Imp : Iir;
+ Func : Iir;
+ begin
+ case Mode is
+ when Conv_Mode_In =>
+ -- IN: from actual to formal.
+ Push_Identifier_Prefix (Mark2, "CONVIN");
+ Out_Type := Get_Type (Formal);
+ In_Type := Get_Type (Actual);
+ Imp := Get_In_Conversion (Assoc);
+
+ when Conv_Mode_Out =>
+ -- OUT: from formal to actual.
+ Push_Identifier_Prefix (Mark2, "CONVOUT");
+ In_Type := Get_Type (Formal);
+ Out_Type := Get_Type (Actual);
+ Imp := Get_Out_Conversion (Assoc);
+
+ end case;
+ -- FIXME: individual assoc -> overload.
+ Push_Identifier_Prefix
+ (Mark3, Get_Identifier (Get_Association_Interface (Assoc)));
+
+ -- Handle anonymous subtypes.
+ Chap3.Translate_Anonymous_Type_Definition (Out_Type, False);
+ Chap3.Translate_Anonymous_Type_Definition (In_Type, False);
+ Out_Info := Get_Info (Out_Type);
+ In_Info := Get_Info (In_Type);
+
+ -- Start record containing data for the conversion function.
+ Start_Record_Type (El_List);
+
+ -- Add instance field.
+ Conv_Info.Instance_Block := Base_Block;
+ New_Record_Field
+ (El_List, Conv_Info.Instance_Field, Wki_Instance,
+ Block_Info.Block_Decls_Ptr_Type);
+
+ if Entity /= Null_Iir then
+ Conv_Info.Instantiated_Entity := Entity;
+ Entity_Info := Get_Info (Entity);
+ declare
+ Ptr : O_Tnode;
+ begin
+ if Entity_Info.Kind = Kind_Component then
+ Ptr := Entity_Info.Comp_Ptr_Type;
+ else
+ Ptr := Entity_Info.Block_Decls_Ptr_Type;
+ end if;
+ New_Record_Field
+ (El_List, Conv_Info.Instantiated_Field,
+ Get_Identifier ("instantiated"), Ptr);
+ end;
+ else
+ Conv_Info.Instantiated_Entity := Null_Iir;
+ Conv_Info.Instantiated_Field := O_Fnode_Null;
+ end if;
+
+ -- Add input.
+ case In_Info.Type_Mode is
+ when Type_Mode_Thin =>
+ Itype := In_Info.Ortho_Type (Mode_Signal);
+ when Type_Mode_Fat =>
+ Itype := In_Info.Ortho_Ptr_Type (Mode_Signal);
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ end case;
+ New_Record_Field
+ (El_List, Conv_Info.In_Field, Get_Identifier ("val_in"), Itype);
+
+ -- Add output.
+ New_Record_Field
+ (El_List, Conv_Info.Out_Field, Get_Identifier ("val_out"),
+ Get_Object_Type (Out_Info, Mode_Signal));
+ Finish_Record_Type (El_List, Conv_Info.Record_Type);
+ New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type);
+ Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type);
+ New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type);
+
+ -- Declare the subprogram.
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier, O_Storage_Private);
+ New_Interface_Decl
+ (Inter_List, Var_Data, Get_Identifier ("data"),
+ Conv_Info.Record_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg);
+
+ Start_Subprogram_Body (Conv_Info.Subprg);
+ Push_Local_Factory;
+ Open_Temp;
+
+ -- Add an access to local block.
+ V := Create_Temp_Init
+ (Block_Info.Block_Decls_Ptr_Type,
+ New_Value_Selected_Acc_Value (New_Obj (Var_Data),
+ Conv_Info.Instance_Field));
+ Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V);
+
+ -- Add an access to instantiated entity.
+ -- This may be used to do some type checks.
+ if Conv_Info.Instantiated_Entity /= Null_Iir then
+ declare
+ Ptr_Type : O_Tnode;
+ begin
+ if Entity_Info.Kind = Kind_Component then
+ Ptr_Type := Entity_Info.Comp_Ptr_Type;
+ else
+ Ptr_Type := Entity_Info.Block_Decls_Ptr_Type;
+ end if;
+ V := Create_Temp_Init
+ (Ptr_Type,
+ New_Value_Selected_Acc_Value (New_Obj (Var_Data),
+ Conv_Info.Instantiated_Field));
+ if Entity_Info.Kind = Kind_Component then
+ Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V);
+ else
+ Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V);
+ end if;
+ end;
+ end if;
+
+ -- Add access to the instantiation-specific data.
+ -- This is used only for anonymous subtype variables.
+ -- FIXME: what if STMT is a binding_indication ?
+ Stmt_Info := Get_Info (Stmt);
+ if Stmt_Info /= null
+ and then Has_Scope_Type (Stmt_Info.Block_Scope)
+ then
+ Set_Scope_Via_Field (Stmt_Info.Block_Scope,
+ Stmt_Info.Block_Parent_Field,
+ Get_Info (Block).Block_Scope'Access);
+ end if;
+
+ -- Read signal value.
+ E := New_Value_Selected_Acc_Value (New_Obj (Var_Data),
+ Conv_Info.In_Field);
+ case Mode is
+ when Conv_Mode_In =>
+ R := Chap7.Translate_Signal_Effective_Value (E, In_Type);
+ when Conv_Mode_Out =>
+ R := Chap7.Translate_Signal_Driving_Value (E, In_Type);
+ end case;
+
+ case Get_Kind (Imp) is
+ when Iir_Kind_Function_Call =>
+ Func := Get_Implementation (Imp);
+ R := Chap7.Translate_Implicit_Conv
+ (R, In_Type,
+ Get_Type (Get_Interface_Declaration_Chain (Func)),
+ Mode_Value, Assoc);
+
+ -- Create result value.
+ Subprg_Info := Get_Info (Func);
+
+ if Subprg_Info.Use_Stack2 then
+ Create_Temp_Stack2_Mark;
+ end if;
+
+ if Subprg_Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ -- If we need to allocate, do it before starting the call!
+ declare
+ Res_Type : constant Iir := Get_Return_Type (Func);
+ Res_Info : constant Type_Info_Acc := Get_Info (Res_Type);
+ begin
+ Res := Create_Temp (Res_Info);
+ if Res_Info.Type_Mode /= Type_Mode_Fat_Array then
+ Chap4.Allocate_Complex_Object
+ (Res_Type, Alloc_Stack, Res);
+ end if;
+ end;
+ end if;
+
+ -- Call conversion function.
+ Start_Association (Constr, Subprg_Info.Ortho_Func);
+
+ if Subprg_Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ New_Association (Constr, M2E (Res));
+ end if;
+
+ Chap2.Add_Subprg_Instance_Assoc
+ (Constr, Subprg_Info.Subprg_Instance);
+
+ New_Association (Constr, R);
+
+ if Subprg_Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ New_Procedure_Call (Constr);
+ E := M2E (Res);
+ else
+ E := New_Function_Call (Constr);
+ end if;
+ Res := E2M
+ (Chap7.Translate_Implicit_Conv
+ (E, Get_Return_Type (Func),
+ Out_Type, Mode_Value, Imp),
+ Get_Info (Out_Type), Mode_Value);
+
+ when Iir_Kind_Type_Conversion =>
+ declare
+ Conv_Type : Iir;
+ begin
+ Conv_Type := Get_Type (Imp);
+ E := Chap7.Translate_Type_Conversion
+ (R, In_Type, Conv_Type, Assoc);
+ E := Chap7.Translate_Implicit_Conv
+ (E, Conv_Type, Out_Type, Mode_Value, Imp);
+ Res := E2M (E, Get_Info (Out_Type), Mode_Value);
+ end;
+
+ when others =>
+ Error_Kind ("Translate_Association_Subprogram", Imp);
+ end case;
+
+ -- Assign signals.
+ V1 := New_Selected_Acc_Value (New_Obj (Var_Data),
+ Conv_Info.Out_Field);
+ V_Out := Lo2M (V1, Out_Info, Mode_Signal);
+
+ case Mode is
+ when Conv_Mode_In =>
+ Chap7.Set_Effective_Value (V_Out, Out_Type, Res);
+ when Conv_Mode_Out =>
+ Chap7.Set_Driving_Value (V_Out, Out_Type, Res);
+ end case;
+
+ Close_Temp;
+ if Stmt_Info /= null
+ and then Has_Scope_Type (Stmt_Info.Block_Scope)
+ then
+ Clear_Scope (Stmt_Info.Block_Scope);
+ end if;
+ if Conv_Info.Instantiated_Entity /= Null_Iir then
+ if Entity_Info.Kind = Kind_Component then
+ Clear_Scope (Entity_Info.Comp_Scope);
+ else
+ Clear_Scope (Entity_Info.Block_Scope);
+ end if;
+ end if;
+ Clear_Scope (Block_Info.Block_Scope);
+
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ Pop_Identifier_Prefix (Mark3);
+ Pop_Identifier_Prefix (Mark2);
+ end Translate_Association_Subprogram;
+
+ -- ENTITY is null for block_statement.
+ procedure Translate_Association_Subprograms
+ (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir)
+ is
+ Assoc : Iir;
+ Info : Assoc_Info_Acc;
+ begin
+ Assoc := Get_Port_Map_Aspect_Chain (Stmt);
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression
+ then
+ Info := null;
+ if Get_In_Conversion (Assoc) /= Null_Iir then
+ Info := Add_Info (Assoc, Kind_Assoc);
+ Translate_Association_Subprogram
+ (Stmt, Block, Assoc, Conv_Mode_In, Info.Assoc_In,
+ Base_Block, Entity);
+ end if;
+ if Get_Out_Conversion (Assoc) /= Null_Iir then
+ if Info = null then
+ Info := Add_Info (Assoc, Kind_Assoc);
+ end if;
+ Translate_Association_Subprogram
+ (Stmt, Block, Assoc, Conv_Mode_Out, Info.Assoc_Out,
+ Base_Block, Entity);
+ end if;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Translate_Association_Subprograms;
+
+ procedure Elab_Conversion (Sig_In : Iir;
+ Sig_Out : Iir;
+ Reg_Subprg : O_Dnode;
+ Info : Assoc_Conv_Info;
+ Ndest : out Mnode)
+ is
+ Out_Type : Iir;
+ Out_Info : Type_Info_Acc;
+ Ssig : Mnode;
+ Constr : O_Assoc_List;
+ Var_Data : O_Dnode;
+ Data : Elab_Signal_Data;
+ begin
+ Out_Type := Get_Type (Sig_Out);
+ Out_Info := Get_Info (Out_Type);
+
+ -- Allocate data for the subprogram.
+ Var_Data := Create_Temp (Info.Record_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Data),
+ Gen_Alloc (Alloc_System,
+ New_Lit (New_Sizeof (Info.Record_Type,
+ Ghdl_Index_Type)),
+ Info.Record_Ptr_Type));
+
+ -- Set instance.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field),
+ Get_Instance_Access (Info.Instance_Block));
+
+ -- Set instantiated unit instance (if any).
+ if Info.Instantiated_Entity /= Null_Iir then
+ declare
+ Inst_Addr : O_Enode;
+ Inst_Info : Ortho_Info_Acc;
+ begin
+ if Get_Kind (Info.Instantiated_Entity)
+ = Iir_Kind_Component_Declaration
+ then
+ Inst_Info := Get_Info (Info.Instantiated_Entity);
+ Inst_Addr := New_Address
+ (Get_Instance_Ref (Inst_Info.Comp_Scope),
+ Inst_Info.Comp_Ptr_Type);
+ else
+ Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity);
+ end if;
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var_Data),
+ Info.Instantiated_Field),
+ Inst_Addr);
+ end;
+ end if;
+
+ -- Set input.
+ Ssig := Chap6.Translate_Name (Sig_In);
+ Ssig := Stabilize (Ssig, True);
+
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var_Data), Info.In_Field),
+ M2E (Ssig));
+
+ -- Create a copy of SIG_OUT.
+ Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
+ Info.Out_Field),
+ Out_Info, Mode_Signal);
+ Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Ndest);
+ -- Note: NDEST will be assigned by ELAB_SIGNAL.
+ Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
+ Info.Out_Field),
+ Out_Info, Mode_Signal);
+ Data := Elab_Signal_Data'(Has_Val => False,
+ Already_Resolved => True,
+ Val => Mnode_Null,
+ Check_Null => False,
+ If_Stmt => null);
+ Elab_Signal (Ndest, Out_Type, Data);
+
+ Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data),
+ Info.Out_Field),
+ Out_Info, Mode_Signal);
+ Ndest := Stabilize (Ndest, True);
+
+ -- Register.
+ Start_Association (Constr, Reg_Subprg);
+ New_Association
+ (Constr, New_Lit (New_Subprogram_Address (Info.Subprg,
+ Ghdl_Ptr_Type)));
+ New_Association
+ (Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type));
+
+ New_Association
+ (Constr,
+ New_Convert_Ov (M2E (Get_Leftest_Signal (Ssig, Get_Type (Sig_In))),
+ Ghdl_Signal_Ptr));
+ New_Association (Constr, Get_Nbr_Signals (Ssig, Get_Type (Sig_In)));
+
+ New_Association
+ (Constr,
+ New_Convert_Ov
+ (M2E (Get_Leftest_Signal (Ndest, Get_Type (Sig_Out))),
+ Ghdl_Signal_Ptr));
+ New_Association (Constr, Get_Nbr_Signals (Ndest, Get_Type (Sig_Out)));
+
+ New_Procedure_Call (Constr);
+ end Elab_Conversion;
+
+ -- In conversion: from actual to formal.
+ procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode)
+ is
+ Assoc_Info : Assoc_Info_Acc;
+ begin
+ Assoc_Info := Get_Info (Assoc);
+
+ Elab_Conversion
+ (Get_Actual (Assoc), Get_Formal (Assoc),
+ Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest);
+ end Elab_In_Conversion;
+
+ -- Out conversion: from formal to actual.
+ procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode)
+ is
+ Assoc_Info : Assoc_Info_Acc;
+ begin
+ Assoc_Info := Get_Info (Assoc);
+
+ Elab_Conversion
+ (Get_Formal (Assoc), Get_Actual (Assoc),
+ Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest);
+ end Elab_Out_Conversion;
+
+ -- Create a record that describe thes location of an IIR node and
+ -- returns the address of it.
+ function Get_Location (N : Iir) return O_Dnode
+ is
+ Constr : O_Record_Aggr_List;
+ Aggr : O_Cnode;
+ Name : Name_Id;
+ Line : Natural;
+ Col : Natural;
+ C : O_Dnode;
+ begin
+ Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col);
+
+ New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private,
+ Ghdl_Location_Type_Node);
+ Start_Const_Value (C);
+ Start_Record_Aggr (Constr, Ghdl_Location_Type_Node);
+ New_Record_Aggr_El
+ (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type));
+ New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
+ Integer_64 (Line)));
+ New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
+ Integer_64 (Col)));
+ Finish_Record_Aggr (Constr, Aggr);
+ Finish_Const_Value (C, Aggr);
+
+ return C;
+ --return New_Global_Address (C, Ghdl_Location_Ptr_Node);
+ end Get_Location;
+ end Chap4;
+
+ package body Chap5 is
+ procedure Translate_Attribute_Specification
+ (Spec : Iir_Attribute_Specification)
+ is
+ Attr : constant Iir_Attribute_Declaration :=
+ Get_Named_Entity (Get_Attribute_Designator (Spec));
+ Atinfo : constant Type_Info_Acc := Get_Info (Get_Type (Attr));
+ Mark : Id_Mark_Type;
+ Info : Object_Info_Acc;
+ begin
+ Push_Identifier_Prefix_Uniq (Mark);
+ Info := Add_Info (Spec, Kind_Object);
+ Info.Object_Var := Create_Var
+ (Create_Var_Identifier (Attr),
+ Chap4.Get_Object_Type (Atinfo, Mode_Value),
+ Global_Storage);
+ Pop_Identifier_Prefix (Mark);
+ end Translate_Attribute_Specification;
+
+ procedure Elab_Attribute_Specification
+ (Spec : Iir_Attribute_Specification)
+ is
+ Attr : constant Iir_Attribute_Declaration :=
+ Get_Named_Entity (Get_Attribute_Designator (Spec));
+ begin
+ -- Kludge
+ Set_Info (Attr, Get_Info (Spec));
+ Chap4.Elab_Object_Value (Attr, Get_Expression (Spec));
+ Clear_Info (Attr);
+ end Elab_Attribute_Specification;
+
+ procedure Gen_Elab_Disconnect_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Time : O_Dnode)
+ is
+ pragma Unreferenced (Targ_Type);
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Ghdl_Signal_Set_Disconnect);
+ New_Association
+ (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Obj_Value (Time));
+ New_Procedure_Call (Assoc);
+ end Gen_Elab_Disconnect_Non_Composite;
+
+ function Gen_Elab_Disconnect_Prepare
+ (Targ : Mnode; Targ_Type : Iir; Time : O_Dnode)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Time;
+ end Gen_Elab_Disconnect_Prepare;
+
+ function Gen_Elab_Disconnect_Update_Data_Array (Time : O_Dnode;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ_Type, Index);
+ begin
+ return Time;
+ end Gen_Elab_Disconnect_Update_Data_Array;
+
+ function Gen_Elab_Disconnect_Update_Data_Record
+ (Time : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return O_Dnode
+ is
+ pragma Unreferenced (Targ_Type, El);
+ begin
+ return Time;
+ end Gen_Elab_Disconnect_Update_Data_Record;
+
+ procedure Gen_Elab_Disconnect_Finish_Data_Composite
+ (Data : in out O_Dnode)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Gen_Elab_Disconnect_Finish_Data_Composite;
+
+ procedure Gen_Elab_Disconnect is new Foreach_Non_Composite
+ (Data_Type => O_Dnode,
+ Composite_Data_Type => O_Dnode,
+ Do_Non_Composite => Gen_Elab_Disconnect_Non_Composite,
+ Prepare_Data_Array => Gen_Elab_Disconnect_Prepare,
+ Update_Data_Array => Gen_Elab_Disconnect_Update_Data_Array,
+ Finish_Data_Array => Gen_Elab_Disconnect_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Elab_Disconnect_Prepare,
+ Update_Data_Record => Gen_Elab_Disconnect_Update_Data_Record,
+ Finish_Data_Record => Gen_Elab_Disconnect_Finish_Data_Composite);
+
+ procedure Elab_Disconnection_Specification
+ (Spec : Iir_Disconnection_Specification)
+ is
+ Val : O_Dnode;
+ List : constant Iir_List := Get_Signal_List (Spec);
+ El : Iir;
+ begin
+ Val := Create_Temp_Init
+ (Std_Time_Otype,
+ Chap7.Translate_Expression (Get_Expression (Spec)));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Gen_Elab_Disconnect (Chap6.Translate_Name (El),
+ Get_Type (El), Val);
+ end loop;
+ end Elab_Disconnection_Specification;
+
+ type Connect_Mode is
+ (
+ -- Actual is a source for the formal.
+ Connect_Source,
+
+ -- Both.
+ Connect_Both,
+
+ -- Effective value of actual is the effective value of the formal.
+ Connect_Effective,
+
+ -- Actual is a value.
+ Connect_Value
+ );
+
+ type Connect_Data is record
+ Actual_Node : Mnode;
+ Actual_Type : Iir;
+
+ -- Mode of the connection.
+ Mode : Connect_Mode;
+
+ -- If true, formal signal is a copy of the actual.
+ By_Copy : Boolean;
+ end record;
+
+ -- Connect_effective: FORMAL is set from ACTUAL.
+ -- Connect_Source: ACTUAL is set from FORMAL (source of ACTUAL).
+ procedure Connect_Scalar (Formal_Node : Mnode;
+ Formal_Type : Iir;
+ Data : Connect_Data)
+ is
+ Act_Node, Form_Node : Mnode;
+ begin
+ if Data.By_Copy then
+ New_Assign_Stmt (M2Lv (Formal_Node), M2E (Data.Actual_Node));
+ return;
+ end if;
+
+ case Data.Mode is
+ when Connect_Both =>
+ Open_Temp;
+ Act_Node := Stabilize (Data.Actual_Node, True);
+ Form_Node := Stabilize (Formal_Node, True);
+ when Connect_Source
+ | Connect_Effective =>
+ Act_Node := Data.Actual_Node;
+ Form_Node := Formal_Node;
+ when Connect_Value =>
+ null;
+ end case;
+
+ if Data.Mode in Connect_Source .. Connect_Both then
+ -- Formal is a source to actual.
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Ghdl_Signal_Add_Source);
+ New_Association (Constr, New_Convert_Ov (M2E (Act_Node),
+ Ghdl_Signal_Ptr));
+ New_Association (Constr, New_Convert_Ov (M2E (Form_Node),
+ Ghdl_Signal_Ptr));
+ New_Procedure_Call (Constr);
+ end;
+ end if;
+
+ if Data.Mode in Connect_Both .. Connect_Effective then
+ -- The effective value of formal is the effective value of actual.
+ declare
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Ghdl_Signal_Effective_Value);
+ New_Association (Constr, New_Convert_Ov (M2E (Form_Node),
+ Ghdl_Signal_Ptr));
+ New_Association (Constr, New_Convert_Ov (M2E (Act_Node),
+ Ghdl_Signal_Ptr));
+ New_Procedure_Call (Constr);
+ end;
+ end if;
+
+ if Data.Mode = Connect_Value then
+ declare
+ Type_Info : Type_Info_Acc;
+ Subprg : O_Dnode;
+ Constr : O_Assoc_List;
+ Conv : O_Tnode;
+ begin
+ Type_Info := Get_Info (Formal_Type);
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Signal_Associate_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Signal_Associate_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Signal_Associate_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32 =>
+ Subprg := Ghdl_Signal_Associate_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64 =>
+ Subprg := Ghdl_Signal_Associate_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Signal_Associate_F64;
+ Conv := Ghdl_Real_Type;
+ when others =>
+ Error_Kind ("connect_scalar", Formal_Type);
+ end case;
+ Start_Association (Constr, Subprg);
+ New_Association (Constr,
+ New_Convert_Ov (New_Value (M2Lv (Formal_Node)),
+ Ghdl_Signal_Ptr));
+ New_Association (Constr,
+ New_Convert_Ov (M2E (Data.Actual_Node), Conv));
+ New_Procedure_Call (Constr);
+ end;
+ end if;
+
+ if Data.Mode = Connect_Both then
+ Close_Temp;
+ end if;
+ end Connect_Scalar;
+
+ function Connect_Prepare_Data_Composite
+ (Targ : Mnode; Formal_Type : Iir; Data : Connect_Data)
+ return Connect_Data
+ is
+ pragma Unreferenced (Targ, Formal_Type);
+ Res : Connect_Data;
+ Atype : Iir;
+ begin
+ Atype := Get_Base_Type (Data.Actual_Type);
+ if Get_Kind (Atype) = Iir_Kind_Record_Type_Definition then
+ Res := Data;
+ Stabilize (Res.Actual_Node);
+ return Res;
+ else
+ return Data;
+ end if;
+ end Connect_Prepare_Data_Composite;
+
+ function Connect_Update_Data_Array (Data : Connect_Data;
+ Formal_Type : Iir;
+ Index : O_Dnode)
+ return Connect_Data
+ is
+ pragma Unreferenced (Formal_Type);
+ Res : Connect_Data;
+ begin
+ -- FIXME: should check matching elements!
+ Res := (Actual_Node =>
+ Chap3.Index_Base (Chap3.Get_Array_Base (Data.Actual_Node),
+ Data.Actual_Type, New_Obj_Value (Index)),
+ Actual_Type => Get_Element_Subtype (Data.Actual_Type),
+ Mode => Data.Mode,
+ By_Copy => Data.By_Copy);
+ return Res;
+ end Connect_Update_Data_Array;
+
+ function Connect_Update_Data_Record (Data : Connect_Data;
+ Formal_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Connect_Data
+ is
+ pragma Unreferenced (Formal_Type);
+ Res : Connect_Data;
+ begin
+ Res := (Actual_Node =>
+ Chap6.Translate_Selected_Element (Data.Actual_Node, El),
+ Actual_Type => Get_Type (El),
+ Mode => Data.Mode,
+ By_Copy => Data.By_Copy);
+ return Res;
+ end Connect_Update_Data_Record;
+
+ procedure Connect_Finish_Data_Composite (Data : in out Connect_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Connect_Finish_Data_Composite;
+
+ procedure Connect is new Foreach_Non_Composite
+ (Data_Type => Connect_Data,
+ Composite_Data_Type => Connect_Data,
+ Do_Non_Composite => Connect_Scalar,
+ Prepare_Data_Array => Connect_Prepare_Data_Composite,
+ Update_Data_Array => Connect_Update_Data_Array,
+ Finish_Data_Array => Connect_Finish_Data_Composite,
+ Prepare_Data_Record => Connect_Prepare_Data_Composite,
+ Update_Data_Record => Connect_Update_Data_Record,
+ Finish_Data_Record => Connect_Finish_Data_Composite);
+
+ procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir)
+ is
+ Act_Node : Mnode;
+ Bounds : Mnode;
+ Tinfo : Type_Info_Acc;
+ Bound_Var : O_Dnode;
+ Actual_Type : Iir;
+ begin
+ Actual_Type := Get_Type (Actual);
+ Open_Temp;
+ if Is_Fully_Constrained_Type (Actual_Type) then
+ Chap3.Create_Array_Subtype (Actual_Type, False);
+ Tinfo := Get_Info (Actual_Type);
+ Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ if Get_Alloc_Kind_For_Var (Tinfo.T.Array_Bounds) = Alloc_Stack then
+ -- We need a copy.
+ Bound_Var := Create_Temp (Tinfo.T.Bounds_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Bound_Var),
+ Gen_Alloc (Alloc_System,
+ New_Lit (New_Sizeof (Tinfo.T.Bounds_Type,
+ Ghdl_Index_Type)),
+ Tinfo.T.Bounds_Ptr_Type));
+ Gen_Memcpy (New_Obj_Value (Bound_Var),
+ M2Addr (Bounds),
+ New_Lit (New_Sizeof (Tinfo.T.Bounds_Type,
+ Ghdl_Index_Type)));
+ Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value,
+ Tinfo.T.Bounds_Type,
+ Tinfo.T.Bounds_Ptr_Type);
+ end if;
+ else
+ Bounds := Chap3.Get_Array_Bounds (Chap6.Translate_Name (Actual));
+ end if;
+ Act_Node := Chap6.Translate_Name (Port);
+ New_Assign_Stmt
+ (-- FIXME: this works only because it is not stabilized,
+ -- and therefore the bounds field is returned and not
+ -- a pointer to the bounds.
+ M2Lp (Chap3.Get_Array_Bounds (Act_Node)),
+ M2Addr (Bounds));
+ Close_Temp;
+ end Elab_Unconstrained_Port;
+
+ -- Return TRUE if EXPR is a signal name.
+ function Is_Signal (Expr : Iir) return Boolean
+ is
+ Obj : Iir;
+ begin
+ Obj := Sem_Names.Name_To_Object (Expr);
+ if Obj /= Null_Iir then
+ return Is_Signal_Object (Obj);
+ else
+ return False;
+ end if;
+ end Is_Signal;
+
+ procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean)
+ is
+ Formal : constant Iir := Get_Formal (Assoc);
+ Actual : constant Iir := Get_Actual (Assoc);
+ Formal_Type : constant Iir := Get_Type (Formal);
+ Actual_Type : constant Iir := Get_Type (Actual);
+ Inter : constant Iir := Get_Association_Interface (Assoc);
+ Formal_Node, Actual_Node : Mnode;
+ Data : Connect_Data;
+ Mode : Connect_Mode;
+ begin
+ if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then
+ raise Internal_Error;
+ end if;
+
+ Open_Temp;
+ if Get_In_Conversion (Assoc) = Null_Iir
+ and then Get_Out_Conversion (Assoc) = Null_Iir
+ then
+ Formal_Node := Chap6.Translate_Name (Formal);
+ if Get_Object_Kind (Formal_Node) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+ if Is_Signal (Actual) then
+ -- LRM93 4.3.1.2
+ -- For a signal of a scalar type, each source is either
+ -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of
+ -- a component instance or of a block statement with
+ -- which the signalis associated.
+
+ -- LRM93 12.6.2
+ -- For a scalar signal S, the effective value of S is
+ -- determined in the following manner:
+ -- * If S is [...] a port of mode BUFFER or [...],
+ -- then the effective value of S is the same as
+ -- the driving value of S.
+ -- * If S is a connected port of mode IN or INOUT,
+ -- then the effective value of S is the same as
+ -- the effective value of the actual part of the
+ -- association element that associates an actual
+ -- with S.
+ -- * [...]
+ case Get_Mode (Inter) is
+ when Iir_In_Mode =>
+ Mode := Connect_Effective;
+ when Iir_Inout_Mode =>
+ Mode := Connect_Both;
+ when Iir_Out_Mode
+ | Iir_Buffer_Mode
+ | Iir_Linkage_Mode =>
+ Mode := Connect_Source;
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ end case;
+
+ -- translate actual (abort if not a signal).
+ Actual_Node := Chap6.Translate_Name (Actual);
+ if Get_Object_Kind (Actual_Node) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+ else
+ declare
+ Actual_Val : O_Enode;
+ begin
+ Actual_Val := Chap7.Translate_Expression
+ (Actual, Formal_Type);
+ Actual_Node := E2M
+ (Actual_Val, Get_Info (Formal_Type), Mode_Value);
+ Mode := Connect_Value;
+ end;
+ end if;
+
+ if Get_Kind (Formal_Type) in Iir_Kinds_Array_Type_Definition
+ then
+ -- Check length matches.
+ Stabilize (Formal_Node);
+ Stabilize (Actual_Node);
+ Chap3.Check_Array_Match (Formal_Type, Formal_Node,
+ Actual_Type, Actual_Node,
+ Assoc);
+ end if;
+
+ Data := (Actual_Node => Actual_Node,
+ Actual_Type => Actual_Type,
+ Mode => Mode,
+ By_Copy => By_Copy);
+ Connect (Formal_Node, Formal_Type, Data);
+ else
+ if Get_In_Conversion (Assoc) /= Null_Iir then
+ Chap4.Elab_In_Conversion (Assoc, Actual_Node);
+ Formal_Node := Chap6.Translate_Name (Formal);
+ Data := (Actual_Node => Actual_Node,
+ Actual_Type => Formal_Type,
+ Mode => Connect_Effective,
+ By_Copy => False);
+ Connect (Formal_Node, Formal_Type, Data);
+ end if;
+ if Get_Out_Conversion (Assoc) /= Null_Iir then
+ -- flow: FORMAL to ACTUAL
+ Chap4.Elab_Out_Conversion (Assoc, Formal_Node);
+ Actual_Node := Chap6.Translate_Name (Actual);
+ Data := (Actual_Node => Actual_Node,
+ Actual_Type => Actual_Type,
+ Mode => Connect_Source,
+ By_Copy => False);
+ Connect (Formal_Node, Actual_Type, Data);
+ end if;
+ end if;
+
+ Close_Temp;
+ end Elab_Port_Map_Aspect_Assoc;
+
+ -- Return TRUE if the collapse_signal_flag is set for each individual
+ -- association.
+ function Inherit_Collapse_Flag (Assoc : Iir) return Boolean
+ is
+ El : Iir;
+ begin
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Individual =>
+ El := Get_Individual_Association_Chain (Assoc);
+ while El /= Null_Iir loop
+ if Inherit_Collapse_Flag (El) = False then
+ return False;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ return True;
+ when Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_Name =>
+ El := Assoc;
+ while El /= Null_Iir loop
+ if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc))
+ then
+ return False;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ return True;
+ when Iir_Kind_Association_Element_By_Expression =>
+ return Get_Collapse_Signal_Flag (Assoc);
+ when others =>
+ Error_Kind ("inherit_collapse_flag", Assoc);
+ end case;
+ end Inherit_Collapse_Flag;
+
+ procedure Elab_Generic_Map_Aspect (Mapping : Iir)
+ is
+ Assoc : Iir;
+ Formal : Iir;
+ begin
+ -- Elab generics, and associate.
+ Assoc := Get_Generic_Map_Aspect_Chain (Mapping);
+ while Assoc /= Null_Iir loop
+ Open_Temp;
+ Formal := Get_Formal (Assoc);
+ if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then
+ Formal := Get_Named_Entity (Formal);
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ declare
+ Targ : Mnode;
+ begin
+ if Get_Whole_Association_Flag (Assoc) then
+ Chap4.Elab_Object_Storage (Formal);
+ Targ := Chap6.Translate_Name (Formal);
+ Chap4.Elab_Object_Init
+ (Targ, Formal, Get_Actual (Assoc));
+ else
+ Targ := Chap6.Translate_Name (Formal);
+ Chap7.Translate_Assign
+ (Targ, Get_Actual (Assoc), Get_Type (Formal));
+ end if;
+ end;
+ when Iir_Kind_Association_Element_Open =>
+ Chap4.Elab_Object_Value (Formal, Get_Default_Value (Formal));
+ when Iir_Kind_Association_Element_By_Individual =>
+ -- Create the object.
+ declare
+ Formal_Type : constant Iir := Get_Type (Formal);
+ Obj_Info : constant Object_Info_Acc := Get_Info (Formal);
+ Obj_Type : constant Iir := Get_Actual_Type (Assoc);
+ Formal_Node : Mnode;
+ Type_Info : Type_Info_Acc;
+ Bounds : Mnode;
+ begin
+ Chap3.Elab_Object_Subtype (Formal_Type);
+ Type_Info := Get_Info (Formal_Type);
+ Formal_Node := Get_Var
+ (Obj_Info.Object_Var, Type_Info, Mode_Value);
+ Stabilize (Formal_Node);
+ if Obj_Type = Null_Iir then
+ Chap4.Allocate_Complex_Object
+ (Formal_Type, Alloc_System, Formal_Node);
+ else
+ Chap3.Create_Array_Subtype (Obj_Type, False);
+ Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type);
+ Chap3.Translate_Object_Allocation
+ (Formal_Node, Alloc_System, Formal_Type, Bounds);
+ end if;
+ end;
+ when Iir_Kind_Association_Element_Package =>
+ pragma Assert (Get_Kind (Formal) =
+ Iir_Kind_Interface_Package_Declaration);
+ declare
+ Uninst_Pkg : constant Iir := Get_Named_Entity
+ (Get_Uninstantiated_Package_Name (Formal));
+ Uninst_Info : constant Ortho_Info_Acc :=
+ Get_Info (Uninst_Pkg);
+ Formal_Info : constant Ortho_Info_Acc :=
+ Get_Info (Formal);
+ Actual : constant Iir := Get_Named_Entity
+ (Get_Actual (Assoc));
+ Actual_Info : constant Ortho_Info_Acc :=
+ Get_Info (Actual);
+ begin
+ New_Assign_Stmt
+ (Get_Var (Formal_Info.Package_Instance_Spec_Var),
+ New_Address
+ (Get_Instance_Ref
+ (Actual_Info.Package_Instance_Spec_Scope),
+ Uninst_Info.Package_Spec_Ptr_Type));
+ New_Assign_Stmt
+ (Get_Var (Formal_Info.Package_Instance_Body_Var),
+ New_Address
+ (Get_Instance_Ref
+ (Actual_Info.Package_Instance_Body_Scope),
+ Uninst_Info.Package_Body_Ptr_Type));
+ end;
+ when others =>
+ Error_Kind ("elab_generic_map_aspect(1)", Assoc);
+ end case;
+ Close_Temp;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Elab_Generic_Map_Aspect;
+
+ procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir)
+ is
+ Assoc : Iir;
+ Formal : Iir;
+ Formal_Base : Iir;
+ Fb_Type : Iir;
+ Fbt_Info : Type_Info_Acc;
+ Collapse_Individual : Boolean := False;
+ begin
+ -- Ports.
+ Assoc := Get_Port_Map_Aspect_Chain (Mapping);
+ while Assoc /= Null_Iir loop
+ Formal := Get_Formal (Assoc);
+ Formal_Base := Get_Association_Interface (Assoc);
+ Fb_Type := Get_Type (Formal_Base);
+
+ Open_Temp;
+ -- Set bounds of unconstrained ports.
+ Fbt_Info := Get_Info (Fb_Type);
+ if Fbt_Info.Type_Mode = Type_Mode_Fat_Array then
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_Whole_Association_Flag (Assoc) then
+ Elab_Unconstrained_Port (Formal, Get_Actual (Assoc));
+ end if;
+ when Iir_Kind_Association_Element_Open =>
+ declare
+ Actual_Type : Iir;
+ Bounds : Mnode;
+ Formal_Node : Mnode;
+ begin
+ Actual_Type :=
+ Get_Type (Get_Default_Value (Formal_Base));
+ Chap3.Create_Array_Subtype (Actual_Type, True);
+ Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Formal_Node := Chap6.Translate_Name (Formal);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)),
+ M2Addr (Bounds));
+ end;
+ when Iir_Kind_Association_Element_By_Individual =>
+ declare
+ Actual_Type : Iir;
+ Bounds : Mnode;
+ Formal_Node : Mnode;
+ begin
+ Actual_Type := Get_Actual_Type (Assoc);
+ Chap3.Create_Array_Subtype (Actual_Type, False);
+ Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Formal_Node := Chap6.Translate_Name (Formal);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)),
+ M2Addr (Bounds));
+ end;
+ when others =>
+ Error_Kind ("elab_map_aspect(2)", Assoc);
+ end case;
+ end if;
+ Close_Temp;
+
+ -- Allocate storage of ports.
+ Open_Temp;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open =>
+ Chap4.Elab_Signal_Declaration_Storage (Formal);
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_Whole_Association_Flag (Assoc) then
+ Chap4.Elab_Signal_Declaration_Storage (Formal);
+ end if;
+ when others =>
+ Error_Kind ("elab_map_aspect(3)", Assoc);
+ end case;
+ Close_Temp;
+
+ -- Create or copy signals.
+ Open_Temp;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_Whole_Association_Flag (Assoc) then
+ if Get_Collapse_Signal_Flag (Assoc) then
+ -- For collapsed association, copy signals.
+ Elab_Port_Map_Aspect_Assoc (Assoc, True);
+ else
+ -- Create non-collapsed signals.
+ Chap4.Elab_Signal_Declaration_Object
+ (Formal, Block_Parent, False);
+ -- And associate.
+ Elab_Port_Map_Aspect_Assoc (Assoc, False);
+ end if;
+ else
+ -- By sub-element.
+ -- Either the whole signal is collapsed or it was already
+ -- created.
+ -- And associate.
+ Elab_Port_Map_Aspect_Assoc (Assoc, Collapse_Individual);
+ end if;
+ when Iir_Kind_Association_Element_Open =>
+ -- Create non-collapsed signals.
+ Chap4.Elab_Signal_Declaration_Object
+ (Formal, Block_Parent, False);
+ when Iir_Kind_Association_Element_By_Individual =>
+ -- Inherit the collapse flag.
+ -- If it is set for all sub-associations, continue.
+ -- Otherwise, create signals and do not collapse.
+ -- FIXME: this may be slightly optimized.
+ if not Inherit_Collapse_Flag (Assoc) then
+ -- Create the formal.
+ Chap4.Elab_Signal_Declaration_Object
+ (Formal, Block_Parent, False);
+ Collapse_Individual := False;
+ else
+ Collapse_Individual := True;
+ end if;
+ when others =>
+ Error_Kind ("elab_map_aspect(4)", Assoc);
+ end case;
+ Close_Temp;
+
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Elab_Port_Map_Aspect;
+
+ procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is
+ begin
+ -- The generic map must be done before the elaboration of
+ -- the ports, since a port subtype may depend on a generic.
+ Elab_Generic_Map_Aspect (Mapping);
+
+ Elab_Port_Map_Aspect (Mapping, Block_Parent);
+ end Elab_Map_Aspect;
+ end Chap5;
+
+ package body Chap6 is
+ function Get_Array_Bound_Length (Arr : Mnode;
+ Arr_Type : Iir;
+ Dim : Natural)
+ return O_Enode
+ is
+ Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1);
+ Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type);
+ Constraint : Iir;
+ begin
+ if Tinfo.Type_Locally_Constrained then
+ Constraint := Get_Range_Constraint (Index_Type);
+ return New_Lit (Chap7.Translate_Static_Range_Length (Constraint));
+ else
+ return M2E
+ (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (Arr, Arr_Type, Dim)));
+ end if;
+ end Get_Array_Bound_Length;
+
+ procedure Gen_Bound_Error (Loc : Iir)
+ is
+ Constr : O_Assoc_List;
+ Name : Name_Id;
+ Line, Col : Natural;
+ begin
+ Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col);
+
+ Start_Association (Constr, Ghdl_Bound_Check_Failed_L1);
+ Assoc_Filename_Line (Constr, Line);
+ New_Procedure_Call (Constr);
+ end Gen_Bound_Error;
+
+ procedure Gen_Program_Error (Loc : Iir; Code : Natural)
+ is
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Ghdl_Program_Error);
+
+ if Current_Filename_Node = O_Dnode_Null then
+ New_Association (Assoc, New_Lit (New_Null_Access (Char_Ptr_Type)));
+ New_Association (Assoc,
+ New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)));
+ else
+ Assoc_Filename_Line (Assoc, Get_Line_Number (Loc));
+ end if;
+ New_Association
+ (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Code))));
+ New_Procedure_Call (Assoc);
+ end Gen_Program_Error;
+
+ -- Generate code to emit a failure if COND is TRUE, indicating an
+ -- index violation for dimension DIM of an array. LOC is usually
+ -- the expression which has computed the index and is used only for
+ -- its location.
+ procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural)
+ is
+ pragma Unreferenced (Dim);
+ If_Blk : O_If_Block;
+ begin
+ Start_If_Stmt (If_Blk, Cond);
+ Gen_Bound_Error (Loc);
+ Finish_If_Stmt (If_Blk);
+ end Check_Bound_Error;
+
+ -- Return TRUE if an array whose index type is RNG_TYPE indexed by
+ -- an expression of type EXPR_TYPE needs a bound check.
+ function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir)
+ return Boolean
+ is
+ Rng : Iir;
+ begin
+ -- Do checks if type of the expression is not a subtype.
+ -- FIXME: EXPR_TYPE shound not be NULL_IIR (generate stmt)
+ if Expr_Type = Null_Iir then
+ return True;
+ end if;
+ case Get_Kind (Expr_Type) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ null;
+ when others =>
+ return True;
+ end case;
+
+ -- No check if the expression has the type of the index.
+ if Expr_Type = Rng_Type then
+ return False;
+ end if;
+
+ -- No check for 'Range or 'Reverse_Range.
+ Rng := Get_Range_Constraint (Expr_Type);
+ if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute
+ or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute)
+ and then Get_Type (Rng) = Rng_Type
+ then
+ return False;
+ end if;
+
+ return True;
+ end Need_Index_Check;
+
+ procedure Get_Deep_Range_Expression
+ (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean)
+ is
+ T : Iir;
+ R : Iir;
+ begin
+ Is_Reverse := False;
+
+ -- T is an integer/enumeration subtype.
+ T := Atype;
+ loop
+ case Get_Kind (T) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ -- These types have a range.
+ null;
+ when others =>
+ Error_Kind ("get_deep_range_expression(1)", T);
+ end case;
+
+ R := Get_Range_Constraint (T);
+ case Get_Kind (R) is
+ when Iir_Kind_Range_Expression =>
+ Rng := R;
+ return;
+ when Iir_Kind_Range_Array_Attribute =>
+ null;
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Is_Reverse := not Is_Reverse;
+ when others =>
+ Error_Kind ("get_deep_range_expression(2)", R);
+ end case;
+ T := Get_Index_Subtype (R);
+ if T = Null_Iir then
+ Rng := Null_Iir;
+ return;
+ end if;
+ end loop;
+ end Get_Deep_Range_Expression;
+
+ function Translate_Index_To_Offset (Rng : Mnode;
+ Index : O_Enode;
+ Index_Expr : Iir;
+ Range_Type : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Need_Check : Boolean;
+ Dir : O_Enode;
+ If_Blk : O_If_Block;
+ Res : O_Dnode;
+ Off : O_Dnode;
+ Bound : O_Enode;
+ Cond1, Cond2: O_Enode;
+ Index_Node : O_Dnode;
+ Bound_Node : O_Dnode;
+ Index_Info : Type_Info_Acc;
+ Deep_Rng : Iir;
+ Deep_Reverse : Boolean;
+ begin
+ Index_Info := Get_Info (Get_Base_Type (Range_Type));
+ if Index_Expr = Null_Iir then
+ Need_Check := True;
+ Deep_Rng := Null_Iir;
+ Deep_Reverse := False;
+ else
+ Need_Check := Need_Index_Check (Get_Type (Index_Expr), Range_Type);
+ Get_Deep_Range_Expression (Range_Type, Deep_Rng, Deep_Reverse);
+ end if;
+
+ Res := Create_Temp (Ghdl_Index_Type);
+
+ Open_Temp;
+
+ Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value));
+
+ Bound := M2E (Chap3.Range_To_Left (Rng));
+
+ if Deep_Rng /= Null_Iir then
+ if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then
+ -- Direction TO: INDEX - LEFT.
+ New_Assign_Stmt (New_Obj (Off),
+ New_Dyadic_Op (ON_Sub_Ov,
+ Index, Bound));
+ else
+ -- Direction DOWNTO: LEFT - INDEX.
+ New_Assign_Stmt (New_Obj (Off),
+ New_Dyadic_Op (ON_Sub_Ov,
+ Bound, Index));
+ end if;
+ else
+ Index_Node := Create_Temp_Init
+ (Index_Info.Ortho_Type (Mode_Value), Index);
+ Bound_Node := Create_Temp_Init
+ (Index_Info.Ortho_Type (Mode_Value), Bound);
+ Dir := M2E (Chap3.Range_To_Dir (Rng));
+
+ -- Non-static direction.
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Eq, Dir,
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ -- Direction TO: INDEX - LEFT.
+ New_Assign_Stmt (New_Obj (Off),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Index_Node),
+ New_Obj_Value (Bound_Node)));
+ New_Else_Stmt (If_Blk);
+ -- Direction DOWNTO: LEFT - INDEX.
+ New_Assign_Stmt (New_Obj (Off),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Bound_Node),
+ New_Obj_Value (Index_Node)));
+ Finish_If_Stmt (If_Blk);
+ end if;
+
+ -- Get the offset.
+ New_Assign_Stmt
+ (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off),
+ Ghdl_Index_Type));
+
+ -- Check bounds.
+ if Need_Check then
+ Cond1 := New_Compare_Op
+ (ON_Lt,
+ New_Obj_Value (Off),
+ New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value),
+ 0)),
+ Ghdl_Bool_Type);
+
+ Cond2 := New_Compare_Op
+ (ON_Ge,
+ New_Obj_Value (Res),
+ M2E (Chap3.Range_To_Length (Rng)),
+ Ghdl_Bool_Type);
+ Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0);
+ end if;
+
+ Close_Temp;
+
+ return New_Obj_Value (Res);
+ end Translate_Index_To_Offset;
+
+ -- Translate index EXPR in dimension DIM of thin array into an
+ -- offset.
+ -- This checks bounds.
+ function Translate_Thin_Index_Offset (Index_Type : Iir;
+ Dim : Natural;
+ Expr : Iir)
+ return O_Enode
+ is
+ Index_Range : constant Iir := Get_Range_Constraint (Index_Type);
+ Obound : O_Cnode;
+ Res : O_Dnode;
+ Cond2: O_Enode;
+ Index : O_Enode;
+ Index_Base_Type : Iir;
+ V : Iir_Int64;
+ B : Iir_Int64;
+ begin
+ B := Eval_Pos (Get_Left_Limit (Index_Range));
+ if Get_Expr_Staticness (Expr) = Locally then
+ V := Eval_Pos (Eval_Static_Expr (Expr));
+ if Get_Direction (Index_Range) = Iir_To then
+ B := V - B;
+ else
+ B := B - V;
+ end if;
+ return New_Lit
+ (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B)));
+ else
+ Index_Base_Type := Get_Base_Type (Index_Type);
+ Index := Chap7.Translate_Expression (Expr, Index_Base_Type);
+
+ if Get_Direction (Index_Range) = Iir_To then
+ -- Direction TO: INDEX - LEFT.
+ if B /= 0 then
+ Obound := Chap7.Translate_Static_Range_Left
+ (Index_Range, Index_Base_Type);
+ Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound));
+ end if;
+ else
+ -- Direction DOWNTO: LEFT - INDEX.
+ Obound := Chap7.Translate_Static_Range_Left
+ (Index_Range, Index_Base_Type);
+ Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index);
+ end if;
+
+ -- Get the offset.
+ Index := New_Convert_Ov (Index, Ghdl_Index_Type);
+
+ -- Since the value is unsigned, both left and right bounds are
+ -- checked in the same time.
+ if Get_Type (Expr) /= Index_Type then
+ Res := Create_Temp_Init (Ghdl_Index_Type, Index);
+
+ Cond2 := New_Compare_Op
+ (ON_Ge, New_Obj_Value (Res),
+ New_Lit (Chap7.Translate_Static_Range_Length (Index_Range)),
+ Ghdl_Bool_Type);
+ Check_Bound_Error (Cond2, Expr, Dim);
+ Index := New_Obj_Value (Res);
+ end if;
+
+ return Index;
+ end if;
+ end Translate_Thin_Index_Offset;
+
+ -- Translate an indexed name.
+ type Indexed_Name_Data is record
+ Offset : O_Dnode;
+ Res : Mnode;
+ end record;
+
+ function Translate_Indexed_Name_Init (Prefix_Orig : Mnode; Expr : Iir)
+ return Indexed_Name_Data
+ is
+ Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr));
+ Prefix_Info : constant Type_Info_Acc := Get_Info (Prefix_Type);
+ Index_List : constant Iir_List := Get_Index_List (Expr);
+ Type_List : constant Iir_List := Get_Index_Subtype_List (Prefix_Type);
+ Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List);
+ Prefix : Mnode;
+ Index : Iir;
+ Offset : O_Dnode;
+ R : O_Enode;
+ Length : O_Enode;
+ Itype : Iir;
+ Ibasetype : Iir;
+ Range_Ptr : Mnode;
+ begin
+ case Prefix_Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Prefix := Stabilize (Prefix_Orig);
+ when Type_Mode_Array =>
+ Prefix := Prefix_Orig;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Offset := Create_Temp (Ghdl_Index_Type);
+ for Dim in 1 .. Nbr_Dim loop
+ Index := Get_Nth_Element (Index_List, Dim - 1);
+ Itype := Get_Index_Type (Type_List, Dim - 1);
+ Ibasetype := Get_Base_Type (Itype);
+ Open_Temp;
+ -- Compute index for the current dimension.
+ case Prefix_Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Range_Ptr := Stabilize
+ (Chap3.Get_Array_Range (Prefix, Prefix_Type, Dim));
+ R := Translate_Index_To_Offset
+ (Range_Ptr,
+ Chap7.Translate_Expression (Index, Ibasetype),
+ Null_Iir, Itype, Index);
+ when Type_Mode_Array =>
+ if Prefix_Info.Type_Locally_Constrained then
+ R := Translate_Thin_Index_Offset (Itype, Dim, Index);
+ else
+ -- Manually extract range since there is no infos for
+ -- index subtype.
+ Range_Ptr := Chap3.Bounds_To_Range
+ (Chap3.Get_Array_Type_Bounds (Prefix_Type),
+ Prefix_Type, Dim);
+ Stabilize (Range_Ptr);
+ R := Translate_Index_To_Offset
+ (Range_Ptr,
+ Chap7.Translate_Expression (Index, Ibasetype),
+ Index, Itype, Index);
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ if Dim = 1 then
+ -- First dimension.
+ New_Assign_Stmt (New_Obj (Offset), R);
+ else
+ -- If there are more dimension(s) to follow, then multiply
+ -- the current offset by the length of the current dimension.
+ if Prefix_Info.Type_Locally_Constrained then
+ Length := New_Lit (Chap7.Translate_Static_Range_Length
+ (Get_Range_Constraint (Itype)));
+ else
+ Length := M2E (Chap3.Range_To_Length (Range_Ptr));
+ end if;
+ New_Assign_Stmt
+ (New_Obj (Offset),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Dyadic_Op (ON_Mul_Ov,
+ New_Obj_Value (Offset),
+ Length),
+ R));
+ end if;
+ Close_Temp;
+ end loop;
+
+ return (Offset => Offset,
+ Res => Chap3.Index_Base
+ (Chap3.Get_Array_Base (Prefix), Prefix_Type,
+ New_Obj_Value (Offset)));
+ end Translate_Indexed_Name_Init;
+
+ function Translate_Indexed_Name_Finish
+ (Prefix : Mnode; Expr : Iir; Data : Indexed_Name_Data)
+ return Mnode
+ is
+ begin
+ return Chap3.Index_Base (Chap3.Get_Array_Base (Prefix),
+ Get_Type (Get_Prefix (Expr)),
+ New_Obj_Value (Data.Offset));
+ end Translate_Indexed_Name_Finish;
+
+ function Translate_Indexed_Name (Prefix : Mnode; Expr : Iir)
+ return Mnode
+ is
+ begin
+ return Translate_Indexed_Name_Init (Prefix, Expr).Res;
+ end Translate_Indexed_Name;
+
+ type Slice_Name_Data is record
+ Off : Unsigned_64;
+ Is_Off : Boolean;
+
+ Unsigned_Diff : O_Dnode;
+
+ -- Variable pointing to the prefix.
+ Prefix_Var : Mnode;
+
+ -- Variable pointing to slice.
+ Slice_Range : Mnode;
+ end record;
+
+ procedure Translate_Slice_Name_Init
+ (Prefix : Mnode; Expr : Iir_Slice_Name; Data : out Slice_Name_Data)
+ is
+ -- Type of the prefix.
+ Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr));
+
+ -- Type info of the prefix.
+ Prefix_Info : Type_Info_Acc;
+
+ -- Type of the first (and only) index of the prefix array type.
+ Index_Type : constant Iir := Get_Index_Type (Prefix_Type, 0);
+
+ -- Type of the slice.
+ Slice_Type : constant Iir := Get_Type (Expr);
+ Slice_Info : Type_Info_Acc;
+
+ -- True iff the direction of the slice is known at compile time.
+ Static_Range : Boolean;
+
+ -- Suffix of the slice (discrete range).
+ Expr_Range : constant Iir := Get_Suffix (Expr);
+
+ -- Variable pointing to the prefix.
+ Prefix_Var : Mnode;
+
+ -- Type info of the range base type.
+ Index_Info : Type_Info_Acc;
+
+ -- Variables pointing to slice and prefix ranges.
+ Slice_Range : Mnode;
+ Prefix_Range : Mnode;
+
+ Diff : O_Dnode;
+ Unsigned_Diff : O_Dnode;
+ If_Blk, If_Blk1 : O_If_Block;
+ begin
+ -- Evaluate slice bounds.
+ Chap3.Create_Array_Subtype (Slice_Type, True);
+
+ -- The info may have just been created.
+ Prefix_Info := Get_Info (Prefix_Type);
+ Slice_Info := Get_Info (Slice_Type);
+
+ if Slice_Info.Type_Mode = Type_Mode_Array
+ and then Slice_Info.Type_Locally_Constrained
+ and then Prefix_Info.Type_Mode = Type_Mode_Array
+ and then Prefix_Info.Type_Locally_Constrained
+ then
+ Data.Is_Off := True;
+ Data.Prefix_Var := Prefix;
+
+ -- Both prefix and result are constrained array.
+ declare
+ Prefix_Left, Slice_Left : Iir_Int64;
+ Off : Iir_Int64;
+ Slice_Index_Type : Iir;
+ Slice_Range : Iir;
+ Slice_Length : Iir_Int64;
+ Index_Range : Iir;
+ begin
+ Index_Range := Get_Range_Constraint (Index_Type);
+ Prefix_Left := Eval_Pos (Get_Left_Limit (Index_Range));
+ Slice_Index_Type := Get_Index_Type (Slice_Type, 0);
+ Slice_Range := Get_Range_Constraint (Slice_Index_Type);
+ Slice_Left := Eval_Pos (Get_Left_Limit (Slice_Range));
+ Slice_Length := Eval_Discrete_Range_Length (Slice_Range);
+ if Slice_Length = 0 then
+ -- Null slice.
+ Data.Off := 0;
+ return;
+ end if;
+ if Get_Direction (Index_Range) /= Get_Direction (Slice_Range)
+ then
+ -- This is allowed with vhdl87
+ Off := 0;
+ Slice_Length := 0;
+ else
+ -- Both prefix and slice are thin array.
+ case Get_Direction (Index_Range) is
+ when Iir_To =>
+ Off := Slice_Left - Prefix_Left;
+ when Iir_Downto =>
+ Off := Prefix_Left - Slice_Left;
+ end case;
+ if Off < 0 then
+ -- Must have been caught by sem.
+ raise Internal_Error;
+ end if;
+ if Off + Slice_Length
+ > Eval_Discrete_Range_Length (Index_Range)
+ then
+ -- Must have been caught by sem.
+ raise Internal_Error;
+ end if;
+ end if;
+ Data.Off := Unsigned_64 (Off);
+
+ return;
+ end;
+ end if;
+
+ Data.Is_Off := False;
+
+ -- Save prefix.
+ Prefix_Var := Stabilize (Prefix);
+
+ Index_Info := Get_Info (Get_Base_Type (Index_Type));
+
+ -- Save prefix bounds.
+ Prefix_Range := Stabilize
+ (Chap3.Get_Array_Range (Prefix_Var, Prefix_Type, 1));
+
+ -- Save slice bounds.
+ Slice_Range := Stabilize
+ (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type),
+ Slice_Type, 1));
+
+ -- TRUE if the direction of the slice is known.
+ Static_Range := Get_Kind (Expr_Range) = Iir_Kind_Range_Expression;
+
+ -- Check direction against same direction, error if different.
+ -- FIXME: what about v87 -> if different then null slice
+ if not Static_Range
+ or else Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition
+ then
+ -- Check same direction.
+ Check_Bound_Error
+ (New_Compare_Op (ON_Neq,
+ M2E (Chap3.Range_To_Dir (Prefix_Range)),
+ M2E (Chap3.Range_To_Dir (Slice_Range)),
+ Ghdl_Bool_Type),
+ Expr, 1);
+ end if;
+
+ Unsigned_Diff := Create_Temp (Ghdl_Index_Type);
+
+ -- Check if not a null slice.
+ -- The bounds of a null slice may be out of range. So DIFF cannot
+ -- be computed by substraction.
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op
+ (ON_Eq,
+ M2E (Chap3.Range_To_Length (Slice_Range)),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Unsigned_Diff), New_Lit (Ghdl_Index_0));
+ New_Else_Stmt (If_Blk);
+ Diff := Create_Temp (Index_Info.Ortho_Type (Mode_Value));
+
+ -- Compute the offset in the prefix.
+ if not Static_Range then
+ Start_If_Stmt
+ (If_Blk1, New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Slice_Range)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ end if;
+ if not Static_Range or else Get_Direction (Expr_Range) = Iir_To then
+ -- Diff = slice - bounds.
+ New_Assign_Stmt
+ (New_Obj (Diff),
+ New_Dyadic_Op (ON_Sub_Ov,
+ M2E (Chap3.Range_To_Left (Slice_Range)),
+ M2E (Chap3.Range_To_Left (Prefix_Range))));
+ end if;
+ if not Static_Range then
+ New_Else_Stmt (If_Blk1);
+ end if;
+ if not Static_Range or else Get_Direction (Expr_Range) = Iir_Downto
+ then
+ -- Diff = bounds - slice.
+ New_Assign_Stmt
+ (New_Obj (Diff),
+ New_Dyadic_Op (ON_Sub_Ov,
+ M2E (Chap3.Range_To_Left (Prefix_Range)),
+ M2E (Chap3.Range_To_Left (Slice_Range))));
+ end if;
+ if not Static_Range then
+ Finish_If_Stmt (If_Blk1);
+ end if;
+
+ -- Note: this also check for overflow.
+ New_Assign_Stmt
+ (New_Obj (Unsigned_Diff),
+ New_Convert_Ov (New_Obj_Value (Diff), Ghdl_Index_Type));
+
+ -- Check bounds.
+ declare
+ Err_1 : O_Enode;
+ Err_2 : O_Enode;
+ begin
+ -- Bounds error if left of slice is before left of prefix.
+ Err_1 := New_Compare_Op
+ (ON_Lt,
+ New_Obj_Value (Diff),
+ New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value),
+ 0)),
+ Ghdl_Bool_Type);
+ -- Bounds error if right of slice is after right of prefix.
+ Err_2 := New_Compare_Op
+ (ON_Gt,
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Unsigned_Diff),
+ M2E (Chap3.Range_To_Length (Slice_Range))),
+ M2E (Chap3.Range_To_Length (Prefix_Range)),
+ Ghdl_Bool_Type);
+ Check_Bound_Error (New_Dyadic_Op (ON_Or, Err_1, Err_2), Expr, 1);
+ end;
+ Finish_If_Stmt (If_Blk);
+
+ Data.Slice_Range := Slice_Range;
+ Data.Prefix_Var := Prefix_Var;
+ Data.Unsigned_Diff := Unsigned_Diff;
+ Data.Is_Off := False;
+ end Translate_Slice_Name_Init;
+
+ function Translate_Slice_Name_Finish
+ (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data)
+ return Mnode
+ is
+ -- Type of the slice.
+ Slice_Type : constant Iir := Get_Type (Expr);
+ Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type);
+
+ -- Object kind of the prefix.
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix);
+
+ Res_D : O_Dnode;
+ begin
+ if Data.Is_Off then
+ return Chap3.Slice_Base
+ (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type, Data.Off)));
+ else
+ -- Create the result (fat array) and assign the bounds field.
+ case Slice_Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Res_D := Create_Temp (Slice_Info.Ortho_Type (Kind));
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Res_D),
+ Slice_Info.T.Bounds_Field (Kind)),
+ New_Value (M2Lp (Data.Slice_Range)));
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Res_D),
+ Slice_Info.T.Base_Field (Kind)),
+ M2E (Chap3.Slice_Base
+ (Chap3.Get_Array_Base (Prefix),
+ Slice_Type,
+ New_Obj_Value (Data.Unsigned_Diff))));
+ return Dv2M (Res_D, Slice_Info, Kind);
+ when Type_Mode_Array =>
+ return Chap3.Slice_Base
+ (Chap3.Get_Array_Base (Prefix),
+ Slice_Type,
+ New_Obj_Value (Data.Unsigned_Diff));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ end Translate_Slice_Name_Finish;
+
+ function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name)
+ return Mnode
+ is
+ Data : Slice_Name_Data;
+ begin
+ Translate_Slice_Name_Init (Prefix, Expr, Data);
+ return Translate_Slice_Name_Finish (Data.Prefix_Var, Expr, Data);
+ end Translate_Slice_Name;
+
+ function Translate_Interface_Name
+ (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type)
+ return Mnode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter));
+ begin
+ case Info.Kind is
+ when Kind_Object =>
+ -- For a generic or a port.
+ return Get_Var (Info.Object_Var, Type_Info, Kind);
+ when Kind_Interface =>
+ -- For a parameter.
+ if Info.Interface_Field = O_Fnode_Null then
+ -- Normal case: the parameter was translated as an ortho
+ -- interface.
+ case Type_Info.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_By_Value =>
+ return Dv2M (Info.Interface_Node, Type_Info, Kind);
+ when Type_Mode_By_Copy
+ | Type_Mode_By_Ref =>
+ -- Parameter is passed by reference.
+ return Dp2M (Info.Interface_Node, Type_Info, Kind);
+ end case;
+ else
+ -- The parameter was put somewhere else.
+ declare
+ Subprg : constant Iir := Get_Parent (Inter);
+ Subprg_Info : constant Subprg_Info_Acc :=
+ Get_Info (Subprg);
+ Linter : O_Lnode;
+ begin
+ if Info.Interface_Node = O_Dnode_Null then
+ -- The parameter is passed via a field of the RESULT
+ -- record parameter.
+ if Subprg_Info.Res_Record_Var = Null_Var then
+ Linter := New_Obj (Subprg_Info.Res_Interface);
+ else
+ -- Unnesting case.
+ Linter := Get_Var (Subprg_Info.Res_Record_Var);
+ end if;
+ return Lv2M (New_Selected_Element
+ (New_Acc_Value (Linter),
+ Info.Interface_Field),
+ Type_Info, Kind);
+ else
+ -- Unnesting case: the parameter was copied in the
+ -- subprogram frame so that nested subprograms can
+ -- reference it. Use field in FRAME.
+ Linter := New_Selected_Element
+ (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope),
+ Info.Interface_Field);
+ case Type_Info.Type_Mode is
+ when Type_Mode_Unknown =>
+ raise Internal_Error;
+ when Type_Mode_By_Value =>
+ return Lv2M (Linter, Type_Info, Kind);
+ when Type_Mode_By_Copy
+ | Type_Mode_By_Ref =>
+ -- Parameter is passed by reference.
+ return Lp2M (Linter, Type_Info, Kind);
+ end case;
+ end if;
+ end;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Translate_Interface_Name;
+
+ function Translate_Selected_Element (Prefix : Mnode;
+ El : Iir_Element_Declaration)
+ return Mnode
+ is
+ El_Info : constant Field_Info_Acc := Get_Info (El);
+ El_Type : constant Iir := Get_Type (El);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix);
+ Stable_Prefix : Mnode;
+ begin
+ if Is_Complex_Type (El_Tinfo) then
+ -- The element is in fact an offset.
+ Stable_Prefix := Stabilize (Prefix);
+ return E2M
+ (New_Unchecked_Address
+ (New_Slice
+ (New_Access_Element
+ (New_Unchecked_Address
+ (M2Lv (Stable_Prefix), Char_Ptr_Type)),
+ Chararray_Type,
+ New_Value
+ (New_Selected_Element (M2Lv (Stable_Prefix),
+ El_Info.Field_Node (Kind)))),
+ El_Tinfo.Ortho_Ptr_Type (Kind)),
+ El_Tinfo, Kind);
+ else
+ return Lv2M (New_Selected_Element (M2Lv (Prefix),
+ El_Info.Field_Node (Kind)),
+ El_Tinfo, Kind);
+ end if;
+ end Translate_Selected_Element;
+
+-- function Translate_Formal_Interface_Name (Scope_Type : O_Tnode;
+-- Scope_Param : O_Lnode;
+-- Name : Iir;
+-- Kind : Object_Kind_Type)
+-- return Mnode
+-- is
+-- Type_Info : Type_Info_Acc;
+-- Info : Ortho_Info_Acc;
+-- Res : Mnode;
+-- begin
+-- Type_Info := Get_Info (Get_Type (Name));
+-- Info := Get_Info (Name);
+-- Push_Scope_Soft (Scope_Type, Scope_Param);
+-- Res := Get_Var (Info.Object_Var, Type_Info, Kind);
+-- Clear_Scope_Soft (Scope_Type);
+-- return Res;
+-- end Translate_Formal_Interface_Name;
+
+-- function Translate_Formal_Name (Scope_Type : O_Tnode;
+-- Scope_Param : O_Lnode;
+-- Name : Iir)
+-- return Mnode
+-- is
+-- Prefix : Iir;
+-- Prefix_Name : Mnode;
+-- begin
+-- case Get_Kind (Name) is
+-- when Iir_Kind_Interface_Constant_Declaration =>
+-- return Translate_Formal_Interface_Name
+-- (Scope_Type, Scope_Param, Name, Mode_Value);
+
+-- when Iir_Kind_Interface_Signal_Declaration =>
+-- return Translate_Formal_Interface_Name
+-- (Scope_Type, Scope_Param, Name, Mode_Signal);
+
+-- when Iir_Kind_Indexed_Name =>
+-- Prefix := Get_Prefix (Name);
+-- Prefix_Name := Translate_Formal_Name
+-- (Scope_Type, Scope_Param, Prefix);
+-- return Translate_Indexed_Name (Prefix_Name, Name);
+
+-- when Iir_Kind_Slice_Name =>
+-- Prefix := Get_Prefix (Name);
+-- Prefix_Name := Translate_Formal_Name
+-- (Scope_Type, Scope_Param, Prefix);
+-- return Translate_Slice_Name (Prefix_Name, Name);
+
+-- when Iir_Kind_Selected_Element =>
+-- Prefix := Get_Prefix (Name);
+-- Prefix_Name := Translate_Formal_Name
+-- (Scope_Type, Scope_Param, Prefix);
+-- return Translate_Selected_Element
+-- (Prefix_Name, Get_Selected_Element (Name));
+
+-- when others =>
+-- Error_Kind ("translate_generic_name", Name);
+-- end case;
+-- end Translate_Formal_Name;
+
+ function Translate_Name (Name : Iir) return Mnode
+ is
+ Name_Type : constant Iir := Get_Type (Name);
+ Name_Info : constant Ortho_Info_Acc := Get_Info (Name);
+ Type_Info : constant Type_Info_Acc := Get_Info (Name_Type);
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration =>
+ return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Value);
+
+ when Iir_Kind_Attribute_Name =>
+ return Translate_Name (Get_Named_Entity (Name));
+ when Iir_Kind_Attribute_Value =>
+ return Get_Var
+ (Get_Info (Get_Attribute_Specification (Name)).Object_Var,
+ Type_Info, Mode_Value);
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ -- Alias_Var is not like an object variable, since it is
+ -- always a pointer to the aliased object.
+ declare
+ R : O_Lnode;
+ begin
+ R := Get_Var (Name_Info.Alias_Var);
+ case Type_Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ return Get_Var (Name_Info.Alias_Var, Type_Info,
+ Name_Info.Alias_Kind);
+ when Type_Mode_Array
+ | Type_Mode_Record
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc =>
+ R := Get_Var (Name_Info.Alias_Var);
+ return Lp2M (R, Type_Info, Name_Info.Alias_Kind);
+ when Type_Mode_Scalar =>
+ R := Get_Var (Name_Info.Alias_Var);
+ if Name_Info.Alias_Kind = Mode_Signal then
+ return Lv2M (R, Type_Info, Name_Info.Alias_Kind);
+ else
+ return Lp2M (R, Type_Info, Name_Info.Alias_Kind);
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end;
+
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Guard_Signal_Declaration =>
+ return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal);
+
+ when Iir_Kind_Interface_Constant_Declaration =>
+ return Translate_Interface_Name (Name, Name_Info, Mode_Value);
+
+ when Iir_Kind_Interface_File_Declaration =>
+ return Translate_Interface_Name (Name, Name_Info, Mode_Value);
+
+ when Iir_Kind_Interface_Variable_Declaration =>
+ return Translate_Interface_Name (Name, Name_Info, Mode_Value);
+
+ when Iir_Kind_Interface_Signal_Declaration =>
+ return Translate_Interface_Name (Name, Name_Info, Mode_Signal);
+
+ when Iir_Kind_Indexed_Name =>
+ return Translate_Indexed_Name
+ (Translate_Name (Get_Prefix (Name)), Name);
+
+ when Iir_Kind_Slice_Name =>
+ return Translate_Slice_Name
+ (Translate_Name (Get_Prefix (Name)), Name);
+
+ when Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ declare
+ Pfx : O_Enode;
+ begin
+ Pfx := Chap7.Translate_Expression (Get_Prefix (Name));
+ -- FIXME: what about fat pointer ??
+ return Lv2M (New_Access_Element (Pfx),
+ Type_Info, Mode_Value);
+ end;
+
+ when Iir_Kind_Selected_Element =>
+ return Translate_Selected_Element
+ (Translate_Name (Get_Prefix (Name)),
+ Get_Selected_Element (Name));
+
+ when Iir_Kind_Function_Call =>
+ -- This can appear as a prefix of a name, therefore, the
+ -- result is always a composite type or an access type.
+ declare
+ Imp : constant Iir := Get_Implementation (Name);
+ Obj : Iir;
+ Assoc_Chain : Iir;
+ begin
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration
+ then
+ -- FIXME : to be done
+ raise Internal_Error;
+ else
+ Canon.Canon_Subprogram_Call (Name);
+ Assoc_Chain := Get_Parameter_Association_Chain (Name);
+ Obj := Get_Method_Object (Name);
+ return E2M
+ (Chap7.Translate_Function_Call (Imp, Assoc_Chain, Obj),
+ Type_Info, Mode_Value);
+ end if;
+ end;
+
+ when Iir_Kind_Image_Attribute =>
+ -- Can appear as a prefix.
+ return E2M (Chap14.Translate_Image_Attribute (Name),
+ Type_Info, Mode_Value);
+
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Translate_Name (Get_Named_Entity (Name));
+
+ when others =>
+ Error_Kind ("translate_name", Name);
+ end case;
+ end Translate_Name;
+
+ procedure Translate_Direct_Driver
+ (Name : Iir; Sig : out Mnode; Drv : out Mnode)
+ is
+ Name_Type : constant Iir := Get_Type (Name);
+ Name_Info : constant Ortho_Info_Acc := Get_Info (Name);
+ Type_Info : constant Type_Info_Acc := Get_Info (Name_Type);
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Translate_Direct_Driver (Get_Named_Entity (Name), Sig, Drv);
+ when Iir_Kind_Object_Alias_Declaration =>
+ Translate_Direct_Driver (Get_Name (Name), Sig, Drv);
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal);
+ Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value);
+ when Iir_Kind_Slice_Name =>
+ declare
+ Data : Slice_Name_Data;
+ Pfx_Sig : Mnode;
+ Pfx_Drv : Mnode;
+ begin
+ Translate_Direct_Driver
+ (Get_Prefix (Name), Pfx_Sig, Pfx_Drv);
+ Translate_Slice_Name_Init (Pfx_Sig, Name, Data);
+ Sig := Translate_Slice_Name_Finish
+ (Data.Prefix_Var, Name, Data);
+ Drv := Translate_Slice_Name_Finish (Pfx_Drv, Name, Data);
+ end;
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Data : Indexed_Name_Data;
+ Pfx_Sig : Mnode;
+ Pfx_Drv : Mnode;
+ begin
+ Translate_Direct_Driver
+ (Get_Prefix (Name), Pfx_Sig, Pfx_Drv);
+ Data := Translate_Indexed_Name_Init (Pfx_Sig, Name);
+ Sig := Data.Res;
+ Drv := Translate_Indexed_Name_Finish (Pfx_Drv, Name, Data);
+ end;
+ when Iir_Kind_Selected_Element =>
+ declare
+ El : Iir;
+ Pfx_Sig : Mnode;
+ Pfx_Drv : Mnode;
+ begin
+ Translate_Direct_Driver
+ (Get_Prefix (Name), Pfx_Sig, Pfx_Drv);
+ El := Get_Selected_Element (Name);
+ Sig := Translate_Selected_Element (Pfx_Sig, El);
+ Drv := Translate_Selected_Element (Pfx_Drv, El);
+ end;
+ when others =>
+ Error_Kind ("translate_direct_driver", Name);
+ end case;
+ end Translate_Direct_Driver;
+ end Chap6;
+
+ package body Chap7 is
+ function Is_Static_Constant (Decl : Iir_Constant_Declaration)
+ return Boolean
+ is
+ Expr : constant Iir := Get_Default_Value (Decl);
+ Atype : Iir;
+ Info : Iir;
+ begin
+ if Expr = Null_Iir
+ or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal
+ then
+ -- Deferred constant.
+ return False;
+ end if;
+
+ if Get_Expr_Staticness (Decl) = Locally then
+ return True;
+ end if;
+
+ -- Only aggregates are handled.
+ if Get_Kind (Expr) /= Iir_Kind_Aggregate then
+ return False;
+ end if;
+
+ Atype := Get_Type (Decl);
+ -- Bounds must be known (and static).
+ if Get_Type_Staticness (Atype) /= Locally then
+ return False;
+ end if;
+
+ -- Currently, only array aggregates are handled.
+ if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition
+ then
+ return False;
+ end if;
+
+ -- Aggregate elements must be locally static.
+ -- Note: this does not yet handled aggregates of aggregates.
+ if Get_Value_Staticness (Expr) /= Locally then
+ return False;
+ end if;
+ Info := Get_Aggregate_Info (Expr);
+ while Info /= Null_Iir loop
+ if Get_Aggr_Dynamic_Flag (Info) then
+ raise Internal_Error;
+ end if;
+
+ -- Currently, only positionnal aggregates are handled.
+ if Get_Aggr_Named_Flag (Info) then
+ return False;
+ end if;
+ -- Currently, others choice are not handled.
+ if Get_Aggr_Others_Flag (Info) then
+ return False;
+ end if;
+
+ Info := Get_Sub_Aggregate_Info (Info);
+ end loop;
+ return True;
+ end Is_Static_Constant;
+
+ procedure Translate_Static_String_Literal_Inner
+ (List : in out O_Array_Aggr_List;
+ Str : Iir;
+ El_Type : Iir)
+ is
+ use Name_Table;
+
+ Literal_List : Iir_List;
+ Lit : Iir;
+ Len : Nat32;
+ Ptr : String_Fat_Acc;
+ begin
+ Literal_List :=
+ Get_Enumeration_Literal_List (Get_Base_Type (El_Type));
+ Len := Get_String_Length (Str);
+ Ptr := Get_String_Fat_Acc (Str);
+ for I in 1 .. Len loop
+ Lit := Find_Name_In_List (Literal_List, Get_Identifier (Ptr (I)));
+ New_Array_Aggr_El (List, Get_Ortho_Expr (Lit));
+ end loop;
+ end Translate_Static_String_Literal_Inner;
+
+ procedure Translate_Static_Bit_String_Literal_Inner
+ (List : in out O_Array_Aggr_List;
+ Lit : Iir_Bit_String_Literal;
+ El_Type : Iir)
+ is
+ pragma Unreferenced (El_Type);
+ L_0 : O_Cnode;
+ L_1 : O_Cnode;
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ V : O_Cnode;
+ begin
+ L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit));
+ L_1 := Get_Ortho_Expr (Get_Bit_String_1 (Lit));
+ Ptr := Get_String_Fat_Acc (Lit);
+ Len := Get_String_Length (Lit);
+ for I in 1 .. Len loop
+ case Ptr (I) is
+ when '0' =>
+ V := L_0;
+ when '1' =>
+ V := L_1;
+ when others =>
+ raise Internal_Error;
+ end case;
+ New_Array_Aggr_El (List, V);
+ end loop;
+ end Translate_Static_Bit_String_Literal_Inner;
+
+ procedure Translate_Static_Aggregate_1 (List : in out O_Array_Aggr_List;
+ Aggr : Iir;
+ Info : Iir;
+ El_Type : Iir)
+ is
+ Assoc : Iir;
+ N_Info : Iir;
+ Sub : Iir;
+ begin
+ N_Info := Get_Sub_Aggregate_Info (Info);
+
+ case Get_Kind (Aggr) is
+ when Iir_Kind_Aggregate =>
+ Assoc := Get_Association_Choices_Chain (Aggr);
+ while Assoc /= Null_Iir loop
+ Sub := Get_Associated_Expr (Assoc);
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ if N_Info = Null_Iir then
+ New_Array_Aggr_El
+ (List,
+ Translate_Static_Expression (Sub, El_Type));
+ else
+ Translate_Static_Aggregate_1
+ (List, Sub, N_Info, El_Type);
+ end if;
+ when others =>
+ Error_Kind ("translate_static_aggregate_1(2)", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ when Iir_Kind_String_Literal =>
+ if N_Info /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Translate_Static_String_Literal_Inner (List, Aggr, El_Type);
+ when Iir_Kind_Bit_String_Literal =>
+ if N_Info /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Translate_Static_Bit_String_Literal_Inner (List, Aggr, El_Type);
+ when others =>
+ Error_Kind ("translate_static_aggregate_1", Aggr);
+ end case;
+ end Translate_Static_Aggregate_1;
+
+ function Translate_Static_Aggregate (Aggr : Iir)
+ return O_Cnode
+ is
+ Aggr_Type : constant Iir := Get_Type (Aggr);
+ El_Type : constant Iir := Get_Element_Subtype (Aggr_Type);
+ List : O_Array_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True);
+ Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value));
+
+ Translate_Static_Aggregate_1
+ (List, Aggr, Get_Aggregate_Info (Aggr), El_Type);
+ Finish_Array_Aggr (List, Res);
+ return Res;
+ end Translate_Static_Aggregate;
+
+ function Translate_Static_Simple_Aggregate (Aggr : Iir)
+ return O_Cnode
+ is
+ Aggr_Type : Iir;
+ El_List : Iir_List;
+ El : Iir;
+ El_Type : Iir;
+ List : O_Array_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Aggr_Type := Get_Type (Aggr);
+ Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True);
+ El_Type := Get_Element_Subtype (Aggr_Type);
+ El_List := Get_Simple_Aggregate_List (Aggr);
+ Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value));
+
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ New_Array_Aggr_El
+ (List, Translate_Static_Expression (El, El_Type));
+ end loop;
+
+ Finish_Array_Aggr (List, Res);
+ return Res;
+ end Translate_Static_Simple_Aggregate;
+
+ function Translate_Static_String_Literal (Str : Iir)
+ return O_Cnode
+ is
+ use Name_Table;
+
+ Lit_Type : Iir;
+ Element_Type : Iir;
+ Arr_Type : O_Tnode;
+ List : O_Array_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Lit_Type := Get_Type (Str);
+
+ Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True);
+ Arr_Type := Get_Ortho_Type (Lit_Type, Mode_Value);
+
+ Start_Array_Aggr (List, Arr_Type);
+
+ Element_Type := Get_Element_Subtype (Lit_Type);
+
+ Translate_Static_String_Literal_Inner (List, Str, Element_Type);
+
+ Finish_Array_Aggr (List, Res);
+ return Res;
+ end Translate_Static_String_Literal;
+
+ -- Create a variable (constant) for string or bit string literal STR.
+ -- The type of the literal element is ELEMENT_TYPE, and the ortho type
+ -- of the string (a constrained array type) is STR_TYPE.
+ function Create_String_Literal_Var_Inner
+ (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode)
+ return Var_Type
+ is
+ use Name_Table;
+
+ Val_Aggr : O_Array_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Start_Array_Aggr (Val_Aggr, Str_Type);
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Translate_Static_String_Literal_Inner
+ (Val_Aggr, Str, Element_Type);
+ when Iir_Kind_Bit_String_Literal =>
+ Translate_Static_Bit_String_Literal_Inner
+ (Val_Aggr, Str, Element_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Finish_Array_Aggr (Val_Aggr, Res);
+
+ return Create_Global_Const
+ (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res);
+ end Create_String_Literal_Var_Inner;
+
+ -- Create a variable (constant) for string or bit string literal STR.
+ function Create_String_Literal_Var (Str : Iir) return Var_Type is
+ use Name_Table;
+
+ Str_Type : constant Iir := Get_Type (Str);
+ Arr_Type : O_Tnode;
+ begin
+ -- Create the string value.
+ Arr_Type := New_Constrained_Array_Type
+ (Get_Info (Str_Type).T.Base_Type (Mode_Value),
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Get_String_Length (Str))));
+
+ return Create_String_Literal_Var_Inner
+ (Str, Get_Element_Subtype (Str_Type), Arr_Type);
+ end Create_String_Literal_Var;
+
+ -- Some strings literal have an unconstrained array type,
+ -- eg: 'image of constant. Its type is not constrained
+ -- because it is not so in VHDL!
+ function Translate_Non_Static_String_Literal (Str : Iir)
+ return O_Enode
+ is
+ use Name_Table;
+
+ Lit_Type : constant Iir := Get_Type (Str);
+ Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type);
+ Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0);
+ Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type);
+ Bound_Aggr : O_Record_Aggr_List;
+ Index_Aggr : O_Record_Aggr_List;
+ Res_Aggr : O_Record_Aggr_List;
+ Res : O_Cnode;
+ Len : Int32;
+ Val : Var_Type;
+ Bound : Var_Type;
+ R : O_Enode;
+ begin
+ -- Create the string value.
+ Len := Get_String_Length (Str);
+ Val := Create_String_Literal_Var (Str);
+
+ if Type_Info.Type_Mode = Type_Mode_Fat_Array then
+ -- Create the string bound.
+ Start_Record_Aggr (Bound_Aggr, Type_Info.T.Bounds_Type);
+ Start_Record_Aggr (Index_Aggr, Index_Type_Info.T.Range_Type);
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Signed_Literal
+ (Index_Type_Info.Ortho_Type (Mode_Value), 0));
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Signed_Literal (Index_Type_Info.Ortho_Type (Mode_Value),
+ Integer_64 (Len - 1)));
+ New_Record_Aggr_El
+ (Index_Aggr, Ghdl_Dir_To_Node);
+ New_Record_Aggr_El
+ (Index_Aggr,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len)));
+ Finish_Record_Aggr (Index_Aggr, Res);
+ New_Record_Aggr_El (Bound_Aggr, Res);
+ Finish_Record_Aggr (Bound_Aggr, Res);
+ Bound := Create_Global_Const
+ (Create_Uniq_Identifier, Type_Info.T.Bounds_Type,
+ O_Storage_Private, Res);
+
+ -- The descriptor.
+ Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value));
+ New_Record_Aggr_El
+ (Res_Aggr,
+ New_Global_Address (Get_Var_Label (Val),
+ Type_Info.T.Base_Ptr_Type (Mode_Value)));
+ New_Record_Aggr_El
+ (Res_Aggr,
+ New_Global_Address (Get_Var_Label (Bound),
+ Type_Info.T.Bounds_Ptr_Type));
+ Finish_Record_Aggr (Res_Aggr, Res);
+
+ Val := Create_Global_Const
+ (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value),
+ O_Storage_Private, Res);
+ elsif Type_Info.Type_Mode = Type_Mode_Array then
+ -- Type of string literal isn't statically known; check the
+ -- length.
+ Chap6.Check_Bound_Error
+ (New_Compare_Op
+ (ON_Neq,
+ New_Lit (New_Index_Lit (Unsigned_64 (Len))),
+ Chap3.Get_Array_Type_Length (Lit_Type),
+ Ghdl_Bool_Type),
+ Str, 1);
+ else
+ raise Internal_Error;
+ end if;
+
+ R := New_Address (Get_Var (Val),
+ Type_Info.Ortho_Ptr_Type (Mode_Value));
+ return R;
+ end Translate_Non_Static_String_Literal;
+
+ -- Only for Strings of STD.Character.
+ function Translate_Static_String (Str_Type : Iir; Str_Ident : Name_Id)
+ return O_Cnode
+ is
+ use Name_Table;
+
+ Literal_List : Iir_List;
+ Lit : Iir;
+ List : O_Array_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Chap3.Translate_Anonymous_Type_Definition (Str_Type, True);
+
+ Start_Array_Aggr (List, Get_Ortho_Type (Str_Type, Mode_Value));
+
+ Literal_List :=
+ Get_Enumeration_Literal_List (Character_Type_Definition);
+ Image (Str_Ident);
+ for I in 1 .. Name_Length loop
+ Lit := Get_Nth_Element (Literal_List,
+ Character'Pos (Name_Buffer (I)));
+ New_Array_Aggr_El (List, Get_Ortho_Expr (Lit));
+ end loop;
+
+ Finish_Array_Aggr (List, Res);
+ return Res;
+ end Translate_Static_String;
+
+ function Translate_Static_Bit_String_Literal
+ (Lit : Iir_Bit_String_Literal)
+ return O_Cnode
+ is
+ Lit_Type : Iir;
+ Res : O_Cnode;
+ List : O_Array_Aggr_List;
+ begin
+ Lit_Type := Get_Type (Lit);
+ Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True);
+ Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value));
+ Translate_Static_Bit_String_Literal_Inner (List, Lit, Lit_Type);
+ Finish_Array_Aggr (List, Res);
+ return Res;
+ end Translate_Static_Bit_String_Literal;
+
+ function Translate_String_Literal (Str : Iir) return O_Enode
+ is
+ Str_Type : constant Iir := Get_Type (Str);
+ Var : Var_Type;
+ Info : Type_Info_Acc;
+ Res : O_Cnode;
+ R : O_Enode;
+ begin
+ if Get_Constraint_State (Str_Type) = Fully_Constrained
+ and then
+ Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally
+ then
+ Chap3.Create_Array_Subtype (Str_Type, True);
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ Res := Translate_Static_String_Literal (Str);
+ when Iir_Kind_Bit_String_Literal =>
+ Res := Translate_Static_Bit_String_Literal (Str);
+ when Iir_Kind_Simple_Aggregate =>
+ Res := Translate_Static_Simple_Aggregate (Str);
+ when Iir_Kind_Simple_Name_Attribute =>
+ Res := Translate_Static_String
+ (Get_Type (Str), Get_Simple_Name_Identifier (Str));
+ when others =>
+ raise Internal_Error;
+ end case;
+ Info := Get_Info (Str_Type);
+ Var := Create_Global_Const
+ (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value),
+ O_Storage_Private, Res);
+ R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value));
+ return R;
+ else
+ return Translate_Non_Static_String_Literal (Str);
+ end if;
+ end Translate_String_Literal;
+
+ function Translate_Static_Implicit_Conv
+ (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode
+ is
+ Expr_Info : Type_Info_Acc;
+ Res_Info : Type_Info_Acc;
+ Val : Var_Type;
+ Res : O_Cnode;
+ List : O_Record_Aggr_List;
+ Bound : Var_Type;
+ begin
+ if Res_Type = Expr_Type then
+ return Expr;
+ end if;
+ if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then
+ raise Internal_Error;
+ end if;
+ if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then
+ return Expr;
+ end if;
+ if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then
+ raise Internal_Error;
+ end if;
+ Expr_Info := Get_Info (Expr_Type);
+ Res_Info := Get_Info (Res_Type);
+ Val := Create_Global_Const
+ (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value),
+ O_Storage_Private, Expr);
+ Bound := Expr_Info.T.Array_Bounds;
+ if Bound = Null_Var then
+ Bound := Create_Global_Const
+ (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type,
+ O_Storage_Private,
+ Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type));
+ Expr_Info.T.Array_Bounds := Bound;
+ end if;
+
+ Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value));
+ New_Record_Aggr_El
+ (List, New_Global_Address (Get_Var_Label (Val),
+ Res_Info.T.Base_Ptr_Type (Mode_Value)));
+ New_Record_Aggr_El
+ (List, New_Global_Address (Get_Var_Label (Bound),
+ Expr_Info.T.Bounds_Ptr_Type));
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Translate_Static_Implicit_Conv;
+
+ function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode)
+ return O_Cnode
+ is
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal =>
+ return New_Signed_Literal
+ (Res_Type, Integer_64 (Get_Value (Expr)));
+
+ when Iir_Kind_Enumeration_Literal =>
+ return Get_Ortho_Expr (Get_Enumeration_Decl (Expr));
+
+ when Iir_Kind_Floating_Point_Literal =>
+ return New_Float_Literal
+ (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr)));
+
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Unit_Declaration =>
+ return New_Signed_Literal
+ (Res_Type, Integer_64 (Get_Physical_Value (Expr)));
+
+ when others =>
+ Error_Kind ("translate_numeric_literal", Expr);
+ end case;
+ exception
+ when Constraint_Error =>
+ -- Can be raised by Get_Physical_Unit_Value because of the kludge
+ -- on staticness.
+ Error_Msg_Elab ("numeric literal not in range", Expr);
+ return New_Signed_Literal (Res_Type, 0);
+ end Translate_Numeric_Literal;
+
+ function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir)
+ return O_Cnode
+ is
+ Expr_Type : Iir;
+ Expr_Otype : O_Tnode;
+ Tinfo : Type_Info_Acc;
+ begin
+ Expr_Type := Get_Type (Expr);
+ Tinfo := Get_Info (Expr_Type);
+ if Res_Type /= Null_Iir then
+ Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value);
+ else
+ if Tinfo = null then
+ -- FIXME: this is a working kludge, in the case where EXPR_TYPE
+ -- is a subtype which was not yet translated.
+ -- (eg: evaluated array attribute)
+ Tinfo := Get_Info (Get_Base_Type (Expr_Type));
+ end if;
+ Expr_Otype := Tinfo.Ortho_Type (Mode_Value);
+ end if;
+ return Translate_Numeric_Literal (Expr, Expr_Otype);
+ end Translate_Numeric_Literal;
+
+ function Translate_Static_Expression (Expr : Iir; Res_Type : Iir)
+ return O_Cnode
+ is
+ Expr_Type : constant Iir := Get_Type (Expr);
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Physical_Fp_Literal =>
+ return Translate_Numeric_Literal (Expr, Res_Type);
+
+ when Iir_Kind_String_Literal =>
+ return Translate_Static_Implicit_Conv
+ (Translate_Static_String_Literal (Expr), Expr_Type, Res_Type);
+ when Iir_Kind_Bit_String_Literal =>
+ return Translate_Static_Implicit_Conv
+ (Translate_Static_Bit_String_Literal (Expr),
+ Expr_Type, Res_Type);
+ when Iir_Kind_Simple_Aggregate =>
+ return Translate_Static_Implicit_Conv
+ (Translate_Static_Simple_Aggregate (Expr),
+ Expr_Type, Res_Type);
+ when Iir_Kind_Aggregate =>
+ return Translate_Static_Implicit_Conv
+ (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type);
+
+ when Iir_Kinds_Denoting_Name =>
+ return Translate_Static_Expression
+ (Get_Named_Entity (Expr), Res_Type);
+ when others =>
+ Error_Kind ("translate_static_expression", Expr);
+ end case;
+ end Translate_Static_Expression;
+
+ function Translate_Static_Range_Left
+ (Expr : Iir; Range_Type : Iir := Null_Iir)
+ return O_Cnode
+ is
+ Left : O_Cnode;
+ Bound : Iir;
+ begin
+ Bound := Get_Left_Limit (Expr);
+ Left := Chap7.Translate_Static_Expression (Bound, Range_Type);
+-- if Range_Type /= Null_Iir and then Get_Type (Bound) /= Range_Type then
+-- Left := New_Convert_Ov
+-- (Left, Get_Ortho_Type (Range_Type, Mode_Value));
+-- end if;
+ return Left;
+ end Translate_Static_Range_Left;
+
+ function Translate_Static_Range_Right
+ (Expr : Iir; Range_Type : Iir := Null_Iir)
+ return O_Cnode
+ is
+ Right : O_Cnode;
+ begin
+ Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr),
+ Range_Type);
+-- if Range_Type /= Null_Iir then
+-- Right := New_Convert_Ov
+-- (Right, Get_Ortho_Type (Range_Type, Mode_Value));
+-- end if;
+ return Right;
+ end Translate_Static_Range_Right;
+
+ function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode
+ is
+ begin
+ case Get_Direction (Expr) is
+ when Iir_To =>
+ return Ghdl_Dir_To_Node;
+ when Iir_Downto =>
+ return Ghdl_Dir_Downto_Node;
+ end case;
+ end Translate_Static_Range_Dir;
+
+ function Translate_Static_Range_Length (Expr : Iir) return O_Cnode
+ is
+ Ulen : Unsigned_64;
+ begin
+ Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr));
+ return New_Unsigned_Literal (Ghdl_Index_Type, Ulen);
+ end Translate_Static_Range_Length;
+
+ function Translate_Range_Expression_Left (Expr : Iir;
+ Range_Type : Iir := Null_Iir)
+ return O_Enode
+ is
+ Left : O_Enode;
+ begin
+ Left := Chap7.Translate_Expression (Get_Left_Limit (Expr));
+ if Range_Type /= Null_Iir then
+ Left := New_Convert_Ov (Left,
+ Get_Ortho_Type (Range_Type, Mode_Value));
+ end if;
+ return Left;
+ end Translate_Range_Expression_Left;
+
+ function Translate_Range_Expression_Right (Expr : Iir;
+ Range_Type : Iir := Null_Iir)
+ return O_Enode
+ is
+ Right : O_Enode;
+ begin
+ Right := Chap7.Translate_Expression (Get_Right_Limit (Expr));
+ if Range_Type /= Null_Iir then
+ Right := New_Convert_Ov (Right,
+ Get_Ortho_Type (Range_Type, Mode_Value));
+ end if;
+ return Right;
+ end Translate_Range_Expression_Right;
+
+ -- Compute the length of LEFT DIR (to/downto) RIGHT.
+ function Compute_Range_Length
+ (Left : O_Enode; Right : O_Enode; Dir : Iir_Direction)
+ return O_Enode
+ is
+ L : O_Enode;
+ R : O_Enode;
+ Val : O_Enode;
+ Tmp : O_Dnode;
+ Res : O_Dnode;
+ If_Blk : O_If_Block;
+ Rng_Type : O_Tnode;
+ begin
+ Rng_Type := Ghdl_I32_Type;
+ L := New_Convert_Ov (Left, Rng_Type);
+ R := New_Convert_Ov (Right, Rng_Type);
+
+ case Dir is
+ when Iir_To =>
+ Val := New_Dyadic_Op (ON_Sub_Ov, R, L);
+ when Iir_Downto =>
+ Val := New_Dyadic_Op (ON_Sub_Ov, L, R);
+ end case;
+
+ Res := Create_Temp (Ghdl_Index_Type);
+ Open_Temp;
+ Tmp := Create_Temp (Rng_Type);
+ New_Assign_Stmt (New_Obj (Tmp), Val);
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Lt, New_Obj_Value (Tmp),
+ New_Lit (New_Signed_Literal (Rng_Type, 0)),
+ Ghdl_Bool_Type));
+ Init_Var (Res);
+ New_Else_Stmt (If_Blk);
+ Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type);
+ Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1));
+ New_Assign_Stmt (New_Obj (Res), Val);
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ return New_Obj_Value (Res);
+ end Compute_Range_Length;
+
+ function Translate_Range_Expression_Length (Expr : Iir) return O_Enode
+ is
+ Left, Right : O_Enode;
+ begin
+ if Get_Expr_Staticness (Expr) = Locally then
+ return New_Lit (Translate_Static_Range_Length (Expr));
+ else
+ Left := Chap7.Translate_Expression (Get_Left_Limit (Expr));
+ Right := Chap7.Translate_Expression (Get_Right_Limit (Expr));
+
+ return Compute_Range_Length (Left, Right, Get_Direction (Expr));
+ end if;
+ end Translate_Range_Expression_Length;
+
+ function Translate_Range_Length (Expr : Iir) return O_Enode is
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Range_Expression =>
+ return Translate_Range_Expression_Length (Expr);
+ when Iir_Kind_Range_Array_Attribute =>
+ return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir);
+ when others =>
+ Error_Kind ("translate_range_length", Expr);
+ end case;
+ end Translate_Range_Length;
+
+ function Translate_Association (Assoc : Iir) return O_Enode
+ is
+ Formal : constant Iir := Get_Formal (Assoc);
+ Formal_Base : constant Iir := Get_Association_Interface (Assoc);
+ Actual : Iir;
+ begin
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ Actual := Get_Actual (Assoc);
+ when Iir_Kind_Association_Element_Open =>
+ Actual := Get_Default_Value (Formal);
+ when others =>
+ Error_Kind ("translate_association", Assoc);
+ end case;
+
+ case Get_Kind (Formal_Base) is
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return Chap3.Maybe_Insert_Scalar_Check
+ (Translate_Expression (Actual, Get_Type (Formal)),
+ Actual, Get_Type (Formal));
+ when Iir_Kind_Interface_Signal_Declaration =>
+ return Translate_Implicit_Conv
+ (M2E (Chap6.Translate_Name (Actual)),
+ Get_Type (Actual),
+ Get_Type (Formal_Base),
+ Mode_Signal, Assoc);
+ when others =>
+ Error_Kind ("translate_association", Formal);
+ end case;
+ end Translate_Association;
+
+ function Translate_Function_Call
+ (Imp : Iir; Assoc_Chain : Iir; Obj : Iir)
+ return O_Enode
+ is
+ Info : constant Subprg_Info_Acc := Get_Info (Imp);
+ Constr : O_Assoc_List;
+ Assoc : Iir;
+ Res : Mnode;
+ begin
+ if Info.Use_Stack2 then
+ Create_Temp_Stack2_Mark;
+ end if;
+
+ if Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ -- If we need to allocate, do it before starting the call!
+ declare
+ Res_Type : Iir;
+ Res_Info : Type_Info_Acc;
+ begin
+ Res_Type := Get_Return_Type (Imp);
+ Res_Info := Get_Info (Res_Type);
+ Res := Create_Temp (Res_Info);
+ if Res_Info.Type_Mode /= Type_Mode_Fat_Array then
+ Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res);
+ end if;
+ end;
+ end if;
+
+ Start_Association (Constr, Info.Ortho_Func);
+
+ if Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ New_Association (Constr, M2E (Res));
+ end if;
+
+ -- If the subprogram is a method, pass the protected object.
+ if Obj /= Null_Iir then
+ New_Association (Constr, M2E (Chap6.Translate_Name (Obj)));
+ else
+ Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance);
+ end if;
+
+ Assoc := Assoc_Chain;
+ while Assoc /= Null_Iir loop
+ -- FIXME: evaluate expression before, because we
+ -- may allocate objects.
+ New_Association (Constr, Translate_Association (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ if Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ New_Procedure_Call (Constr);
+ return M2E (Res);
+ else
+ return New_Function_Call (Constr);
+ end if;
+ end Translate_Function_Call;
+
+ function Translate_Operator_Function_Call
+ (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir)
+ return O_Enode
+ is
+ function Create_Assoc (Actual : Iir; Formal : Iir)
+ return Iir
+ is
+ R : Iir;
+ begin
+ R := Create_Iir (Iir_Kind_Association_Element_By_Expression);
+ Location_Copy (R, Actual);
+ Set_Actual (R, Actual);
+ Set_Formal (R, Formal);
+ return R;
+ end Create_Assoc;
+
+ Inter : Iir;
+ El_L : Iir;
+ El_R : Iir;
+ Res : O_Enode;
+ begin
+ Inter := Get_Interface_Declaration_Chain (Imp);
+
+ El_L := Create_Assoc (Left, Inter);
+
+ if Right /= Null_Iir then
+ Inter := Get_Chain (Inter);
+ El_R := Create_Assoc (Right, Inter);
+ Set_Chain (El_L, El_R);
+ end if;
+
+ Res := Translate_Function_Call (Imp, El_L, Null_Iir);
+
+ Free_Iir (El_L);
+ if Right /= Null_Iir then
+ Free_Iir (El_R);
+ end if;
+
+ return Translate_Implicit_Conv
+ (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left);
+ end Translate_Operator_Function_Call;
+
+ function Convert_Constrained_To_Unconstrained
+ (Expr : Mnode; Res_Type : Iir)
+ return Mnode
+ is
+ Type_Info : constant Type_Info_Acc := Get_Info (Res_Type);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Expr);
+ Stable_Expr : Mnode;
+ Res : Mnode;
+ begin
+ Res := Create_Temp (Type_Info, Kind);
+ Stable_Expr := Stabilize (Expr);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Res)),
+ New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)),
+ Type_Info.T.Base_Ptr_Type (Kind)));
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ M2Addr (Chap3.Get_Array_Bounds (Stable_Expr)));
+ return Res;
+ end Convert_Constrained_To_Unconstrained;
+
+ function Convert_Array_To_Thin_Array (Expr : Mnode;
+ Expr_Type : Iir;
+ Atype : Iir;
+ Loc : Iir)
+ return Mnode
+ is
+ Expr_Indexes : constant Iir_List :=
+ Get_Index_Subtype_List (Expr_Type);
+ Expr_Stable : Mnode;
+ Success_Label, Failure_Label : O_Snode;
+ begin
+ Expr_Stable := Stabilize (Expr);
+
+ Open_Temp;
+ -- Check each dimension.
+ Start_Loop_Stmt (Success_Label);
+ Start_Loop_Stmt (Failure_Label);
+ for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop
+ Gen_Exit_When
+ (Failure_Label,
+ New_Compare_Op
+ (ON_Neq,
+ Chap6.Get_Array_Bound_Length
+ (Expr_Stable, Expr_Type, I),
+ Chap6.Get_Array_Bound_Length
+ (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I),
+ Ghdl_Bool_Type));
+ end loop;
+ New_Exit_Stmt (Success_Label);
+ Finish_Loop_Stmt (Failure_Label);
+ Chap6.Gen_Bound_Error (Loc);
+ Finish_Loop_Stmt (Success_Label);
+ Close_Temp;
+
+ return Chap3.Get_Array_Base (Expr_Stable);
+ end Convert_Array_To_Thin_Array;
+
+ function Translate_Implicit_Array_Conversion
+ (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return Mnode
+ is
+ Ainfo : Type_Info_Acc;
+ Einfo : Type_Info_Acc;
+ begin
+ pragma Assert
+ (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition);
+
+ if Res_Type = Expr_Type then
+ return Expr;
+ end if;
+
+ Ainfo := Get_Info (Res_Type);
+ Einfo := Get_Info (Expr_Type);
+ case Ainfo.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ -- X to unconstrained.
+ case Einfo.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ -- unconstrained to unconstrained.
+ return Expr;
+ when Type_Mode_Array =>
+ -- constrained to unconstrained.
+ return Convert_Constrained_To_Unconstrained
+ (Expr, Res_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Type_Mode_Array =>
+ -- X to constrained.
+ if Einfo.Type_Locally_Constrained
+ and then Ainfo.Type_Locally_Constrained
+ then
+ -- FIXME: optimize static vs non-static
+ -- constrained to constrained.
+ if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then
+ -- FIXME: generate a bound error ?
+ -- Even if this is caught at compile-time,
+ -- the code is not required to run.
+ Chap6.Gen_Bound_Error (Loc);
+ end if;
+ return Expr;
+ else
+ -- Unbounded/bounded array to bounded array.
+ return Convert_Array_To_Thin_Array
+ (Expr, Expr_Type, Res_Type, Loc);
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Translate_Implicit_Array_Conversion;
+
+ -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE.
+ function Translate_Implicit_Conv (Expr : O_Enode;
+ Expr_Type : Iir;
+ Atype : Iir;
+ Is_Sig : Object_Kind_Type;
+ Loc : Iir)
+ return O_Enode is
+ begin
+ -- Same type: nothing to do.
+ if Atype = Expr_Type then
+ return Expr;
+ end if;
+
+ if Expr_Type = Universal_Integer_Type_Definition then
+ return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value));
+ elsif Expr_Type = Universal_Real_Type_Definition then
+ return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value));
+ elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then
+ return M2E (Translate_Implicit_Array_Conversion
+ (E2M (Expr, Get_Info (Expr_Type), Is_Sig),
+ Expr_Type, Atype, Loc));
+ else
+ return Expr;
+ end if;
+ end Translate_Implicit_Conv;
+
+ type Predefined_To_Onop_Type is array (Iir_Predefined_Functions)
+ of ON_Op_Kind;
+ Predefined_To_Onop : constant Predefined_To_Onop_Type :=
+ (Iir_Predefined_Boolean_Or => ON_Or,
+ Iir_Predefined_Boolean_Not => ON_Not,
+ Iir_Predefined_Boolean_And => ON_And,
+ Iir_Predefined_Boolean_Xor => ON_Xor,
+
+ Iir_Predefined_Bit_Not => ON_Not,
+ Iir_Predefined_Bit_And => ON_And,
+ Iir_Predefined_Bit_Or => ON_Or,
+ Iir_Predefined_Bit_Xor => ON_Xor,
+
+ Iir_Predefined_Integer_Equality => ON_Eq,
+ Iir_Predefined_Integer_Inequality => ON_Neq,
+ Iir_Predefined_Integer_Less_Equal => ON_Le,
+ Iir_Predefined_Integer_Less => ON_Lt,
+ Iir_Predefined_Integer_Greater => ON_Gt,
+ Iir_Predefined_Integer_Greater_Equal => ON_Ge,
+ Iir_Predefined_Integer_Plus => ON_Add_Ov,
+ Iir_Predefined_Integer_Minus => ON_Sub_Ov,
+ Iir_Predefined_Integer_Mul => ON_Mul_Ov,
+ Iir_Predefined_Integer_Rem => ON_Rem_Ov,
+ Iir_Predefined_Integer_Mod => ON_Mod_Ov,
+ Iir_Predefined_Integer_Div => ON_Div_Ov,
+ Iir_Predefined_Integer_Absolute => ON_Abs_Ov,
+ Iir_Predefined_Integer_Negation => ON_Neg_Ov,
+
+ Iir_Predefined_Enum_Equality => ON_Eq,
+ Iir_Predefined_Enum_Inequality => ON_Neq,
+ Iir_Predefined_Enum_Greater_Equal => ON_Ge,
+ Iir_Predefined_Enum_Greater => ON_Gt,
+ Iir_Predefined_Enum_Less => ON_Lt,
+ Iir_Predefined_Enum_Less_Equal => ON_Le,
+
+ Iir_Predefined_Physical_Equality => ON_Eq,
+ Iir_Predefined_Physical_Inequality => ON_Neq,
+ Iir_Predefined_Physical_Less => ON_Lt,
+ Iir_Predefined_Physical_Less_Equal => ON_Le,
+ Iir_Predefined_Physical_Greater => ON_Gt,
+ Iir_Predefined_Physical_Greater_Equal => ON_Ge,
+ Iir_Predefined_Physical_Negation => ON_Neg_Ov,
+ Iir_Predefined_Physical_Absolute => ON_Abs_Ov,
+ Iir_Predefined_Physical_Minus => ON_Sub_Ov,
+ Iir_Predefined_Physical_Plus => ON_Add_Ov,
+
+ Iir_Predefined_Floating_Greater => ON_Gt,
+ Iir_Predefined_Floating_Greater_Equal => ON_Ge,
+ Iir_Predefined_Floating_Less => ON_Lt,
+ Iir_Predefined_Floating_Less_Equal => ON_Le,
+ Iir_Predefined_Floating_Equality => ON_Eq,
+ Iir_Predefined_Floating_Inequality => ON_Neq,
+ Iir_Predefined_Floating_Minus => ON_Sub_Ov,
+ Iir_Predefined_Floating_Plus => ON_Add_Ov,
+ Iir_Predefined_Floating_Mul => ON_Mul_Ov,
+ Iir_Predefined_Floating_Div => ON_Div_Ov,
+ Iir_Predefined_Floating_Negation => ON_Neg_Ov,
+ Iir_Predefined_Floating_Absolute => ON_Abs_Ov,
+
+ others => ON_Nil);
+
+ function Translate_Shortcut_Operator
+ (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir)
+ return O_Enode
+ is
+ Rtype : Iir;
+ Res : O_Dnode;
+ Res_Type : O_Tnode;
+ If_Blk : O_If_Block;
+ Val : Integer;
+ V : O_Cnode;
+ Kind : Iir_Predefined_Functions;
+ Invert : Boolean;
+ begin
+ Rtype := Get_Return_Type (Imp);
+ Res_Type := Get_Ortho_Type (Rtype, Mode_Value);
+ Res := Create_Temp (Res_Type);
+ Open_Temp;
+ New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left));
+ Close_Temp;
+ Kind := Get_Implicit_Definition (Imp);
+
+ -- Short cut: RIGHT is the result (and must be evaluated) iff
+ -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1).
+ case Kind is
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Boolean_And =>
+ Invert := False;
+ Val := 1;
+ when Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Boolean_Nand =>
+ Invert := True;
+ Val := 1;
+ when Iir_Predefined_Bit_Or
+ | Iir_Predefined_Boolean_Or =>
+ Invert := False;
+ Val := 0;
+ when Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_Nor =>
+ Invert := True;
+ Val := 0;
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("translate_shortcut_operator: cannot handle "
+ & Iir_Predefined_Functions'Image (Kind));
+ raise Internal_Error;
+ end case;
+
+ V := Get_Ortho_Expr
+ (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val));
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Res), New_Lit (V),
+ Ghdl_Bool_Type));
+ Open_Temp;
+ New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right));
+ Close_Temp;
+ Finish_If_Stmt (If_Blk);
+ if Invert then
+ return New_Monadic_Op (ON_Not, New_Obj_Value (Res));
+ else
+ return New_Obj_Value (Res);
+ end if;
+ end Translate_Shortcut_Operator;
+
+ function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode)
+ return O_Enode
+ is
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Func);
+ New_Association (Constr, Left);
+ if Right /= O_Enode_Null then
+ New_Association (Constr, Right);
+ end if;
+ return New_Function_Call (Constr);
+ end Translate_Lib_Operator;
+
+ function Translate_Predefined_Lib_Operator
+ (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration)
+ return O_Enode
+ is
+ Info : constant Subprg_Info_Acc := Get_Info (Func);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance);
+ New_Association (Constr, Left);
+ if Right /= O_Enode_Null then
+ New_Association (Constr, Right);
+ end if;
+ return New_Function_Call (Constr);
+ end Translate_Predefined_Lib_Operator;
+
+ function Translate_Predefined_Array_Operator
+ (Left, Right : O_Enode; Func : Iir)
+ return O_Enode
+ is
+ Res : O_Dnode;
+ Constr : O_Assoc_List;
+ Info : Type_Info_Acc;
+ Func_Info : Subprg_Info_Acc;
+ begin
+ Create_Temp_Stack2_Mark;
+ Info := Get_Info (Get_Return_Type (Func));
+ Res := Create_Temp (Info.Ortho_Type (Mode_Value));
+ Func_Info := Get_Info (Func);
+ Start_Association (Constr, Func_Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance);
+ New_Association (Constr,
+ New_Address (New_Obj (Res),
+ Info.Ortho_Ptr_Type (Mode_Value)));
+ New_Association (Constr, Left);
+ if Right /= O_Enode_Null then
+ New_Association (Constr, Right);
+ end if;
+ New_Procedure_Call (Constr);
+ return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value));
+ end Translate_Predefined_Array_Operator;
+
+ function Translate_Predefined_Array_Operator_Convert
+ (Left, Right : O_Enode; Func : Iir; Res_Type : Iir)
+ return O_Enode
+ is
+ Res : O_Enode;
+ Ret_Type : Iir;
+ begin
+ Ret_Type := Get_Return_Type (Func);
+ Res := Translate_Predefined_Array_Operator (Left, Right, Func);
+ return Translate_Implicit_Conv
+ (Res, Ret_Type, Res_Type, Mode_Value, Func);
+ end Translate_Predefined_Array_Operator_Convert;
+
+ -- Create an array aggregate containing one element, EL.
+ function Translate_Element_To_Array (El : O_Enode; Arr_Type : Iir)
+ return O_Enode
+ is
+ Res : O_Dnode;
+ Ainfo : Type_Info_Acc;
+ Einfo : Type_Info_Acc;
+ V : O_Dnode;
+ begin
+ Ainfo := Get_Info (Arr_Type);
+ Einfo := Get_Info (Get_Element_Subtype (Arr_Type));
+ Res := Create_Temp (Ainfo.Ortho_Type (Mode_Value));
+ if Is_Composite (Einfo) then
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Res),
+ Ainfo.T.Base_Field (Mode_Value)),
+ New_Convert_Ov (El, Ainfo.T.Base_Ptr_Type (Mode_Value)));
+ else
+ V := Create_Temp_Init (Einfo.Ortho_Type (Mode_Value), El);
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Res),
+ Ainfo.T.Base_Field (Mode_Value)),
+ New_Convert_Ov (New_Address (New_Obj (V),
+ Einfo.Ortho_Ptr_Type (Mode_Value)),
+ Ainfo.T.Base_Ptr_Type (Mode_Value)));
+ end if;
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Res),
+ Ainfo.T.Bounds_Field (Mode_Value)),
+ New_Address (Get_Var (Ainfo.T.Array_1bound),
+ Ainfo.T.Bounds_Ptr_Type));
+ return New_Address (New_Obj (Res), Ainfo.Ortho_Ptr_Type (Mode_Value));
+ end Translate_Element_To_Array;
+
+ function Translate_Concat_Operator
+ (Left_Tree, Right_Tree : O_Enode;
+ Imp : Iir_Implicit_Function_Declaration;
+ Res_Type : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Ret_Type : constant Iir := Get_Return_Type (Imp);
+ Kind : constant Iir_Predefined_Functions :=
+ Get_Implicit_Definition (Imp);
+ Arr_El1 : O_Enode;
+ Arr_El2 : O_Enode;
+ Res : O_Enode;
+ begin
+ case Kind is
+ when Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Arr_El1 := Translate_Element_To_Array (Left_Tree, Ret_Type);
+ when others =>
+ Arr_El1 := Left_Tree;
+ end case;
+ case Kind is
+ when Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Arr_El2 := Translate_Element_To_Array (Right_Tree, Ret_Type);
+ when others =>
+ Arr_El2 := Right_Tree;
+ end case;
+ Res := Translate_Predefined_Array_Operator (Arr_El1, Arr_El2, Imp);
+ return Translate_Implicit_Conv
+ (Res, Ret_Type, Res_Type, Mode_Value, Loc);
+ end Translate_Concat_Operator;
+
+ function Translate_Scalar_Min_Max
+ (Op : ON_Op_Kind;
+ Left, Right : Iir;
+ Res_Type : Iir)
+ return O_Enode
+ is
+ Res_Otype : constant O_Tnode :=
+ Get_Ortho_Type (Res_Type, Mode_Value);
+ Res, L, R : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ -- Create a variable for the result.
+ Res := Create_Temp (Res_Otype);
+
+ Open_Temp;
+ L := Create_Temp_Init
+ (Res_Otype, Translate_Expression (Left, Res_Type));
+ R := Create_Temp_Init
+ (Res_Otype, Translate_Expression (Right, Res_Type));
+
+ Start_If_Stmt (If_Blk, New_Compare_Op (Op,
+ New_Obj_Value (L),
+ New_Obj_Value (R),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+
+ return New_Obj_Value (Res);
+ end Translate_Scalar_Min_Max;
+
+ function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean;
+ Left : Iir;
+ Res_Type : Iir)
+ return O_Enode
+ is
+ Res_Otype : constant O_Tnode :=
+ Get_Ortho_Type (Res_Type, Mode_Value);
+ Left_Type : constant Iir := Get_Type (Left);
+ Res, El, Len : O_Dnode;
+ Arr : Mnode;
+ If_Blk : O_If_Block;
+ Label : O_Snode;
+ Op : ON_Op_Kind;
+ begin
+ -- Create a variable for the result.
+ Res := Create_Temp (Res_Otype);
+
+ Open_Temp;
+ if Is_Min then
+ Op := ON_Lt;
+ else
+ Op := ON_Gt;
+ end if;
+ New_Assign_Stmt
+ (New_Obj (Res),
+ Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min));
+
+ El := Create_Temp (Res_Otype);
+ Arr := Stabilize (E2M (Translate_Expression (Left),
+ Get_Info (Left_Type), Mode_Value));
+ Len := Create_Temp_Init
+ (Ghdl_Index_Type,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (Arr, Left_Type, 1))));
+
+ -- Create:
+ -- loop
+ -- exit when LEN = 0;
+ -- LEN := LEN - 1;
+ -- if ARR[LEN] </> RES then
+ -- RES := ARR[LEN];
+ -- end if;
+ -- end loop;
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ Dec_Var (Len);
+ New_Assign_Stmt
+ (New_Obj (El),
+ M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr),
+ Left_Type, New_Obj_Value (Len))));
+ Start_If_Stmt (If_Blk, New_Compare_Op (Op,
+ New_Obj_Value (El),
+ New_Obj_Value (Res),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El));
+ Finish_If_Stmt (If_Blk);
+ Finish_Loop_Stmt (Label);
+
+ Close_Temp;
+
+ return New_Obj_Value (Res);
+ end Translate_Predefined_Vector_Min_Max;
+
+ function Translate_Std_Ulogic_Match (Func : O_Dnode;
+ L, R : O_Enode;
+ Res_Type : O_Tnode)
+ return O_Enode
+ is
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Func);
+ New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type));
+ New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type));
+ return New_Convert_Ov (New_Function_Call (Constr), Res_Type);
+ end Translate_Std_Ulogic_Match;
+
+ function Translate_To_String (Subprg : O_Dnode;
+ Res_Type : Iir;
+ Loc : Iir;
+ Val : O_Enode;
+ Arg2 : O_Enode := O_Enode_Null;
+ Arg3 : O_Enode := O_Enode_Null)
+ return O_Enode
+ is
+ Val_Type : constant Iir := Get_Base_Type (Res_Type);
+ Res : O_Dnode;
+ Assoc : O_Assoc_List;
+ begin
+ Res := Create_Temp (Std_String_Node);
+ Create_Temp_Stack2_Mark;
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc,
+ New_Address (New_Obj (Res), Std_String_Ptr_Node));
+ New_Association (Assoc, Val);
+ if Arg2 /= O_Enode_Null then
+ New_Association (Assoc, Arg2);
+ if Arg3 /= O_Enode_Null then
+ New_Association (Assoc, Arg3);
+ end if;
+ end if;
+ New_Procedure_Call (Assoc);
+ return M2E (Translate_Implicit_Array_Conversion
+ (Dv2M (Res, Get_Info (Val_Type), Mode_Value),
+ Val_Type, Res_Type, Loc));
+ end Translate_To_String;
+
+ function Translate_Bv_To_String (Subprg : O_Dnode;
+ Val : O_Enode;
+ Val_Type : Iir;
+ Res_Type : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Arr : Mnode;
+ begin
+ Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value));
+ return Translate_To_String
+ (Subprg, Res_Type, Loc,
+ M2E (Chap3.Get_Array_Base (Arr)),
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (Arr, Val_Type, 1))));
+ end Translate_Bv_To_String;
+
+ subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range
+ Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor;
+
+ function Translate_Predefined_Logical
+ (Op : Predefined_Boolean_Logical; Left, Right : O_Enode)
+ return O_Enode is
+ begin
+ case Op is
+ when Iir_Predefined_Boolean_And =>
+ return New_Dyadic_Op (ON_And, Left, Right);
+ when Iir_Predefined_Boolean_Or =>
+ return New_Dyadic_Op (ON_Or, Left, Right);
+ when Iir_Predefined_Boolean_Nand =>
+ return New_Monadic_Op
+ (ON_Not, New_Dyadic_Op (ON_And, Left, Right));
+ when Iir_Predefined_Boolean_Nor =>
+ return New_Monadic_Op
+ (ON_Not, New_Dyadic_Op (ON_Or, Left, Right));
+ when Iir_Predefined_Boolean_Xor =>
+ return New_Dyadic_Op (ON_Xor, Left, Right);
+ when Iir_Predefined_Boolean_Xnor =>
+ return New_Monadic_Op
+ (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right));
+ end case;
+ end Translate_Predefined_Logical;
+
+ function Translate_Predefined_TF_Array_Element
+ (Op : Predefined_Boolean_Logical;
+ Left, Right : Iir;
+ Res_Type : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Arr_Type : constant Iir := Get_Type (Left);
+ Res_Btype : constant Iir := Get_Base_Type (Res_Type);
+ Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype);
+ Base_Ptr_Type : constant O_Tnode :=
+ Res_Info.T.Base_Ptr_Type (Mode_Value);
+ Arr : Mnode;
+ El : O_Dnode;
+ Base : O_Dnode;
+ Len : O_Dnode;
+ Label : O_Snode;
+ Res : Mnode;
+ begin
+ -- Translate the array.
+ Arr := Stabilize (E2M (Translate_Expression (Left),
+ Get_Info (Arr_Type), Mode_Value));
+
+ -- Extract its length.
+ Len := Create_Temp_Init
+ (Ghdl_Index_Type,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (Arr, Arr_Type, 1))));
+
+ -- Allocate the result array.
+ Base := Create_Temp_Init
+ (Base_Ptr_Type,
+ Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type));
+
+ Open_Temp;
+ -- Translate the element.
+ El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value),
+ Translate_Expression (Right));
+ -- Create:
+ -- loop
+ -- exit when LEN = 0;
+ -- LEN := LEN - 1;
+ -- BASE[LEN] := EL op ARR[LEN];
+ -- end loop;
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ Dec_Var (Len);
+ New_Assign_Stmt
+ (New_Indexed_Acc_Value (New_Obj (Base),
+ New_Obj_Value (Len)),
+ Translate_Predefined_Logical
+ (Op,
+ New_Obj_Value (El),
+ M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr),
+ Arr_Type, New_Obj_Value (Len)))));
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+
+ Res := Create_Temp (Res_Info, Mode_Value);
+ New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)),
+ New_Obj_Value (Base));
+ New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ M2Addr (Chap3.Get_Array_Bounds (Arr)));
+
+ return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type,
+ Mode_Value, Loc);
+ end Translate_Predefined_TF_Array_Element;
+
+ function Translate_Predefined_TF_Reduction
+ (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir)
+ return O_Enode
+ is
+ Arr_Type : constant Iir := Get_Type (Operand);
+ Enums : constant Iir_List :=
+ Get_Enumeration_Literal_List (Get_Base_Type (Res_Type));
+ Init_Enum : Iir;
+
+ Res : O_Dnode;
+ Arr_Expr : O_Enode;
+ Arr : Mnode;
+ Len : O_Dnode;
+ Label : O_Snode;
+ begin
+ if Op = ON_And then
+ Init_Enum := Get_Nth_Element (Enums, 1);
+ else
+ Init_Enum := Get_Nth_Element (Enums, 0);
+ end if;
+
+ Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value),
+ New_Lit (Get_Ortho_Expr (Init_Enum)));
+
+ Open_Temp;
+ -- Translate the array. Note that Translate_Expression may create
+ -- the info for the array type, so be sure to call it before calling
+ -- Get_Info.
+ Arr_Expr := Translate_Expression (Operand);
+ Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value));
+
+ -- Extract its length.
+ Len := Create_Temp_Init
+ (Ghdl_Index_Type,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (Arr, Arr_Type, 1))));
+
+ -- Create:
+ -- loop
+ -- exit when LEN = 0;
+ -- LEN := LEN - 1;
+ -- RES := RES op ARR[LEN];
+ -- end loop;
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ Dec_Var (Len);
+ New_Assign_Stmt
+ (New_Obj (Res),
+ New_Dyadic_Op
+ (Op,
+ New_Obj_Value (Res),
+ M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr),
+ Arr_Type, New_Obj_Value (Len)))));
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+
+ return New_Obj_Value (Res);
+ end Translate_Predefined_TF_Reduction;
+
+ function Translate_Predefined_Array_Min_Max
+ (Is_Min : Boolean;
+ Left, Right : O_Enode;
+ Left_Type, Right_Type : Iir;
+ Res_Type : Iir;
+ Imp : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Arr_Type : constant Iir := Get_Base_Type (Left_Type);
+ Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type);
+ L, R : Mnode;
+ If_Blk : O_If_Block;
+ Res : Mnode;
+ begin
+ Res := Create_Temp (Arr_Info, Mode_Value);
+ L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value));
+ R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value));
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op
+ (ON_Eq,
+ Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp),
+ New_Lit (Ghdl_Compare_Lt),
+ Std_Boolean_Type_Node));
+ if Is_Min then
+ Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion
+ (L, Left_Type, Arr_Type, Loc));
+ else
+ Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion
+ (R, Right_Type, Arr_Type, Loc));
+ end if;
+ New_Else_Stmt (If_Blk);
+ if Is_Min then
+ Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion
+ (R, Right_Type, Arr_Type, Loc));
+ else
+ Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion
+ (L, Left_Type, Arr_Type, Loc));
+ end if;
+ Finish_If_Stmt (If_Blk);
+
+ return M2E (Translate_Implicit_Array_Conversion
+ (Res, Arr_Type, Res_Type, Loc));
+ end Translate_Predefined_Array_Min_Max;
+
+ function Translate_Predefined_TF_Edge
+ (Is_Rising : Boolean; Left : Iir)
+ return O_Enode
+ is
+ Enums : constant Iir_List :=
+ Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left)));
+ Name : Mnode;
+ begin
+ Name := Stabilize (Chap6.Translate_Name (Left), True);
+ return New_Dyadic_Op
+ (ON_And,
+ New_Value (Chap14.Get_Signal_Field
+ (Name, Ghdl_Signal_Event_Field)),
+ New_Compare_Op
+ (ON_Eq,
+ New_Value (New_Access_Element (M2E (Name))),
+ New_Lit (Get_Ortho_Expr
+ (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))),
+ Std_Boolean_Type_Node));
+ end Translate_Predefined_TF_Edge;
+
+ function Translate_Predefined_Std_Ulogic_Array_Match
+ (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir)
+ return O_Enode
+ is
+ Res_Otype : constant O_Tnode :=
+ Get_Ortho_Type (Res_Type, Mode_Value);
+ L_Type : constant Iir := Get_Type (Left);
+ R_Type : constant Iir := Get_Type (Right);
+ L_Expr, R_Expr : O_Enode;
+ L, R : Mnode;
+ Assoc : O_Assoc_List;
+
+ Res : O_Dnode;
+ begin
+ Res := Create_Temp (Ghdl_I32_Type);
+
+ Open_Temp;
+ -- Translate the arrays. Note that Translate_Expression may create
+ -- the info for the array type, so be sure to call it before calling
+ -- Get_Info.
+ L_Expr := Translate_Expression (Left);
+ L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value));
+
+ R_Expr := Translate_Expression (Right);
+ R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value));
+
+ Start_Association (Assoc, Subprg);
+ New_Association
+ (Assoc,
+ New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type));
+ New_Association
+ (Assoc,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (L, L_Type, 1))));
+
+ New_Association
+ (Assoc,
+ New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type));
+ New_Association
+ (Assoc,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (R, R_Type, 1))));
+
+ New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc));
+
+ Close_Temp;
+
+ return New_Convert_Ov (New_Obj_Value (Res), Res_Otype);
+ end Translate_Predefined_Std_Ulogic_Array_Match;
+
+ function Translate_Predefined_Operator
+ (Imp : Iir_Implicit_Function_Declaration;
+ Left, Right : Iir;
+ Res_Type : Iir;
+ Loc : Iir)
+ return O_Enode
+ is
+ Kind : constant Iir_Predefined_Functions :=
+ Get_Implicit_Definition (Imp);
+ Left_Tree : O_Enode;
+ Right_Tree : O_Enode;
+ Left_Type : Iir;
+ Right_Type : Iir;
+ Res_Otype : O_Tnode;
+ Op : ON_Op_Kind;
+ Inter : Iir;
+ Res : O_Enode;
+ begin
+ case Kind is
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Bit_Or
+ | Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_And
+ | Iir_Predefined_Boolean_Or
+ | Iir_Predefined_Boolean_Nand
+ | Iir_Predefined_Boolean_Nor =>
+ -- Right operand of shortcur operators may not be evaluated.
+ return Translate_Shortcut_Operator (Imp, Left, Right);
+
+ -- Operands of min/max are evaluated in a declare block.
+ when Iir_Predefined_Enum_Minimum
+ | Iir_Predefined_Integer_Minimum
+ | Iir_Predefined_Floating_Minimum
+ | Iir_Predefined_Physical_Minimum =>
+ return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type);
+ when Iir_Predefined_Enum_Maximum
+ | Iir_Predefined_Integer_Maximum
+ | Iir_Predefined_Floating_Maximum
+ | Iir_Predefined_Physical_Maximum =>
+ return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type);
+
+ -- Avoid implicit conversion of the array parameters to the
+ -- unbounded type for optimizing purpose. FIXME: should do the
+ -- same for the result.
+ when Iir_Predefined_TF_Array_Element_And =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_And =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc);
+ when Iir_Predefined_TF_Array_Element_Or =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_Or =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc);
+ when Iir_Predefined_TF_Array_Element_Nand =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_Nand =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc);
+ when Iir_Predefined_TF_Array_Element_Nor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_Nor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc);
+ when Iir_Predefined_TF_Array_Element_Xor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_Xor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc);
+ when Iir_Predefined_TF_Array_Element_Xnor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc);
+ when Iir_Predefined_TF_Element_Array_Xnor =>
+ return Translate_Predefined_TF_Array_Element
+ (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc);
+
+ -- Avoid implicit conversion of the array parameters to the
+ -- unbounded type for optimizing purpose.
+ when Iir_Predefined_TF_Reduction_And =>
+ return Translate_Predefined_TF_Reduction
+ (ON_And, Left, Res_Type);
+ when Iir_Predefined_TF_Reduction_Or =>
+ return Translate_Predefined_TF_Reduction
+ (ON_Or, Left, Res_Type);
+ when Iir_Predefined_TF_Reduction_Nand =>
+ return New_Monadic_Op
+ (ON_Not,
+ Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type));
+ when Iir_Predefined_TF_Reduction_Nor =>
+ return New_Monadic_Op
+ (ON_Not,
+ Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type));
+ when Iir_Predefined_TF_Reduction_Xor =>
+ return Translate_Predefined_TF_Reduction
+ (ON_Xor, Left, Res_Type);
+ when Iir_Predefined_TF_Reduction_Xnor =>
+ return New_Monadic_Op
+ (ON_Not,
+ Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type));
+
+ when Iir_Predefined_Vector_Minimum =>
+ return Translate_Predefined_Vector_Min_Max
+ (True, Left, Res_Type);
+ when Iir_Predefined_Vector_Maximum =>
+ return Translate_Predefined_Vector_Min_Max
+ (False, Left, Res_Type);
+
+ when Iir_Predefined_Bit_Rising_Edge
+ | Iir_Predefined_Boolean_Rising_Edge =>
+ return Translate_Predefined_TF_Edge (True, Left);
+ when Iir_Predefined_Bit_Falling_Edge
+ | Iir_Predefined_Boolean_Falling_Edge =>
+ return Translate_Predefined_TF_Edge (False, Left);
+
+ when Iir_Predefined_Std_Ulogic_Array_Match_Equality =>
+ return Translate_Predefined_Std_Ulogic_Array_Match
+ (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type);
+ when Iir_Predefined_Std_Ulogic_Array_Match_Inequality =>
+ return Translate_Predefined_Std_Ulogic_Array_Match
+ (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type);
+
+ when others =>
+ null;
+ end case;
+
+ -- Evaluate parameters.
+ Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value);
+ Inter := Get_Interface_Declaration_Chain (Imp);
+ if Left = Null_Iir then
+ Left_Tree := O_Enode_Null;
+ else
+ Left_Type := Get_Type (Inter);
+ Left_Tree := Translate_Expression (Left, Left_Type);
+ end if;
+
+ if Right = Null_Iir then
+ Right_Tree := O_Enode_Null;
+ else
+ Right_Type := Get_Type (Get_Chain (Inter));
+ Right_Tree := Translate_Expression (Right, Right_Type);
+ end if;
+
+ Op := Predefined_To_Onop (Kind);
+ if Op /= ON_Nil then
+ case Op is
+ when ON_Eq
+ | ON_Neq
+ | ON_Ge
+ | ON_Gt
+ | ON_Le
+ | ON_Lt =>
+ Res := New_Compare_Op (Op, Left_Tree, Right_Tree,
+ Std_Boolean_Type_Node);
+ when ON_Add_Ov
+ | ON_Sub_Ov
+ | ON_Mul_Ov
+ | ON_Div_Ov
+ | ON_Rem_Ov
+ | ON_Mod_Ov
+ | ON_Xor =>
+ Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree);
+ when ON_Abs_Ov
+ | ON_Neg_Ov
+ | ON_Not =>
+ Res := New_Monadic_Op (Op, Left_Tree);
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("translate_predefined_operator: cannot handle "
+ & ON_Op_Kind'Image (Op));
+ raise Internal_Error;
+ end case;
+ Res := Translate_Implicit_Conv
+ (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc);
+ return Res;
+ end if;
+
+ case Kind is
+ when Iir_Predefined_Bit_Xnor
+ | Iir_Predefined_Boolean_Xnor =>
+ return Translate_Predefined_Logical
+ (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree);
+ when Iir_Predefined_Bit_Match_Equality =>
+ return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree,
+ Get_Ortho_Type (Res_Type, Mode_Value));
+ when Iir_Predefined_Bit_Match_Inequality =>
+ return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree,
+ Get_Ortho_Type (Res_Type, Mode_Value));
+
+ when Iir_Predefined_Bit_Condition =>
+ return New_Compare_Op
+ (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)),
+ Std_Boolean_Type_Node);
+
+ when Iir_Predefined_Integer_Identity
+ | Iir_Predefined_Floating_Identity
+ | Iir_Predefined_Physical_Identity =>
+ return Translate_Implicit_Conv
+ (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc);
+
+ when Iir_Predefined_Access_Equality
+ | Iir_Predefined_Access_Inequality =>
+ if Is_Composite (Get_Info (Left_Type)) then
+ -- a fat pointer.
+ declare
+ T : Type_Info_Acc;
+ B : Type_Info_Acc;
+ L, R : O_Dnode;
+ V1, V2 : O_Enode;
+ Op1, Op2 : ON_Op_Kind;
+ begin
+ if Kind = Iir_Predefined_Access_Equality then
+ Op1 := ON_Eq;
+ Op2 := ON_And;
+ else
+ Op1 := ON_Neq;
+ Op2 := ON_Or;
+ end if;
+ T := Get_Info (Left_Type);
+ B := Get_Info (Get_Designated_Type (Left_Type));
+ L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value));
+ R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value));
+ New_Assign_Stmt (New_Obj (L), Left_Tree);
+ New_Assign_Stmt (New_Obj (R), Right_Tree);
+ V1 := New_Compare_Op
+ (Op1,
+ New_Value_Selected_Acc_Value
+ (New_Obj (L), B.T.Base_Field (Mode_Value)),
+ New_Value_Selected_Acc_Value
+ (New_Obj (R), B.T.Base_Field (Mode_Value)),
+ Std_Boolean_Type_Node);
+ V2 := New_Compare_Op
+ (Op1,
+ New_Value_Selected_Acc_Value
+ (New_Obj (L), B.T.Bounds_Field (Mode_Value)),
+ New_Value_Selected_Acc_Value
+ (New_Obj (R), B.T.Bounds_Field (Mode_Value)),
+ Std_Boolean_Type_Node);
+ return New_Dyadic_Op (Op2, V1, V2);
+ end;
+ else
+ -- a thin pointer.
+ if Kind = Iir_Predefined_Access_Equality then
+ return New_Compare_Op
+ (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node);
+ else
+ return New_Compare_Op
+ (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node);
+ end if;
+ end if;
+
+ when Iir_Predefined_Physical_Integer_Div =>
+ return New_Dyadic_Op (ON_Div_Ov, Left_Tree,
+ New_Convert_Ov (Right_Tree, Res_Otype));
+ when Iir_Predefined_Physical_Physical_Div =>
+ return New_Convert_Ov
+ (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype);
+
+ -- LRM 7.2.6
+ -- Multiplication of a value P of a physical type Tp by a
+ -- value I of type INTEGER is equivalent to the following
+ -- computation: Tp'Val (Tp'Pos (P) * I)
+ -- FIXME: this is not what is really done...
+ when Iir_Predefined_Integer_Physical_Mul =>
+ return New_Dyadic_Op (ON_Mul_Ov,
+ New_Convert_Ov (Left_Tree, Res_Otype),
+ Right_Tree);
+ when Iir_Predefined_Physical_Integer_Mul =>
+ return New_Dyadic_Op (ON_Mul_Ov, Left_Tree,
+ New_Convert_Ov (Right_Tree, Res_Otype));
+
+ -- LRM 7.2.6
+ -- Multiplication of a value P of a physical type Tp by a
+ -- value F of type REAL is equivalten to the following
+ -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F))
+ -- FIXME: we do not restrict with INTEGER.
+ when Iir_Predefined_Physical_Real_Mul =>
+ declare
+ Right_Otype : O_Tnode;
+ begin
+ Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value);
+ return New_Convert_Ov
+ (New_Dyadic_Op (ON_Mul_Ov,
+ New_Convert_Ov (Left_Tree, Right_Otype),
+ Right_Tree),
+ Res_Otype);
+ end;
+ when Iir_Predefined_Physical_Real_Div =>
+ declare
+ Right_Otype : O_Tnode;
+ begin
+ Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value);
+ return New_Convert_Ov
+ (New_Dyadic_Op (ON_Div_Ov,
+ New_Convert_Ov (Left_Tree, Right_Otype),
+ Right_Tree),
+ Res_Otype);
+ end;
+ when Iir_Predefined_Real_Physical_Mul =>
+ declare
+ Left_Otype : O_Tnode;
+ begin
+ Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value);
+ return New_Convert_Ov
+ (New_Dyadic_Op (ON_Mul_Ov,
+ Left_Tree,
+ New_Convert_Ov (Right_Tree, Left_Otype)),
+ Res_Otype);
+ end;
+
+ when Iir_Predefined_Universal_R_I_Mul =>
+ return New_Dyadic_Op (ON_Mul_Ov,
+ Left_Tree,
+ New_Convert_Ov (Right_Tree, Res_Otype));
+
+ when Iir_Predefined_Floating_Exp =>
+ Res := Translate_Lib_Operator
+ (New_Convert_Ov (Left_Tree, Std_Real_Otype),
+ Right_Tree, Ghdl_Real_Exp);
+ return New_Convert_Ov (Res, Res_Otype);
+ when Iir_Predefined_Integer_Exp =>
+ Res := Translate_Lib_Operator
+ (New_Convert_Ov (Left_Tree, Std_Integer_Otype),
+ Right_Tree,
+ Ghdl_Integer_Exp);
+ return New_Convert_Ov (Res, Res_Otype);
+
+ when Iir_Predefined_Array_Inequality
+ | Iir_Predefined_Record_Inequality =>
+ return New_Monadic_Op
+ (ON_Not, Translate_Predefined_Lib_Operator
+ (Left_Tree, Right_Tree, Imp));
+ when Iir_Predefined_Array_Equality
+ | Iir_Predefined_Record_Equality =>
+ return Translate_Predefined_Lib_Operator
+ (Left_Tree, Right_Tree, Imp);
+
+ when Iir_Predefined_Array_Greater =>
+ return New_Compare_Op
+ (ON_Eq,
+ Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree,
+ Imp),
+ New_Lit (Ghdl_Compare_Gt),
+ Std_Boolean_Type_Node);
+ when Iir_Predefined_Array_Greater_Equal =>
+ return New_Compare_Op
+ (ON_Ge,
+ Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree,
+ Imp),
+ New_Lit (Ghdl_Compare_Eq),
+ Std_Boolean_Type_Node);
+ when Iir_Predefined_Array_Less =>
+ return New_Compare_Op
+ (ON_Eq,
+ Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree,
+ Imp),
+ New_Lit (Ghdl_Compare_Lt),
+ Std_Boolean_Type_Node);
+ when Iir_Predefined_Array_Less_Equal =>
+ return New_Compare_Op
+ (ON_Le,
+ Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree,
+ Imp),
+ New_Lit (Ghdl_Compare_Eq),
+ Std_Boolean_Type_Node);
+
+ when Iir_Predefined_TF_Array_And
+ | Iir_Predefined_TF_Array_Or
+ | Iir_Predefined_TF_Array_Nand
+ | Iir_Predefined_TF_Array_Nor
+ | Iir_Predefined_TF_Array_Xor
+ | Iir_Predefined_TF_Array_Xnor
+ | Iir_Predefined_TF_Array_Not
+ | Iir_Predefined_Array_Srl
+ | Iir_Predefined_Array_Sra
+ | Iir_Predefined_Array_Ror =>
+ return Translate_Predefined_Array_Operator_Convert
+ (Left_Tree, Right_Tree, Imp, Res_Type);
+
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Rol =>
+ Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree);
+ return Translate_Predefined_Array_Operator_Convert
+ (Left_Tree, Right_Tree, Imp, Res_Type);
+
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ return Translate_Concat_Operator
+ (Left_Tree, Right_Tree, Imp, Res_Type, Loc);
+
+ when Iir_Predefined_Endfile =>
+ return Translate_Lib_Operator
+ (Left_Tree, O_Enode_Null, Ghdl_File_Endfile);
+
+ when Iir_Predefined_Now_Function =>
+ return New_Obj_Value (Ghdl_Now);
+
+ when Iir_Predefined_Std_Ulogic_Match_Equality =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Eq,
+ Left_Tree, Right_Tree, Res_Otype);
+ when Iir_Predefined_Std_Ulogic_Match_Inequality =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Ne,
+ Left_Tree, Right_Tree, Res_Otype);
+ when Iir_Predefined_Std_Ulogic_Match_Less =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Lt,
+ Left_Tree, Right_Tree, Res_Otype);
+ when Iir_Predefined_Std_Ulogic_Match_Less_Equal =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Le,
+ Left_Tree, Right_Tree, Res_Otype);
+ when Iir_Predefined_Std_Ulogic_Match_Greater =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Lt,
+ Right_Tree, Left_Tree, Res_Otype);
+ when Iir_Predefined_Std_Ulogic_Match_Greater_Equal =>
+ return Translate_Std_Ulogic_Match
+ (Ghdl_Std_Ulogic_Match_Le,
+ Right_Tree, Left_Tree, Res_Otype);
+
+ when Iir_Predefined_Bit_Array_Match_Equality =>
+ return New_Compare_Op
+ (ON_Eq,
+ Translate_Predefined_Lib_Operator
+ (Left_Tree, Right_Tree, Imp),
+ New_Lit (Std_Boolean_True_Node),
+ Res_Otype);
+ when Iir_Predefined_Bit_Array_Match_Inequality =>
+ return New_Compare_Op
+ (ON_Eq,
+ Translate_Predefined_Lib_Operator
+ (Left_Tree, Right_Tree, Imp),
+ New_Lit (Std_Boolean_False_Node),
+ Res_Otype);
+
+ when Iir_Predefined_Array_Minimum =>
+ return Translate_Predefined_Array_Min_Max
+ (True, Left_Tree, Right_Tree, Left_Type, Right_Type,
+ Res_Type, Imp, Loc);
+ when Iir_Predefined_Array_Maximum =>
+ return Translate_Predefined_Array_Min_Max
+ (False, Left_Tree, Right_Tree, Left_Type, Right_Type,
+ Res_Type, Imp, Loc);
+
+ when Iir_Predefined_Integer_To_String =>
+ case Get_Info (Left_Type).Type_Mode is
+ when Type_Mode_I32 =>
+ return Translate_To_String
+ (Ghdl_To_String_I32, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Ghdl_I32_Type));
+ when others =>
+ raise Internal_Error;
+ end case;
+ when Iir_Predefined_Enum_To_String =>
+ -- LRM08 5.7 String representations
+ -- - For a given value of type CHARACTER, [...]
+ --
+ -- So special case for character.
+ if Get_Base_Type (Left_Type) = Character_Type_Definition then
+ return Translate_To_String
+ (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree);
+ end if;
+
+ -- LRM08 5.7 String representations
+ -- - For a given value of type other than CHARACTER, [...]
+ declare
+ Conv : O_Tnode;
+ Subprg : O_Dnode;
+ begin
+ case Get_Info (Left_Type).Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_To_String_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_To_String_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_To_String_E32;
+ Conv := Ghdl_I32_Type;
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Translate_To_String
+ (Subprg, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Conv),
+ New_Lit (Rtis.New_Rti_Address
+ (Get_Info (Left_Type).Type_Rti)));
+ end;
+ when Iir_Predefined_Floating_To_String =>
+ return Translate_To_String
+ (Ghdl_To_String_F64, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Ghdl_Real_Type));
+ when Iir_Predefined_Real_To_String_Digits =>
+ return Translate_To_String
+ (Ghdl_To_String_F64_Digits, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Ghdl_Real_Type),
+ New_Convert_Ov (Right_Tree, Ghdl_I32_Type));
+ when Iir_Predefined_Real_To_String_Format =>
+ return Translate_To_String
+ (Ghdl_To_String_F64_Format, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Ghdl_Real_Type),
+ Right_Tree);
+ when Iir_Predefined_Physical_To_String =>
+ declare
+ Conv : O_Tnode;
+ Subprg : O_Dnode;
+ begin
+ case Get_Info (Left_Type).Type_Mode is
+ when Type_Mode_P32 =>
+ Subprg := Ghdl_To_String_P32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64 =>
+ Subprg := Ghdl_To_String_P64;
+ Conv := Ghdl_I64_Type;
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Translate_To_String
+ (Subprg, Res_Type, Loc,
+ New_Convert_Ov (Left_Tree, Conv),
+ New_Lit (Rtis.New_Rti_Address
+ (Get_Info (Left_Type).Type_Rti)));
+ end;
+ when Iir_Predefined_Time_To_String_Unit =>
+ return Translate_To_String
+ (Ghdl_Time_To_String_Unit, Res_Type, Loc,
+ Left_Tree, Right_Tree,
+ New_Lit (Rtis.New_Rti_Address
+ (Get_Info (Left_Type).Type_Rti)));
+ when Iir_Predefined_Bit_Vector_To_Ostring =>
+ return Translate_Bv_To_String
+ (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc);
+ when Iir_Predefined_Bit_Vector_To_Hstring =>
+ return Translate_Bv_To_String
+ (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc);
+ when Iir_Predefined_Array_Char_To_String =>
+ declare
+ El_Type : constant Iir := Get_Element_Subtype (Left_Type);
+ Subprg : O_Dnode;
+ Arg : Mnode;
+ begin
+ Arg := Stabilize
+ (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value));
+ case Get_Info (El_Type).Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Array_Char_To_String_B1;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Array_Char_To_String_E8;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Array_Char_To_String_E32;
+ when others =>
+ raise Internal_Error;
+ end case;
+ return Translate_To_String
+ (Subprg, Res_Type, Loc,
+ New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)),
+ Ghdl_Ptr_Type),
+ Chap3.Get_Array_Length (Arg, Left_Type),
+ New_Lit (Rtis.New_Rti_Address
+ (Get_Info (El_Type).Type_Rti)));
+ end;
+
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("translate_predefined_operator(2): cannot handle "
+ & Iir_Predefined_Functions'Image (Kind));
+ raise Internal_Error;
+ return O_Enode_Null;
+ end case;
+ end Translate_Predefined_Operator;
+
+ -- Assign EXPR to TARGET.
+ procedure Translate_Assign
+ (Target : Mnode;
+ Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir)
+ is
+ T_Info : constant Type_Info_Acc := Get_Info (Target_Type);
+ begin
+ case T_Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ New_Assign_Stmt
+ (M2Lv (Target),
+ Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type));
+ when Type_Mode_Acc
+ | Type_Mode_File =>
+ New_Assign_Stmt (M2Lv (Target), Val);
+ when Type_Mode_Fat_Acc =>
+ Chap3.Translate_Object_Copy (Target, Val, Target_Type);
+ when Type_Mode_Fat_Array =>
+ declare
+ T : Mnode;
+ E : O_Dnode;
+ begin
+ T := Stabilize (Target);
+ E := Create_Temp_Init
+ (T_Info.Ortho_Ptr_Type (Mode_Value), Val);
+ Chap3.Check_Array_Match
+ (Target_Type, T,
+ Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc);
+ Chap3.Translate_Object_Copy
+ (T, New_Obj_Value (E), Target_Type);
+ end;
+ when Type_Mode_Array =>
+ -- Source is of type TARGET_TYPE, so no length check is
+ -- necessary.
+ Chap3.Translate_Object_Copy (Target, Val, Target_Type);
+ when Type_Mode_Record =>
+ Chap3.Translate_Object_Copy (Target, Val, Target_Type);
+ when Type_Mode_Unknown
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Assign;
+
+ procedure Translate_Assign
+ (Target : Mnode; Expr : Iir; Target_Type : Iir)
+ is
+ Val : O_Enode;
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Aggregate then
+ -- FIXME: handle overlap between TARGET and EXPR.
+ Translate_Aggregate (Target, Target_Type, Expr);
+ else
+ Open_Temp;
+ Val := Chap7.Translate_Expression (Expr, Target_Type);
+ Translate_Assign (Target, Val, Expr, Target_Type, Expr);
+ Close_Temp;
+ end if;
+ end Translate_Assign;
+
+ -- If AGGR is of the form (others => (others => EXPR)) (where the
+ -- number of (others => ) sub-aggregate is at least 1, return EXPR
+ -- otherwise return NULL_IIR.
+ function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir
+ is
+ Chain : Iir;
+ Aggr1 : Iir;
+ --Type_Info : Type_Info_Acc;
+ begin
+ Aggr1 := Aggr;
+ -- Do not use translate_aggregate_others for a complex type.
+ --Type_Info := Get_Info (Get_Type (Aggr));
+ --if Type_Info.C /= null and then Type_Info.C.Builder_Need_Func then
+ -- return Null_Iir;
+ --end if;
+ loop
+ Chain := Get_Association_Choices_Chain (Aggr1);
+ if not Is_Chain_Length_One (Chain) then
+ return Null_Iir;
+ end if;
+ if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then
+ return Null_Iir;
+ end if;
+ Aggr1 := Get_Associated_Expr (Chain);
+ case Get_Kind (Aggr1) is
+ when Iir_Kind_Aggregate =>
+ if Get_Type (Aggr1) /= Null_Iir then
+ -- Stop when a sub-aggregate is in fact an aggregate.
+ return Aggr1;
+ end if;
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return Null_Iir;
+ --Error_Kind ("is_aggregate_others", Aggr1);
+ when others =>
+ return Aggr1;
+ end case;
+ end loop;
+ end Is_Aggregate_Others;
+
+ -- Generate code for (others => EL).
+ procedure Translate_Aggregate_Others
+ (Target : Mnode; Target_Type : Iir; El : Iir)
+ is
+ Base_Ptr : Mnode;
+ Info : Type_Info_Acc;
+ It : O_Dnode;
+ Len : O_Dnode;
+ Len_Val : O_Enode;
+ Label : O_Snode;
+ Arr_Var : Mnode;
+ El_Node : Mnode;
+ begin
+ Open_Temp;
+
+ Info := Get_Info (Target_Type);
+ case Info.Type_Mode is
+ when Type_Mode_Fat_Array =>
+ Arr_Var := Stabilize (Target);
+ Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var));
+ Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type);
+ when Type_Mode_Array =>
+ Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target));
+ Len_Val := Chap3.Get_Array_Type_Length (Target_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
+ -- FIXME: use this (since this use one variable instead of two):
+ -- I := length;
+ -- loop
+ -- exit when I = 0;
+ -- I := I - 1;
+ -- A[I] := xxx;
+ -- end loop;
+ Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val);
+ if True then
+ It := Create_Temp (Ghdl_Index_Type);
+ else
+ New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ end if;
+ Init_Var (It);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label, New_Compare_Op (ON_Eq,
+ New_Obj_Value (It), New_Obj_Value (Len),
+ Ghdl_Bool_Type));
+ El_Node := Chap3.Index_Base (Base_Ptr, Target_Type,
+ New_Obj_Value (It));
+ --New_Assign_Stmt (El_Node, Chap7.Translate_Expression (El));
+ Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type));
+ Inc_Var (It);
+ Finish_Loop_Stmt (Label);
+
+ Close_Temp;
+ end Translate_Aggregate_Others;
+
+ procedure Translate_Array_Aggregate_Gen
+ (Base_Ptr : Mnode;
+ Bounds_Ptr : Mnode;
+ Aggr : Iir;
+ Aggr_Type : Iir;
+ Dim : Natural;
+ Var_Index : O_Dnode)
+ is
+ Index_List : Iir_List;
+ Expr_Type : Iir;
+ Final : Boolean;
+
+ procedure Do_Assign (Expr : Iir)
+ is
+ begin
+ if Final then
+ Translate_Assign (Chap3.Index_Base (Base_Ptr, Aggr_Type,
+ New_Obj_Value (Var_Index)),
+ Expr, Expr_Type);
+ Inc_Var (Var_Index);
+ else
+ Translate_Array_Aggregate_Gen
+ (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index);
+ end if;
+ end Do_Assign;
+
+ P : Natural;
+ El : Iir;
+ begin
+ case Get_Kind (Aggr) is
+ when Iir_Kind_Aggregate =>
+ -- Continue below.
+ null;
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ declare
+ Len : constant Nat32 := Get_String_Length (Aggr);
+
+ -- Type of the unconstrained array type.
+ Arr_Type : O_Tnode;
+
+ -- Type of the constrained array type.
+ Str_Type : O_Tnode;
+
+ Cst : Var_Type;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ begin
+ Expr_Type := Get_Element_Subtype (Aggr_Type);
+
+ -- Create a constant for the string.
+ -- First, create its type, because the literal has no
+ -- type (subaggregate).
+ Arr_Type := New_Array_Type
+ (Get_Ortho_Type (Expr_Type, Mode_Value),
+ Ghdl_Index_Type);
+ New_Type_Decl (Create_Uniq_Identifier, Arr_Type);
+ Str_Type := New_Constrained_Array_Type
+ (Arr_Type, New_Index_Lit (Unsigned_64 (Len)));
+ Cst := Create_String_Literal_Var_Inner
+ (Aggr, Expr_Type, Str_Type);
+
+ -- Copy it.
+ Open_Temp;
+ Var_I := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Index_Lit (Nat32'Pos (Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type,
+ New_Obj_Value (Var_Index))),
+ New_Value (New_Indexed_Element (Get_Var (Cst),
+ New_Obj_Value (Var_I))));
+ Inc_Var (Var_I);
+ Inc_Var (Var_Index);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ end;
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Index_List := Get_Index_Subtype_List (Aggr_Type);
+
+ -- FINAL is true if the elements of the aggregate are elements of
+ -- the array.
+ if Get_Nbr_Elements (Index_List) = Dim then
+ Expr_Type := Get_Element_Subtype (Aggr_Type);
+ Final:= True;
+ else
+ Final := False;
+ end if;
+
+ El := Get_Association_Choices_Chain (Aggr);
+
+ -- First, assign positionnal association.
+ -- FIXME: count the number of positionnal association and generate
+ -- an error if there is more positionnal association than elements
+ -- in the array.
+ P := 0;
+ loop
+ if El = Null_Iir then
+ -- There is only positionnal associations.
+ return;
+ end if;
+ exit when Get_Kind (El) /= Iir_Kind_Choice_By_None;
+ Do_Assign (Get_Associated_Expr (El));
+ P := P + 1;
+ El := Get_Chain (El);
+ end loop;
+
+ -- Then, assign named or others association.
+ if Get_Chain (El) = Null_Iir then
+ -- There is only one choice
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_Others =>
+ -- falltrough...
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ Do_Assign (Get_Associated_Expr (El));
+ return;
+ when Iir_Kind_Choice_By_Range =>
+ declare
+ Var_Length : O_Dnode;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ begin
+ Open_Temp;
+ Var_Length := Create_Temp_Init
+ (Ghdl_Index_Type,
+ Chap7.Translate_Range_Length (Get_Choice_Range (El)));
+ Var_I := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ Do_Assign (Get_Associated_Expr (El));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ end;
+ return;
+ when others =>
+ Error_Kind ("translate_array_aggregate_gen", El);
+ end case;
+ end if;
+
+ -- Several choices..
+ declare
+ Range_Type : Iir;
+ Var_Pos : O_Dnode;
+ Var_Len : O_Dnode;
+ Range_Ptr : Mnode;
+ Rtinfo : Type_Info_Acc;
+ If_Blk : O_If_Block;
+ Case_Blk : O_Case_Block;
+ Label : O_Snode;
+ El_Assoc : Iir;
+ Len_Tmp : O_Enode;
+ begin
+ Open_Temp;
+ -- Create a loop from left +- number of positionnals associations
+ -- to/downto right.
+ Range_Type :=
+ Get_Base_Type (Get_Nth_Element (Index_List, Dim - 1));
+ Rtinfo := Get_Info (Range_Type);
+ Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value));
+ Range_Ptr := Stabilize
+ (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim));
+ New_Assign_Stmt (New_Obj (Var_Pos),
+ M2E (Chap3.Range_To_Left (Range_Ptr)));
+ Var_Len := Create_Temp (Ghdl_Index_Type);
+ if P /= 0 then
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Range_Ptr)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (P),
+ Range_Type);
+ New_Else_Stmt (If_Blk);
+ Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (P),
+ Range_Type);
+ Finish_If_Stmt (If_Blk);
+ end if;
+
+ Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr));
+ if P /= 0 then
+ Len_Tmp := New_Dyadic_Op
+ (ON_Sub_Ov,
+ Len_Tmp,
+ New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (P))));
+ end if;
+ New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp);
+
+ -- Start loop.
+ Start_Loop_Stmt (Label);
+ -- Check if end of loop.
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Len),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+
+ -- convert aggr into a case statement.
+ Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos));
+ El_Assoc := Null_Iir;
+ while El /= Null_Iir loop
+ Start_Choice (Case_Blk);
+ Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk);
+ if Get_Associated_Expr (El) /= Null_Iir then
+ El_Assoc := Get_Associated_Expr (El);
+ end if;
+ Finish_Choice (Case_Blk);
+ Do_Assign (El_Assoc);
+ P := P + 1;
+ El := Get_Chain (El);
+ end loop;
+ Finish_Case_Stmt (Case_Blk);
+ -- Update var_pos
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Range_Ptr)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (1),
+ Range_Type);
+ New_Else_Stmt (If_Blk);
+ Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (1),
+ Range_Type);
+ Finish_If_Stmt (If_Blk);
+ New_Assign_Stmt
+ (New_Obj (Var_Len),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Var_Len),
+ New_Lit (Ghdl_Index_1)));
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ end;
+ end Translate_Array_Aggregate_Gen;
+
+ procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir)
+ is
+ Targ : Mnode;
+ Aggr_Type : constant Iir := Get_Type (Aggr);
+ Aggr_Base_Type : constant Iir_Record_Type_Definition :=
+ Get_Base_Type (Aggr_Type);
+ El_List : constant Iir_List :=
+ Get_Elements_Declaration_List (Aggr_Base_Type);
+ El_Index : Natural;
+ Nbr_El : constant Natural := Get_Nbr_Elements (El_List);
+
+ -- Record which elements of the record have been set. The 'others'
+ -- clause applies to all elements not already set.
+ type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean;
+ pragma Pack (Bool_Array_Type);
+ Set_Array : Bool_Array_Type := (others => False);
+
+ -- The expression associated.
+ El_Expr : Iir;
+
+ -- Set an elements.
+ procedure Set_El (El : Iir_Element_Declaration) is
+ begin
+ Translate_Assign (Chap6.Translate_Selected_Element (Targ, El),
+ El_Expr, Get_Type (El));
+ Set_Array (Natural (Get_Element_Position (El))) := True;
+ end Set_El;
+
+ Assoc : Iir;
+ N_El_Expr : Iir;
+ begin
+ Open_Temp;
+ Targ := Stabilize (Target);
+ El_Index := 0;
+ Assoc := Get_Association_Choices_Chain (Aggr);
+ while Assoc /= Null_Iir loop
+ N_El_Expr := Get_Associated_Expr (Assoc);
+ if N_El_Expr /= Null_Iir then
+ El_Expr := N_El_Expr;
+ end if;
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_None =>
+ Set_El (Get_Nth_Element (El_List, El_Index));
+ El_Index := El_Index + 1;
+ when Iir_Kind_Choice_By_Name =>
+ Set_El (Get_Choice_Name (Assoc));
+ El_Index := Natural'Last;
+ when Iir_Kind_Choice_By_Others =>
+ for J in Set_Array'Range loop
+ if not Set_Array (J) then
+ Set_El (Get_Nth_Element (El_List, J));
+ end if;
+ end loop;
+ when others =>
+ Error_Kind ("translate_record_aggregate", Assoc);
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ Close_Temp;
+ end Translate_Record_Aggregate;
+
+ procedure Translate_Array_Aggregate
+ (Target : Mnode; Target_Type : Iir; Aggr : Iir)
+ is
+ Aggr_Type : constant Iir := Get_Type (Aggr);
+ Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type);
+ Targ_Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (Target_Type);
+
+ Aggr_Info : Iir_Aggregate_Info;
+ Base : Mnode;
+ Bounds : Mnode;
+ Var_Index : O_Dnode;
+ Targ : Mnode;
+
+ Rinfo : Type_Info_Acc;
+ Bt : Iir;
+
+ -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right)
+ function Check_Value (Lval : Iir;
+ Lop : ON_Op_Kind;
+ Rval : Iir;
+ Rop : ON_Op_Kind;
+ Rng : Mnode)
+ return O_Enode
+ is
+ L, R : O_Enode;
+ begin
+ L := New_Compare_Op
+ (Lop,
+ New_Lit (Translate_Static_Expression (Lval, Bt)),
+ M2E (Chap3.Range_To_Left (Rng)),
+ Ghdl_Bool_Type);
+ R := New_Compare_Op
+ (Rop,
+ New_Lit (Translate_Static_Expression (Rval, Bt)),
+ M2E (Chap3.Range_To_Right (Rng)),
+ Ghdl_Bool_Type);
+ return New_Dyadic_Op (ON_Or, L, R);
+ end Check_Value;
+
+ Range_Ptr : Mnode;
+ Subtarg_Type : Iir;
+ Subaggr_Type : Iir;
+ L, H : Iir;
+ Min : Iir_Int32;
+ Has_Others : Boolean;
+
+ Var_Err : O_Dnode;
+ E : O_Enode;
+ If_Blk : O_If_Block;
+ Op : ON_Op_Kind;
+ begin
+ Open_Temp;
+ Targ := Stabilize (Target);
+ Base := Stabilize (Chap3.Get_Array_Base (Targ));
+ Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ));
+ Aggr_Info := Get_Aggregate_Info (Aggr);
+
+ -- Check type
+ for I in Natural loop
+ Subaggr_Type := Get_Index_Type (Index_List, I);
+ exit when Subaggr_Type = Null_Iir;
+ Subtarg_Type := Get_Index_Type (Targ_Index_List, I);
+
+ Bt := Get_Base_Type (Subaggr_Type);
+ Rinfo := Get_Info (Bt);
+
+ if Get_Aggr_Dynamic_Flag (Aggr_Info) then
+ -- Dynamic range, must evaluate it.
+ Open_Temp;
+ declare
+ A_Range : O_Dnode;
+ Rng_Ptr : O_Dnode;
+ begin
+ -- Evaluate the range.
+ Chap3.Translate_Anonymous_Type_Definition
+ (Subaggr_Type, True);
+
+ A_Range := Create_Temp (Rinfo.T.Range_Type);
+ Rng_Ptr := Create_Temp_Ptr
+ (Rinfo.T.Range_Ptr_Type, New_Obj (A_Range));
+ Chap7.Translate_Range_Ptr
+ (Rng_Ptr,
+ Get_Range_Constraint (Subaggr_Type),
+ Subaggr_Type);
+
+ -- Check range length VS target length.
+ Chap6.Check_Bound_Error
+ (New_Compare_Op
+ (ON_Neq,
+ M2E (Chap3.Range_To_Length
+ (Dv2M (A_Range,
+ Rinfo,
+ Mode_Value,
+ Rinfo.T.Range_Type,
+ Rinfo.T.Range_Ptr_Type))),
+ M2E (Chap3.Range_To_Length
+ (Chap3.Bounds_To_Range
+ (Bounds, Target_Type, I + 1))),
+ Ghdl_Bool_Type),
+ Aggr, I);
+ end;
+ Close_Temp;
+ elsif Get_Type_Staticness (Subaggr_Type) /= Locally
+ or else Subaggr_Type /= Subtarg_Type
+ then
+ -- Note: if the aggregate has no others, then the bounds
+ -- must be the same, otherwise, aggregate bounds must be
+ -- inside type bounds.
+ Has_Others := Get_Aggr_Others_Flag (Aggr_Info);
+ Min := Get_Aggr_Min_Length (Aggr_Info);
+ L := Get_Aggr_Low_Limit (Aggr_Info);
+
+ if Min > 0 or L /= Null_Iir then
+ Open_Temp;
+
+ -- Pointer to the range.
+ Range_Ptr := Stabilize
+ (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1));
+ Var_Err := Create_Temp (Ghdl_Bool_Type);
+ H := Get_Aggr_High_Limit (Aggr_Info);
+
+ if L /= Null_Iir then
+ -- Check the index range of the aggregrate is equal
+ -- (or within in presence of 'others') the index range
+ -- of the target.
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Range_Ptr)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ if Has_Others then
+ E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr);
+ else
+ E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr);
+ end if;
+ New_Assign_Stmt (New_Obj (Var_Err), E);
+ New_Else_Stmt (If_Blk);
+ if Has_Others then
+ E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr);
+ else
+ E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr);
+ end if;
+ New_Assign_Stmt (New_Obj (Var_Err), E);
+ Finish_If_Stmt (If_Blk);
+ -- If L and H are greather than the minimum length,
+ -- then there is no need to check with min.
+ if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then
+ Min := 0;
+ end if;
+ end if;
+
+ if Min > 0 then
+ -- Check the number of elements is equal (or less in
+ -- presence of 'others') than the length of the index
+ -- range of the target.
+ if Has_Others then
+ Op := ON_Lt;
+ else
+ Op := ON_Neq;
+ end if;
+ E := New_Compare_Op
+ (Op,
+ M2E (Chap3.Range_To_Length (Range_Ptr)),
+ New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Min))),
+ Ghdl_Bool_Type);
+ if L /= Null_Iir then
+ E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err));
+ end if;
+ New_Assign_Stmt (New_Obj (Var_Err), E);
+ end if;
+ Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr, I);
+ Close_Temp;
+ end if;
+ end if;
+
+ -- Next dimension.
+ Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info);
+ end loop;
+
+ Var_Index := Create_Temp_Init
+ (Ghdl_Index_Type, New_Lit (Ghdl_Index_0));
+ Translate_Array_Aggregate_Gen
+ (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index);
+ Close_Temp;
+
+ -- FIXME: creating aggregate subtype is expensive and rarely used.
+ -- (one of the current use - only ? - is check_array_match).
+ Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False);
+ end Translate_Array_Aggregate;
+
+ procedure Translate_Aggregate
+ (Target : Mnode; Target_Type : Iir; Aggr : Iir)
+ is
+ Aggr_Type : constant Iir := Get_Type (Aggr);
+ El : Iir;
+ begin
+ case Get_Kind (Aggr_Type) is
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition =>
+ El := Is_Aggregate_Others (Aggr);
+ if El /= Null_Iir then
+ Translate_Aggregate_Others (Target, Target_Type, El);
+ else
+ Translate_Array_Aggregate (Target, Target_Type, Aggr);
+ end if;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Translate_Record_Aggregate (Target, Aggr);
+ when others =>
+ Error_Kind ("translate_aggregate", Aggr_Type);
+ end case;
+ end Translate_Aggregate;
+
+ function Translate_Allocator_By_Expression (Expr : Iir)
+ return O_Enode
+ is
+ Val : O_Enode;
+ Val_M : Mnode;
+ A_Type : constant Iir := Get_Type (Expr);
+ A_Info : constant Type_Info_Acc := Get_Info (A_Type);
+ D_Type : constant Iir := Get_Designated_Type (A_Type);
+ D_Info : constant Type_Info_Acc := Get_Info (D_Type);
+ R : Mnode;
+ Rtype : O_Tnode;
+ begin
+ -- Compute the expression.
+ Val := Translate_Expression (Get_Expression (Expr), D_Type);
+ -- Allocate memory for the object.
+ case A_Info.Type_Mode is
+ when Type_Mode_Fat_Acc =>
+ R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)),
+ D_Info, Mode_Value);
+ Val_M := Stabilize (E2M (Val, D_Info, Mode_Value));
+ Chap3.Translate_Object_Allocation
+ (R, Alloc_Heap, D_Type,
+ Chap3.Get_Array_Bounds (Val_M));
+ Val := M2E (Val_M);
+ Rtype := A_Info.Ortho_Ptr_Type (Mode_Value);
+ when Type_Mode_Acc =>
+ R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)),
+ D_Info, Mode_Value);
+ Chap3.Translate_Object_Allocation
+ (R, Alloc_Heap, D_Type, Mnode_Null);
+ Rtype := A_Info.Ortho_Type (Mode_Value);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Chap3.Translate_Object_Copy (R, Val, D_Type);
+ return New_Convert_Ov (M2Addr (R), Rtype);
+ end Translate_Allocator_By_Expression;
+
+ function Translate_Allocator_By_Subtype (Expr : Iir)
+ return O_Enode
+ is
+ P_Type : constant Iir := Get_Type (Expr);
+ P_Info : constant Type_Info_Acc := Get_Info (P_Type);
+ D_Type : constant Iir := Get_Designated_Type (P_Type);
+ D_Info : constant Type_Info_Acc := Get_Info (D_Type);
+ Sub_Type : Iir;
+ Bounds : Mnode;
+ Res : Mnode;
+ Rtype : O_Tnode;
+ begin
+ case P_Info.Type_Mode is
+ when Type_Mode_Fat_Acc =>
+ Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)),
+ D_Info, Mode_Value);
+ -- FIXME: should allocate bounds, and directly set bounds
+ -- from the range.
+ Sub_Type := Get_Subtype_Indication (Expr);
+ Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type);
+ Chap3.Create_Array_Subtype (Sub_Type, True);
+ Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type);
+ Rtype := P_Info.Ortho_Ptr_Type (Mode_Value);
+ when Type_Mode_Acc =>
+ Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)),
+ D_Info, Mode_Value);
+ Bounds := Mnode_Null;
+ Rtype := P_Info.Ortho_Type (Mode_Value);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds);
+ Chap4.Init_Object (Res, D_Type);
+ return New_Convert_Ov (M2Addr (Res), Rtype);
+ end Translate_Allocator_By_Subtype;
+
+ function Translate_Fat_Array_Type_Conversion
+ (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return O_Enode;
+
+ function Translate_Array_Subtype_Conversion
+ (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return O_Enode
+ is
+ Res_Info : constant Type_Info_Acc := Get_Info (Res_Type);
+ Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type);
+ E : Mnode;
+ begin
+ E := Stabilize (E2M (Expr, Expr_Info, Mode_Value));
+ case Res_Info.Type_Mode is
+ when Type_Mode_Array =>
+ Chap3.Check_Array_Match
+ (Res_Type, T2M (Res_Type, Mode_Value),
+ Expr_Type, E,
+ Loc);
+ return New_Convert_Ov
+ (M2Addr (Chap3.Get_Array_Base (E)),
+ Res_Info.Ortho_Ptr_Type (Mode_Value));
+ when Type_Mode_Fat_Array =>
+ declare
+ Res : Mnode;
+ begin
+ Res := Create_Temp (Res_Info);
+ Copy_Fat_Pointer (Res, E);
+ Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc);
+ return M2Addr (Res);
+ end;
+ when others =>
+ Error_Kind ("translate_array_subtype_conversion", Res_Type);
+ end case;
+ end Translate_Array_Subtype_Conversion;
+
+ function Translate_Type_Conversion
+ (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return O_Enode
+ is
+ Res_Info : constant Type_Info_Acc := Get_Info (Res_Type);
+ Res : O_Enode;
+ begin
+ case Get_Kind (Res_Type) is
+ when Iir_Kinds_Scalar_Type_Definition =>
+ Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value));
+ if Chap3.Need_Range_Check (Null_Iir, Res_Type) then
+ Res := Chap3.Insert_Scalar_Check
+ (Res, Null_Iir, Res_Type, Loc);
+ end if;
+ return Res;
+ when Iir_Kinds_Array_Type_Definition =>
+ if Get_Constraint_State (Res_Type) = Fully_Constrained then
+ return Translate_Array_Subtype_Conversion
+ (Expr, Expr_Type, Res_Type, Loc);
+ else
+ return Translate_Fat_Array_Type_Conversion
+ (Expr, Expr_Type, Res_Type, Loc);
+ end if;
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return Expr;
+ when others =>
+ Error_Kind ("translate_type_conversion", Res_Type);
+ end case;
+ end Translate_Type_Conversion;
+
+ function Translate_Fat_Array_Type_Conversion
+ (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir)
+ return O_Enode
+ is
+ Res_Info : constant Type_Info_Acc := Get_Info (Res_Type);
+ Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type);
+ Res_Indexes : constant Iir_List :=
+ Get_Index_Subtype_List (Res_Type);
+ Expr_Indexes : constant Iir_List :=
+ Get_Index_Subtype_List (Expr_Type);
+
+ Res_Base_Type : constant Iir := Get_Base_Type (Res_Type);
+ Expr_Base_Type : constant Iir := Get_Base_Type (Expr_Type);
+ Res_Base_Indexes : constant Iir_List :=
+ Get_Index_Subtype_List (Res_Base_Type);
+ Expr_Base_Indexes : constant Iir_List :=
+ Get_Index_Subtype_List (Expr_Base_Type);
+ Res : Mnode;
+ E : Mnode;
+ Bounds : O_Dnode;
+ R_El : Iir;
+ E_El : Iir;
+ begin
+ Res := Create_Temp (Res_Info, Mode_Value);
+ Bounds := Create_Temp (Res_Info.T.Bounds_Type);
+ E := Stabilize (E2M (Expr, Expr_Info, Mode_Value));
+ Open_Temp;
+ -- Set base.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Res)),
+ New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)),
+ Res_Info.T.Base_Ptr_Type (Mode_Value)));
+ -- Set bounds.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type));
+
+ -- Convert bounds.
+ for I in Natural loop
+ R_El := Get_Index_Type (Res_Indexes, I);
+ E_El := Get_Index_Type (Expr_Indexes, I);
+ exit when R_El = Null_Iir;
+ declare
+ Rb_Ptr : Mnode;
+ Eb_Ptr : Mnode;
+ Ee : O_Enode;
+ Same_Index_Type : constant Boolean :=
+ (Get_Index_Type (Res_Base_Indexes, I)
+ = Get_Index_Type (Expr_Base_Indexes, I));
+ begin
+ Open_Temp;
+ Rb_Ptr := Stabilize
+ (Chap3.Get_Array_Range (Res, Res_Type, I + 1));
+ Eb_Ptr := Stabilize
+ (Chap3.Get_Array_Range (E, Expr_Type, I + 1));
+ -- Convert left and right (unless they have the same type -
+ -- this is an optimization but also this deals with null
+ -- array in common cases).
+ Ee := M2E (Chap3.Range_To_Left (Eb_Ptr));
+ if not Same_Index_Type then
+ Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc);
+ end if;
+ New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee);
+ Ee := M2E (Chap3.Range_To_Right (Eb_Ptr));
+ if not Same_Index_Type then
+ Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc);
+ end if;
+ New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee);
+ -- Copy Dir and Length.
+ New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)),
+ M2E (Chap3.Range_To_Dir (Eb_Ptr)));
+ New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)),
+ M2E (Chap3.Range_To_Length (Eb_Ptr)));
+ Close_Temp;
+ end;
+ end loop;
+ Close_Temp;
+ return M2E (Res);
+ end Translate_Fat_Array_Type_Conversion;
+
+ function Sig2val_Prepare_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Mnode)
+ return Mnode
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ if Get_Type_Info (Data).Type_Mode = Type_Mode_Fat_Array then
+ return Stabilize (Chap3.Get_Array_Base (Data));
+ else
+ return Stabilize (Data);
+ end if;
+ end Sig2val_Prepare_Composite;
+
+ function Sig2val_Update_Data_Array
+ (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode
+ is
+ begin
+ return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index));
+ end Sig2val_Update_Data_Array;
+
+ function Sig2val_Update_Data_Record
+ (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return Mnode
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Chap6.Translate_Selected_Element (Val, El);
+ end Sig2val_Update_Data_Record;
+
+ procedure Sig2val_Finish_Data_Composite (Data : in out Mnode)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Sig2val_Finish_Data_Composite;
+
+ procedure Translate_Signal_Assign_Effective_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Mnode)
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ New_Assign_Stmt (New_Access_Element (M2E (Targ)), M2E (Data));
+ end Translate_Signal_Assign_Effective_Non_Composite;
+
+ procedure Translate_Signal_Assign_Effective is new Foreach_Non_Composite
+ (Data_Type => Mnode,
+ Composite_Data_Type => Mnode,
+ Do_Non_Composite => Translate_Signal_Assign_Effective_Non_Composite,
+ Prepare_Data_Array => Sig2val_Prepare_Composite,
+ Update_Data_Array => Sig2val_Update_Data_Array,
+ Finish_Data_Array => Sig2val_Finish_Data_Composite,
+ Prepare_Data_Record => Sig2val_Prepare_Composite,
+ Update_Data_Record => Sig2val_Update_Data_Record,
+ Finish_Data_Record => Sig2val_Finish_Data_Composite);
+
+ procedure Translate_Signal_Assign_Driving_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data: Mnode)
+ is
+ begin
+ New_Assign_Stmt
+ (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type,
+ Ghdl_Signal_Driving_Value_Field),
+ M2E (Data));
+ end Translate_Signal_Assign_Driving_Non_Composite;
+
+ procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite
+ (Data_Type => Mnode,
+ Composite_Data_Type => Mnode,
+ Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite,
+ Prepare_Data_Array => Sig2val_Prepare_Composite,
+ Update_Data_Array => Sig2val_Update_Data_Array,
+ Finish_Data_Array => Sig2val_Finish_Data_Composite,
+ Prepare_Data_Record => Sig2val_Prepare_Composite,
+ Update_Data_Record => Sig2val_Update_Data_Record,
+ Finish_Data_Record => Sig2val_Finish_Data_Composite);
+
+ function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode
+ is
+ procedure Translate_Signal_Non_Composite
+ (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Mnode)
+ is
+ begin
+ New_Assign_Stmt (M2Lv (Targ),
+ Read_Value (M2E (Data), Targ_Type));
+ end Translate_Signal_Non_Composite;
+
+ procedure Translate_Signal_Target is new Foreach_Non_Composite
+ (Data_Type => Mnode,
+ Composite_Data_Type => Mnode,
+ Do_Non_Composite => Translate_Signal_Non_Composite,
+ Prepare_Data_Array => Sig2val_Prepare_Composite,
+ Update_Data_Array => Sig2val_Update_Data_Array,
+ Finish_Data_Array => Sig2val_Finish_Data_Composite,
+ Prepare_Data_Record => Sig2val_Prepare_Composite,
+ Update_Data_Record => Sig2val_Update_Data_Record,
+ Finish_Data_Record => Sig2val_Finish_Data_Composite);
+
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Info (Sig_Type);
+ if Tinfo.Type_Mode in Type_Mode_Scalar then
+ return Read_Value (Sig, Sig_Type);
+ else
+ declare
+ Res : Mnode;
+ Var_Val : Mnode;
+ begin
+ -- allocate result array
+ if Tinfo.Type_Mode = Type_Mode_Fat_Array then
+ Res := Create_Temp (Tinfo);
+
+ Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal));
+
+ -- Copy bounds.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ M2Addr (Chap3.Get_Array_Bounds (Var_Val)));
+
+ -- Allocate base.
+ Chap3.Allocate_Fat_Array_Base (Alloc_Stack, Res, Sig_Type);
+ elsif Is_Complex_Type (Tinfo) then
+ Res := Create_Temp (Tinfo);
+ Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res);
+ else
+ Res := Create_Temp (Tinfo);
+ end if;
+
+ Open_Temp;
+
+ if Tinfo.Type_Mode /= Type_Mode_Fat_Array then
+ Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal));
+ end if;
+
+ Translate_Signal_Target (Res, Sig_Type, Var_Val);
+ Close_Temp;
+ return M2Addr (Res);
+ end;
+ end if;
+ end Translate_Signal_Value;
+
+ -- Get the effective value of a simple signal SIG.
+ function Read_Signal_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode
+ is
+ pragma Unreferenced (Sig_Type);
+ begin
+ return New_Value (New_Access_Element (Sig));
+ end Read_Signal_Value;
+
+ -- Get the value of signal SIG.
+ function Translate_Signal is new Translate_Signal_Value
+ (Read_Value => Read_Signal_Value);
+
+ function Translate_Signal_Effective_Value
+ (Sig : O_Enode; Sig_Type : Iir) return O_Enode
+ renames Translate_Signal;
+
+ function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode is
+ begin
+ return New_Value (Chap14.Get_Signal_Value_Field
+ (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field));
+ end Read_Signal_Driving_Value;
+
+ function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value
+ (Read_Value => Read_Signal_Driving_Value);
+
+ function Translate_Signal_Driving_Value
+ (Sig : O_Enode; Sig_Type : Iir) return O_Enode
+ renames Translate_Signal_Driving_Value_1;
+
+ procedure Set_Effective_Value
+ (Sig : Mnode; Sig_Type : Iir; Val : Mnode)
+ renames Translate_Signal_Assign_Effective;
+ procedure Set_Driving_Value
+ (Sig : Mnode; Sig_Type : Iir; Val : Mnode)
+ renames Translate_Signal_Assign_Driving;
+
+ function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir)
+ return O_Enode
+ is
+ Imp : Iir;
+ Expr_Type : Iir;
+ Res_Type : Iir;
+ Res : O_Enode;
+ begin
+ Expr_Type := Get_Type (Expr);
+ if Rtype = Null_Iir then
+ Res_Type := Expr_Type;
+ else
+ Res_Type := Rtype;
+ end if;
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Floating_Point_Literal =>
+ return New_Lit (Translate_Static_Expression (Expr, Rtype));
+
+ when Iir_Kind_Physical_Int_Literal =>
+ declare
+ Unit : Iir;
+ Unit_Info : Object_Info_Acc;
+ begin
+ Unit := Get_Unit_Name (Expr);
+ Unit_Info := Get_Info (Unit);
+ if Unit_Info = null then
+ return New_Lit
+ (Translate_Static_Expression (Expr, Rtype));
+ else
+ -- Time units might be not locally static.
+ return New_Dyadic_Op
+ (ON_Mul_Ov,
+ New_Lit (New_Signed_Literal
+ (Get_Ortho_Type (Expr_Type, Mode_Value),
+ Integer_64 (Get_Value (Expr)))),
+ New_Value (Get_Var (Unit_Info.Object_Var)));
+ end if;
+ end;
+
+ when Iir_Kind_Physical_Fp_Literal =>
+ declare
+ Unit : Iir;
+ Unit_Info : Object_Info_Acc;
+ L, R : O_Enode;
+ begin
+ Unit := Get_Unit_Name (Expr);
+ Unit_Info := Get_Info (Unit);
+ if Unit_Info = null then
+ return New_Lit
+ (Translate_Static_Expression (Expr, Rtype));
+ else
+ -- Time units might be not locally static.
+ L := New_Lit
+ (New_Float_Literal
+ (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr))));
+ R := New_Convert_Ov
+ (New_Value (Get_Var (Unit_Info.Object_Var)),
+ Ghdl_Real_Type);
+ return New_Convert_Ov
+ (New_Dyadic_Op (ON_Mul_Ov, L, R),
+ Get_Ortho_Type (Expr_Type, Mode_Value));
+ end if;
+ end;
+
+ when Iir_Kind_Unit_Declaration =>
+ declare
+ Unit_Info : Object_Info_Acc;
+ begin
+ Unit_Info := Get_Info (Expr);
+ if Unit_Info = null then
+ return New_Lit
+ (Translate_Static_Expression (Expr, Rtype));
+ else
+ -- Time units might be not locally static.
+ return New_Value (Get_Var (Unit_Info.Object_Var));
+ end if;
+ end;
+
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Simple_Name_Attribute =>
+ Res := Translate_String_Literal (Expr);
+
+ when Iir_Kind_Aggregate =>
+ declare
+ Aggr_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Mres : Mnode;
+ begin
+ -- Extract the type of the aggregate. Use the type of the
+ -- context if it is fully constrained.
+ pragma Assert (Rtype /= Null_Iir);
+ if Is_Fully_Constrained_Type (Rtype) then
+ Aggr_Type := Rtype;
+ else
+ Aggr_Type := Expr_Type;
+ end if;
+ if Get_Kind (Aggr_Type) = Iir_Kind_Array_Subtype_Definition
+ then
+ Chap3.Create_Array_Subtype (Aggr_Type, True);
+ end if;
+
+ -- FIXME: this may be not necessary
+ Tinfo := Get_Info (Aggr_Type);
+
+ -- The result area has to be created
+ if Is_Complex_Type (Tinfo) then
+ Mres := Create_Temp (Tinfo);
+ Chap4.Allocate_Complex_Object
+ (Aggr_Type, Alloc_Stack, Mres);
+ else
+ -- if thin array/record:
+ -- create result
+ Mres := Create_Temp (Tinfo);
+ end if;
+
+ Translate_Aggregate (Mres, Aggr_Type, Expr);
+ Res := M2E (Mres);
+
+ if Aggr_Type /= Rtype then
+ Res := Translate_Implicit_Conv
+ (Res, Aggr_Type, Rtype, Mode_Value, Expr);
+ end if;
+ return Res;
+ end;
+
+ when Iir_Kind_Null_Literal =>
+ declare
+ Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type);
+ Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value);
+ L : O_Dnode;
+ B : Type_Info_Acc;
+ begin
+ if Tinfo.Type_Mode = Type_Mode_Fat_Acc then
+ -- Create a fat null pointer.
+ -- FIXME: should be optimized!!
+ L := Create_Temp (Otype);
+ B := Get_Info (Get_Designated_Type (Expr_Type));
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (L),
+ B.T.Base_Field (Mode_Value)),
+ New_Lit
+ (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value))));
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Obj (L), B.T.Bounds_Field (Mode_Value)),
+ New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type)));
+ return New_Address (New_Obj (L),
+ Tinfo.Ortho_Ptr_Type (Mode_Value));
+ else
+ return New_Lit (New_Null_Access (Otype));
+ end if;
+ end;
+
+ when Iir_Kind_Overflow_Literal =>
+ declare
+ Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type);
+ Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value);
+ L : O_Dnode;
+ begin
+ -- Generate the error message
+ Chap6.Gen_Bound_Error (Expr);
+
+ -- Create a dummy value
+ L := Create_Temp (Otype);
+ if Tinfo.Type_Mode = Type_Mode_Fat_Acc then
+ return New_Address (New_Obj (L),
+ Tinfo.Ortho_Ptr_Type (Mode_Value));
+ else
+ return New_Obj_Value (L);
+ end if;
+ end;
+
+ when Iir_Kind_Parenthesis_Expression =>
+ return Translate_Expression (Get_Expression (Expr), Rtype);
+
+ when Iir_Kind_Allocator_By_Expression =>
+ return Translate_Allocator_By_Expression (Expr);
+ when Iir_Kind_Allocator_By_Subtype =>
+ return Translate_Allocator_By_Subtype (Expr);
+
+ when Iir_Kind_Qualified_Expression =>
+ -- FIXME: check type.
+ Res := Translate_Expression (Get_Expression (Expr), Expr_Type);
+
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Attribute_Name =>
+ declare
+ L : Mnode;
+ begin
+ L := Chap6.Translate_Name (Expr);
+
+ Res := M2E (L);
+ if Get_Object_Kind (L) = Mode_Signal then
+ Res := Translate_Signal (Res, Expr_Type);
+ end if;
+ end;
+
+ when Iir_Kind_Iterator_Declaration =>
+ declare
+ Expr_Info : Ortho_Info_Acc;
+ begin
+ Expr_Info := Get_Info (Expr);
+ Res := New_Value (Get_Var (Expr_Info.Iterator_Var));
+ if Rtype /= Null_Iir then
+ Res := New_Convert_Ov
+ (Res, Get_Ortho_Type (Rtype, Mode_Value));
+ end if;
+ return Res;
+ end;
+
+ when Iir_Kinds_Dyadic_Operator =>
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then
+ return Translate_Predefined_Operator
+ (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr);
+ else
+ return Translate_Operator_Function_Call
+ (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type);
+ end if;
+ when Iir_Kinds_Monadic_Operator =>
+ Imp := Get_Implementation (Expr);
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then
+ return Translate_Predefined_Operator
+ (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr);
+ else
+ return Translate_Operator_Function_Call
+ (Imp, Get_Operand (Expr), Null_Iir, Res_Type);
+ end if;
+ when Iir_Kind_Function_Call =>
+ Imp := Get_Implementation (Expr);
+ declare
+ Assoc_Chain : Iir;
+ begin
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration
+ then
+ declare
+ Left, Right : Iir;
+ begin
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ if Assoc_Chain = Null_Iir then
+ Left := Null_Iir;
+ Right := Null_Iir;
+ else
+ Left := Get_Actual (Assoc_Chain);
+ Assoc_Chain := Get_Chain (Assoc_Chain);
+ if Assoc_Chain = Null_Iir then
+ Right := Null_Iir;
+ else
+ Right := Get_Actual (Assoc_Chain);
+ end if;
+ end if;
+ return Translate_Predefined_Operator
+ (Imp, Left, Right, Res_Type, Expr);
+ end;
+ else
+ Canon.Canon_Subprogram_Call (Expr);
+ Assoc_Chain := Get_Parameter_Association_Chain (Expr);
+ Res := Translate_Function_Call
+ (Imp, Assoc_Chain, Get_Method_Object (Expr));
+ Expr_Type := Get_Return_Type (Imp);
+ end if;
+ end;
+
+ when Iir_Kind_Type_Conversion =>
+ declare
+ Conv_Expr : Iir;
+ begin
+ Conv_Expr := Get_Expression (Expr);
+ Res := Translate_Type_Conversion
+ (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr),
+ Expr_Type, Expr);
+ end;
+
+ when Iir_Kind_Length_Array_Attribute =>
+ return Chap14.Translate_Length_Array_Attribute
+ (Expr, Res_Type);
+ when Iir_Kind_Low_Array_Attribute =>
+ return Chap14.Translate_Low_Array_Attribute (Expr);
+ when Iir_Kind_High_Array_Attribute =>
+ return Chap14.Translate_High_Array_Attribute (Expr);
+ when Iir_Kind_Left_Array_Attribute =>
+ return Chap14.Translate_Left_Array_Attribute (Expr);
+ when Iir_Kind_Right_Array_Attribute =>
+ return Chap14.Translate_Right_Array_Attribute (Expr);
+ when Iir_Kind_Ascending_Array_Attribute =>
+ return Chap14.Translate_Ascending_Array_Attribute (Expr);
+
+ when Iir_Kind_Val_Attribute =>
+ return Chap14.Translate_Val_Attribute (Expr);
+ when Iir_Kind_Pos_Attribute =>
+ return Chap14.Translate_Pos_Attribute (Expr, Res_Type);
+
+ when Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute =>
+ return Chap14.Translate_Succ_Pred_Attribute (Expr);
+
+ when Iir_Kind_Image_Attribute =>
+ Res := Chap14.Translate_Image_Attribute (Expr);
+
+ when Iir_Kind_Value_Attribute =>
+ return Chap14.Translate_Value_Attribute (Expr);
+
+ when Iir_Kind_Event_Attribute =>
+ return Chap14.Translate_Event_Attribute (Expr);
+ when Iir_Kind_Active_Attribute =>
+ return Chap14.Translate_Active_Attribute (Expr);
+ when Iir_Kind_Last_Value_Attribute =>
+ Res := Chap14.Translate_Last_Value_Attribute (Expr);
+
+ when Iir_Kind_High_Type_Attribute =>
+ return Chap14.Translate_High_Low_Type_Attribute
+ (Get_Type (Expr), True);
+ when Iir_Kind_Low_Type_Attribute =>
+ return Chap14.Translate_High_Low_Type_Attribute
+ (Get_Type (Expr), False);
+ when Iir_Kind_Left_Type_Attribute =>
+ return M2E
+ (Chap3.Range_To_Left
+ (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type),
+ Get_Info (Get_Base_Type (Expr_Type)), Mode_Value)));
+ when Iir_Kind_Right_Type_Attribute =>
+ return M2E
+ (Chap3.Range_To_Right
+ (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type),
+ Get_Info (Get_Base_Type (Expr_Type)), Mode_Value)));
+
+ when Iir_Kind_Last_Event_Attribute =>
+ return Chap14.Translate_Last_Time_Attribute
+ (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field);
+ when Iir_Kind_Last_Active_Attribute =>
+ return Chap14.Translate_Last_Time_Attribute
+ (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field);
+
+ when Iir_Kind_Driving_Value_Attribute =>
+ Res := Chap14.Translate_Driving_Value_Attribute (Expr);
+ when Iir_Kind_Driving_Attribute =>
+ Res := Chap14.Translate_Driving_Attribute (Expr);
+
+ when Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr);
+
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Selected_Name =>
+ return Translate_Expression (Get_Named_Entity (Expr), Rtype);
+
+ when others =>
+ Error_Kind ("translate_expression", Expr);
+ end case;
+
+ -- Quick test to avoid useless calls.
+ if Expr_Type /= Res_Type then
+ Res := Translate_Implicit_Conv
+ (Res, Expr_Type, Res_Type, Mode_Value, Expr);
+ end if;
+
+ return Res;
+ end Translate_Expression;
+
+ -- Check if RNG is of the form:
+ -- 1 to T'length
+ -- or T'Length downto 1
+ -- or 0 to T'length - 1
+ -- or T'Length - 1 downto 0
+ -- In either of these cases, return T'Length
+ function Is_Length_Range_Expression (Rng : Iir_Range_Expression)
+ return Iir
+ is
+ -- Pattern of a bound.
+ type Length_Pattern is
+ (
+ Pat_Unknown,
+ Pat_Length,
+ Pat_Length_1, -- Length - 1
+ Pat_1,
+ Pat_0
+ );
+ Length_Attr : Iir := Null_Iir;
+
+ -- Classify the bound.
+ -- Set LENGTH_ATTR is the pattern is Pat_Length.
+ function Get_Length_Pattern (Expr : Iir; Recurse : Boolean)
+ return Length_Pattern
+ is
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Length_Array_Attribute =>
+ Length_Attr := Expr;
+ return Pat_Length;
+ when Iir_Kind_Integer_Literal =>
+ case Get_Value (Expr) is
+ when 0 =>
+ return Pat_0;
+ when 1 =>
+ return Pat_1;
+ when others =>
+ return Pat_Unknown;
+ end case;
+ when Iir_Kind_Substraction_Operator =>
+ if not Recurse then
+ return Pat_Unknown;
+ end if;
+ if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length
+ and then
+ Get_Length_Pattern (Get_Right (Expr), False) = Pat_1
+ then
+ return Pat_Length_1;
+ else
+ return Pat_Unknown;
+ end if;
+ when others =>
+ return Pat_Unknown;
+ end case;
+ end Get_Length_Pattern;
+ Left_Pat, Right_Pat : Length_Pattern;
+ begin
+ Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True);
+ if Left_Pat = Pat_Unknown then
+ return Null_Iir;
+ end if;
+ Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True);
+ if Right_Pat = Pat_Unknown then
+ return Null_Iir;
+ end if;
+ case Get_Direction (Rng) is
+ when Iir_To =>
+ if (Left_Pat = Pat_1 and Right_Pat = Pat_Length)
+ or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1)
+ then
+ return Length_Attr;
+ end if;
+ when Iir_Downto =>
+ if (Left_Pat = Pat_Length and Right_Pat = Pat_1)
+ or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0)
+ then
+ return Length_Attr;
+ end if;
+ end case;
+ return Null_Iir;
+ end Is_Length_Range_Expression;
+
+ procedure Translate_Range_Expression_Ptr
+ (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir)
+ is
+ T_Info : Type_Info_Acc;
+ Length_Attr : Iir;
+ begin
+ T_Info := Get_Info (Range_Type);
+ Open_Temp;
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Left),
+ Chap7.Translate_Range_Expression_Left (Expr, Range_Type));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Right),
+ Chap7.Translate_Range_Expression_Right (Expr, Range_Type));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Dir),
+ New_Lit (Chap7.Translate_Static_Range_Dir (Expr)));
+ if T_Info.T.Range_Length /= O_Fnode_Null then
+ if Get_Expr_Staticness (Expr) = Locally then
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr),
+ T_Info.T.Range_Length),
+ New_Lit (Translate_Static_Range_Length (Expr)));
+ else
+ Length_Attr := Is_Length_Range_Expression (Expr);
+ if Length_Attr = Null_Iir then
+ Open_Temp;
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr),
+ T_Info.T.Range_Length),
+ Compute_Range_Length
+ (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr),
+ T_Info.T.Range_Left),
+ New_Value_Selected_Acc_Value (New_Obj (Res_Ptr),
+ T_Info.T.Range_Right),
+ Get_Direction (Expr)));
+ Close_Temp;
+ else
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr),
+ T_Info.T.Range_Length),
+ Chap14.Translate_Length_Array_Attribute
+ (Length_Attr, Null_Iir));
+ end if;
+ end if;
+ end if;
+ Close_Temp;
+ end Translate_Range_Expression_Ptr;
+
+ -- Reverse range ARANGE.
+ procedure Translate_Reverse_Range_Ptr
+ (Res_Ptr : O_Dnode; Arange : O_Lnode; Range_Type : Iir)
+ is
+ Rinfo : Type_Info_Acc;
+ Ptr : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Rinfo := Get_Info (Get_Base_Type (Range_Type));
+ Open_Temp;
+ Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, Arange);
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Left),
+ New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Right));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Right),
+ New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Left));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Length),
+ New_Value_Selected_Acc_Value (New_Obj (Ptr),
+ Rinfo.T.Range_Length));
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op
+ (ON_Eq,
+ New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Dir),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir),
+ New_Lit (Ghdl_Dir_Downto_Node));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir),
+ New_Lit (Ghdl_Dir_To_Node));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end Translate_Reverse_Range_Ptr;
+
+ procedure Copy_Range (Dest_Ptr : O_Dnode;
+ Src_Ptr : O_Dnode;
+ Info : Type_Info_Acc)
+ is
+ begin
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Left),
+ New_Value_Selected_Acc_Value (New_Obj (Src_Ptr),
+ Info.T.Range_Left));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Right),
+ New_Value_Selected_Acc_Value (New_Obj (Src_Ptr),
+ Info.T.Range_Right));
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Dir),
+ New_Value_Selected_Acc_Value (New_Obj (Src_Ptr),
+ Info.T.Range_Dir));
+ if Info.T.Range_Length /= O_Fnode_Null then
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Dest_Ptr),
+ Info.T.Range_Length),
+ New_Value_Selected_Acc_Value (New_Obj (Src_Ptr),
+ Info.T.Range_Length));
+ end if;
+ end Copy_Range;
+
+ procedure Translate_Range_Ptr
+ (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir)
+ is
+ begin
+ case Get_Kind (Arange) is
+ when Iir_Kind_Range_Array_Attribute =>
+ declare
+ Ptr : O_Dnode;
+ Rinfo : Type_Info_Acc;
+ begin
+ Rinfo := Get_Info (Get_Base_Type (Range_Type));
+ Open_Temp;
+ Ptr := Create_Temp_Ptr
+ (Rinfo.T.Range_Ptr_Type,
+ Chap14.Translate_Range_Array_Attribute (Arange));
+ Copy_Range (Res_Ptr, Ptr, Rinfo);
+ Close_Temp;
+ end;
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Translate_Reverse_Range_Ptr
+ (Res_Ptr,
+ Chap14.Translate_Range_Array_Attribute (Arange),
+ Range_Type);
+ when Iir_Kind_Range_Expression =>
+ Translate_Range_Expression_Ptr (Res_Ptr, Arange, Range_Type);
+ when others =>
+ Error_Kind ("translate_range_ptr", Arange);
+ end case;
+ end Translate_Range_Ptr;
+
+ procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir)
+ is
+ begin
+ case Get_Kind (Arange) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ if not Is_Anonymous_Type_Definition (Arange) then
+ declare
+ Ptr : O_Dnode;
+ Rinfo : Type_Info_Acc;
+ begin
+ Rinfo := Get_Info (Arange);
+ Open_Temp;
+ Ptr := Create_Temp_Ptr
+ (Rinfo.T.Range_Ptr_Type, Get_Var (Rinfo.T.Range_Var));
+ Copy_Range (Res_Ptr, Ptr, Rinfo);
+ Close_Temp;
+ end;
+ else
+ Translate_Range_Ptr (Res_Ptr,
+ Get_Range_Constraint (Arange),
+ Get_Base_Type (Arange));
+ end if;
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Range_Expression =>
+ Translate_Range_Ptr (Res_Ptr, Arange, Get_Type (Arange));
+ when others =>
+ Error_Kind ("translate_discrete_range_ptr", Arange);
+ end case;
+ end Translate_Discrete_Range_Ptr;
+
+ function Translate_Range (Arange : Iir; Range_Type : Iir)
+ return O_Lnode is
+ begin
+ case Get_Kind (Arange) is
+ when Iir_Kinds_Denoting_Name =>
+ return Translate_Range (Get_Named_Entity (Arange), Range_Type);
+ when Iir_Kind_Subtype_Declaration =>
+ -- Must be a scalar subtype. Range of types is static.
+ return Get_Var (Get_Info (Get_Type (Arange)).T.Range_Var);
+ when Iir_Kind_Range_Array_Attribute =>
+ return Chap14.Translate_Range_Array_Attribute (Arange);
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ declare
+ Res : O_Dnode;
+ Res_Ptr : O_Dnode;
+ Rinfo : Type_Info_Acc;
+ begin
+ Rinfo := Get_Info (Range_Type);
+ Res := Create_Temp (Rinfo.T.Range_Type);
+ Open_Temp;
+ Res_Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type,
+ New_Obj (Res));
+ Translate_Reverse_Range_Ptr
+ (Res_Ptr,
+ Chap14.Translate_Range_Array_Attribute (Arange),
+ Range_Type);
+ Close_Temp;
+ return New_Obj (Res);
+ end;
+ when Iir_Kind_Range_Expression =>
+ declare
+ Res : O_Dnode;
+ Ptr : O_Dnode;
+ T_Info : Type_Info_Acc;
+ begin
+ T_Info := Get_Info (Range_Type);
+ Res := Create_Temp (T_Info.T.Range_Type);
+ Open_Temp;
+ Ptr := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type,
+ New_Obj (Res));
+ Translate_Range_Expression_Ptr (Ptr, Arange, Range_Type);
+ Close_Temp;
+ return New_Obj (Res);
+ end;
+ when others =>
+ Error_Kind ("translate_range", Arange);
+ end case;
+ return O_Lnode_Null;
+ end Translate_Range;
+
+ function Translate_Static_Range (Arange : Iir; Range_Type : Iir)
+ return O_Cnode
+ is
+ Constr : O_Record_Aggr_List;
+ Res : O_Cnode;
+ T_Info : Type_Info_Acc;
+ begin
+ T_Info := Get_Info (Range_Type);
+ Start_Record_Aggr (Constr, T_Info.T.Range_Type);
+ New_Record_Aggr_El
+ (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type));
+ New_Record_Aggr_El
+ (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type));
+ New_Record_Aggr_El
+ (Constr, Chap7.Translate_Static_Range_Dir (Arange));
+ if T_Info.T.Range_Length /= O_Fnode_Null then
+ New_Record_Aggr_El
+ (Constr, Chap7.Translate_Static_Range_Length (Arange));
+ end if;
+ Finish_Record_Aggr (Constr, Res);
+ return Res;
+ end Translate_Static_Range;
+
+ procedure Translate_Predefined_Array_Compare (Subprg : Iir)
+ is
+ procedure Gen_Compare (L, R : O_Dnode)
+ is
+ If_Blk1, If_Blk2 : O_If_Block;
+ begin
+ Start_If_Stmt
+ (If_Blk1,
+ New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R),
+ Ghdl_Bool_Type));
+ Start_If_Stmt
+ (If_Blk2,
+ New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R),
+ Ghdl_Bool_Type));
+ New_Return_Stmt (New_Lit (Ghdl_Compare_Gt));
+ New_Else_Stmt (If_Blk2);
+ New_Return_Stmt (New_Lit (Ghdl_Compare_Lt));
+ Finish_If_Stmt (If_Blk2);
+ Finish_If_Stmt (If_Blk1);
+ end Gen_Compare;
+
+ Arr_Type : constant Iir_Array_Type_Definition :=
+ Get_Type (Get_Interface_Declaration_Chain (Subprg));
+ Info : constant Type_Info_Acc := Get_Info (Arr_Type);
+ Id : constant Name_Id :=
+ Get_Identifier (Get_Type_Declarator (Arr_Type));
+ Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value);
+
+ F_Info : Subprg_Info_Acc;
+ L, R : O_Dnode;
+ Interface_List : O_Inter_List;
+ If_Blk : O_If_Block;
+ Var_L_Len, Var_R_Len : O_Dnode;
+ Var_L_El, Var_R_El : O_Dnode;
+ Var_I, Var_Len : O_Dnode;
+ Label : O_Snode;
+ El_Otype : O_Tnode;
+ begin
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance);
+
+ -- Create function.
+ Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"),
+ Global_Storage, Ghdl_Compare_Type);
+ New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ El_Otype := Get_Ortho_Type
+ (Get_Element_Subtype (Arr_Type), Mode_Value);
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ -- Compute length of L and R.
+ New_Var_Decl (Var_L_Len, Wki_L_Len,
+ O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_R_Len, Wki_R_Len,
+ O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Assign_Stmt (New_Obj (Var_L_Len),
+ Chap6.Get_Array_Bound_Length
+ (Dp2M (L, Info, Mode_Value), Arr_Type, 1));
+ New_Assign_Stmt (New_Obj (Var_R_Len),
+ Chap6.Get_Array_Bound_Length
+ (Dp2M (R, Info, Mode_Value), Arr_Type, 1));
+ -- Find the minimum length.
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_L_Len),
+ New_Obj_Value (Var_R_Len),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len));
+ Finish_If_Stmt (If_Blk);
+
+ -- for each element, compare elements; if not equal return the
+ -- comparaison result.
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Var_Len),
+ Ghdl_Bool_Type));
+ -- Compare the length and return the result.
+ Gen_Compare (Var_L_Len, Var_R_Len);
+ New_Return_Stmt (New_Lit (Ghdl_Compare_Eq));
+ Finish_If_Stmt (If_Blk);
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local,
+ El_Otype);
+ New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local,
+ El_Otype);
+ New_Assign_Stmt
+ (New_Obj (Var_L_El),
+ M2E (Chap3.Index_Base
+ (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)),
+ Arr_Type,
+ New_Obj_Value (Var_I))));
+ New_Assign_Stmt
+ (New_Obj (Var_R_El),
+ M2E (Chap3.Index_Base
+ (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)),
+ Arr_Type,
+ New_Obj_Value (Var_I))));
+ Gen_Compare (Var_L_El, Var_R_El);
+ Finish_Declare_Stmt;
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Array_Compare;
+
+ -- Find the declaration of the predefined function IMP in type
+ -- definition BASE_TYPE.
+ function Find_Predefined_Function
+ (Base_Type : Iir; Imp : Iir_Predefined_Functions)
+ return Iir
+ is
+ El : Iir;
+ begin
+ El := Get_Chain (Get_Type_Declarator (Base_Type));
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ if Get_Implicit_Definition (El) = Imp then
+ return El;
+ else
+ El := Get_Chain (El);
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ raise Internal_Error;
+ end Find_Predefined_Function;
+
+ function Translate_Equality (L, R : Mnode; Etype : Iir)
+ return O_Enode
+ is
+ Tinfo : Type_Info_Acc;
+ begin
+ Tinfo := Get_Type_Info (L);
+ case Tinfo.Type_Mode is
+ when Type_Mode_Scalar
+ | Type_Mode_Acc =>
+ return New_Compare_Op (ON_Eq, M2E (L), M2E (R),
+ Ghdl_Bool_Type);
+ when Type_Mode_Fat_Acc =>
+ -- a fat pointer.
+ declare
+ B : Type_Info_Acc;
+ Ln, Rn : Mnode;
+ V1, V2 : O_Enode;
+ begin
+ B := Get_Info (Get_Designated_Type (Etype));
+ Ln := Stabilize (L);
+ Rn := Stabilize (R);
+ V1 := New_Compare_Op
+ (ON_Eq,
+ New_Value (New_Selected_Element
+ (M2Lv (Ln), B.T.Base_Field (Mode_Value))),
+ New_Value (New_Selected_Element
+ (M2Lv (Rn), B.T.Base_Field (Mode_Value))),
+ Std_Boolean_Type_Node);
+ V2 := New_Compare_Op
+ (ON_Eq,
+ New_Value (New_Selected_Element
+ (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))),
+ New_Value (New_Selected_Element
+ (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))),
+ Std_Boolean_Type_Node);
+ return New_Dyadic_Op (ON_And, V1, V2);
+ end;
+
+ when Type_Mode_Array =>
+ declare
+ Lc, Rc : O_Enode;
+ Base_Type : Iir_Array_Type_Definition;
+ Func : Iir;
+ begin
+ Base_Type := Get_Base_Type (Etype);
+ Lc := Translate_Implicit_Conv
+ (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir);
+ Rc := Translate_Implicit_Conv
+ (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir);
+ Func := Find_Predefined_Function
+ (Base_Type, Iir_Predefined_Array_Equality);
+ return Translate_Predefined_Lib_Operator (Lc, Rc, Func);
+ end;
+
+ when Type_Mode_Record =>
+ declare
+ Func : Iir;
+ begin
+ Func := Find_Predefined_Function
+ (Get_Base_Type (Etype), Iir_Predefined_Record_Equality);
+ return Translate_Predefined_Lib_Operator
+ (M2E (L), M2E (R), Func);
+ end;
+
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Fat_Array
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Equality;
+
+ procedure Translate_Predefined_Array_Equality (Subprg : Iir)
+ is
+ F_Info : Subprg_Info_Acc;
+ Arr_Type : Iir_Array_Type_Definition;
+ Arr_Ptr_Type : O_Tnode;
+ Info : Type_Info_Acc;
+ Id : Name_Id;
+ Var_L, Var_R : O_Dnode;
+ L, R : Mnode;
+ Interface_List : O_Inter_List;
+ Indexes : Iir_List;
+ Nbr_Indexes : Natural;
+ If_Blk : O_If_Block;
+ Var_I : O_Dnode;
+ Var_Len : O_Dnode;
+ Label : O_Snode;
+ Le, Re : Mnode;
+ El_Type : Iir;
+ begin
+ Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg));
+ El_Type := Get_Element_Subtype (Arr_Type);
+ Info := Get_Info (Arr_Type);
+ Id := Get_Identifier (Get_Type_Declarator (Arr_Type));
+ Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value);
+
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+
+ -- Create function.
+ Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"),
+ Global_Storage, Std_Boolean_Type_Node);
+ Chap2.Create_Subprg_Instance (Interface_List, Subprg);
+ New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ L := Dp2M (Var_L, Info, Mode_Value);
+ R := Dp2M (Var_R, Info, Mode_Value);
+
+ Indexes := Get_Index_Subtype_List (Arr_Type);
+ Nbr_Indexes := Get_Nbr_Elements (Indexes);
+
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ Chap2.Start_Subprg_Instance_Use (Subprg);
+ -- for each dimension: if length mismatch: return false
+ for I in 1 .. Nbr_Indexes loop
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op
+ (ON_Neq,
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (L, Arr_Type, I))),
+ M2E (Chap3.Range_To_Length
+ (Chap3.Get_Array_Range (R, Arr_Type, I))),
+ Std_Boolean_Type_Node));
+ New_Return_Stmt (New_Lit (Std_Boolean_False_Node));
+ Finish_If_Stmt (If_Blk);
+ end loop;
+
+ -- for each element: if element is not equal, return false
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type);
+ Open_Temp;
+ New_Assign_Stmt (New_Obj (Var_Len),
+ Chap3.Get_Array_Length (L, Arr_Type));
+ Close_Temp;
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ -- If the end of the array is reached, return TRUE.
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Var_Len),
+ Ghdl_Bool_Type));
+ New_Return_Stmt (New_Lit (Std_Boolean_True_Node));
+ Finish_If_Stmt (If_Blk);
+ Open_Temp;
+ Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type,
+ New_Obj_Value (Var_I));
+ Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type,
+ New_Obj_Value (Var_I));
+ Start_If_Stmt
+ (If_Blk,
+ New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type)));
+ New_Return_Stmt (New_Lit (Std_Boolean_False_Node));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Chap2.Finish_Subprg_Instance_Use (Subprg);
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Array_Equality;
+
+ procedure Translate_Predefined_Record_Equality (Subprg : Iir)
+ is
+ F_Info : Subprg_Info_Acc;
+ Rec_Type : Iir_Record_Type_Definition;
+ Rec_Ptr_Type : O_Tnode;
+ Info : Type_Info_Acc;
+ Id : Name_Id;
+ Var_L, Var_R : O_Dnode;
+ L, R : Mnode;
+ Interface_List : O_Inter_List;
+ If_Blk : O_If_Block;
+ Le, Re : Mnode;
+
+ El_List : Iir_List;
+ El : Iir_Element_Declaration;
+ begin
+ Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg));
+ Info := Get_Info (Rec_Type);
+ Id := Get_Identifier (Get_Type_Declarator (Rec_Type));
+ Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value);
+
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance);
+
+ -- Create function.
+ Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"),
+ Global_Storage, Std_Boolean_Type_Node);
+ Chap2.Create_Subprg_Instance (Interface_List, Subprg);
+ New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ Chap2.Start_Subprg_Instance_Use (Subprg);
+
+ L := Dp2M (Var_L, Info, Mode_Value);
+ R := Dp2M (Var_R, Info, Mode_Value);
+
+ -- Compare each element.
+ El_List := Get_Elements_Declaration_List (Rec_Type);
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Le := Chap6.Translate_Selected_Element (L, El);
+ Re := Chap6.Translate_Selected_Element (R, El);
+
+ Open_Temp;
+ Start_If_Stmt
+ (If_Blk,
+ New_Monadic_Op (ON_Not,
+ Translate_Equality (Le, Re, Get_Type (El))));
+ New_Return_Stmt (New_Lit (Std_Boolean_False_Node));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end loop;
+ New_Return_Stmt (New_Lit (Std_Boolean_True_Node));
+ Chap2.Finish_Subprg_Instance_Use (Subprg);
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Record_Equality;
+
+ procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir)
+ is
+ F_Info : Subprg_Info_Acc;
+ Arr_Type : Iir_Array_Type_Definition;
+ Arr_Ptr_Type : O_Tnode;
+
+ -- Info for the array type.
+ Info : Type_Info_Acc;
+
+ -- Info for the index type.
+ Iinfo : Type_Info_Acc;
+ Index_Type : Iir;
+
+ Index_Otype : O_Tnode;
+ Id : Name_Id;
+ Interface_List : O_Inter_List;
+ Var_Res, Var_L, Var_R : O_Dnode;
+ Res, L, R : Mnode;
+ Var_Length, Var_L_Len, Var_R_Len : O_Dnode;
+ Var_Bounds, Var_Right : O_Dnode;
+ V_Bounds : Mnode;
+ If_Blk : O_If_Block;
+ begin
+ Arr_Type := Get_Return_Type (Subprg);
+ Info := Get_Info (Arr_Type);
+ Id := Get_Identifier (Get_Type_Declarator (Arr_Type));
+ Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value);
+
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ F_Info.Use_Stack2 := True;
+
+ -- Create function.
+ Start_Procedure_Decl
+ (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage);
+ -- Note: contrary to user function which returns composite value
+ -- via a result record, a concatenation returns its value without
+ -- the use of the record.
+ Chap2.Create_Subprg_Instance (Interface_List, Subprg);
+ New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type);
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Index_Type := Get_Index_Type (Arr_Type, 0);
+ Iinfo := Get_Info (Index_Type);
+ Index_Otype := Iinfo.Ortho_Type (Mode_Value);
+
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ Chap2.Start_Subprg_Instance_Use (Subprg);
+ New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local,
+ Ghdl_Index_Type);
+ New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local,
+ Info.T.Bounds_Ptr_Type);
+
+ L := Dp2M (Var_L, Info, Mode_Value);
+ R := Dp2M (Var_R, Info, Mode_Value);
+ Res := Dp2M (Var_Res, Info, Mode_Value);
+ V_Bounds := Dp2M (Var_Bounds, Info, Mode_Value,
+ Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type);
+
+ -- Compute length.
+ New_Assign_Stmt
+ (New_Obj (Var_L_Len), Chap3.Get_Array_Length (L, Arr_Type));
+ New_Assign_Stmt
+ (New_Obj (Var_R_Len), Chap3.Get_Array_Length (R, Arr_Type));
+ New_Assign_Stmt
+ (New_Obj (Var_Length), New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_L_Len),
+ New_Obj_Value (Var_R_Len)));
+
+ -- Check case where the result is the right operand.
+ declare
+ Len : O_Enode;
+ begin
+ if Flags.Vhdl_Std = Vhdl_87 then
+ -- LRM87 7.2.4
+ -- [...], unless the left operand is a null array, in which
+ -- case the result of the concatenation is the right operand.
+ Len := New_Obj_Value (Var_L_Len);
+
+ else
+ -- LRM93 7.2.4
+ -- If both operands are null arrays, then the result of the
+ -- concatenation is the right operand.
+ -- GHDL: since the length type is unsigned, then both operands
+ -- are null arrays iff the result is a null array.
+ Len := New_Obj_Value (Var_Length);
+ end if;
+
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ Len,
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type));
+ Copy_Fat_Pointer (Res, R);
+ New_Return_Stmt;
+ Finish_If_Stmt (If_Blk);
+ end;
+
+ -- Allocate bounds.
+ New_Assign_Stmt
+ (New_Obj (Var_Bounds),
+ Gen_Alloc (Alloc_Return,
+ New_Lit (New_Sizeof (Info.T.Bounds_Type,
+ Ghdl_Index_Type)),
+ Info.T.Bounds_Ptr_Type));
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Obj_Value (Var_Bounds));
+
+ -- Set bound.
+ if Flags.Vhdl_Std = Vhdl_87 then
+ -- Set length.
+ New_Assign_Stmt
+ (M2Lv (Chap3.Range_To_Length
+ (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))),
+ New_Obj_Value (Var_Length));
+
+ -- Set direction, left bound and right bound.
+ -- LRM87 7.2.4
+ -- The left bound of this result is the left bound of the left
+ -- operand, unless the left operand is a null array, in which
+ -- case the result of the concatenation is the right operand.
+ -- The direction of the result is the direction of the left
+ -- operand, unless the left operand is a null array, in which
+ -- case the direction of the result is that of the right operand.
+ declare
+ Var_Dir, Var_Left : O_Dnode;
+ Var_Length1 : O_Dnode;
+ begin
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_Right, Get_Identifier ("right_bound"),
+ O_Storage_Local, Index_Otype);
+ New_Var_Decl (Var_Dir, Wki_Dir, O_Storage_Local,
+ Ghdl_Dir_Type_Node);
+ New_Var_Decl (Var_Left, Get_Identifier ("left_bound"),
+ O_Storage_Local, Iinfo.Ortho_Type (Mode_Value));
+ New_Var_Decl (Var_Length1, Get_Identifier ("length_1"),
+ O_Storage_Local, Ghdl_Index_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Dir),
+ M2E (Chap3.Range_To_Dir
+ (Chap3.Get_Array_Range (L, Arr_Type, 1))));
+ New_Assign_Stmt
+ (M2Lv (Chap3.Range_To_Dir
+ (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))),
+ New_Obj_Value (Var_Dir));
+ New_Assign_Stmt
+ (New_Obj (Var_Left),
+ M2E (Chap3.Range_To_Left
+ (Chap3.Get_Array_Range (L, Arr_Type, 1))));
+ -- Note this substraction cannot overflow, since LENGTH >= 1.
+ New_Assign_Stmt
+ (New_Obj (Var_Length1),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Var_Length),
+ New_Lit (Ghdl_Index_1)));
+ New_Assign_Stmt
+ (M2Lv (Chap3.Range_To_Left
+ (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))),
+ New_Obj_Value (Var_Left));
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq, New_Obj_Value (Var_Dir),
+ New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Obj (Var_Right),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Left),
+ New_Convert_Ov (New_Obj_Value (Var_Length1),
+ Index_Otype)));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt
+ (New_Obj (Var_Right),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Var_Left),
+ New_Convert_Ov (New_Obj_Value (Var_Length1),
+ Index_Otype)));
+ Finish_If_Stmt (If_Blk);
+ -- Check the right bounds is inside the bounds of the
+ -- index type.
+ Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg);
+ New_Assign_Stmt
+ (M2Lv (Chap3.Range_To_Right
+ (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))),
+ New_Obj_Value (Var_Right));
+ Finish_Declare_Stmt;
+ end;
+ else
+ -- LRM93 7.2.4
+ -- [...], the direction and bounds of the result are determined
+ -- as follows: Let S be the index subtype of the base type of the
+ -- result. The direction of the result of the concatenation is
+ -- the direction of S, and the left bound of the result is
+ -- S'LEFT.
+ declare
+ Var_Range_Ptr : O_Dnode;
+ begin
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_Range_Ptr, Get_Identifier ("range_ptr"),
+ O_Storage_Local, Iinfo.T.Range_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Range_Ptr),
+ M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1)));
+ Chap3.Create_Range_From_Length
+ (Index_Type, Var_Length, Var_Range_Ptr, Subprg);
+ Finish_Declare_Stmt;
+ end;
+ end if;
+
+ -- Allocate array base.
+ Chap3.Allocate_Fat_Array_Base (Alloc_Return, Res, Arr_Type);
+
+ -- Copy left.
+ declare
+ V_Arr : O_Dnode;
+ Var_Arr : Mnode;
+ begin
+ Open_Temp;
+ V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value));
+ Var_Arr := Dv2M (V_Arr, Info, Mode_Value);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)),
+ M2Addr (Chap3.Get_Array_Bounds (L)));
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Var_Arr)),
+ M2Addr (Chap3.Get_Array_Base (Res)));
+ Chap3.Translate_Object_Copy
+ (Var_Arr, New_Obj_Value (Var_L), Arr_Type);
+ Close_Temp;
+ end;
+
+ -- Copy right.
+ declare
+ V_Arr : O_Dnode;
+ Var_Arr : Mnode;
+ begin
+ Open_Temp;
+ V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value));
+ Var_Arr := Dv2M (V_Arr, Info, Mode_Value);
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)),
+ M2Addr (Chap3.Get_Array_Bounds (R)));
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Var_Arr)),
+ M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res),
+ Arr_Type,
+ New_Obj_Value (Var_L_Len))));
+ Chap3.Translate_Object_Copy
+ (Var_Arr, New_Obj_Value (Var_R), Arr_Type);
+ Close_Temp;
+ end;
+ Chap2.Finish_Subprg_Instance_Use (Subprg);
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Array_Array_Concat;
+
+ procedure Translate_Predefined_Array_Logical (Subprg : Iir)
+ is
+ Arr_Type : constant Iir_Array_Type_Definition :=
+ Get_Type (Get_Interface_Declaration_Chain (Subprg));
+ -- Info for the array type.
+ Info : constant Type_Info_Acc := Get_Info (Arr_Type);
+ -- Identifier of the type.
+ Id : constant Name_Id :=
+ Get_Identifier (Get_Type_Declarator (Arr_Type));
+ Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value);
+ F_Info : Subprg_Info_Acc;
+ Interface_List : O_Inter_List;
+ Var_Res : O_Dnode;
+ Res : Mnode;
+ L, R : O_Dnode;
+ Var_Length, Var_I : O_Dnode;
+ Var_Base, Var_L_Base, Var_R_Base : O_Dnode;
+ If_Blk : O_If_Block;
+ Label : O_Snode;
+ Name : O_Ident;
+ Is_Monadic : Boolean;
+ El, L_El : O_Enode;
+ Op : ON_Op_Kind;
+ Do_Invert : Boolean;
+ begin
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance);
+ F_Info.Use_Stack2 := True;
+
+ Is_Monadic := False;
+ case Get_Implicit_Definition (Subprg) is
+ when Iir_Predefined_TF_Array_And =>
+ Name := Create_Identifier (Id, "_AND");
+ Op := ON_And;
+ Do_Invert := False;
+ when Iir_Predefined_TF_Array_Or =>
+ Name := Create_Identifier (Id, "_OR");
+ Op := ON_Or;
+ Do_Invert := False;
+ when Iir_Predefined_TF_Array_Nand =>
+ Name := Create_Identifier (Id, "_NAND");
+ Op := ON_And;
+ Do_Invert := True;
+ when Iir_Predefined_TF_Array_Nor =>
+ Name := Create_Identifier (Id, "_NOR");
+ Op := ON_Or;
+ Do_Invert := True;
+ when Iir_Predefined_TF_Array_Xor =>
+ Name := Create_Identifier (Id, "_XOR");
+ Op := ON_Xor;
+ Do_Invert := False;
+ when Iir_Predefined_TF_Array_Xnor =>
+ Name := Create_Identifier (Id, "_XNOR");
+ Op := ON_Xor;
+ Do_Invert := True;
+ when Iir_Predefined_TF_Array_Not =>
+ Name := Create_Identifier (Id, "_NOT");
+ Is_Monadic := True;
+ Op := ON_Not;
+ Do_Invert := False;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Create function.
+ Start_Procedure_Decl (Interface_List, Name, Global_Storage);
+ -- Note: contrary to user function which returns composite value
+ -- via a result record, a concatenation returns its value without
+ -- the use of the record.
+ New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type);
+ if not Is_Monadic then
+ New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type);
+ end if;
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local,
+ Ghdl_Index_Type);
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local,
+ Info.T.Base_Ptr_Type (Mode_Value));
+ New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local,
+ Info.T.Base_Ptr_Type (Mode_Value));
+ if not Is_Monadic then
+ New_Var_Decl
+ (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local,
+ Info.T.Base_Ptr_Type (Mode_Value));
+ end if;
+ Open_Temp;
+ -- Get length of LEFT.
+ New_Assign_Stmt (New_Obj (Var_Length),
+ Chap6.Get_Array_Bound_Length
+ (Dp2M (L, Info, Mode_Value), Arr_Type, 1));
+ -- If dyadic, check RIGHT has the same length.
+ if not Is_Monadic then
+ Chap6.Check_Bound_Error
+ (New_Compare_Op (ON_Neq,
+ New_Obj_Value (Var_Length),
+ Chap6.Get_Array_Bound_Length
+ (Dp2M (R, Info, Mode_Value), Arr_Type, 1),
+ Ghdl_Bool_Type),
+ Subprg, 0);
+ end if;
+
+ -- Create the result from LEFT bound.
+ Res := Dp2M (Var_Res, Info, Mode_Value);
+ Chap3.Translate_Object_Allocation
+ (Res, Alloc_Return, Arr_Type,
+ Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value)));
+ New_Assign_Stmt
+ (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res)));
+ New_Assign_Stmt
+ (New_Obj (Var_L_Base),
+ M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value))));
+ if not Is_Monadic then
+ New_Assign_Stmt
+ (New_Obj (Var_R_Base),
+ M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value))));
+ end if;
+
+ -- Do the logical operation on each element.
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ New_Return_Stmt;
+ Finish_If_Stmt (If_Blk);
+ L_El := New_Value (New_Indexed_Element
+ (New_Acc_Value (New_Obj (Var_L_Base)),
+ New_Obj_Value (Var_I)));
+ if Is_Monadic then
+ El := New_Monadic_Op (Op, L_El);
+ else
+ El := New_Dyadic_Op
+ (Op, L_El,
+ New_Value (New_Indexed_Element
+ (New_Acc_Value (New_Obj (Var_R_Base)),
+ New_Obj_Value (Var_I))));
+ end if;
+ if Do_Invert then
+ El := New_Monadic_Op (ON_Not, El);
+ end if;
+
+ New_Assign_Stmt (New_Indexed_Element
+ (New_Acc_Value (New_Obj (Var_Base)),
+ New_Obj_Value (Var_I)),
+ El);
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Array_Logical;
+
+ procedure Translate_Predefined_Array_Shift (Subprg : Iir)
+ is
+ F_Info : Subprg_Info_Acc;
+ Inter : Iir;
+ Arr_Type : Iir_Array_Type_Definition;
+ Arr_Ptr_Type : O_Tnode;
+ Int_Type : O_Tnode;
+ -- Info for the array type.
+ Info : Type_Info_Acc;
+ Id : Name_Id;
+ Interface_List : O_Inter_List;
+ Var_Res : O_Dnode;
+ Var_L, Var_R : O_Dnode;
+ Name : O_Ident;
+
+ type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation);
+ Shift : Shift_Kind;
+
+ -- Body;
+ Var_Length, Var_I, Var_I1 : O_Dnode;
+ Var_Res_Base, Var_L_Base : O_Dnode;
+ Var_Rl : O_Dnode;
+ Var_E : O_Dnode;
+ L : Mnode;
+ If_Blk, If_Blk1 : O_If_Block;
+ Label : O_Snode;
+ Res : Mnode;
+
+ procedure Do_Shift (To_Right : Boolean)
+ is
+ Tmp : O_Enode;
+ begin
+ -- LEFT:
+ -- * I := 0;
+ if not To_Right then
+ Init_Var (Var_I);
+ end if;
+
+ -- * If R < LENGTH then
+ Start_If_Stmt (If_Blk1,
+ New_Compare_Op (ON_Lt,
+ New_Obj_Value (Var_Rl),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ -- Shift the elements (that remains in the result).
+ -- RIGHT:
+ -- * for I = R to LENGTH - 1 loop
+ -- * RES[I] := L[I - R]
+ -- LEFT:
+ -- * for I = 0 to LENGTH - R loop
+ -- * RES[I] := L[R + I]
+ if To_Right then
+ New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl));
+ Init_Var (Var_I1);
+ else
+ New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl));
+ end if;
+ Start_Loop_Stmt (Label);
+ if To_Right then
+ Tmp := New_Obj_Value (Var_I);
+ else
+ Tmp := New_Obj_Value (Var_I1);
+ end if;
+ Gen_Exit_When (Label, New_Compare_Op (ON_Ge,
+ Tmp,
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Indexed_Acc_Value (New_Obj (Var_Res_Base),
+ New_Obj_Value (Var_I)),
+ New_Value
+ (New_Indexed_Acc_Value (New_Obj (Var_L_Base),
+ New_Obj_Value (Var_I1))));
+ Inc_Var (Var_I);
+ Inc_Var (Var_I1);
+ Finish_Loop_Stmt (Label);
+ -- RIGHT:
+ -- * else
+ -- * R := LENGTH;
+ if To_Right then
+ New_Else_Stmt (If_Blk1);
+ New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length));
+ end if;
+ Finish_If_Stmt (If_Blk1);
+
+ -- Pad the result.
+ -- RIGHT:
+ -- * For I = 0 to R - 1
+ -- * RES[I] := 0/L[0/LENGTH-1]
+ -- LEFT:
+ -- * For I = LENGTH - R to LENGTH - 1
+ -- * RES[I] := 0/L[0/LENGTH-1]
+ if To_Right then
+ Init_Var (Var_I);
+ else
+ -- I is yet correctly set.
+ null;
+ end if;
+ if Shift = Sh_Arith then
+ if To_Right then
+ Tmp := New_Lit (Ghdl_Index_0);
+ else
+ Tmp := New_Dyadic_Op
+ (ON_Sub_Ov,
+ New_Obj_Value (Var_Length),
+ New_Lit (Ghdl_Index_1));
+ end if;
+ New_Assign_Stmt
+ (New_Obj (Var_E),
+ New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base),
+ Tmp)));
+ end if;
+ Start_Loop_Stmt (Label);
+ if To_Right then
+ Tmp := New_Obj_Value (Var_Rl);
+ else
+ Tmp := New_Obj_Value (Var_Length);
+ end if;
+ Gen_Exit_When (Label, New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ Tmp,
+ Ghdl_Bool_Type));
+ case Shift is
+ when Sh_Logical =>
+ declare
+ Enum_List : Iir_List;
+ begin
+ Enum_List := Get_Enumeration_Literal_List
+ (Get_Base_Type (Get_Element_Subtype (Arr_Type)));
+ Tmp := New_Lit
+ (Get_Ortho_Expr (Get_First_Element (Enum_List)));
+ end;
+ when Sh_Arith =>
+ Tmp := New_Obj_Value (Var_E);
+ when Rotation =>
+ raise Internal_Error;
+ end case;
+
+ New_Assign_Stmt
+ (New_Indexed_Acc_Value (New_Obj (Var_Res_Base),
+ New_Obj_Value (Var_I)), Tmp);
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ end Do_Shift;
+ begin
+ Inter := Get_Interface_Declaration_Chain (Subprg);
+
+ Info := Get_Info (Get_Type (Get_Chain (Inter)));
+ Int_Type := Info.Ortho_Type (Mode_Value);
+
+ Arr_Type := Get_Type (Inter);
+ Info := Get_Info (Arr_Type);
+ Id := Get_Identifier (Get_Type_Declarator (Arr_Type));
+ Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value);
+
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance);
+ F_Info.Use_Stack2 := True;
+
+ case Get_Implicit_Definition (Subprg) is
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl =>
+ -- Shift logical.
+ Name := Create_Identifier (Id, "_SHL");
+ Shift := Sh_Logical;
+ when Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra =>
+ -- Shift arithmetic.
+ Name := Create_Identifier (Id, "_SHA");
+ Shift := Sh_Arith;
+ when Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ -- Rotation
+ Name := Create_Identifier (Id, "_ROT");
+ Shift := Rotation;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Create function.
+ Start_Procedure_Decl (Interface_List, Name, Global_Storage);
+ -- Note: contrary to user function which returns composite value
+ -- via a result record, a shift returns its value without
+ -- the use of the record.
+ New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type);
+ New_Interface_Decl (Interface_List, Var_R, Wki_Right, Int_Type);
+ Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ -- Body
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local,
+ Ghdl_Index_Type);
+ if Shift /= Rotation then
+ New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local,
+ Ghdl_Index_Type);
+ end if;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local,
+ Ghdl_Index_Type);
+ New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"),
+ O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value));
+ New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"),
+ O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value));
+ if Shift = Sh_Arith then
+ New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local,
+ Get_Info (Get_Element_Subtype (Arr_Type)).
+ Ortho_Type (Mode_Value));
+ end if;
+ Res := Dp2M (Var_Res, Info, Mode_Value);
+ L := Dp2M (Var_L, Info, Mode_Value);
+
+ -- LRM93 7.2.3
+ -- The index subtypes of the return values of all shift operators is
+ -- the same as the index subtype of their left arguments.
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Bounds (Res)),
+ M2Addr (Chap3.Get_Array_Bounds (L)));
+
+ -- Get length of LEFT.
+ New_Assign_Stmt (New_Obj (Var_Length),
+ Chap3.Get_Array_Length (L, Arr_Type));
+
+ -- LRM93 7.2.3 [6 times]
+ -- That is, if R is 0 or L is a null array, the return value is L.
+ Start_If_Stmt
+ (If_Blk,
+ New_Dyadic_Op
+ (ON_Or,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_R),
+ New_Lit (New_Signed_Literal (Int_Type, 0)),
+ Ghdl_Bool_Type),
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Length),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type)));
+ New_Assign_Stmt
+ (M2Lp (Chap3.Get_Array_Base (Res)),
+ M2Addr (Chap3.Get_Array_Base (L)));
+ New_Return_Stmt;
+ Finish_If_Stmt (If_Blk);
+
+ -- Allocate base.
+ New_Assign_Stmt
+ (New_Obj (Var_Res_Base),
+ Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length),
+ Info.T.Base_Ptr_Type (Mode_Value)));
+ New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)),
+ New_Obj_Value (Var_Res_Base));
+
+ New_Assign_Stmt (New_Obj (Var_L_Base),
+ M2Addr (Chap3.Get_Array_Base (L)));
+
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Gt,
+ New_Obj_Value (Var_R),
+ New_Lit (New_Signed_Literal (Int_Type,
+ 0)),
+ Ghdl_Bool_Type));
+ -- R > 0.
+ -- Ie, to the right
+ case Shift is
+ when Rotation =>
+ -- * I1 := LENGTH - (R mod LENGTH)
+ New_Assign_Stmt
+ (New_Obj (Var_I1),
+ New_Dyadic_Op
+ (ON_Sub_Ov,
+ New_Obj_Value (Var_Length),
+ New_Dyadic_Op (ON_Mod_Ov,
+ New_Convert_Ov (New_Obj_Value (Var_R),
+ Ghdl_Index_Type),
+ New_Obj_Value (Var_Length))));
+
+ when Sh_Logical
+ | Sh_Arith =>
+ -- Real SRL or SRA.
+ New_Assign_Stmt
+ (New_Obj (Var_Rl),
+ New_Convert_Ov (New_Obj_Value (Var_R), Ghdl_Index_Type));
+
+ Do_Shift (True);
+ end case;
+
+ New_Else_Stmt (If_Blk);
+
+ -- R < 0, to the left.
+ case Shift is
+ when Rotation =>
+ -- * I1 := (-R) mod LENGTH
+ New_Assign_Stmt
+ (New_Obj (Var_I1),
+ New_Dyadic_Op (ON_Mod_Ov,
+ New_Convert_Ov
+ (New_Monadic_Op (ON_Neg_Ov,
+ New_Obj_Value (Var_R)),
+ Ghdl_Index_Type),
+ New_Obj_Value (Var_Length)));
+ when Sh_Logical
+ | Sh_Arith =>
+ -- Real SLL or SLA.
+ New_Assign_Stmt
+ (New_Obj (Var_Rl),
+ New_Convert_Ov (New_Monadic_Op (ON_Neg_Ov,
+ New_Obj_Value (Var_R)),
+ Ghdl_Index_Type));
+
+ Do_Shift (False);
+ end case;
+ Finish_If_Stmt (If_Blk);
+
+ if Shift = Rotation then
+ -- * If I1 = LENGTH then
+ -- * I1 := 0
+ Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I1),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ Init_Var (Var_I1);
+ Finish_If_Stmt (If_Blk);
+
+ -- * for I = 0 to LENGTH - 1 loop
+ -- * RES[I] := L[I1];
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When (Label, New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Indexed_Acc_Value (New_Obj (Var_Res_Base),
+ New_Obj_Value (Var_I)),
+ New_Value
+ (New_Indexed_Acc_Value (New_Obj (Var_L_Base),
+ New_Obj_Value (Var_I1))));
+ Inc_Var (Var_I);
+ -- * I1 := I1 + 1
+ Inc_Var (Var_I1);
+ -- * If I1 = LENGTH then
+ -- * I1 := 0
+ Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I1),
+ New_Obj_Value (Var_Length),
+ Ghdl_Bool_Type));
+ Init_Var (Var_I1);
+ Finish_If_Stmt (If_Blk);
+ Finish_Loop_Stmt (Label);
+ end if;
+ Finish_Subprogram_Body;
+ end Translate_Predefined_Array_Shift;
+
+ procedure Translate_File_Subprogram (Subprg : Iir; File_Type : Iir)
+ is
+ Etype : Iir;
+ Tinfo : Type_Info_Acc;
+ Kind : Iir_Predefined_Functions;
+ F_Info : Subprg_Info_Acc;
+ Name : O_Ident;
+ Inter_List : O_Inter_List;
+ Id : Name_Id;
+ Var_File : O_Dnode;
+ Var_Val : O_Dnode;
+
+ procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode);
+
+ procedure Translate_Rw_Array
+ (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode)
+ is
+ Var_It : O_Dnode;
+ Label : O_Snode;
+ begin
+ Var_It := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Var_It);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_It),
+ New_Obj_Value (Var_Max),
+ Ghdl_Bool_Type));
+ Translate_Rw
+ (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)),
+ Get_Element_Subtype (Val_Type), Proc);
+ Inc_Var (Var_It);
+ Finish_Loop_Stmt (Label);
+ end Translate_Rw_Array;
+
+ procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode)
+ is
+ Val_Info : Type_Info_Acc;
+ Assocs : O_Assoc_List;
+ begin
+ Val_Info := Get_Type_Info (Val);
+ case Val_Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ Start_Association (Assocs, Proc);
+ -- compute file parameter (get an index)
+ New_Association (Assocs, New_Obj_Value (Var_File));
+ -- compute the value.
+ New_Association
+ (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type));
+ -- length.
+ New_Association
+ (Assocs,
+ New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value),
+ Ghdl_Index_Type)));
+ -- call a predefined procedure
+ New_Procedure_Call (Assocs);
+ when Type_Mode_Record =>
+ declare
+ El_List : Iir_List;
+ El : Iir;
+ Val1 : Mnode;
+ begin
+ Open_Temp;
+ Val1 := Stabilize (Val);
+ El_List := Get_Elements_Declaration_List
+ (Get_Base_Type (Val_Type));
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ Translate_Rw
+ (Chap6.Translate_Selected_Element (Val1, El),
+ Get_Type (El), Proc);
+ end loop;
+ Close_Temp;
+ end;
+ when Type_Mode_Array =>
+ declare
+ Var_Max : O_Dnode;
+ begin
+ Open_Temp;
+ Var_Max := Create_Temp (Ghdl_Index_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Max),
+ Chap3.Get_Array_Type_Length (Val_Type));
+ Translate_Rw_Array (Val, Val_Type, Var_Max, Proc);
+ Close_Temp;
+ end;
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc
+ | Type_Mode_Fat_Array
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Rw;
+
+ procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode)
+ is
+ Assocs : O_Assoc_List;
+ begin
+ Start_Association (Assocs, Proc);
+ New_Association (Assocs, New_Obj_Value (Var_File));
+ New_Association
+ (Assocs, New_Unchecked_Address (New_Obj (Var_Length),
+ Ghdl_Ptr_Type));
+ New_Association
+ (Assocs,
+ New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type)));
+ New_Procedure_Call (Assocs);
+ end Translate_Rw_Length;
+
+ Var : Mnode;
+ begin
+ Etype := Get_Type (Get_File_Type_Mark (File_Type));
+ Tinfo := Get_Info (Etype);
+ if Tinfo.Type_Mode in Type_Mode_Scalar then
+ -- Intrinsic.
+ return;
+ end if;
+
+ F_Info := Add_Info (Subprg, Kind_Subprg);
+ --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance);
+ F_Info.Use_Stack2 := False;
+
+ Id := Get_Identifier (Get_Type_Declarator (File_Type));
+ Kind := Get_Implicit_Definition (Subprg);
+ case Kind is
+ when Iir_Predefined_Write =>
+ Name := Create_Identifier (Id, "_WRITE");
+ when Iir_Predefined_Read
+ | Iir_Predefined_Read_Length =>
+ Name := Create_Identifier (Id, "_READ");
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Create function.
+ if Kind = Iir_Predefined_Read_Length then
+ Start_Function_Decl
+ (Inter_List, Name, Global_Storage, Std_Integer_Otype);
+ else
+ Start_Procedure_Decl (Inter_List, Name, Global_Storage);
+ end if;
+ Chap2.Create_Subprg_Instance (Inter_List, Subprg);
+
+ New_Interface_Decl
+ (Inter_List, Var_File, Get_Identifier ("FILE"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl
+ (Inter_List, Var_Val, Wki_Val,
+ Tinfo.Ortho_Ptr_Type (Mode_Value));
+ Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Start_Subprogram_Body (F_Info.Ortho_Func);
+ Chap2.Start_Subprg_Instance_Use (Subprg);
+ Push_Local_Factory;
+
+ Var := Dp2M (Var_Val, Tinfo, Mode_Value);
+
+ case Kind is
+ when Iir_Predefined_Write =>
+ if Tinfo.Type_Mode = Type_Mode_Fat_Array then
+ declare
+ Var_Max : O_Dnode;
+ begin
+ Open_Temp;
+ Var_Max := Create_Temp_Init
+ (Ghdl_Index_Type,
+ Chap3.Get_Array_Length (Var, Etype));
+ Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar);
+ Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype,
+ Var_Max, Ghdl_Write_Scalar);
+ Close_Temp;
+ end;
+ else
+ Translate_Rw (Var, Etype, Ghdl_Write_Scalar);
+ end if;
+ when Iir_Predefined_Read =>
+ Translate_Rw (Var, Etype, Ghdl_Read_Scalar);
+
+ when Iir_Predefined_Read_Length =>
+ declare
+ Var_Len : O_Dnode;
+ begin
+ Open_Temp;
+ Var_Len := Create_Temp (Ghdl_Index_Type);
+ Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar);
+
+ Chap6.Check_Bound_Error
+ (New_Compare_Op (ON_Gt,
+ New_Obj_Value (Var_Len),
+ Chap3.Get_Array_Length (Var, Etype),
+ Ghdl_Bool_Type),
+ Subprg, 1);
+ Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype,
+ Var_Len, Ghdl_Read_Scalar);
+ New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len),
+ Std_Integer_Otype));
+ Close_Temp;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Chap2.Finish_Subprg_Instance_Use (Subprg);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_File_Subprogram;
+
+ procedure Init_Implicit_Subprogram_Infos
+ (Infos : out Implicit_Subprogram_Infos) is
+ begin
+ -- Be independant of declaration order since the same subprogram
+ -- may be used for several implicit operators (eg. array comparaison)
+ Infos.Arr_Eq_Info := null;
+ Infos.Arr_Cmp_Info := null;
+ Infos.Arr_Concat_Info := null;
+ Infos.Rec_Eq_Info := null;
+ Infos.Arr_Shl_Info := null;
+ Infos.Arr_Sha_Info := null;
+ Infos.Arr_Rot_Info := null;
+ end Init_Implicit_Subprogram_Infos;
+
+ procedure Translate_Implicit_Subprogram
+ (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos)
+ is
+ Kind : constant Iir_Predefined_Functions :=
+ Get_Implicit_Definition (Subprg);
+ begin
+ if Predefined_To_Onop (Kind) /= ON_Nil then
+ -- Intrinsic.
+ return;
+ end if;
+
+ case Kind is
+ when Iir_Predefined_Error =>
+ raise Internal_Error;
+ when Iir_Predefined_Boolean_And
+ | Iir_Predefined_Boolean_Or
+ | Iir_Predefined_Boolean_Xor
+ | Iir_Predefined_Boolean_Not
+ | Iir_Predefined_Enum_Equality
+ | Iir_Predefined_Enum_Inequality
+ | Iir_Predefined_Enum_Less
+ | Iir_Predefined_Enum_Less_Equal
+ | Iir_Predefined_Enum_Greater
+ | Iir_Predefined_Enum_Greater_Equal
+ | Iir_Predefined_Bit_And
+ | Iir_Predefined_Bit_Or
+ | Iir_Predefined_Bit_Xor
+ | Iir_Predefined_Bit_Not
+ | Iir_Predefined_Integer_Equality
+ | Iir_Predefined_Integer_Inequality
+ | Iir_Predefined_Integer_Less
+ | Iir_Predefined_Integer_Less_Equal
+ | Iir_Predefined_Integer_Greater
+ | Iir_Predefined_Integer_Greater_Equal
+ | Iir_Predefined_Integer_Negation
+ | Iir_Predefined_Integer_Absolute
+ | Iir_Predefined_Integer_Plus
+ | Iir_Predefined_Integer_Minus
+ | Iir_Predefined_Integer_Mul
+ | Iir_Predefined_Integer_Div
+ | Iir_Predefined_Integer_Mod
+ | Iir_Predefined_Integer_Rem
+ | Iir_Predefined_Floating_Equality
+ | Iir_Predefined_Floating_Inequality
+ | Iir_Predefined_Floating_Less
+ | Iir_Predefined_Floating_Less_Equal
+ | Iir_Predefined_Floating_Greater
+ | Iir_Predefined_Floating_Greater_Equal
+ | Iir_Predefined_Floating_Negation
+ | Iir_Predefined_Floating_Absolute
+ | Iir_Predefined_Floating_Plus
+ | Iir_Predefined_Floating_Minus
+ | Iir_Predefined_Floating_Mul
+ | Iir_Predefined_Floating_Div
+ | Iir_Predefined_Physical_Equality
+ | Iir_Predefined_Physical_Inequality
+ | Iir_Predefined_Physical_Less
+ | Iir_Predefined_Physical_Less_Equal
+ | Iir_Predefined_Physical_Greater
+ | Iir_Predefined_Physical_Greater_Equal
+ | Iir_Predefined_Physical_Negation
+ | Iir_Predefined_Physical_Absolute
+ | Iir_Predefined_Physical_Plus
+ | Iir_Predefined_Physical_Minus =>
+ pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil);
+ return;
+
+ when Iir_Predefined_Boolean_Nand
+ | Iir_Predefined_Boolean_Nor
+ | Iir_Predefined_Boolean_Xnor
+ | Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Bit_Xnor
+ | Iir_Predefined_Bit_Match_Equality
+ | Iir_Predefined_Bit_Match_Inequality
+ | Iir_Predefined_Bit_Match_Less
+ | Iir_Predefined_Bit_Match_Less_Equal
+ | Iir_Predefined_Bit_Match_Greater
+ | Iir_Predefined_Bit_Match_Greater_Equal
+ | Iir_Predefined_Bit_Condition
+ | Iir_Predefined_Boolean_Rising_Edge
+ | Iir_Predefined_Boolean_Falling_Edge
+ | Iir_Predefined_Bit_Rising_Edge
+ | Iir_Predefined_Bit_Falling_Edge =>
+ -- Intrinsic.
+ null;
+
+ when Iir_Predefined_Enum_Minimum
+ | Iir_Predefined_Enum_Maximum
+ | Iir_Predefined_Enum_To_String =>
+ -- Intrinsic.
+ null;
+
+ when Iir_Predefined_Integer_Identity
+ | Iir_Predefined_Integer_Exp
+ | Iir_Predefined_Integer_Minimum
+ | Iir_Predefined_Integer_Maximum
+ | Iir_Predefined_Integer_To_String =>
+ -- Intrinsic.
+ null;
+ when Iir_Predefined_Universal_R_I_Mul
+ | Iir_Predefined_Universal_I_R_Mul
+ | Iir_Predefined_Universal_R_I_Div =>
+ -- Intrinsic
+ null;
+
+ when Iir_Predefined_Physical_Identity
+ | Iir_Predefined_Physical_Minimum
+ | Iir_Predefined_Physical_Maximum
+ | Iir_Predefined_Physical_To_String
+ | Iir_Predefined_Time_To_String_Unit =>
+ null;
+
+ when Iir_Predefined_Physical_Integer_Mul
+ | Iir_Predefined_Physical_Integer_Div
+ | Iir_Predefined_Integer_Physical_Mul
+ | Iir_Predefined_Physical_Real_Mul
+ | Iir_Predefined_Physical_Real_Div
+ | Iir_Predefined_Real_Physical_Mul
+ | Iir_Predefined_Physical_Physical_Div =>
+ null;
+
+ when Iir_Predefined_Floating_Exp
+ | Iir_Predefined_Floating_Identity
+ | Iir_Predefined_Floating_Minimum
+ | Iir_Predefined_Floating_Maximum
+ | Iir_Predefined_Floating_To_String
+ | Iir_Predefined_Real_To_String_Digits
+ | Iir_Predefined_Real_To_String_Format =>
+ null;
+
+ when Iir_Predefined_Record_Equality
+ | Iir_Predefined_Record_Inequality =>
+ if Infos.Rec_Eq_Info = null then
+ Translate_Predefined_Record_Equality (Subprg);
+ Infos.Rec_Eq_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Rec_Eq_Info);
+ end if;
+
+ when Iir_Predefined_Array_Equality
+ | Iir_Predefined_Array_Inequality
+ | Iir_Predefined_Bit_Array_Match_Equality
+ | Iir_Predefined_Bit_Array_Match_Inequality =>
+ if Infos.Arr_Eq_Info = null then
+ Translate_Predefined_Array_Equality (Subprg);
+ Infos.Arr_Eq_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Eq_Info);
+ end if;
+
+ when Iir_Predefined_Array_Greater
+ | Iir_Predefined_Array_Greater_Equal
+ | Iir_Predefined_Array_Less
+ | Iir_Predefined_Array_Less_Equal
+ | Iir_Predefined_Array_Minimum
+ | Iir_Predefined_Array_Maximum =>
+ if Infos.Arr_Cmp_Info = null then
+ Translate_Predefined_Array_Compare (Subprg);
+ Infos.Arr_Cmp_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Cmp_Info);
+ end if;
+
+ when Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ if Infos.Arr_Concat_Info = null then
+ Translate_Predefined_Array_Array_Concat (Subprg);
+ Infos.Arr_Concat_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Concat_Info);
+ end if;
+
+ when Iir_Predefined_Vector_Minimum
+ | Iir_Predefined_Vector_Maximum =>
+ null;
+
+ when Iir_Predefined_TF_Array_And
+ | Iir_Predefined_TF_Array_Or
+ | Iir_Predefined_TF_Array_Nand
+ | Iir_Predefined_TF_Array_Nor
+ | Iir_Predefined_TF_Array_Xor
+ | Iir_Predefined_TF_Array_Xnor
+ | Iir_Predefined_TF_Array_Not =>
+ Translate_Predefined_Array_Logical (Subprg);
+
+ when Iir_Predefined_TF_Reduction_And
+ | Iir_Predefined_TF_Reduction_Or
+ | Iir_Predefined_TF_Reduction_Nand
+ | Iir_Predefined_TF_Reduction_Nor
+ | Iir_Predefined_TF_Reduction_Xor
+ | Iir_Predefined_TF_Reduction_Xnor
+ | Iir_Predefined_TF_Reduction_Not
+ | Iir_Predefined_TF_Array_Element_And
+ | Iir_Predefined_TF_Element_Array_And
+ | Iir_Predefined_TF_Array_Element_Or
+ | Iir_Predefined_TF_Element_Array_Or
+ | Iir_Predefined_TF_Array_Element_Nand
+ | Iir_Predefined_TF_Element_Array_Nand
+ | Iir_Predefined_TF_Array_Element_Nor
+ | Iir_Predefined_TF_Element_Array_Nor
+ | Iir_Predefined_TF_Array_Element_Xor
+ | Iir_Predefined_TF_Element_Array_Xor
+ | Iir_Predefined_TF_Array_Element_Xnor
+ | Iir_Predefined_TF_Element_Array_Xnor =>
+ null;
+
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl =>
+ if Infos.Arr_Shl_Info = null then
+ Translate_Predefined_Array_Shift (Subprg);
+ Infos.Arr_Shl_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Shl_Info);
+ end if;
+
+ when Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra =>
+ if Infos.Arr_Sha_Info = null then
+ Translate_Predefined_Array_Shift (Subprg);
+ Infos.Arr_Sha_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Sha_Info);
+ end if;
+
+ when Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ if Infos.Arr_Rot_Info = null then
+ Translate_Predefined_Array_Shift (Subprg);
+ Infos.Arr_Rot_Info := Get_Info (Subprg);
+ else
+ Set_Info (Subprg, Infos.Arr_Rot_Info);
+ end if;
+
+ when Iir_Predefined_Access_Equality
+ | Iir_Predefined_Access_Inequality =>
+ -- Intrinsic.
+ null;
+ when Iir_Predefined_Deallocate =>
+ -- Intrinsic.
+ null;
+
+ when Iir_Predefined_File_Open
+ | Iir_Predefined_File_Open_Status
+ | Iir_Predefined_File_Close
+ | Iir_Predefined_Flush
+ | Iir_Predefined_Endfile =>
+ -- All of them have predefined definitions.
+ null;
+
+ when Iir_Predefined_Write
+ | Iir_Predefined_Read_Length
+ | Iir_Predefined_Read =>
+ declare
+ Param : Iir;
+ File_Type : Iir;
+ begin
+ Param := Get_Interface_Declaration_Chain (Subprg);
+ File_Type := Get_Type (Param);
+ if not Get_Text_File_Flag (File_Type) then
+ Translate_File_Subprogram (Subprg, File_Type);
+ end if;
+ end;
+
+ when Iir_Predefined_Attribute_Image
+ | Iir_Predefined_Attribute_Value
+ | Iir_Predefined_Attribute_Pos
+ | Iir_Predefined_Attribute_Val
+ | Iir_Predefined_Attribute_Succ
+ | Iir_Predefined_Attribute_Pred
+ | Iir_Predefined_Attribute_Leftof
+ | Iir_Predefined_Attribute_Rightof
+ | Iir_Predefined_Attribute_Left
+ | Iir_Predefined_Attribute_Right
+ | Iir_Predefined_Attribute_Event
+ | Iir_Predefined_Attribute_Active
+ | Iir_Predefined_Attribute_Last_Event
+ | Iir_Predefined_Attribute_Last_Active
+ | Iir_Predefined_Attribute_Last_Value
+ | Iir_Predefined_Attribute_Driving
+ | Iir_Predefined_Attribute_Driving_Value =>
+ raise Internal_Error;
+
+ when Iir_Predefined_Array_Char_To_String
+ | Iir_Predefined_Bit_Vector_To_Ostring
+ | Iir_Predefined_Bit_Vector_To_Hstring
+ | Iir_Predefined_Std_Ulogic_Match_Equality
+ | Iir_Predefined_Std_Ulogic_Match_Inequality
+ | Iir_Predefined_Std_Ulogic_Match_Less
+ | Iir_Predefined_Std_Ulogic_Match_Less_Equal
+ | Iir_Predefined_Std_Ulogic_Match_Greater
+ | Iir_Predefined_Std_Ulogic_Match_Greater_Equal
+ | Iir_Predefined_Std_Ulogic_Array_Match_Equality
+ | Iir_Predefined_Std_Ulogic_Array_Match_Inequality =>
+ null;
+
+ when Iir_Predefined_Now_Function =>
+ null;
+
+ -- when others =>
+ -- Error_Kind ("translate_implicit_subprogram ("
+ -- & Iir_Predefined_Functions'Image (Kind) & ")",
+ -- Subprg);
+ end case;
+ end Translate_Implicit_Subprogram;
+ end Chap7;
+
+ package body Chap8 is
+ procedure Translate_Return_Statement (Stmt : Iir_Return_Statement)
+ is
+ Subprg_Info : constant Ortho_Info_Acc :=
+ Get_Info (Chap2.Current_Subprogram);
+ Expr : constant Iir := Get_Expression (Stmt);
+ Ret_Type : Iir;
+ Ret_Info : Type_Info_Acc;
+
+ procedure Gen_Return is
+ begin
+ if Subprg_Info.Subprg_Exit /= O_Snode_Null then
+ New_Exit_Stmt (Subprg_Info.Subprg_Exit);
+ else
+ New_Return_Stmt;
+ end if;
+ end Gen_Return;
+
+ procedure Gen_Return_Value (Val : O_Enode) is
+ begin
+ if Subprg_Info.Subprg_Exit /= O_Snode_Null then
+ New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val);
+ New_Exit_Stmt (Subprg_Info.Subprg_Exit);
+ else
+ New_Return_Stmt (Val);
+ end if;
+ end Gen_Return_Value;
+ begin
+ if Expr = Null_Iir then
+ -- Return in a procedure.
+ Gen_Return;
+ return;
+ end if;
+
+ -- Return in a function.
+ Ret_Type := Get_Return_Type (Chap2.Current_Subprogram);
+ Ret_Info := Get_Info (Ret_Type);
+ case Ret_Info.Type_Mode is
+ when Type_Mode_Scalar =>
+ -- * if the return type is scalar, simply returns.
+ declare
+ V : O_Dnode;
+ R : O_Enode;
+ begin
+ -- Always uses a temporary in case of the return expression
+ -- uses secondary stack.
+ -- FIXME: don't use the temp if not required.
+ R := Chap7.Translate_Expression (Expr, Ret_Type);
+ if Has_Stack2_Mark
+ or else Chap3.Need_Range_Check (Expr, Ret_Type)
+ then
+ V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value));
+ New_Assign_Stmt (New_Obj (V), R);
+ Stack2_Release;
+ Chap3.Check_Range (V, Expr, Ret_Type, Expr);
+ Gen_Return_Value (New_Obj_Value (V));
+ else
+ Gen_Return_Value (R);
+ end if;
+ end;
+ when Type_Mode_Acc =>
+ -- * access: thin and no range.
+ declare
+ Res : O_Enode;
+ begin
+ Res := Chap7.Translate_Expression (Expr, Ret_Type);
+ Gen_Return_Value (Res);
+ end;
+ when Type_Mode_Fat_Array =>
+ -- * if the return type is unconstrained: allocate an area from
+ -- the secondary stack, copy it to the area, and fill the fat
+ -- pointer.
+ -- Evaluate the result.
+ declare
+ Val : Mnode;
+ Area : Mnode;
+ begin
+ Area := Dp2M (Subprg_Info.Res_Interface,
+ Ret_Info, Mode_Value);
+ Val := Stabilize
+ (E2M (Chap7.Translate_Expression (Expr, Ret_Type),
+ Ret_Info, Mode_Value));
+ Chap3.Translate_Object_Allocation
+ (Area, Alloc_Return, Ret_Type,
+ Chap3.Get_Array_Bounds (Val));
+ Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type);
+ Gen_Return;
+ end;
+ when Type_Mode_Record
+ | Type_Mode_Array
+ | Type_Mode_Fat_Acc =>
+ -- * if the return type is a constrained composite type, copy
+ -- it to the result area.
+ -- Create a temporary area so that if the expression use
+ -- stack2, it will be freed before the return (otherwise,
+ -- the stack area will be lost).
+ declare
+ V : Mnode;
+ begin
+ Open_Temp;
+ V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value);
+ Chap3.Translate_Object_Copy
+ (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type);
+ Close_Temp;
+ Gen_Return;
+ end;
+ when Type_Mode_File =>
+ -- FIXME: Is it possible ?
+ Error_Kind ("translate_return_statement", Ret_Type);
+ when Type_Mode_Unknown
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Return_Statement;
+
+ procedure Translate_If_Statement (Stmt : Iir)
+ is
+ Blk : O_If_Block;
+ Else_Clause : Iir;
+ begin
+ Start_If_Stmt
+ (Blk, Chap7.Translate_Expression (Get_Condition (Stmt)));
+
+ Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt));
+
+ Else_Clause := Get_Else_Clause (Stmt);
+ if Else_Clause /= Null_Iir then
+ New_Else_Stmt (Blk);
+ if Get_Condition (Else_Clause) = Null_Iir then
+ Translate_Statements_Chain
+ (Get_Sequential_Statement_Chain (Else_Clause));
+ else
+ Open_Temp;
+ Translate_If_Statement (Else_Clause);
+ Close_Temp;
+ end if;
+ end if;
+ Finish_If_Stmt (Blk);
+ end Translate_If_Statement;
+
+ function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode)
+ return O_Enode
+ is
+ begin
+ return New_Value (New_Selected_Element
+ (New_Access_Element (New_Value (O_Range)), Field));
+ end Get_Range_Ptr_Field_Value;
+
+ -- Inc or dec ITERATOR according to DIR.
+ procedure Gen_Update_Iterator (Iterator : O_Dnode;
+ Dir : Iir_Direction;
+ Val : Unsigned_64;
+ Itype : Iir)
+ is
+ Op : ON_Op_Kind;
+ Base_Type : Iir;
+ V : O_Enode;
+ begin
+ case Dir is
+ when Iir_To =>
+ Op := ON_Add_Ov;
+ when Iir_Downto =>
+ Op := ON_Sub_Ov;
+ end case;
+ Base_Type := Get_Base_Type (Itype);
+ case Get_Kind (Base_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ V := New_Lit
+ (New_Signed_Literal
+ (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val)));
+ when Iir_Kind_Enumeration_Type_Definition =>
+ declare
+ List : Iir_List;
+ begin
+ List := Get_Enumeration_Literal_List (Base_Type);
+ -- FIXME: what about type E is ('T') ??
+ if Natural (Val) > Get_Nbr_Elements (List) then
+ raise Internal_Error;
+ end if;
+ V := New_Lit
+ (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val))));
+ end;
+
+ when others =>
+ Error_Kind ("gen_update_iterator", Base_Type);
+ end case;
+ New_Assign_Stmt (New_Obj (Iterator),
+ New_Dyadic_Op (Op, New_Obj_Value (Iterator), V));
+ end Gen_Update_Iterator;
+
+ type For_Loop_Data is record
+ Iterator : Iir_Iterator_Declaration;
+ Stmt : Iir_For_Loop_Statement;
+ -- If around the loop, to check if the loop must be executed.
+ If_Blk : O_If_Block;
+ Label_Next, Label_Exit : O_Snode;
+ -- Right bound of the iterator, used only if the iterator is a
+ -- range expression.
+ O_Right : O_Dnode;
+ -- Range variable of the iterator, used only if the iterator is not
+ -- a range expression.
+ O_Range : O_Dnode;
+ end record;
+
+ procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration;
+ Stmt : Iir_For_Loop_Statement;
+ Data : out For_Loop_Data)
+ is
+ Iter_Type : Iir;
+ Iter_Base_Type : Iir;
+ Var_Iter : Var_Type;
+ Constraint : Iir;
+ Cond : O_Enode;
+ Dir : Iir_Direction;
+ Iter_Type_Info : Ortho_Info_Acc;
+ Op : ON_Op_Kind;
+ begin
+ -- Initialize DATA.
+ Data.Iterator := Iterator;
+ Data.Stmt := Stmt;
+
+ Iter_Type := Get_Type (Iterator);
+ Iter_Base_Type := Get_Base_Type (Iter_Type);
+ Iter_Type_Info := Get_Info (Iter_Base_Type);
+ Var_Iter := Get_Info (Iterator).Iterator_Var;
+
+ Open_Temp;
+
+ Constraint := Get_Range_Constraint (Iter_Type);
+ if Get_Kind (Constraint) = Iir_Kind_Range_Expression then
+ New_Assign_Stmt
+ (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left
+ (Constraint, Iter_Base_Type));
+ Dir := Get_Direction (Constraint);
+ Data.O_Right := Create_Temp
+ (Iter_Type_Info.Ortho_Type (Mode_Value));
+ New_Assign_Stmt
+ (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right
+ (Constraint, Iter_Base_Type));
+ case Dir is
+ when Iir_To =>
+ Op := ON_Le;
+ when Iir_Downto =>
+ Op := ON_Ge;
+ end case;
+ -- Check for at least one iteration.
+ Cond := New_Compare_Op
+ (Op, New_Value (Get_Var (Var_Iter)),
+ New_Obj_Value (Data.O_Right),
+ Ghdl_Bool_Type);
+ else
+ Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type);
+ New_Assign_Stmt (New_Obj (Data.O_Range),
+ New_Address (Chap7.Translate_Range
+ (Constraint, Iter_Base_Type),
+ Iter_Type_Info.T.Range_Ptr_Type));
+ New_Assign_Stmt
+ (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value
+ (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left));
+ -- Before starting the loop, check wether there will be at least
+ -- one iteration.
+ Cond := New_Compare_Op
+ (ON_Gt,
+ Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range),
+ Iter_Type_Info.T.Range_Length),
+ New_Lit (Ghdl_Index_0),
+ Ghdl_Bool_Type);
+ end if;
+
+ Start_If_Stmt (Data.If_Blk, Cond);
+
+ -- Start loop.
+ -- There are two blocks: one for the exit, one for the next.
+ Start_Loop_Stmt (Data.Label_Exit);
+ Start_Loop_Stmt (Data.Label_Next);
+
+ if Stmt /= Null_Iir then
+ declare
+ Loop_Info : Loop_Info_Acc;
+ begin
+ Loop_Info := Add_Info (Stmt, Kind_Loop);
+ Loop_Info.Label_Exit := Data.Label_Exit;
+ Loop_Info.Label_Next := Data.Label_Next;
+ end;
+ end if;
+ end Start_For_Loop;
+
+ procedure Finish_For_Loop (Data : in out For_Loop_Data)
+ is
+ Cond : O_Enode;
+ If_Blk1 : O_If_Block;
+ Iter_Type : Iir;
+ Iter_Base_Type : Iir;
+ Iter_Type_Info : Type_Info_Acc;
+ Var_Iter : Var_Type;
+ Constraint : Iir;
+ Deep_Rng : Iir;
+ Deep_Reverse : Boolean;
+ begin
+ New_Exit_Stmt (Data.Label_Next);
+ Finish_Loop_Stmt (Data.Label_Next);
+
+ -- Check end of loop.
+ -- Equality is necessary and enough.
+ Iter_Type := Get_Type (Data.Iterator);
+ Iter_Base_Type := Get_Base_Type (Iter_Type);
+ Iter_Type_Info := Get_Info (Iter_Base_Type);
+ Var_Iter := Get_Info (Data.Iterator).Iterator_Var;
+
+ Constraint := Get_Range_Constraint (Iter_Type);
+
+ if Get_Kind (Constraint) = Iir_Kind_Range_Expression then
+ Cond := New_Obj_Value (Data.O_Right);
+ else
+ Cond := Get_Range_Ptr_Field_Value
+ (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right);
+ end if;
+ Gen_Exit_When (Data.Label_Exit,
+ New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)),
+ Cond, Ghdl_Bool_Type));
+
+ -- Update the iterator.
+ Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse);
+ if Deep_Rng /= Null_Iir then
+ if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then
+ Gen_Update_Iterator
+ (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type);
+ else
+ Gen_Update_Iterator
+ (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type);
+ end if;
+ else
+ Start_If_Stmt
+ (If_Blk1, New_Compare_Op
+ (ON_Eq,
+ Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range),
+ Iter_Type_Info.T.Range_Dir),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ Gen_Update_Iterator
+ (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type);
+ New_Else_Stmt (If_Blk1);
+ Gen_Update_Iterator
+ (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type);
+ Finish_If_Stmt (If_Blk1);
+ end if;
+
+ Finish_Loop_Stmt (Data.Label_Exit);
+ Finish_If_Stmt (Data.If_Blk);
+ Close_Temp;
+
+ if Data.Stmt /= Null_Iir then
+ Free_Info (Data.Stmt);
+ end if;
+ end Finish_For_Loop;
+
+ Current_Loop : Iir := Null_Iir;
+
+ procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement)
+ is
+ Iterator : constant Iir := Get_Parameter_Specification (Stmt);
+ Iter_Type : constant Iir := Get_Type (Iterator);
+ Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type);
+ Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type);
+ Data : For_Loop_Data;
+ It_Info : Ortho_Info_Acc;
+ Var_Iter : Var_Type;
+ Prev_Loop : Iir;
+ begin
+ Prev_Loop := Current_Loop;
+ Current_Loop := Stmt;
+ Start_Declare_Stmt;
+
+ Chap3.Translate_Object_Subtype (Iterator, False);
+
+ -- Create info for the iterator.
+ It_Info := Add_Info (Iterator, Kind_Iterator);
+ Var_Iter := Create_Var
+ (Create_Var_Identifier (Iterator),
+ Iter_Type_Info.Ortho_Type (Mode_Value),
+ O_Storage_Local);
+ It_Info.Iterator_Var := Var_Iter;
+
+ Start_For_Loop (Iterator, Stmt, Data);
+
+ Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt));
+
+ Finish_For_Loop (Data);
+
+ Finish_Declare_Stmt;
+
+ Free_Info (Iterator);
+ Current_Loop := Prev_Loop;
+ end Translate_For_Loop_Statement;
+
+ procedure Translate_While_Loop_Statement
+ (Stmt : Iir_While_Loop_Statement)
+ is
+ Info : Loop_Info_Acc;
+ Cond : Iir;
+ Prev_Loop : Iir;
+ begin
+ Prev_Loop := Current_Loop;
+ Current_Loop := Stmt;
+
+ Info := Add_Info (Stmt, Kind_Loop);
+
+ Start_Loop_Stmt (Info.Label_Exit);
+ Info.Label_Next := O_Snode_Null;
+
+ Open_Temp;
+ Cond := Get_Condition (Stmt);
+ if Cond /= Null_Iir then
+ Gen_Exit_When
+ (Info.Label_Exit,
+ New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond)));
+ end if;
+ Close_Temp;
+
+ Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt));
+
+ Finish_Loop_Stmt (Info.Label_Exit);
+ Free_Info (Stmt);
+ Current_Loop := Prev_Loop;
+ end Translate_While_Loop_Statement;
+
+ procedure Translate_Exit_Next_Statement (Stmt : Iir)
+ is
+ Cond : constant Iir := Get_Condition (Stmt);
+ If_Blk : O_If_Block;
+ Info : Loop_Info_Acc;
+ Loop_Label : Iir;
+ Loop_Stmt : Iir;
+ begin
+ if Cond /= Null_Iir then
+ Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond));
+ end if;
+
+ Loop_Label := Get_Loop_Label (Stmt);
+ if Loop_Label = Null_Iir then
+ Loop_Stmt := Current_Loop;
+ else
+ Loop_Stmt := Get_Named_Entity (Loop_Label);
+ end if;
+
+ Info := Get_Info (Loop_Stmt);
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Exit_Statement =>
+ New_Exit_Stmt (Info.Label_Exit);
+ when Iir_Kind_Next_Statement =>
+ if Info.Label_Next /= O_Snode_Null then
+ -- For-loop.
+ New_Exit_Stmt (Info.Label_Next);
+ else
+ -- While-loop.
+ New_Next_Stmt (Info.Label_Exit);
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+ if Cond /= Null_Iir then
+ Finish_If_Stmt (If_Blk);
+ end if;
+ end Translate_Exit_Next_Statement;
+
+ procedure Translate_Variable_Aggregate_Assignment
+ (Targ : Iir; Targ_Type : Iir; Val : Mnode);
+
+ procedure Translate_Variable_Array_Aggr
+ (Targ : Iir_Aggregate;
+ Targ_Type : Iir;
+ Val : Mnode;
+ Index : in out Unsigned_64;
+ Dim : Natural)
+ is
+ El : Iir;
+ Final : Boolean;
+ El_Type : Iir;
+ begin
+ Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type));
+ if Final then
+ El_Type := Get_Element_Subtype (Targ_Type);
+ end if;
+ El := Get_Association_Choices_Chain (Targ);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ if Final then
+ Translate_Variable_Aggregate_Assignment
+ (Get_Associated_Expr (El), El_Type,
+ Chap3.Index_Base
+ (Val, Targ_Type,
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type, Index))));
+ Index := Index + 1;
+ else
+ Translate_Variable_Array_Aggr
+ (Get_Associated_Expr (El),
+ Targ_Type, Val, Index, Dim + 1);
+ end if;
+ when others =>
+ Error_Kind ("translate_variable_array_aggr", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Variable_Array_Aggr;
+
+ procedure Translate_Variable_Rec_Aggr
+ (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode)
+ is
+ Aggr_El : Iir;
+ El_List : Iir_List;
+ El_Index : Natural;
+ Elem : Iir;
+ begin
+ El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type));
+ El_Index := 0;
+ Aggr_El := Get_Association_Choices_Chain (Targ);
+ while Aggr_El /= Null_Iir loop
+ case Get_Kind (Aggr_El) is
+ when Iir_Kind_Choice_By_None =>
+ Elem := Get_Nth_Element (El_List, El_Index);
+ El_Index := El_Index + 1;
+ when Iir_Kind_Choice_By_Name =>
+ Elem := Get_Choice_Name (Aggr_El);
+ when others =>
+ Error_Kind ("translate_variable_rec_aggr", Aggr_El);
+ end case;
+ Translate_Variable_Aggregate_Assignment
+ (Get_Associated_Expr (Aggr_El), Get_Type (Elem),
+ Chap6.Translate_Selected_Element (Val, Elem));
+ Aggr_El := Get_Chain (Aggr_El);
+ end loop;
+ end Translate_Variable_Rec_Aggr;
+
+ procedure Translate_Variable_Aggregate_Assignment
+ (Targ : Iir; Targ_Type : Iir; Val : Mnode)
+ is
+ Index : Unsigned_64;
+ begin
+ if Get_Kind (Targ) = Iir_Kind_Aggregate then
+ case Get_Kind (Targ_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ Index := 0;
+ Translate_Variable_Array_Aggr
+ (Targ, Targ_Type, Val, Index, 1);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val);
+ when others =>
+ Error_Kind
+ ("translate_variable_aggregate_assignment", Targ_Type);
+ end case;
+ else
+ declare
+ Targ_Node : Mnode;
+ begin
+ Targ_Node := Chap6.Translate_Name (Targ);
+ Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type);
+ end;
+ end if;
+ end Translate_Variable_Aggregate_Assignment;
+
+ procedure Translate_Variable_Assignment_Statement
+ (Stmt : Iir_Variable_Assignment_Statement)
+ is
+ Target : constant Iir := Get_Target (Stmt);
+ Targ_Type : constant Iir := Get_Type (Target);
+ Expr : constant Iir := Get_Expression (Stmt);
+ Targ_Node : Mnode;
+ begin
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ declare
+ E : O_Enode;
+ Temp : Mnode;
+ begin
+ Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True);
+
+ -- Use a temporary variable, to avoid overlap.
+ Temp := Create_Temp (Get_Info (Targ_Type));
+ Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp);
+
+ E := Chap7.Translate_Expression (Expr, Targ_Type);
+ Chap3.Translate_Object_Copy (Temp, E, Targ_Type);
+ Translate_Variable_Aggregate_Assignment
+ (Target, Targ_Type, Temp);
+ return;
+ end;
+ else
+ Targ_Node := Chap6.Translate_Name (Target);
+ if Get_Kind (Expr) = Iir_Kind_Aggregate then
+ declare
+ E : O_Enode;
+ begin
+ E := Chap7.Translate_Expression (Expr, Targ_Type);
+ Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type);
+ end;
+ else
+ Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type);
+ end if;
+ end if;
+ end Translate_Variable_Assignment_Statement;
+
+ procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir)
+ is
+ Expr : Iir;
+ Msg : O_Enode;
+ Severity : O_Enode;
+ Assocs : O_Assoc_List;
+ Loc : O_Dnode;
+ begin
+ Loc := Chap4.Get_Location (Stmt);
+ Expr := Get_Report_Expression (Stmt);
+ if Expr = Null_Iir then
+ Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node));
+ else
+ Msg := Chap7.Translate_Expression (Expr, String_Type_Definition);
+ end if;
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr = Null_Iir then
+ Severity := New_Lit (Get_Ortho_Expr (Level));
+ else
+ Severity := Chap7.Translate_Expression (Expr);
+ end if;
+ -- Do call.
+ Start_Association (Assocs, Subprg);
+ New_Association (Assocs, Msg);
+ New_Association (Assocs, Severity);
+ New_Association (Assocs, New_Address (New_Obj (Loc),
+ Ghdl_Location_Ptr_Node));
+ New_Procedure_Call (Assocs);
+ end Translate_Report;
+
+ -- Return True if the current library unit is part of library IEEE.
+ function Is_Within_Ieee_Library return Boolean
+ is
+ Design_File : Iir;
+ Library : Iir;
+ begin
+ -- Guard.
+ if Current_Library_Unit = Null_Iir then
+ return False;
+ end if;
+ Design_File :=
+ Get_Design_File (Get_Design_Unit (Current_Library_Unit));
+ Library := Get_Library (Design_File);
+ return Get_Identifier (Library) = Std_Names.Name_Ieee;
+ end Is_Within_Ieee_Library;
+
+ procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement)
+ is
+ Expr : Iir;
+ If_Blk : O_If_Block;
+ Subprg : O_Dnode;
+ begin
+ -- Select the procedure to call in case of assertion (so that
+ -- assertions within the IEEE library could be ignored).
+ if Is_Within_Ieee_Library then
+ Subprg := Ghdl_Ieee_Assert_Failed;
+ else
+ Subprg := Ghdl_Assert_Failed;
+ end if;
+
+ Expr := Get_Assertion_Condition (Stmt);
+ if Get_Expr_Staticness (Expr) = Locally then
+ if Eval_Pos (Expr) = 1 then
+ -- Assert TRUE is a noop.
+ -- FIXME: generate a noop ?
+ return;
+ end if;
+ Translate_Report (Stmt, Subprg, Severity_Level_Error);
+ else
+ -- An assertion is reported if the condition is false!
+ Start_If_Stmt (If_Blk,
+ New_Monadic_Op (ON_Not,
+ Chap7.Translate_Expression (Expr)));
+ -- Note: it is necessary to create a declare block, to avoid bad
+ -- order with the if block.
+ Open_Temp;
+ Translate_Report (Stmt, Subprg, Severity_Level_Error);
+ Close_Temp;
+ Finish_If_Stmt (If_Blk);
+ end if;
+ end Translate_Assertion_Statement;
+
+ procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is
+ begin
+ Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note);
+ end Translate_Report_Statement;
+
+ -- Helper to compare a string choice with the selector.
+ function Translate_Simple_String_Choice
+ (Expr : O_Dnode;
+ Val : O_Enode;
+ Val_Node : O_Dnode;
+ Tinfo : Type_Info_Acc;
+ Func : Iir)
+ return O_Enode
+ is
+ Assoc : O_Assoc_List;
+ Func_Info : Subprg_Info_Acc;
+ begin
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (Val_Node),
+ Tinfo.T.Base_Field (Mode_Value)),
+ Val);
+ Func_Info := Get_Info (Func);
+ Start_Association (Assoc, Func_Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance);
+ New_Association (Assoc, New_Obj_Value (Expr));
+ New_Association
+ (Assoc, New_Address (New_Obj (Val_Node),
+ Tinfo.Ortho_Ptr_Type (Mode_Value)));
+ return New_Function_Call (Assoc);
+ end Translate_Simple_String_Choice;
+
+ -- Helper to evaluate the selector and preparing a choice variable.
+ procedure Translate_String_Case_Statement_Common
+ (Stmt : Iir_Case_Statement;
+ Expr_Type : out Iir;
+ Tinfo : out Type_Info_Acc;
+ Expr_Node : out O_Dnode;
+ C_Node : out O_Dnode)
+ is
+ Expr : Iir;
+ Base_Type : Iir;
+ begin
+ -- Translate into if/elsif statements.
+ -- FIXME: if the number of literals ** length of the array < 256,
+ -- use a case statement.
+ Expr := Get_Expression (Stmt);
+ Expr_Type := Get_Type (Expr);
+ Base_Type := Get_Base_Type (Expr_Type);
+ Tinfo := Get_Info (Base_Type);
+
+ -- Translate selector.
+ Expr_Node := Create_Temp_Init
+ (Tinfo.Ortho_Ptr_Type (Mode_Value),
+ Chap7.Translate_Expression (Expr, Base_Type));
+
+ -- Copy the bounds for the choices.
+ C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value));
+ New_Assign_Stmt
+ (New_Selected_Element (New_Obj (C_Node),
+ Tinfo.T.Bounds_Field (Mode_Value)),
+ New_Value_Selected_Acc_Value
+ (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value)));
+ end Translate_String_Case_Statement_Common;
+
+ -- Translate a string case statement using a dichotomy.
+ procedure Translate_String_Case_Statement_Dichotomy
+ (Stmt : Iir_Case_Statement)
+ is
+ -- Selector.
+ Expr_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Expr_Node : O_Dnode;
+ C_Node : O_Dnode;
+
+ Choices_Chain : Iir;
+ Choice : Iir;
+ Has_Others : Boolean;
+ Func : Iir;
+
+ -- Number of non-others choices.
+ Nbr_Choices : Natural;
+ -- Number of associations.
+ Nbr_Assocs : Natural;
+
+ Info : Ortho_Info_Acc;
+ First, Last : Ortho_Info_Acc;
+ Sel_Length : Iir_Int64;
+
+ -- Dichotomy table (table of choices).
+ String_Type : O_Tnode;
+ Table_Base_Type : O_Tnode;
+ Table_Type : O_Tnode;
+ Table : O_Dnode;
+ List : O_Array_Aggr_List;
+ Table_Cst : O_Cnode;
+
+ -- Association table.
+ -- Indexed by the choice, returns an index to the associated
+ -- statement list.
+ -- Could be replaced by jump table.
+ Assoc_Table_Base_Type : O_Tnode;
+ Assoc_Table_Type : O_Tnode;
+ Assoc_Table : O_Dnode;
+ begin
+ Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt);
+
+ -- Count number of choices and number of associations.
+ Nbr_Choices := 0;
+ Nbr_Assocs := 0;
+ Choice := Choices_Chain;
+ First := null;
+ Last := null;
+ Has_Others := False;
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ Has_Others := True;
+ exit;
+ when Iir_Kind_Choice_By_Expression =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ if not Get_Same_Alternative_Flag (Choice) then
+ Nbr_Assocs := Nbr_Assocs + 1;
+ end if;
+ Info := Add_Info (Choice, Kind_Str_Choice);
+ if First = null then
+ First := Info;
+ else
+ Last.Choice_Chain := Info;
+ end if;
+ Last := Info;
+ Info.Choice_Chain := null;
+ Info.Choice_Assoc := Nbr_Assocs - 1;
+ Info.Choice_Parent := Choice;
+ Info.Choice_Expr := Get_Choice_Expression (Choice);
+
+ Nbr_Choices := Nbr_Choices + 1;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ -- Sort choices.
+ declare
+ procedure Merge_Sort (Head : Ortho_Info_Acc;
+ Nbr : Natural;
+ Res : out Ortho_Info_Acc;
+ Next : out Ortho_Info_Acc)
+ is
+ L, R, L_End, R_End : Ortho_Info_Acc;
+ E, Last : Ortho_Info_Acc;
+ Half : constant Natural := Nbr / 2;
+ begin
+ -- Sorting less than 2 elements is easy!
+ if Nbr < 2 then
+ Res := Head;
+ if Nbr = 0 then
+ Next := Head;
+ else
+ Next := Head.Choice_Chain;
+ end if;
+ return;
+ end if;
+
+ Merge_Sort (Head, Half, L, L_End);
+ Merge_Sort (L_End, Nbr - Half, R, R_End);
+ Next := R_End;
+
+ -- Merge
+ Last := null;
+ loop
+ if L /= L_End
+ and then
+ (R = R_End
+ or else
+ Compare_String_Literals (L.Choice_Expr, R.Choice_Expr)
+ = Compare_Lt)
+ then
+ E := L;
+ L := L.Choice_Chain;
+ elsif R /= R_End then
+ E := R;
+ R := R.Choice_Chain;
+ else
+ exit;
+ end if;
+ if Last = null then
+ Res := E;
+ else
+ Last.Choice_Chain := E;
+ end if;
+ Last := E;
+ end loop;
+ Last.Choice_Chain := R_End;
+ end Merge_Sort;
+ Next : Ortho_Info_Acc;
+ begin
+ Merge_Sort (First, Nbr_Choices, First, Next);
+ if Next /= null then
+ raise Internal_Error;
+ end if;
+ end;
+
+ Translate_String_Case_Statement_Common
+ (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node);
+
+ -- Generate choices table.
+ Sel_Length := Eval_Discrete_Type_Length
+ (Get_String_Type_Bound_Type (Expr_Type));
+ String_Type := New_Constrained_Array_Type
+ (Tinfo.T.Base_Type (Mode_Value),
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length)));
+ Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type);
+ New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type);
+ Table_Type := New_Constrained_Array_Type
+ (Table_Base_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices)));
+ New_Type_Decl (Create_Uniq_Identifier, Table_Type);
+ New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private,
+ Table_Type);
+ Start_Const_Value (Table);
+ Start_Array_Aggr (List, Table_Type);
+ Info := First;
+ while Info /= null loop
+ New_Array_Aggr_El (List, Chap7.Translate_Static_Expression
+ (Info.Choice_Expr, Expr_Type));
+ Info := Info.Choice_Chain;
+ end loop;
+ Finish_Array_Aggr (List, Table_Cst);
+ Finish_Const_Value (Table, Table_Cst);
+
+ -- Generate assoc table.
+ Assoc_Table_Base_Type :=
+ New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type);
+ New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type);
+ Assoc_Table_Type := New_Constrained_Array_Type
+ (Assoc_Table_Base_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices)));
+ New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type);
+ New_Const_Decl (Assoc_Table, Create_Uniq_Identifier,
+ O_Storage_Private, Assoc_Table_Type);
+ Start_Const_Value (Assoc_Table);
+ Start_Array_Aggr (List, Assoc_Table_Type);
+ Info := First;
+ while Info /= null loop
+ New_Array_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Info.Choice_Assoc)));
+ Info := Info.Choice_Chain;
+ end loop;
+ Finish_Array_Aggr (List, Table_Cst);
+ Finish_Const_Value (Assoc_Table, Table_Cst);
+
+ -- Generate dichotomy code.
+ declare
+ Var_Lo, Var_Hi, Var_Mid : O_Dnode;
+ Var_Cmp : O_Dnode;
+ Var_Idx : O_Dnode;
+ Label : O_Snode;
+ Others_Lit : O_Cnode;
+ If_Blk1, If_Blk2 : O_If_Block;
+ Case_Blk : O_Case_Block;
+ begin
+ Var_Idx := Create_Temp (Ghdl_Index_Type);
+
+ Start_Declare_Stmt;
+
+ New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type);
+ New_Var_Decl (Var_Cmp, Wki_Cmp,
+ O_Storage_Local, Ghdl_Compare_Type);
+
+ New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0));
+ New_Assign_Stmt
+ (New_Obj (Var_Hi),
+ New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Choices))));
+
+ Func := Chap7.Find_Predefined_Function
+ (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater);
+
+ if Has_Others then
+ Others_Lit := New_Unsigned_Literal
+ (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs));
+ end if;
+
+ Start_Loop_Stmt (Label);
+ New_Assign_Stmt
+ (New_Obj (Var_Mid),
+ New_Dyadic_Op (ON_Div_Ov,
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Lo),
+ New_Obj_Value (Var_Hi)),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type, 2))));
+ New_Assign_Stmt
+ (New_Obj (Var_Cmp),
+ Translate_Simple_String_Choice
+ (Expr_Node,
+ New_Address (New_Indexed_Element (New_Obj (Table),
+ New_Obj_Value (Var_Mid)),
+ Tinfo.T.Base_Ptr_Type (Mode_Value)),
+ C_Node, Tinfo, Func));
+ Start_If_Stmt
+ (If_Blk1,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Cmp),
+ New_Lit (Ghdl_Compare_Eq),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Obj (Var_Idx),
+ New_Value (New_Indexed_Element (New_Obj (Assoc_Table),
+ New_Obj_Value (Var_Mid))));
+ New_Exit_Stmt (Label);
+ Finish_If_Stmt (If_Blk1);
+
+ Start_If_Stmt
+ (If_Blk1,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_Cmp),
+ New_Lit (Ghdl_Compare_Lt),
+ Ghdl_Bool_Type));
+ Start_If_Stmt
+ (If_Blk2,
+ New_Compare_Op (ON_Le,
+ New_Obj_Value (Var_Mid),
+ New_Obj_Value (Var_Lo),
+ Ghdl_Bool_Type));
+ if not Has_Others then
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice);
+ else
+ New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit));
+ New_Exit_Stmt (Label);
+ end if;
+ New_Else_Stmt (If_Blk2);
+ New_Assign_Stmt (New_Obj (Var_Hi),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Var_Mid),
+ New_Lit (Ghdl_Index_1)));
+ Finish_If_Stmt (If_Blk2);
+
+ New_Else_Stmt (If_Blk1);
+
+ Start_If_Stmt
+ (If_Blk2,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_Mid),
+ New_Obj_Value (Var_Hi),
+ Ghdl_Bool_Type));
+ if not Has_Others then
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice);
+ else
+ New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit));
+ New_Exit_Stmt (Label);
+ end if;
+ New_Else_Stmt (If_Blk2);
+ New_Assign_Stmt (New_Obj (Var_Lo),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Var_Mid),
+ New_Lit (Ghdl_Index_1)));
+ Finish_If_Stmt (If_Blk2);
+
+ Finish_If_Stmt (If_Blk1);
+
+ Finish_Loop_Stmt (Label);
+
+ Finish_Declare_Stmt;
+
+ Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx));
+
+ Choice := Choices_Chain;
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ Start_Choice (Case_Blk);
+ New_Expr_Choice (Case_Blk, Others_Lit);
+ Finish_Choice (Case_Blk);
+ Translate_Statements_Chain
+ (Get_Associated_Chain (Choice));
+ when Iir_Kind_Choice_By_Expression =>
+ if not Get_Same_Alternative_Flag (Choice) then
+ Start_Choice (Case_Blk);
+ New_Expr_Choice
+ (Case_Blk,
+ New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Get_Info (Choice).Choice_Assoc)));
+ Finish_Choice (Case_Blk);
+ Translate_Statements_Chain
+ (Get_Associated_Chain (Choice));
+ end if;
+ Free_Info (Choice);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ Start_Choice (Case_Blk);
+ New_Default_Choice (Case_Blk);
+ Finish_Choice (Case_Blk);
+ Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice);
+
+ Finish_Case_Stmt (Case_Blk);
+ end;
+ end Translate_String_Case_Statement_Dichotomy;
+
+ -- Case statement whose expression is an unidim array.
+ -- Translate into if/elsif statements (linear search).
+ procedure Translate_String_Case_Statement_Linear
+ (Stmt : Iir_Case_Statement)
+ is
+ Expr_Type : Iir;
+ -- Node containing the address of the selector.
+ Expr_Node : O_Dnode;
+ -- Node containing the current choice.
+ Val_Node : O_Dnode;
+ Tinfo : Type_Info_Acc;
+
+ Cond_Var : O_Dnode;
+
+ Func : Iir;
+
+ procedure Translate_String_Choice (Choice : Iir)
+ is
+ Cond : O_Enode;
+ If_Blk : O_If_Block;
+ Stmt_Chain : Iir;
+ First : Boolean;
+ Ch : Iir;
+ Ch_Expr : Iir;
+ begin
+ if Choice = Null_Iir then
+ return;
+ end if;
+
+ First := True;
+ Stmt_Chain := Get_Associated_Chain (Choice);
+ Ch := Choice;
+ loop
+ case Get_Kind (Ch) is
+ when Iir_Kind_Choice_By_Expression =>
+ Ch_Expr := Get_Choice_Expression (Ch);
+ Cond := Translate_Simple_String_Choice
+ (Expr_Node,
+ Chap7.Translate_Expression (Ch_Expr,
+ Get_Type (Ch_Expr)),
+ Val_Node, Tinfo, Func);
+ when Iir_Kind_Choice_By_Others =>
+ Translate_Statements_Chain (Stmt_Chain);
+ return;
+ when others =>
+ Error_Kind ("translate_string_choice", Ch);
+ end case;
+ if not First then
+ New_Assign_Stmt
+ (New_Obj (Cond_Var),
+ New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond));
+ end if;
+ Ch := Get_Chain (Ch);
+ exit when Ch = Null_Iir;
+ exit when not Get_Same_Alternative_Flag (Ch);
+ exit when Get_Associated_Chain (Ch) /= Null_Iir;
+ if First then
+ New_Assign_Stmt (New_Obj (Cond_Var), Cond);
+ First := False;
+ end if;
+ end loop;
+ if not First then
+ Cond := New_Obj_Value (Cond_Var);
+ end if;
+ Start_If_Stmt (If_Blk, Cond);
+ Translate_Statements_Chain (Stmt_Chain);
+ New_Else_Stmt (If_Blk);
+ Translate_String_Choice (Ch);
+ Finish_If_Stmt (If_Blk);
+ end Translate_String_Choice;
+ begin
+ Translate_String_Case_Statement_Common
+ (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node);
+
+ Func := Chap7.Find_Predefined_Function
+ (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality);
+
+ Cond_Var := Create_Temp (Std_Boolean_Type_Node);
+
+ Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt));
+ end Translate_String_Case_Statement_Linear;
+
+ procedure Translate_Case_Choice
+ (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block)
+ is
+ Expr : Iir;
+ begin
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ New_Default_Choice (Blk);
+ when Iir_Kind_Choice_By_Expression =>
+ Expr := Get_Choice_Expression (Choice);
+ New_Expr_Choice
+ (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type));
+ when Iir_Kind_Choice_By_Range =>
+ declare
+ H, L : Iir;
+ begin
+ Expr := Get_Choice_Range (Choice);
+ Get_Low_High_Limit (Expr, L, H);
+ New_Range_Choice
+ (Blk,
+ Chap7.Translate_Static_Expression (L, Choice_Type),
+ Chap7.Translate_Static_Expression (H, Choice_Type));
+ end;
+ when others =>
+ Error_Kind ("translate_case_choice", Choice);
+ end case;
+ end Translate_Case_Choice;
+
+ procedure Translate_Case_Statement (Stmt : Iir_Case_Statement)
+ is
+ Expr : Iir;
+ Expr_Type : Iir;
+ Case_Blk : O_Case_Block;
+ Choice : Iir;
+ Stmt_Chain : Iir;
+ begin
+ Expr := Get_Expression (Stmt);
+ Expr_Type := Get_Type (Expr);
+ if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then
+ declare
+ Nbr_Choices : Natural := 0;
+ Choice : Iir;
+ begin
+ Choice := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Choice /= Null_Iir loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ exit;
+ when Iir_Kind_Choice_By_Expression =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Nbr_Choices := Nbr_Choices + 1;
+ Choice := Get_Chain (Choice);
+ end loop;
+
+ if Nbr_Choices < 3 then
+ Translate_String_Case_Statement_Linear (Stmt);
+ else
+ Translate_String_Case_Statement_Dichotomy (Stmt);
+ end if;
+ end;
+ return;
+ end if;
+ Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr));
+ Choice := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Choice /= Null_Iir loop
+ Start_Choice (Case_Blk);
+ Stmt_Chain := Get_Associated_Chain (Choice);
+ loop
+ Translate_Case_Choice (Choice, Expr_Type, Case_Blk);
+ Choice := Get_Chain (Choice);
+ exit when Choice = Null_Iir;
+ exit when not Get_Same_Alternative_Flag (Choice);
+ pragma Assert (Get_Associated_Chain (Choice) = Null_Iir);
+ end loop;
+ Finish_Choice (Case_Blk);
+ Translate_Statements_Chain (Stmt_Chain);
+ end loop;
+ Finish_Case_Stmt (Case_Blk);
+ end Translate_Case_Statement;
+
+ procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir)
+ is
+ F_Assoc : Iir;
+ Value_Assoc : Iir;
+ Value : O_Dnode;
+ Formal_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Assocs : O_Assoc_List;
+ Subprg_Info : Subprg_Info_Acc;
+ begin
+ F_Assoc := Param_Chain;
+ Value_Assoc := Get_Chain (Param_Chain);
+ Formal_Type := Get_Type (Get_Formal (Value_Assoc));
+ Tinfo := Get_Info (Formal_Type);
+ case Tinfo.Type_Mode is
+ when Type_Mode_Scalar =>
+ Open_Temp;
+ Start_Association (Assocs, Ghdl_Write_Scalar);
+ -- compute file parameter (get an index)
+ New_Association
+ (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc)));
+ -- compute the value.
+ Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value));
+ New_Assign_Stmt
+ (New_Obj (Value),
+ Chap7.Translate_Expression (Get_Actual (Value_Assoc),
+ Formal_Type));
+ New_Association
+ (Assocs,
+ New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type));
+ -- length.
+ New_Association
+ (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value),
+ Ghdl_Index_Type)));
+ -- call a predefined procedure
+ New_Procedure_Call (Assocs);
+ Close_Temp;
+ when Type_Mode_Array
+ | Type_Mode_Record
+ | Type_Mode_Fat_Array =>
+ Subprg_Info := Get_Info (Imp);
+ Start_Association (Assocs, Subprg_Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc
+ (Assocs, Subprg_Info.Subprg_Instance);
+ New_Association
+ (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc)));
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (Value_Assoc),
+ Formal_Type));
+ New_Procedure_Call (Assocs);
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Write_Procedure_Call;
+
+ procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir)
+ is
+ F_Assoc : Iir;
+ Value_Assoc : Iir;
+ Value : Mnode;
+ Formal_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Assocs : O_Assoc_List;
+ Subprg_Info : Subprg_Info_Acc;
+ begin
+ F_Assoc := Param_Chain;
+ Value_Assoc := Get_Chain (Param_Chain);
+ Formal_Type := Get_Type (Get_Formal (Value_Assoc));
+ Tinfo := Get_Info (Formal_Type);
+ case Tinfo.Type_Mode is
+ when Type_Mode_Scalar =>
+ Open_Temp;
+ Start_Association (Assocs, Ghdl_Read_Scalar);
+ -- compute file parameter (get an index)
+ New_Association
+ (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc)));
+ -- value
+ Value := Chap6.Translate_Name (Get_Actual (Value_Assoc));
+ New_Association
+ (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type));
+ -- length.
+ New_Association
+ (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value),
+ Ghdl_Index_Type)));
+ -- call a predefined procedure
+ New_Procedure_Call (Assocs);
+ Close_Temp;
+ when Type_Mode_Array
+ | Type_Mode_Record =>
+ Subprg_Info := Get_Info (Imp);
+ Start_Association (Assocs, Subprg_Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc
+ (Assocs, Subprg_Info.Subprg_Instance);
+ New_Association
+ (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc)));
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (Value_Assoc)));
+ New_Procedure_Call (Assocs);
+ when Type_Mode_Fat_Array =>
+ declare
+ Length_Assoc : Iir;
+ Length : Mnode;
+ begin
+ Length_Assoc := Get_Chain (Value_Assoc);
+ Subprg_Info := Get_Info (Imp);
+ Start_Association (Assocs, Subprg_Info.Ortho_Func);
+ Chap2.Add_Subprg_Instance_Assoc
+ (Assocs, Subprg_Info.Subprg_Instance);
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (F_Assoc)));
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (Value_Assoc),
+ Formal_Type));
+ Length := Chap6.Translate_Name (Get_Actual (Length_Assoc));
+ New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs));
+ end;
+ when Type_Mode_Unknown
+ | Type_Mode_File
+ | Type_Mode_Acc
+ | Type_Mode_Fat_Acc
+ | Type_Mode_Protected =>
+ raise Internal_Error;
+ end case;
+ end Translate_Read_Procedure_Call;
+
+ procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call)
+ is
+ Imp : constant Iir := Get_Implementation (Call);
+ Kind : constant Iir_Predefined_Functions :=
+ Get_Implicit_Definition (Imp);
+ Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call);
+ begin
+ case Kind is
+ when Iir_Predefined_Write =>
+ -- Check wether text or not.
+ declare
+ File_Param : Iir;
+ Assocs : O_Assoc_List;
+ begin
+ File_Param := Param_Chain;
+ -- FIXME: do the test.
+ if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param)))
+ then
+ -- If text:
+ Start_Association (Assocs, Ghdl_Text_Write);
+ -- compute file parameter (get an index)
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (File_Param)));
+ -- compute string parameter (get a fat array pointer)
+ New_Association
+ (Assocs, Chap7.Translate_Expression
+ (Get_Actual (Get_Chain (Param_Chain)),
+ String_Type_Definition));
+ -- call a predefined procedure
+ New_Procedure_Call (Assocs);
+ else
+ Translate_Write_Procedure_Call (Imp, Param_Chain);
+ end if;
+ end;
+
+ when Iir_Predefined_Read_Length =>
+ -- FIXME: works only for text read length.
+ declare
+ File_Param : Iir;
+ N_Param : Iir;
+ Assocs : O_Assoc_List;
+ Str : O_Enode;
+ Res : Mnode;
+ begin
+ File_Param := Param_Chain;
+ if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param)))
+ then
+ N_Param := Get_Chain (File_Param);
+ Str := Chap7.Translate_Expression
+ (Get_Actual (N_Param), String_Type_Definition);
+ N_Param := Get_Chain (N_Param);
+ Res := Chap6.Translate_Name (Get_Actual (N_Param));
+ Start_Association (Assocs, Ghdl_Text_Read_Length);
+ -- compute file parameter (get an index)
+ New_Association
+ (Assocs,
+ Chap7.Translate_Expression (Get_Actual (File_Param)));
+ -- compute string parameter (get a fat array pointer)
+ New_Association (Assocs, Str);
+ -- call a predefined procedure
+ New_Assign_Stmt
+ (M2Lv (Res), New_Function_Call (Assocs));
+ else
+ Translate_Read_Procedure_Call (Imp, Param_Chain);
+ end if;
+ end;
+
+ when Iir_Predefined_Read =>
+ Translate_Read_Procedure_Call (Imp, Param_Chain);
+
+ when Iir_Predefined_Deallocate =>
+ Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain));
+
+ when Iir_Predefined_File_Open =>
+ declare
+ N_Param : Iir;
+ File_Param : Iir;
+ Name_Param : Iir;
+ Kind_Param : Iir;
+ Constr : O_Assoc_List;
+ begin
+ File_Param := Get_Actual (Param_Chain);
+ N_Param := Get_Chain (Param_Chain);
+ Name_Param := Get_Actual (N_Param);
+ N_Param := Get_Chain (N_Param);
+ Kind_Param := Get_Actual (N_Param);
+ if Get_Text_File_Flag (Get_Type (File_Param)) then
+ Start_Association (Constr, Ghdl_Text_File_Open);
+ else
+ Start_Association (Constr, Ghdl_File_Open);
+ end if;
+ New_Association
+ (Constr, Chap7.Translate_Expression (File_Param));
+ New_Association
+ (Constr, New_Convert_Ov
+ (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type));
+ New_Association
+ (Constr,
+ Chap7.Translate_Expression (Name_Param,
+ String_Type_Definition));
+ New_Procedure_Call (Constr);
+ end;
+
+ when Iir_Predefined_File_Open_Status =>
+ declare
+ Std_File_Open_Status_Otype : constant O_Tnode :=
+ Get_Ortho_Type (File_Open_Status_Type_Definition,
+ Mode_Value);
+ N_Param : Iir;
+ Status_Param : constant Iir := Get_Actual (Param_Chain);
+ File_Param : Iir;
+ Name_Param : Iir;
+ Kind_Param : Iir;
+ Constr : O_Assoc_List;
+ Status : Mnode;
+ begin
+ Status := Chap6.Translate_Name (Status_Param);
+ N_Param := Get_Chain (Param_Chain);
+ File_Param := Get_Actual (N_Param);
+ N_Param := Get_Chain (N_Param);
+ Name_Param := Get_Actual (N_Param);
+ N_Param := Get_Chain (N_Param);
+ Kind_Param := Get_Actual (N_Param);
+ if Get_Text_File_Flag (Get_Type (File_Param)) then
+ Start_Association (Constr, Ghdl_Text_File_Open_Status);
+ else
+ Start_Association (Constr, Ghdl_File_Open_Status);
+ end if;
+ New_Association
+ (Constr, Chap7.Translate_Expression (File_Param));
+ New_Association
+ (Constr, New_Convert_Ov
+ (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type));
+ New_Association
+ (Constr,
+ Chap7.Translate_Expression (Name_Param,
+ String_Type_Definition));
+ New_Assign_Stmt
+ (M2Lv (Status),
+ New_Convert_Ov (New_Function_Call (Constr),
+ Std_File_Open_Status_Otype));
+ end;
+
+ when Iir_Predefined_File_Close =>
+ declare
+ File_Param : constant Iir := Get_Actual (Param_Chain);
+ Constr : O_Assoc_List;
+ begin
+ if Get_Text_File_Flag (Get_Type (File_Param)) then
+ Start_Association (Constr, Ghdl_Text_File_Close);
+ else
+ Start_Association (Constr, Ghdl_File_Close);
+ end if;
+ New_Association
+ (Constr, Chap7.Translate_Expression (File_Param));
+ New_Procedure_Call (Constr);
+ end;
+
+ when Iir_Predefined_Flush =>
+ declare
+ File_Param : constant Iir := Get_Actual (Param_Chain);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Ghdl_File_Flush);
+ New_Association
+ (Constr, Chap7.Translate_Expression (File_Param));
+ New_Procedure_Call (Constr);
+ end;
+
+ when others =>
+ Ada.Text_IO.Put_Line
+ ("translate_implicit_procedure_call: cannot handle "
+ & Iir_Predefined_Functions'Image (Kind));
+ raise Internal_Error;
+ end case;
+ end Translate_Implicit_Procedure_Call;
+
+ function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode)
+ return O_Enode
+ is
+ Constr : O_Assoc_List;
+ Conv_Info : Subprg_Info_Acc;
+ Res : O_Dnode;
+ Imp : Iir;
+ begin
+ if Conv = Null_Iir then
+ return M2E (Src);
+-- case Get_Type_Info (Dest).Type_Mode is
+-- when Type_Mode_Thin =>
+-- New_Assign_Stmt (M2Lv (Dest), M2E (Src));
+-- when Type_Mode_Fat_Acc =>
+-- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src));
+-- when others =>
+-- raise Internal_Error;
+-- end case;
+ else
+ case Get_Kind (Conv) is
+ when Iir_Kind_Function_Call =>
+ -- Call conversion function.
+ Imp := Get_Implementation (Conv);
+ Conv_Info := Get_Info (Imp);
+ Start_Association (Constr, Conv_Info.Ortho_Func);
+
+ if Conv_Info.Res_Interface /= O_Dnode_Null then
+ Res := Create_Temp (Conv_Info.Res_Record_Type);
+ -- Composite result.
+ New_Association
+ (Constr,
+ New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr));
+ end if;
+
+ Chap2.Add_Subprg_Instance_Assoc
+ (Constr, Conv_Info.Subprg_Instance);
+
+ New_Association (Constr, M2E (Src));
+
+ if Conv_Info.Res_Interface /= O_Dnode_Null then
+ -- Composite result.
+ New_Procedure_Call (Constr);
+ return New_Address (New_Obj (Res),
+ Conv_Info.Res_Record_Ptr);
+ else
+ return New_Function_Call (Constr);
+ end if;
+ when Iir_Kind_Type_Conversion =>
+ return Chap7.Translate_Type_Conversion
+ (M2E (Src), Get_Type (Expr),
+ Get_Type (Conv), Null_Iir);
+ when others =>
+ Error_Kind ("do_conversion", Conv);
+ end case;
+ end if;
+ end Do_Conversion;
+
+ procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call)
+ is
+ type Mnode_Array is array (Natural range <>) of Mnode;
+ type O_Enode_Array is array (Natural range <>) of O_Enode;
+ Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt);
+ Nbr_Assoc : constant Natural :=
+ Iir_Chains.Get_Chain_Length (Assoc_Chain);
+ Params : Mnode_Array (0 .. Nbr_Assoc - 1);
+ E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1);
+ Imp : constant Iir := Get_Implementation (Stmt);
+ Info : constant Subprg_Info_Acc := Get_Info (Imp);
+ Res : O_Dnode;
+ El : Iir;
+ Pos : Natural;
+ Constr : O_Assoc_List;
+ Act : Iir;
+ Actual_Type : Iir;
+ Formal : Iir;
+ Base_Formal : Iir;
+ Formal_Type : Iir;
+ Ftype_Info : Type_Info_Acc;
+ Formal_Info : Ortho_Info_Acc;
+ Val : O_Enode;
+ Param : Mnode;
+ Last_Individual : Natural;
+ Ptr : O_Lnode;
+ In_Conv : Iir;
+ In_Expr : Iir;
+ Out_Conv : Iir;
+ Out_Expr : Iir;
+ Formal_Object_Kind : Object_Kind_Type;
+ Bounds : Mnode;
+ Obj : Iir;
+ begin
+ -- Create an in-out result record for in-out arguments passed by
+ -- value.
+ if Info.Res_Record_Type /= O_Tnode_Null then
+ Res := Create_Temp (Info.Res_Record_Type);
+ else
+ Res := O_Dnode_Null;
+ end if;
+
+ -- Evaluate in-out parameters and parameters passed by ref, since
+ -- they can add declarations.
+ -- Non-composite in-out parameters address are saved in order to
+ -- be able to assignate the result.
+ El := Assoc_Chain;
+ Pos := 0;
+ while El /= Null_Iir loop
+ Params (Pos) := Mnode_Null;
+ E_Params (Pos) := O_Enode_Null;
+
+ Formal := Get_Formal (El);
+ if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then
+ Formal := Get_Named_Entity (Formal);
+ end if;
+ Base_Formal := Get_Association_Interface (El);
+ Formal_Type := Get_Type (Formal);
+ Formal_Info := Get_Info (Base_Formal);
+ if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration
+ then
+ Formal_Object_Kind := Mode_Signal;
+ else
+ Formal_Object_Kind := Mode_Value;
+ end if;
+ Ftype_Info := Get_Info (Formal_Type);
+
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_Open =>
+ Act := Get_Default_Value (Formal);
+ In_Conv := Null_Iir;
+ Out_Conv := Null_Iir;
+ when Iir_Kind_Association_Element_By_Expression =>
+ Act := Get_Actual (El);
+ In_Conv := Get_In_Conversion (El);
+ Out_Conv := Get_Out_Conversion (El);
+ when Iir_Kind_Association_Element_By_Individual =>
+ Actual_Type := Get_Actual_Type (El);
+ if Formal_Info.Interface_Field /= O_Fnode_Null then
+ -- A non-composite type cannot be associated by element.
+ raise Internal_Error;
+ end if;
+ if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then
+ Chap3.Create_Array_Subtype (Actual_Type, True);
+ Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Param := Create_Temp (Ftype_Info, Formal_Object_Kind);
+ Chap3.Translate_Object_Allocation
+ (Param, Alloc_Stack, Formal_Type, Bounds);
+ else
+ Param := Create_Temp (Ftype_Info, Formal_Object_Kind);
+ Chap4.Allocate_Complex_Object
+ (Formal_Type, Alloc_Stack, Param);
+ end if;
+ Last_Individual := Pos;
+ Params (Pos) := Param;
+ goto Continue;
+ when others =>
+ Error_Kind ("translate_procedure_call", El);
+ end case;
+ Actual_Type := Get_Type (Act);
+
+ if Formal_Info.Interface_Field /= O_Fnode_Null then
+ -- Copy-out argument.
+ -- This is not a composite type.
+ Param := Chap6.Translate_Name (Act);
+ if Get_Object_Kind (Param) /= Mode_Value then
+ raise Internal_Error;
+ end if;
+ Params (Pos) := Stabilize (Param);
+ if In_Conv /= Null_Iir
+ or else Get_Mode (Formal) = Iir_Inout_Mode
+ then
+ -- Arguments may be assigned if there is an in conversion.
+ Ptr := New_Selected_Element
+ (New_Obj (Res), Formal_Info.Interface_Field);
+ Param := Lv2M (Ptr, Ftype_Info, Mode_Value);
+ if In_Conv /= Null_Iir then
+ In_Expr := In_Conv;
+ else
+ In_Expr := Act;
+ end if;
+ Chap7.Translate_Assign
+ (Param,
+ Do_Conversion (In_Conv, Act, Params (Pos)),
+ In_Expr,
+ Formal_Type, El);
+ end if;
+ elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then
+ -- Passed by reference.
+ case Get_Kind (Base_Formal) is
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ -- No conversion here.
+ E_Params (Pos) := Chap7.Translate_Expression
+ (Act, Formal_Type);
+ when Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Param := Chap6.Translate_Name (Act);
+ -- Atype may not have been set (eg: slice).
+ if Base_Formal /= Formal then
+ Stabilize (Param);
+ Params (Pos) := Param;
+ end if;
+ E_Params (Pos) := M2E (Param);
+ if Formal_Type /= Actual_Type then
+ -- Implicit array conversion or subtype check.
+ E_Params (Pos) := Chap7.Translate_Implicit_Conv
+ (E_Params (Pos), Actual_Type, Formal_Type,
+ Get_Object_Kind (Param), Stmt);
+ end if;
+ when others =>
+ Error_Kind ("translate_procedure_call(2)", Formal);
+ end case;
+ end if;
+ if Base_Formal /= Formal then
+ -- Individual association.
+ if Ftype_Info.Type_Mode not in Type_Mode_By_Value then
+ -- Not by-value actual already translated.
+ Val := E_Params (Pos);
+ else
+ -- By value association.
+ Act := Get_Actual (El);
+ if Get_Kind (Base_Formal)
+ = Iir_Kind_Interface_Constant_Declaration
+ then
+ Val := Chap7.Translate_Expression (Act, Formal_Type);
+ else
+ Params (Pos) := Chap6.Translate_Name (Act);
+ -- Since signals are passed by reference, they are not
+ -- copied back, so do not stabilize them (furthermore,
+ -- it is not possible to stabilize them).
+ if Formal_Object_Kind = Mode_Value then
+ Params (Pos) := Stabilize (Params (Pos));
+ end if;
+ Val := M2E (Params (Pos));
+ end if;
+ end if;
+ -- Assign formal.
+ -- Change the formal variable so that it is the local variable
+ -- that will be passed to the subprogram.
+ declare
+ Prev_Node : O_Dnode;
+ begin
+ Prev_Node := Formal_Info.Interface_Node;
+ -- We need a pointer since the interface is by reference.
+ Formal_Info.Interface_Node :=
+ M2Dp (Params (Last_Individual));
+ Param := Chap6.Translate_Name (Formal);
+ Formal_Info.Interface_Node := Prev_Node;
+ end;
+ Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El);
+ end if;
+ << Continue >> null;
+ El := Get_Chain (El);
+ Pos := Pos + 1;
+ end loop;
+
+ -- Second stage: really perform the call.
+ Start_Association (Constr, Info.Ortho_Func);
+ if Res /= O_Dnode_Null then
+ New_Association (Constr,
+ New_Address (New_Obj (Res), Info.Res_Record_Ptr));
+ end if;
+
+ Obj := Get_Method_Object (Stmt);
+ if Obj /= Null_Iir then
+ New_Association (Constr, M2E (Chap6.Translate_Name (Obj)));
+ else
+ Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance);
+ end if;
+
+ -- Parameters.
+ El := Assoc_Chain;
+ Pos := 0;
+ while El /= Null_Iir loop
+ Formal := Get_Formal (El);
+ if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then
+ Formal := Get_Named_Entity (Formal);
+ end if;
+ Base_Formal := Get_Association_Interface (El);
+ Formal_Info := Get_Info (Base_Formal);
+ Formal_Type := Get_Type (Formal);
+ Ftype_Info := Get_Info (Formal_Type);
+
+ if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then
+ Last_Individual := Pos;
+ New_Association (Constr, M2E (Params (Pos)));
+ elsif Base_Formal /= Formal then
+ -- Individual association.
+ null;
+ elsif Formal_Info.Interface_Field = O_Fnode_Null then
+ if Ftype_Info.Type_Mode in Type_Mode_By_Value then
+ -- Parameter passed by value.
+ if E_Params (Pos) /= O_Enode_Null then
+ Val := E_Params (Pos);
+ raise Internal_Error;
+ else
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_Open =>
+ Act := Get_Default_Value (Formal);
+ In_Conv := Null_Iir;
+ when Iir_Kind_Association_Element_By_Expression =>
+ Act := Get_Actual (El);
+ In_Conv := Get_In_Conversion (El);
+ when others =>
+ Error_Kind ("translate_procedure_call(2)", El);
+ end case;
+ case Get_Kind (Formal) is
+ when Iir_Kind_Interface_Signal_Declaration =>
+ Param := Chap6.Translate_Name (Act);
+ -- This is a scalar.
+ Val := M2E (Param);
+ when others =>
+ if In_Conv = Null_Iir then
+ Val := Chap7.Translate_Expression
+ (Act, Formal_Type);
+ else
+ Actual_Type := Get_Type (Act);
+ Val := Do_Conversion
+ (In_Conv,
+ Act,
+ E2M (Chap7.Translate_Expression (Act,
+ Actual_Type),
+ Get_Info (Actual_Type),
+ Mode_Value));
+ end if;
+ end case;
+ end if;
+ New_Association (Constr, Val);
+ else
+ -- Parameter passed by ref, which was already computed.
+ New_Association (Constr, E_Params (Pos));
+ end if;
+ end if;
+ El := Get_Chain (El);
+ Pos := Pos + 1;
+ end loop;
+
+ New_Procedure_Call (Constr);
+
+ -- Copy-out non-composite parameters.
+ El := Assoc_Chain;
+ Pos := 0;
+ while El /= Null_Iir loop
+ Formal := Get_Formal (El);
+ Base_Formal := Get_Association_Interface (El);
+ Formal_Type := Get_Type (Formal);
+ Ftype_Info := Get_Info (Formal_Type);
+ Formal_Info := Get_Info (Base_Formal);
+ if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration
+ and then Get_Mode (Base_Formal) in Iir_Out_Modes
+ and then Params (Pos) /= Mnode_Null
+ then
+ if Formal_Info.Interface_Field /= O_Fnode_Null then
+ -- OUT parameters.
+ Out_Conv := Get_Out_Conversion (El);
+ if Out_Conv = Null_Iir then
+ Out_Expr := Formal;
+ else
+ Out_Expr := Out_Conv;
+ end if;
+ Ptr := New_Selected_Element
+ (New_Obj (Res), Formal_Info.Interface_Field);
+ Param := Lv2M (Ptr, Ftype_Info, Mode_Value);
+ Chap7.Translate_Assign (Params (Pos),
+ Do_Conversion (Out_Conv, Formal,
+ Param),
+ Out_Expr,
+ Get_Type (Get_Actual (El)), El);
+ elsif Base_Formal /= Formal then
+ -- By individual.
+ -- Copy back.
+ Act := Get_Actual (El);
+ declare
+ Prev_Node : O_Dnode;
+ begin
+ Prev_Node := Formal_Info.Interface_Node;
+ -- We need a pointer since the interface is by reference.
+ Formal_Info.Interface_Node :=
+ M2Dp (Params (Last_Individual));
+ Val := Chap7.Translate_Expression
+ (Formal, Get_Type (Act));
+ Formal_Info.Interface_Node := Prev_Node;
+ end;
+ Chap7.Translate_Assign
+ (Params (Pos), Val, Formal, Get_Type (Act), El);
+ end if;
+ end if;
+ El := Get_Chain (El);
+ Pos := Pos + 1;
+ end loop;
+ end Translate_Procedure_Call;
+
+ procedure Translate_Wait_Statement (Stmt : Iir)
+ is
+ Sensitivity : Iir_List;
+ Cond : Iir;
+ Timeout : Iir;
+ Constr : O_Assoc_List;
+ begin
+ Sensitivity := Get_Sensitivity_List (Stmt);
+ Cond := Get_Condition_Clause (Stmt);
+ Timeout := Get_Timeout_Clause (Stmt);
+
+ if Sensitivity = Null_Iir_List and Cond /= Null_Iir then
+ Sensitivity := Create_Iir_List;
+ Canon.Canon_Extract_Sensitivity (Cond, Sensitivity);
+ Set_Sensitivity_List (Stmt, Sensitivity);
+ end if;
+
+ -- Check for simple cases.
+ if Sensitivity = Null_Iir_List
+ and then Cond = Null_Iir
+ then
+ if Timeout = Null_Iir then
+ -- Process exit.
+ Start_Association (Constr, Ghdl_Process_Wait_Exit);
+ New_Procedure_Call (Constr);
+ else
+ -- Wait for a timeout.
+ Start_Association (Constr, Ghdl_Process_Wait_Timeout);
+ New_Association (Constr, Chap7.Translate_Expression
+ (Timeout, Time_Type_Definition));
+ New_Procedure_Call (Constr);
+ end if;
+ return;
+ end if;
+
+ -- Evaluate the timeout (if any) and register it,
+ if Timeout /= Null_Iir then
+ Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout);
+ New_Association (Constr, Chap7.Translate_Expression
+ (Timeout, Time_Type_Definition));
+ New_Procedure_Call (Constr);
+ end if;
+
+ -- Evaluate the sensitivity list and register it.
+ if Sensitivity /= Null_Iir_List then
+ Register_Signal_List
+ (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity);
+ end if;
+
+ if Cond = Null_Iir then
+ declare
+ V : O_Dnode;
+ begin
+ -- declare
+ -- v : __ghdl_bool_type_node;
+ -- begin
+ -- v := suspend ();
+ -- end;
+ Open_Temp;
+ V := Create_Temp (Ghdl_Bool_Type);
+ Start_Association (Constr, Ghdl_Process_Wait_Suspend);
+ New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr));
+ Close_Temp;
+ end;
+ else
+ declare
+ Label : O_Snode;
+ begin
+ -- start loop
+ Start_Loop_Stmt (Label);
+
+ -- if suspend() then -- return true if timeout.
+ -- exit;
+ -- end if;
+ Start_Association (Constr, Ghdl_Process_Wait_Suspend);
+ Gen_Exit_When (Label, New_Function_Call (Constr));
+
+ -- if condition then
+ -- exit;
+ -- end if;
+ Open_Temp;
+ Gen_Exit_When
+ (Label,
+ Chap7.Translate_Expression (Cond, Boolean_Type_Definition));
+ Close_Temp;
+
+ -- end loop;
+ Finish_Loop_Stmt (Label);
+ end;
+ end if;
+
+ -- wait_close;
+ Start_Association (Constr, Ghdl_Process_Wait_Close);
+ New_Procedure_Call (Constr);
+ end Translate_Wait_Statement;
+
+ -- Signal assignment.
+ Signal_Assign_Line : Natural;
+ procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Val : O_Enode)
+ is
+ Type_Info : Type_Info_Acc;
+ Subprg : O_Dnode;
+ Conv : O_Tnode;
+ Assoc : O_Assoc_List;
+ begin
+ Type_Info := Get_Info (Targ_Type);
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Signal_Simple_Assign_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Signal_Simple_Assign_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Signal_Simple_Assign_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Subprg := Ghdl_Signal_Simple_Assign_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Subprg := Ghdl_Signal_Simple_Assign_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Signal_Simple_Assign_F64;
+ Conv := Ghdl_Real_Type;
+ when Type_Mode_Array =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("gen_signal_assign_non_composite", Targ_Type);
+ end case;
+ if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then
+ declare
+ If_Blk : O_If_Block;
+ Val2 : O_Dnode;
+ Targ2 : O_Dnode;
+ begin
+ Open_Temp;
+ Val2 := Create_Temp_Init
+ (Type_Info.Ortho_Type (Mode_Value), Val);
+ Targ2 := Create_Temp_Init
+ (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type));
+ Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error);
+ New_Association (Assoc, New_Obj_Value (Targ2));
+ Assoc_Filename_Line (Assoc, Signal_Assign_Line);
+ New_Procedure_Call (Assoc);
+ New_Else_Stmt (If_Blk);
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Obj_Value (Targ2));
+ New_Association
+ (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv));
+ New_Procedure_Call (Assoc);
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end;
+ else
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Convert_Ov (Val, Conv));
+ New_Procedure_Call (Assoc);
+ end if;
+ end Gen_Simple_Signal_Assign_Non_Composite;
+
+ procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite
+ (Data_Type => O_Enode,
+ Composite_Data_Type => Mnode,
+ Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite,
+ Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite,
+ Update_Data_Array => Gen_Oenode_Update_Data_Array,
+ Finish_Data_Array => Gen_Oenode_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite,
+ Update_Data_Record => Gen_Oenode_Update_Data_Record,
+ Finish_Data_Record => Gen_Oenode_Finish_Data_Composite);
+
+ type Signal_Assign_Data is record
+ Expr : Mnode;
+ Reject : O_Dnode;
+ After : O_Dnode;
+ end record;
+
+ procedure Gen_Start_Signal_Assign_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data)
+ is
+ Type_Info : Type_Info_Acc;
+ Subprg : O_Dnode;
+ Conv : O_Tnode;
+ Assoc : O_Assoc_List;
+ begin
+ if Data.Expr = Mnode_Null then
+ -- Null transaction.
+ Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null);
+ New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Obj_Value (Data.Reject));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+ return;
+ end if;
+
+ Type_Info := Get_Info (Targ_Type);
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Signal_Start_Assign_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Signal_Start_Assign_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Signal_Start_Assign_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Subprg := Ghdl_Signal_Start_Assign_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Subprg := Ghdl_Signal_Start_Assign_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Signal_Start_Assign_F64;
+ Conv := Ghdl_Real_Type;
+ when Type_Mode_Array =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("gen_signal_assign_non_composite", Targ_Type);
+ end case;
+ -- Check range.
+ if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then
+ declare
+ If_Blk : O_If_Block;
+ V : Mnode;
+ Starg : O_Dnode;
+ begin
+ Open_Temp;
+ V := Stabilize_Value (Data.Expr);
+ Starg := Create_Temp_Init
+ (Ghdl_Signal_Ptr,
+ New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
+ Start_If_Stmt
+ (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type));
+ Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error);
+ New_Association (Assoc, New_Obj_Value (Starg));
+ New_Association (Assoc, New_Obj_Value (Data.Reject));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ Assoc_Filename_Line (Assoc, Signal_Assign_Line);
+ New_Procedure_Call (Assoc);
+ New_Else_Stmt (If_Blk);
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Obj_Value (Starg));
+ New_Association (Assoc, New_Obj_Value (Data.Reject));
+ New_Association (Assoc, New_Convert_Ov (M2E (V), Conv));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end;
+ else
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Obj_Value (Data.Reject));
+ New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+ end if;
+ end Gen_Start_Signal_Assign_Non_Composite;
+
+ function Gen_Signal_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data)
+ return Signal_Assign_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Val;
+ end Gen_Signal_Prepare_Data_Composite;
+
+ function Gen_Signal_Prepare_Data_Record
+ (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data)
+ return Signal_Assign_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ if Val.Expr = Mnode_Null then
+ return Val;
+ else
+ return Signal_Assign_Data'
+ (Expr => Stabilize (Val.Expr),
+ Reject => Val.Reject,
+ After => Val.After);
+ end if;
+ end Gen_Signal_Prepare_Data_Record;
+
+ function Gen_Signal_Update_Data_Array
+ (Val : Signal_Assign_Data;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Signal_Assign_Data
+ is
+ Res : Signal_Assign_Data;
+ begin
+ if Val.Expr = Mnode_Null then
+ -- Handle null transaction.
+ return Val;
+ end if;
+ Res := Signal_Assign_Data'
+ (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr),
+ Targ_Type, New_Obj_Value (Index)),
+ Reject => Val.Reject,
+ After => Val.After);
+ return Res;
+ end Gen_Signal_Update_Data_Array;
+
+ function Gen_Signal_Update_Data_Record
+ (Val : Signal_Assign_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Signal_Assign_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ Res : Signal_Assign_Data;
+ begin
+ if Val.Expr = Mnode_Null then
+ -- Handle null transaction.
+ return Val;
+ end if;
+ Res := Signal_Assign_Data'
+ (Expr => Chap6.Translate_Selected_Element (Val.Expr, El),
+ Reject => Val.Reject,
+ After => Val.After);
+ return Res;
+ end Gen_Signal_Update_Data_Record;
+
+ procedure Gen_Signal_Finish_Data_Composite
+ (Data : in out Signal_Assign_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Gen_Signal_Finish_Data_Composite;
+
+ procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite
+ (Data_Type => Signal_Assign_Data,
+ Composite_Data_Type => Signal_Assign_Data,
+ Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite,
+ Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite,
+ Update_Data_Array => Gen_Signal_Update_Data_Array,
+ Finish_Data_Array => Gen_Signal_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Signal_Prepare_Data_Record,
+ Update_Data_Record => Gen_Signal_Update_Data_Record,
+ Finish_Data_Record => Gen_Signal_Finish_Data_Composite);
+
+ procedure Gen_Next_Signal_Assign_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data)
+ is
+ Type_Info : Type_Info_Acc;
+ Subprg : O_Dnode;
+ Conv : O_Tnode;
+ Assoc : O_Assoc_List;
+ begin
+ if Data.Expr = Mnode_Null then
+ -- Null transaction.
+ Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null);
+ New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+ return;
+ end if;
+
+ Type_Info := Get_Info (Targ_Type);
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Signal_Next_Assign_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Signal_Next_Assign_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Signal_Next_Assign_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Subprg := Ghdl_Signal_Next_Assign_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Subprg := Ghdl_Signal_Next_Assign_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Signal_Next_Assign_F64;
+ Conv := Ghdl_Real_Type;
+ when Type_Mode_Array =>
+ raise Internal_Error;
+ when others =>
+ Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type);
+ end case;
+ if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then
+ declare
+ If_Blk : O_If_Block;
+ V : Mnode;
+ Starg : O_Dnode;
+ begin
+ Open_Temp;
+ V := Stabilize_Value (Data.Expr);
+ Starg := Create_Temp_Init
+ (Ghdl_Signal_Ptr,
+ New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
+ Start_If_Stmt
+ (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type));
+
+ Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error);
+ New_Association (Assoc, New_Obj_Value (Starg));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ Assoc_Filename_Line (Assoc, Signal_Assign_Line);
+ New_Procedure_Call (Assoc);
+
+ New_Else_Stmt (If_Blk);
+
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Obj_Value (Starg));
+ New_Association (Assoc, New_Convert_Ov (M2E (V), Conv));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end;
+ else
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)),
+ Ghdl_Signal_Ptr));
+ New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv));
+ New_Association (Assoc, New_Obj_Value (Data.After));
+ New_Procedure_Call (Assoc);
+ end if;
+ end Gen_Next_Signal_Assign_Non_Composite;
+
+ procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite
+ (Data_Type => Signal_Assign_Data,
+ Composite_Data_Type => Signal_Assign_Data,
+ Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite,
+ Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite,
+ Update_Data_Array => Gen_Signal_Update_Data_Array,
+ Finish_Data_Array => Gen_Signal_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Signal_Prepare_Data_Record,
+ Update_Data_Record => Gen_Signal_Update_Data_Record,
+ Finish_Data_Record => Gen_Signal_Finish_Data_Composite);
+
+ procedure Translate_Signal_Target_Aggr
+ (Aggr : Mnode; Target : Iir; Target_Type : Iir);
+
+ procedure Translate_Signal_Target_Array_Aggr
+ (Aggr : Mnode;
+ Target : Iir;
+ Target_Type : Iir;
+ Idx : O_Dnode;
+ Dim : Natural)
+ is
+ Index_List : constant Iir_List :=
+ Get_Index_Subtype_List (Target_Type);
+ Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List);
+ Sub_Aggr : Mnode;
+ El : Iir;
+ Expr : Iir;
+ begin
+ El := Get_Association_Choices_Chain (Target);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Choice_By_None =>
+ Sub_Aggr := Chap3.Index_Base
+ (Aggr, Target_Type, New_Obj_Value (Idx));
+ when others =>
+ Error_Kind ("translate_signal_target_array_aggr", El);
+ end case;
+ Expr := Get_Associated_Expr (El);
+ if Dim = Nbr_Dim then
+ Translate_Signal_Target_Aggr
+ (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type));
+ if Get_Kind (El) = Iir_Kind_Choice_By_None then
+ Inc_Var (Idx);
+ else
+ raise Internal_Error;
+ end if;
+ else
+ Translate_Signal_Target_Array_Aggr
+ (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Signal_Target_Array_Aggr;
+
+ procedure Translate_Signal_Target_Record_Aggr
+ (Aggr : Mnode; Target : Iir; Target_Type : Iir)
+ is
+ Aggr_El : Iir;
+ El_List : Iir_List;
+ El_Index : Natural;
+ Element : Iir_Element_Declaration;
+ begin
+ El_List := Get_Elements_Declaration_List
+ (Get_Base_Type (Target_Type));
+ El_Index := 0;
+ Aggr_El := Get_Association_Choices_Chain (Target);
+ while Aggr_El /= Null_Iir loop
+ case Get_Kind (Aggr_El) is
+ when Iir_Kind_Choice_By_None =>
+ Element := Get_Nth_Element (El_List, El_Index);
+ El_Index := El_Index + 1;
+ when Iir_Kind_Choice_By_Name =>
+ Element := Get_Choice_Name (Aggr_El);
+ El_Index := Natural'Last;
+ when others =>
+ Error_Kind ("translate_signal_target_record_aggr", Aggr_El);
+ end case;
+ Translate_Signal_Target_Aggr
+ (Chap6.Translate_Selected_Element (Aggr, Element),
+ Get_Associated_Expr (Aggr_El), Get_Type (Element));
+ Aggr_El := Get_Chain (Aggr_El);
+ end loop;
+ end Translate_Signal_Target_Record_Aggr;
+
+ procedure Translate_Signal_Target_Aggr
+ (Aggr : Mnode; Target : Iir; Target_Type : Iir)
+ is
+ Src : Mnode;
+ begin
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ declare
+ Idx : O_Dnode;
+ St_Aggr : Mnode;
+ begin
+ Open_Temp;
+ St_Aggr := Stabilize (Aggr);
+ case Get_Kind (Target_Type) is
+ when Iir_Kinds_Array_Type_Definition =>
+ Idx := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Idx);
+ Translate_Signal_Target_Array_Aggr
+ (St_Aggr, Target, Target_Type, Idx, 1);
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ Translate_Signal_Target_Record_Aggr
+ (St_Aggr, Target, Target_Type);
+ when others =>
+ Error_Kind ("translate_signal_target_aggr", Target_Type);
+ end case;
+ Close_Temp;
+ end;
+ else
+ Src := Chap6.Translate_Name (Target);
+ Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type);
+ end if;
+ end Translate_Signal_Target_Aggr;
+
+ type Signal_Direct_Assign_Data is record
+ -- The driver
+ Drv : Mnode;
+
+ -- The value
+ Expr : Mnode;
+
+ -- The node for the expression (used to locate errors).
+ Expr_Node : Iir;
+ end record;
+
+ procedure Gen_Signal_Direct_Assign_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data)
+ is
+ Targ_Sig : Mnode;
+ If_Blk : O_If_Block;
+ Constr : O_Assoc_List;
+ Cond : O_Dnode;
+ Drv : Mnode;
+ begin
+ Open_Temp;
+ Targ_Sig := Stabilize (Targ, True);
+ Cond := Create_Temp (Ghdl_Bool_Type);
+ Drv := Stabilize (Data.Drv, False);
+
+ -- Set driver.
+ Chap7.Translate_Assign
+ (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node);
+
+ -- Test if the signal is active.
+ Start_If_Stmt
+ (If_Blk,
+ New_Value (Chap14.Get_Signal_Field
+ (Targ_Sig, Ghdl_Signal_Has_Active_Field)));
+ -- Either because has_active is true.
+ New_Assign_Stmt (New_Obj (Cond),
+ New_Lit (Ghdl_Bool_True_Node));
+ New_Else_Stmt (If_Blk);
+ -- Or because the value is different from the current driving value.
+ -- FIXME: ideally, we should compare the value with the current
+ -- value of the driver. This is an approximation that might break
+ -- with weird resolution functions.
+ New_Assign_Stmt
+ (New_Obj (Cond),
+ New_Compare_Op (ON_Neq,
+ Chap7.Translate_Signal_Driving_Value
+ (M2E (Targ_Sig), Targ_Type),
+ M2E (Drv),
+ Ghdl_Bool_Type));
+ Finish_If_Stmt (If_Blk);
+
+ -- Put signal into active list (if not already in the list).
+ -- FIXME: this is not thread-safe!
+ Start_If_Stmt (If_Blk, New_Obj_Value (Cond));
+ Start_Association (Constr, Ghdl_Signal_Direct_Assign);
+ New_Association (Constr,
+ New_Convert_Ov (New_Value (M2Lv (Targ_Sig)),
+ Ghdl_Signal_Ptr));
+ New_Procedure_Call (Constr);
+ Finish_If_Stmt (If_Blk);
+
+ Close_Temp;
+ end Gen_Signal_Direct_Assign_Non_Composite;
+
+ function Gen_Signal_Direct_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data)
+ return Signal_Direct_Assign_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Val;
+ end Gen_Signal_Direct_Prepare_Data_Composite;
+
+ function Gen_Signal_Direct_Prepare_Data_Record
+ (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data)
+ return Signal_Direct_Assign_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Signal_Direct_Assign_Data'
+ (Drv => Stabilize (Val.Drv),
+ Expr => Stabilize (Val.Expr),
+ Expr_Node => Val.Expr_Node);
+ end Gen_Signal_Direct_Prepare_Data_Record;
+
+ function Gen_Signal_Direct_Update_Data_Array
+ (Val : Signal_Direct_Assign_Data;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Signal_Direct_Assign_Data
+ is
+ begin
+ return Signal_Direct_Assign_Data'
+ (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv),
+ Targ_Type, New_Obj_Value (Index)),
+ Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr),
+ Targ_Type, New_Obj_Value (Index)),
+ Expr_Node => Val.Expr_Node);
+ end Gen_Signal_Direct_Update_Data_Array;
+
+ function Gen_Signal_Direct_Update_Data_Record
+ (Val : Signal_Direct_Assign_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Signal_Direct_Assign_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Signal_Direct_Assign_Data'
+ (Drv => Chap6.Translate_Selected_Element (Val.Drv, El),
+ Expr => Chap6.Translate_Selected_Element (Val.Expr, El),
+ Expr_Node => Val.Expr_Node);
+ end Gen_Signal_Direct_Update_Data_Record;
+
+ procedure Gen_Signal_Direct_Finish_Data_Composite
+ (Data : in out Signal_Direct_Assign_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Gen_Signal_Direct_Finish_Data_Composite;
+
+ procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite
+ (Data_Type => Signal_Direct_Assign_Data,
+ Composite_Data_Type => Signal_Direct_Assign_Data,
+ Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite,
+ Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite,
+ Update_Data_Array => Gen_Signal_Direct_Update_Data_Array,
+ Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record,
+ Update_Data_Record => Gen_Signal_Direct_Update_Data_Record,
+ Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite);
+
+ procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir)
+ is
+ Target : constant Iir := Get_Target (Stmt);
+ Target_Type : constant Iir := Get_Type (Target);
+ Arg : Signal_Direct_Assign_Data;
+ Targ_Sig : Mnode;
+ begin
+ Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv);
+
+ Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type),
+ Get_Info (Target_Type), Mode_Value);
+ Arg.Expr_Node := We;
+ Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg);
+ end Translate_Direct_Signal_Assignment;
+
+ procedure Translate_Signal_Assignment_Statement (Stmt : Iir)
+ is
+ Target : Iir;
+ Target_Type : Iir;
+ We : Iir_Waveform_Element;
+ Targ : Mnode;
+ Val : O_Enode;
+ Value : Iir;
+ Is_Simple : Boolean;
+ begin
+ Target := Get_Target (Stmt);
+ Target_Type := Get_Type (Target);
+ We := Get_Waveform_Chain (Stmt);
+
+ if We /= Null_Iir
+ and then Get_Chain (We) = Null_Iir
+ and then Get_Time (We) = Null_Iir
+ and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay
+ and then Get_Reject_Time_Expression (Stmt) = Null_Iir
+ then
+ -- Simple signal assignment ?
+ Value := Get_We_Value (We);
+ Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal;
+ else
+ Is_Simple := False;
+ end if;
+
+ if Get_Kind (Target) = Iir_Kind_Aggregate then
+ Chap3.Translate_Anonymous_Type_Definition (Target_Type, True);
+ Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal);
+ Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ);
+ Translate_Signal_Target_Aggr (Targ, Target, Target_Type);
+ else
+ if Is_Simple
+ and then Flag_Direct_Drivers
+ and then Chap4.Has_Direct_Driver (Target)
+ then
+ Translate_Direct_Signal_Assignment (Stmt, Value);
+ return;
+ end if;
+ Targ := Chap6.Translate_Name (Target);
+ if Get_Object_Kind (Targ) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+ end if;
+
+ if We = Null_Iir then
+ -- Implicit disconnect statment.
+ Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect);
+ return;
+ end if;
+
+ -- Handle a simple and common case: only one waveform, inertial,
+ -- and no time (eg: sig <= expr).
+ Value := Get_We_Value (We);
+ Signal_Assign_Line := Get_Line_Number (Value);
+ if Get_Chain (We) = Null_Iir
+ and then Get_Time (We) = Null_Iir
+ and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay
+ and then Get_Reject_Time_Expression (Stmt) = Null_Iir
+ and then Get_Kind (Value) /= Iir_Kind_Null_Literal
+ then
+ Val := Chap7.Translate_Expression (Value, Target_Type);
+ Gen_Simple_Signal_Assign (Targ, Target_Type, Val);
+ return;
+ end if;
+
+ -- General case.
+ declare
+ Var_Targ : Mnode;
+ Targ_Tinfo : Type_Info_Acc;
+ begin
+ Open_Temp;
+ Targ_Tinfo := Get_Info (Target_Type);
+ Var_Targ := Stabilize (Targ, True);
+
+ -- Translate the first waveform element.
+ declare
+ Reject_Time : O_Dnode;
+ After_Time : O_Dnode;
+ Del : Iir;
+ Rej : Iir;
+ Val : Mnode;
+ Data : Signal_Assign_Data;
+ begin
+ Open_Temp;
+ Reject_Time := Create_Temp (Std_Time_Otype);
+ After_Time := Create_Temp (Std_Time_Otype);
+ Del := Get_Time (We);
+ if Del = Null_Iir then
+ New_Assign_Stmt
+ (New_Obj (After_Time),
+ New_Lit (New_Signed_Literal (Std_Time_Otype, 0)));
+ else
+ New_Assign_Stmt
+ (New_Obj (After_Time),
+ Chap7.Translate_Expression (Del, Time_Type_Definition));
+ end if;
+ case Get_Delay_Mechanism (Stmt) is
+ when Iir_Transport_Delay =>
+ New_Assign_Stmt
+ (New_Obj (Reject_Time),
+ New_Lit (New_Signed_Literal (Std_Time_Otype, 0)));
+ when Iir_Inertial_Delay =>
+ Rej := Get_Reject_Time_Expression (Stmt);
+ if Rej = Null_Iir then
+ New_Assign_Stmt (New_Obj (Reject_Time),
+ New_Obj_Value (After_Time));
+ else
+ New_Assign_Stmt
+ (New_Obj (Reject_Time), Chap7.Translate_Expression
+ (Rej, Time_Type_Definition));
+ end if;
+ end case;
+ if Get_Kind (Value) = Iir_Kind_Null_Literal then
+ Val := Mnode_Null;
+ else
+ Val := E2M (Chap7.Translate_Expression (Value, Target_Type),
+ Targ_Tinfo, Mode_Value);
+ Val := Stabilize (Val);
+ end if;
+ Data := Signal_Assign_Data'(Expr => Val,
+ Reject => Reject_Time,
+ After => After_Time);
+ Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data);
+ Close_Temp;
+ end;
+
+ -- Translate other waveform elements.
+ We := Get_Chain (We);
+ while We /= Null_Iir loop
+ declare
+ After_Time : O_Dnode;
+ Val : Mnode;
+ Data : Signal_Assign_Data;
+ begin
+ Open_Temp;
+ After_Time := Create_Temp (Std_Time_Otype);
+ New_Assign_Stmt
+ (New_Obj (After_Time),
+ Chap7.Translate_Expression (Get_Time (We),
+ Time_Type_Definition));
+ Value := Get_We_Value (We);
+ Signal_Assign_Line := Get_Line_Number (Value);
+ if Get_Kind (Value) = Iir_Kind_Null_Literal then
+ Val := Mnode_Null;
+ else
+ Val :=
+ E2M (Chap7.Translate_Expression (Value, Target_Type),
+ Targ_Tinfo, Mode_Value);
+ end if;
+ Data := Signal_Assign_Data'(Expr => Val,
+ Reject => O_Dnode_Null,
+ After => After_Time);
+ Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data);
+ Close_Temp;
+ end;
+ We := Get_Chain (We);
+ end loop;
+
+ Close_Temp;
+ end;
+ end Translate_Signal_Assignment_Statement;
+
+ procedure Translate_Statement (Stmt : Iir)
+ is
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Stmt));
+ Open_Temp;
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Return_Statement =>
+ Translate_Return_Statement (Stmt);
+
+ when Iir_Kind_If_Statement =>
+ Translate_If_Statement (Stmt);
+ when Iir_Kind_Assertion_Statement =>
+ Translate_Assertion_Statement (Stmt);
+ when Iir_Kind_Report_Statement =>
+ Translate_Report_Statement (Stmt);
+ when Iir_Kind_Case_Statement =>
+ Translate_Case_Statement (Stmt);
+
+ when Iir_Kind_For_Loop_Statement =>
+ Translate_For_Loop_Statement (Stmt);
+ when Iir_Kind_While_Loop_Statement =>
+ Translate_While_Loop_Statement (Stmt);
+ when Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement =>
+ Translate_Exit_Next_Statement (Stmt);
+
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Translate_Signal_Assignment_Statement (Stmt);
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Translate_Variable_Assignment_Statement (Stmt);
+
+ when Iir_Kind_Null_Statement =>
+ -- A null statement is translated to a NOP, so that the
+ -- statement generates code (and a breakpoint can be set on
+ -- it).
+ -- Emit_Nop;
+ null;
+
+ when Iir_Kind_Procedure_Call_Statement =>
+ declare
+ Call : constant Iir := Get_Procedure_Call (Stmt);
+ Imp : constant Iir := Get_Implementation (Call);
+ begin
+ Canon.Canon_Subprogram_Call (Call);
+ if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration
+ then
+ Translate_Implicit_Procedure_Call (Call);
+ else
+ Translate_Procedure_Call (Call);
+ end if;
+ end;
+
+ when Iir_Kind_Wait_Statement =>
+ Translate_Wait_Statement (Stmt);
+
+ when others =>
+ Error_Kind ("translate_statement", Stmt);
+ end case;
+ Close_Temp;
+ end Translate_Statement;
+
+ procedure Translate_Statements_Chain (First : Iir)
+ is
+ Stmt : Iir;
+ begin
+ Stmt := First;
+ while Stmt /= Null_Iir loop
+ Translate_Statement (Stmt);
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Translate_Statements_Chain;
+
+ function Translate_Statements_Chain_Has_Return (First : Iir)
+ return Boolean
+ is
+ Stmt : Iir;
+ Has_Return : Boolean := False;
+ begin
+ Stmt := First;
+ while Stmt /= Null_Iir loop
+ Translate_Statement (Stmt);
+ if Get_Kind (Stmt) = Iir_Kind_Return_Statement then
+ Has_Return := True;
+ end if;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ return Has_Return;
+ end Translate_Statements_Chain_Has_Return;
+ end Chap8;
+
+ package body Chap9 is
+ procedure Set_Direct_Drivers (Proc : Iir)
+ is
+ Proc_Info : constant Proc_Info_Acc := Get_Info (Proc);
+ Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers;
+ Info : Ortho_Info_Acc;
+ Var : Var_Type;
+ Sig : Iir;
+ begin
+ for I in Drivers.all'Range loop
+ Var := Drivers (I).Var;
+ if Var /= Null_Var then
+ Sig := Get_Object_Prefix (Drivers (I).Sig);
+ Info := Get_Info (Sig);
+ case Info.Kind is
+ when Kind_Object =>
+ Info.Object_Driver := Var;
+ when Kind_Alias =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ end loop;
+ end Set_Direct_Drivers;
+
+ procedure Reset_Direct_Drivers (Proc : Iir)
+ is
+ Proc_Info : constant Proc_Info_Acc := Get_Info (Proc);
+ Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers;
+ Info : Ortho_Info_Acc;
+ Var : Var_Type;
+ Sig : Iir;
+ begin
+ for I in Drivers.all'Range loop
+ Var := Drivers (I).Var;
+ if Var /= Null_Var then
+ Sig := Get_Object_Prefix (Drivers (I).Sig);
+ Info := Get_Info (Sig);
+ case Info.Kind is
+ when Kind_Object =>
+ Info.Object_Driver := Null_Var;
+ when Kind_Alias =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ end loop;
+ end Reset_Direct_Drivers;
+
+ procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc)
+ is
+ Info : constant Proc_Info_Acc := Get_Info (Proc);
+ Inter_List : O_Inter_List;
+ Instance : O_Dnode;
+ begin
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Process_Subprg);
+
+ Start_Subprogram_Body (Info.Process_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+
+ Chap8.Translate_Statements_Chain
+ (Get_Sequential_Statement_Chain (Proc));
+
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_Process_Statement;
+
+ procedure Translate_Implicit_Guard_Signal
+ (Guard : Iir; Base : Block_Info_Acc)
+ is
+ Info : Object_Info_Acc;
+ Inter_List : O_Inter_List;
+ Instance : O_Dnode;
+ Guard_Expr : Iir;
+ begin
+ Guard_Expr := Get_Guard_Expression (Guard);
+ -- Create the subprogram to compute the value of GUARD.
+ Info := Get_Info (Guard);
+ Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"),
+ O_Storage_Private, Std_Boolean_Type_Node);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Object_Function);
+
+ Start_Subprogram_Body (Info.Object_Function);
+ Push_Local_Factory;
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+ Open_Temp;
+ New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr));
+ Close_Temp;
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_Implicit_Guard_Signal;
+
+ procedure Translate_Component_Instantiation_Statement (Inst : Iir)
+ is
+ Comp : constant Iir := Get_Instantiated_Unit (Inst);
+ Info : Block_Info_Acc;
+ Comp_Info : Comp_Info_Acc;
+
+ Mark2 : Id_Mark_Type;
+ Assoc, Conv, In_Type : Iir;
+ Has_Conv_Record : Boolean := False;
+ begin
+ Info := Add_Info (Inst, Kind_Block);
+
+ if Is_Component_Instantiation (Inst) then
+ -- Via a component declaration.
+ Comp_Info := Get_Info (Get_Named_Entity (Comp));
+ Info.Block_Link_Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (Inst),
+ Get_Scope_Type (Comp_Info.Comp_Scope));
+ else
+ -- Direct instantiation.
+ Info.Block_Link_Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (Inst),
+ Rtis.Ghdl_Component_Link_Type);
+ end if;
+
+ -- When conversions are used, the subtype of the actual (or of the
+ -- formal for out conversions) may not be yet translated. This
+ -- can happen if the name is a slice.
+ -- We need to translate it and create variables in the instance
+ -- because it will be referenced by the conversion subprogram.
+ Assoc := Get_Port_Map_Aspect_Chain (Inst);
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression
+ then
+ Conv := Get_In_Conversion (Assoc);
+ In_Type := Get_Type (Get_Actual (Assoc));
+ if Conv /= Null_Iir
+ and then Is_Anonymous_Type_Definition (In_Type)
+ then
+ -- Lazy creation of the record.
+ if not Has_Conv_Record then
+ Has_Conv_Record := True;
+ Push_Instance_Factory (Info.Block_Scope'Access);
+ end if;
+
+ -- FIXME: handle with overload multiple case on the same
+ -- formal.
+ Push_Identifier_Prefix
+ (Mark2,
+ Get_Identifier (Get_Association_Interface (Assoc)));
+ Chap3.Translate_Type_Definition (In_Type, True);
+ Pop_Identifier_Prefix (Mark2);
+ end if;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ if Has_Conv_Record then
+ Pop_Instance_Factory (Info.Block_Scope'Access);
+ New_Type_Decl
+ (Create_Identifier (Get_Identifier (Inst), "__CONVS"),
+ Get_Scope_Type (Info.Block_Scope));
+ Info.Block_Parent_Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (Get_Identifier (Inst),
+ "__CONVS"),
+ Get_Scope_Type (Info.Block_Scope));
+ end if;
+ end Translate_Component_Instantiation_Statement;
+
+ procedure Translate_Process_Declarations (Proc : Iir)
+ is
+ Mark : Id_Mark_Type;
+ Info : Ortho_Info_Acc;
+
+ Drivers : Iir_List;
+ Nbr_Drivers : Natural;
+ Sig : Iir;
+ begin
+ Info := Add_Info (Proc, Kind_Process);
+
+ -- Create process record.
+ Push_Identifier_Prefix (Mark, Get_Identifier (Proc));
+ Push_Instance_Factory (Info.Process_Scope'Access);
+ Chap4.Translate_Declaration_Chain (Proc);
+
+ if Flag_Direct_Drivers then
+ -- Create direct drivers.
+ Drivers := Trans_Analyzes.Extract_Drivers (Proc);
+ if Flag_Dump_Drivers then
+ Trans_Analyzes.Dump_Drivers (Proc, Drivers);
+ end if;
+
+ Nbr_Drivers := Get_Nbr_Elements (Drivers);
+ Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers);
+ for I in 1 .. Nbr_Drivers loop
+ Sig := Get_Nth_Element (Drivers, I - 1);
+ Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var);
+ Sig := Get_Object_Prefix (Sig);
+ if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration
+ and then not Get_After_Drivers_Flag (Sig)
+ then
+ Info.Process_Drivers (I).Var :=
+ Create_Var (Create_Var_Identifier (Sig, "_DDRV", I),
+ Chap4.Get_Object_Type
+ (Get_Info (Get_Type (Sig)), Mode_Value));
+
+ -- Do not create driver severals times.
+ Set_After_Drivers_Flag (Sig, True);
+ end if;
+ end loop;
+ Trans_Analyzes.Free_Drivers_List (Drivers);
+ end if;
+ Pop_Instance_Factory (Info.Process_Scope'Access);
+ New_Type_Decl (Create_Identifier ("INSTTYPE"),
+ Get_Scope_Type (Info.Process_Scope));
+ Pop_Identifier_Prefix (Mark);
+
+ -- Create a field in the parent record.
+ Add_Scope_Field (Create_Identifier_Without_Prefix (Proc),
+ Info.Process_Scope);
+ end Translate_Process_Declarations;
+
+ procedure Translate_Psl_Directive_Declarations (Stmt : Iir)
+ is
+ use PSL.Nodes;
+ use PSL.NFAs;
+
+ N : constant NFA := Get_PSL_NFA (Stmt);
+
+ Mark : Id_Mark_Type;
+ Info : Ortho_Info_Acc;
+ begin
+ Info := Add_Info (Stmt, Kind_Psl_Directive);
+
+ -- Create process record.
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Push_Instance_Factory (Info.Psl_Scope'Access);
+
+ Labelize_States (N, Info.Psl_Vect_Len);
+ Info.Psl_Vect_Type := New_Constrained_Array_Type
+ (Std_Boolean_Array_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len)));
+ New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type);
+ Info.Psl_Vect_Var := Create_Var
+ (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type);
+
+ if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then
+ Info.Psl_Bool_Var := Create_Var
+ (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type);
+ end if;
+
+ Pop_Instance_Factory (Info.Psl_Scope'Access);
+ New_Type_Decl (Create_Identifier ("INSTTYPE"),
+ Get_Scope_Type (Info.Psl_Scope));
+ Pop_Identifier_Prefix (Mark);
+
+ -- Create a field in the parent record.
+ Add_Scope_Field
+ (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope);
+ end Translate_Psl_Directive_Declarations;
+
+ function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean)
+ return O_Enode
+ is
+ use PSL.Nodes;
+ begin
+ case Get_Kind (Expr) is
+ when N_HDL_Expr =>
+ declare
+ E : Iir;
+ Rtype : Iir;
+ Res : O_Enode;
+ begin
+ E := Get_HDL_Node (Expr);
+ Rtype := Get_Base_Type (Get_Type (E));
+ Res := Chap7.Translate_Expression (E);
+ if Rtype = Boolean_Type_Definition then
+ return Res;
+ elsif Rtype = Ieee.Std_Logic_1164.Std_Ulogic_Type then
+ return New_Value
+ (New_Indexed_Element
+ (New_Obj (Ghdl_Std_Ulogic_To_Boolean_Array),
+ New_Convert_Ov (Res, Ghdl_Index_Type)));
+ else
+ Error_Kind ("translate_psl_expr/hdl_expr", Expr);
+ end if;
+ end;
+ when N_True =>
+ return New_Lit (Std_Boolean_True_Node);
+ when N_EOS =>
+ if Eos then
+ return New_Lit (Std_Boolean_True_Node);
+ else
+ return New_Lit (Std_Boolean_False_Node);
+ end if;
+ when N_Not_Bool =>
+ return New_Monadic_Op
+ (ON_Not,
+ Translate_Psl_Expr (Get_Boolean (Expr), Eos));
+ when N_And_Bool =>
+ return New_Dyadic_Op
+ (ON_And,
+ Translate_Psl_Expr (Get_Left (Expr), Eos),
+ Translate_Psl_Expr (Get_Right (Expr), Eos));
+ when N_Or_Bool =>
+ return New_Dyadic_Op
+ (ON_Or,
+ Translate_Psl_Expr (Get_Left (Expr), Eos),
+ Translate_Psl_Expr (Get_Right (Expr), Eos));
+ when others =>
+ Error_Kind ("translate_psl_expr", Expr);
+ end case;
+ end Translate_Psl_Expr;
+
+ -- Return TRUE iff NFA has an edge with an EOS.
+ -- If so, we need to create a finalizer.
+ function Psl_Need_Finalizer (Nfa : PSL_NFA) return Boolean
+ is
+ use PSL.NFAs;
+ S : NFA_State;
+ E : NFA_Edge;
+ begin
+ S := Get_Final_State (Nfa);
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then
+ return True;
+ end if;
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+ return False;
+ end Psl_Need_Finalizer;
+
+ procedure Create_Psl_Final_Proc
+ (Stmt : Iir; Base : Block_Info_Acc; Instance : out O_Dnode)
+ is
+ Inter_List : O_Inter_List;
+ Info : constant Psl_Info_Acc := Get_Info (Stmt);
+ begin
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("FINALPROC"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Final_Subprg);
+ end Create_Psl_Final_Proc;
+
+ procedure Translate_Psl_Directive_Statement
+ (Stmt : Iir; Base : Block_Info_Acc)
+ is
+ use PSL.NFAs;
+ Inter_List : O_Inter_List;
+ Instance : O_Dnode;
+ Info : constant Psl_Info_Acc := Get_Info (Stmt);
+ Var_I : O_Dnode;
+ Var_Nvec : O_Dnode;
+ Label : O_Snode;
+ Clk_Blk : O_If_Block;
+ S_Blk : O_If_Block;
+ E_Blk : O_If_Block;
+ S : NFA_State;
+ S_Num : Int32;
+ E : NFA_Edge;
+ Sd : NFA_State;
+ Cond : O_Enode;
+ NFA : PSL_NFA;
+ D_Lit : O_Cnode;
+ begin
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Psl_Proc_Subprg);
+
+ Start_Subprogram_Body (Info.Psl_Proc_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+
+ -- New state vector.
+ New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type);
+
+ -- For cover directive, return now if already covered.
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Psl_Assert_Statement =>
+ null;
+ when Iir_Kind_Psl_Cover_Statement =>
+ Start_If_Stmt (S_Blk, New_Value (Get_Var (Info.Psl_Bool_Var)));
+ New_Return_Stmt;
+ Finish_If_Stmt (S_Blk);
+ when others =>
+ Error_Kind ("Translate_Psl_Directive_Statement(1)", Stmt);
+ end case;
+
+ -- Initialize the new state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Obj_Value (Var_I)),
+ New_Lit (Std_Boolean_False_Node));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ -- Global if statement for the clock.
+ Open_Temp;
+ Start_If_Stmt (Clk_Blk,
+ Translate_Psl_Expr (Get_PSL_Clock (Stmt), False));
+
+ -- For each state: if set, evaluate all outgoing edges.
+ NFA := Get_PSL_NFA (Stmt);
+ S := Get_First_State (NFA);
+ while S /= No_State loop
+ S_Num := Get_State_Label (S);
+ Open_Temp;
+
+ Start_If_Stmt
+ (S_Blk,
+ New_Value
+ (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (New_Index_Lit
+ (Unsigned_64 (S_Num))))));
+
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Sd := Get_Edge_Dest (E);
+ Open_Temp;
+
+ D_Lit := New_Index_Lit (Unsigned_64 (Get_State_Label (Sd)));
+ Cond := New_Monadic_Op
+ (ON_Not,
+ New_Value (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Lit (D_Lit))));
+ Cond := New_Dyadic_Op
+ (ON_And, Cond, Translate_Psl_Expr (Get_Edge_Expr (E), False));
+ Start_If_Stmt (E_Blk, Cond);
+ New_Assign_Stmt
+ (New_Indexed_Element (New_Obj (Var_Nvec), New_Lit (D_Lit)),
+ New_Lit (Std_Boolean_True_Node));
+ Finish_If_Stmt (E_Blk);
+
+ Close_Temp;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+
+ Finish_If_Stmt (S_Blk);
+ Close_Temp;
+ S := Get_Next_State (S);
+ end loop;
+
+ -- Check fail state.
+ S := Get_Final_State (NFA);
+ S_Num := Get_State_Label (S);
+ pragma Assert (Integer (S_Num) = Info.Psl_Vect_Len - 1);
+ Start_If_Stmt
+ (S_Blk,
+ New_Value
+ (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Lit (New_Index_Lit
+ (Unsigned_64 (S_Num))))));
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Psl_Assert_Statement =>
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error);
+ when Iir_Kind_Psl_Cover_Statement =>
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Cover, Severity_Level_Note);
+ New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var),
+ New_Lit (Ghdl_Bool_True_Node));
+ when others =>
+ Error_Kind ("Translate_Psl_Directive_Statement", Stmt);
+ end case;
+ Finish_If_Stmt (S_Blk);
+
+ -- Assign state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt
+ (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Obj_Value (Var_I)),
+ New_Value (New_Indexed_Element (New_Obj (Var_Nvec),
+ New_Obj_Value (Var_I))));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ Close_Temp;
+ Finish_If_Stmt (Clk_Blk);
+
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ -- The finalizer.
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Psl_Assert_Statement =>
+ if Psl_Need_Finalizer (NFA) then
+ Create_Psl_Final_Proc (Stmt, Base, Instance);
+
+ Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+
+ S := Get_Final_State (NFA);
+ E := Get_First_Dest_Edge (S);
+ while E /= No_Edge loop
+ Sd := Get_Edge_Src (E);
+
+ if PSL.NFAs.Utils.Has_EOS (Get_Edge_Expr (E)) then
+
+ S_Num := Get_State_Label (Sd);
+ Open_Temp;
+
+ Cond := New_Value
+ (New_Indexed_Element
+ (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (New_Index_Lit (Unsigned_64 (S_Num)))));
+ Cond := New_Dyadic_Op
+ (ON_And, Cond,
+ Translate_Psl_Expr (Get_Edge_Expr (E), True));
+ Start_If_Stmt (E_Blk, Cond);
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error);
+ New_Return_Stmt;
+ Finish_If_Stmt (E_Blk);
+
+ Close_Temp;
+ end if;
+
+ E := Get_Next_Dest_Edge (E);
+ end loop;
+
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ else
+ Info.Psl_Proc_Final_Subprg := O_Dnode_Null;
+ end if;
+
+ when Iir_Kind_Psl_Cover_Statement =>
+ Create_Psl_Final_Proc (Stmt, Base, Instance);
+
+ Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg);
+ Push_Local_Factory;
+ -- Push scope for architecture declarations.
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+
+ Start_If_Stmt
+ (S_Blk,
+ New_Monadic_Op (ON_Not,
+ New_Value (Get_Var (Info.Psl_Bool_Var))));
+ Chap8.Translate_Report
+ (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error);
+ Finish_If_Stmt (S_Blk);
+
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+
+ when others =>
+ Error_Kind ("Translate_Psl_Directive_Statement(3)", Stmt);
+ end case;
+ end Translate_Psl_Directive_Statement;
+
+ -- Create the instance for block BLOCK.
+ -- BLOCK can be either an entity, an architecture or a block statement.
+ procedure Translate_Block_Declarations (Block : Iir; Origin : Iir)
+ is
+ El : Iir;
+ begin
+ Chap4.Translate_Declaration_Chain (Block);
+
+ El := Get_Concurrent_Statement_Chain (Block);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Translate_Process_Declarations (El);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Translate_Psl_Directive_Declarations (El);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Translate_Component_Instantiation_Statement (El);
+ when Iir_Kind_Block_Statement =>
+ declare
+ Info : Block_Info_Acc;
+ Hdr : Iir_Block_Header;
+ Guard : Iir;
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (El));
+
+ Info := Add_Info (El, Kind_Block);
+ Chap1.Start_Block_Decl (El);
+ Push_Instance_Factory (Info.Block_Scope'Access);
+
+ Guard := Get_Guard_Decl (El);
+ if Guard /= Null_Iir then
+ Chap4.Translate_Declaration (Guard);
+ end if;
+
+ -- generics, ports.
+ Hdr := Get_Block_Header (El);
+ if Hdr /= Null_Iir then
+ Chap4.Translate_Generic_Chain (Hdr);
+ Chap4.Translate_Port_Chain (Hdr);
+ end if;
+
+ Chap9.Translate_Block_Declarations (El, Origin);
+
+ Pop_Instance_Factory (Info.Block_Scope'Access);
+ Pop_Identifier_Prefix (Mark);
+
+ -- Create a field in the parent record.
+ Add_Scope_Field
+ (Create_Identifier_Without_Prefix (El),
+ Info.Block_Scope);
+ end;
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Scheme : constant Iir := Get_Generation_Scheme (El);
+ Info : Block_Info_Acc;
+ Mark : Id_Mark_Type;
+ Iter_Type : Iir;
+ It_Info : Ortho_Info_Acc;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (El));
+
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Iter_Type := Get_Type (Scheme);
+ Chap3.Translate_Object_Subtype (Scheme, True);
+ end if;
+
+ Info := Add_Info (El, Kind_Block);
+ Chap1.Start_Block_Decl (El);
+ Push_Instance_Factory (Info.Block_Scope'Access);
+
+ -- Add a parent field in the current instance.
+ Info.Block_Origin_Field := Add_Instance_Factory_Field
+ (Get_Identifier ("ORIGIN"),
+ Get_Info (Origin).Block_Decls_Ptr_Type);
+
+ -- Iterator.
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Info.Block_Configured_Field :=
+ Add_Instance_Factory_Field
+ (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type);
+ It_Info := Add_Info (Scheme, Kind_Iterator);
+ It_Info.Iterator_Var := Create_Var
+ (Create_Var_Identifier (Scheme),
+ Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type
+ (Mode_Value));
+ end if;
+
+ Chap9.Translate_Block_Declarations (El, El);
+
+ Pop_Instance_Factory (Info.Block_Scope'Access);
+
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ -- Create array type of block_decls_type
+ Info.Block_Decls_Array_Type := New_Array_Type
+ (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type);
+ New_Type_Decl (Create_Identifier ("INSTARRTYPE"),
+ Info.Block_Decls_Array_Type);
+ -- Create access to the array type.
+ Info.Block_Decls_Array_Ptr_Type := New_Access_Type
+ (Info.Block_Decls_Array_Type);
+ New_Type_Decl (Create_Identifier ("INSTARRPTR"),
+ Info.Block_Decls_Array_Ptr_Type);
+ -- Add a field in parent record
+ Info.Block_Parent_Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (El),
+ Info.Block_Decls_Array_Ptr_Type);
+ else
+ -- Create an access field in the parent record.
+ Info.Block_Parent_Field := Add_Instance_Factory_Field
+ (Create_Identifier_Without_Prefix (El),
+ Info.Block_Decls_Ptr_Type);
+ end if;
+
+ Pop_Identifier_Prefix (Mark);
+ end;
+ when others =>
+ Error_Kind ("translate_block_declarations", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Translate_Block_Declarations;
+
+ procedure Translate_Component_Instantiation_Subprogram
+ (Stmt : Iir; Base : Block_Info_Acc)
+ is
+ procedure Set_Component_Link (Ref_Scope : Var_Scope_Type;
+ Comp_Field : O_Fnode)
+ is
+ begin
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Selected_Element (Get_Instance_Ref (Ref_Scope),
+ Comp_Field),
+ Rtis.Ghdl_Component_Link_Stmt),
+ New_Lit (Rtis.Get_Context_Rti (Stmt)));
+ end Set_Component_Link;
+
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+
+ Parent : constant Iir := Get_Parent (Stmt);
+ Parent_Info : constant Block_Info_Acc := Get_Info (Parent);
+
+ Comp : Iir;
+ Comp_Info : Comp_Info_Acc;
+ Inter_List : O_Inter_List;
+ Instance : O_Dnode;
+ begin
+ -- Create the elaborator for the instantiation.
+ Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"),
+ O_Storage_Private);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Base.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Info.Block_Elab_Subprg);
+
+ Start_Subprogram_Body (Info.Block_Elab_Subprg);
+ Push_Local_Factory;
+ Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance);
+
+ New_Debug_Line_Stmt (Get_Line_Number (Stmt));
+
+ -- Add access to the instantiation-specific data.
+ -- This is used only for anonymous subtype variables.
+ if Has_Scope_Type (Info.Block_Scope) then
+ Set_Scope_Via_Field (Info.Block_Scope,
+ Info.Block_Parent_Field,
+ Parent_Info.Block_Scope'Access);
+ end if;
+
+ Comp := Get_Instantiated_Unit (Stmt);
+ if Is_Entity_Instantiation (Stmt) then
+ -- This is a direct instantiation.
+ Set_Component_Link (Parent_Info.Block_Scope,
+ Info.Block_Link_Field);
+ Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir);
+ else
+ Comp := Get_Named_Entity (Comp);
+ Comp_Info := Get_Info (Comp);
+ Set_Scope_Via_Field (Comp_Info.Comp_Scope,
+ Info.Block_Link_Field,
+ Parent_Info.Block_Scope'Access);
+
+ -- Set the link from component declaration to component
+ -- instantiation statement.
+ Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link);
+
+ Chap5.Elab_Map_Aspect (Stmt, Comp);
+
+ Clear_Scope (Comp_Info.Comp_Scope);
+ end if;
+
+ if Has_Scope_Type (Info.Block_Scope) then
+ Clear_Scope (Info.Block_Scope);
+ end if;
+
+ Clear_Scope (Base.Block_Scope);
+ Pop_Local_Factory;
+ Finish_Subprogram_Body;
+ end Translate_Component_Instantiation_Subprogram;
+
+ -- Translate concurrent statements into subprograms.
+ procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir)
+ is
+ Base_Info : constant Block_Info_Acc := Get_Info (Base_Block);
+ Stmt : Iir;
+ Mark : Id_Mark_Type;
+ begin
+ Chap4.Translate_Declaration_Chain_Subprograms (Block);
+
+ Stmt := Get_Concurrent_Statement_Chain (Block);
+ while Stmt /= Null_Iir loop
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ if Flag_Direct_Drivers then
+ Chap9.Set_Direct_Drivers (Stmt);
+ end if;
+
+ Chap4.Translate_Declaration_Chain_Subprograms (Stmt);
+ Translate_Process_Statement (Stmt, Base_Info);
+
+ if Flag_Direct_Drivers then
+ Chap9.Reset_Direct_Drivers (Stmt);
+ end if;
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Translate_Psl_Directive_Statement (Stmt, Base_Info);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Chap4.Translate_Association_Subprograms
+ (Stmt, Block, Base_Block,
+ Get_Entity_From_Entity_Aspect
+ (Get_Instantiated_Unit (Stmt)));
+ Translate_Component_Instantiation_Subprogram
+ (Stmt, Base_Info);
+ when Iir_Kind_Block_Statement =>
+ declare
+ Guard : constant Iir := Get_Guard_Decl (Stmt);
+ Hdr : constant Iir := Get_Block_Header (Stmt);
+ begin
+ if Guard /= Null_Iir then
+ Translate_Implicit_Guard_Signal (Guard, Base_Info);
+ end if;
+ if Hdr /= Null_Iir then
+ Chap4.Translate_Association_Subprograms
+ (Hdr, Block, Base_Block, Null_Iir);
+ end if;
+ Translate_Block_Subprograms (Stmt, Base_Block);
+ end;
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+ Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack;
+ begin
+ Chap2.Push_Subprg_Instance (Info.Block_Scope'Access,
+ Info.Block_Decls_Ptr_Type,
+ Wki_Instance,
+ Prev_Subprg_Instance);
+ Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope,
+ Info.Block_Origin_Field,
+ Info.Block_Scope'Access);
+ Translate_Block_Subprograms (Stmt, Stmt);
+ Clear_Scope (Base_Info.Block_Scope);
+ Chap2.Pop_Subprg_Instance
+ (Wki_Instance, Prev_Subprg_Instance);
+ end;
+ when others =>
+ Error_Kind ("translate_block_subprograms", Stmt);
+ end case;
+ Pop_Identifier_Prefix (Mark);
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Translate_Block_Subprograms;
+
+ -- Remove anonymous and implicit type definitions in a list of names.
+ -- Such type definitions are created during slice translations, however
+ -- variables created are defined in the translation scope.
+ -- If the type is referenced again, the variables must be reachable.
+ -- This is not the case for elaborator subprogram (which may references
+ -- slices in the sensitivity or driver list) and the process subprg.
+ procedure Destroy_Types_In_Name (Name : Iir)
+ is
+ El : Iir;
+ Atype : Iir;
+ Info : Type_Info_Acc;
+ begin
+ El := Name;
+ loop
+ Atype := Null_Iir;
+ case Get_Kind (El) is
+ when Iir_Kind_Selected_Element
+ | Iir_Kind_Indexed_Name =>
+ El := Get_Prefix (El);
+ when Iir_Kind_Slice_Name =>
+ Atype := Get_Type (El);
+ El := Get_Prefix (El);
+ when Iir_Kind_Object_Alias_Declaration =>
+ El := Get_Name (El);
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ El := Get_Prefix (El);
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration =>
+ exit;
+ when Iir_Kinds_Denoting_Name =>
+ El := Get_Named_Entity (El);
+ when others =>
+ Error_Kind ("destroy_types_in_name", El);
+ end case;
+ if Atype /= Null_Iir
+ and then Is_Anonymous_Type_Definition (Atype)
+ then
+ Info := Get_Info (Atype);
+ if Info /= null then
+ Free_Type_Info (Info);
+ Clear_Info (Atype);
+ end if;
+ end if;
+ end loop;
+ end Destroy_Types_In_Name;
+
+ procedure Destroy_Types_In_List (List : Iir_List)
+ is
+ El : Iir;
+ begin
+ if List = Null_Iir_List then
+ return;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Destroy_Types_In_Name (El);
+ end loop;
+ end Destroy_Types_In_List;
+
+ procedure Gen_Register_Direct_Driver_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Drv : Mnode)
+ is
+ pragma Unreferenced (Targ_Type);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver);
+ New_Association
+ (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
+ New_Association
+ (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type));
+ New_Procedure_Call (Constr);
+ end Gen_Register_Direct_Driver_Non_Composite;
+
+ function Gen_Register_Direct_Driver_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Val : Mnode)
+ return Mnode
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Val;
+ end Gen_Register_Direct_Driver_Prepare_Data_Composite;
+
+ function Gen_Register_Direct_Driver_Prepare_Data_Record
+ (Targ : Mnode; Targ_Type : Iir; Val : Mnode)
+ return Mnode
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Stabilize (Val);
+ end Gen_Register_Direct_Driver_Prepare_Data_Record;
+
+ function Gen_Register_Direct_Driver_Update_Data_Array
+ (Val : Mnode; Targ_Type : Iir; Index : O_Dnode)
+ return Mnode
+ is
+ begin
+ return Chap3.Index_Base (Chap3.Get_Array_Base (Val),
+ Targ_Type, New_Obj_Value (Index));
+ end Gen_Register_Direct_Driver_Update_Data_Array;
+
+ function Gen_Register_Direct_Driver_Update_Data_Record
+ (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration)
+ return Mnode
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ return Chap6.Translate_Selected_Element (Val, El);
+ end Gen_Register_Direct_Driver_Update_Data_Record;
+
+ procedure Gen_Register_Direct_Driver_Finish_Data_Composite
+ (Data : in out Mnode)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Gen_Register_Direct_Driver_Finish_Data_Composite;
+
+ procedure Gen_Register_Direct_Driver is new Foreach_Non_Composite
+ (Data_Type => Mnode,
+ Composite_Data_Type => Mnode,
+ Do_Non_Composite => Gen_Register_Direct_Driver_Non_Composite,
+ Prepare_Data_Array =>
+ Gen_Register_Direct_Driver_Prepare_Data_Composite,
+ Update_Data_Array => Gen_Register_Direct_Driver_Update_Data_Array,
+ Finish_Data_Array => Gen_Register_Direct_Driver_Finish_Data_Composite,
+ Prepare_Data_Record => Gen_Register_Direct_Driver_Prepare_Data_Record,
+ Update_Data_Record => Gen_Register_Direct_Driver_Update_Data_Record,
+ Finish_Data_Record =>
+ Gen_Register_Direct_Driver_Finish_Data_Composite);
+
+-- procedure Register_Scalar_Direct_Driver (Sig : Mnode;
+-- Sig_Type : Iir;
+-- Drv : Mnode)
+-- is
+-- pragma Unreferenced (Sig_Type);
+-- Constr : O_Assoc_List;
+-- begin
+-- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver);
+-- New_Association
+-- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr));
+-- New_Association
+-- (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type));
+-- New_Procedure_Call (Constr);
+-- end Register_Scalar_Direct_Driver;
+
+ -- PROC: the process to be elaborated
+ -- BASE_INFO: info for the global block
+ procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc)
+ is
+ Info : constant Proc_Info_Acc := Get_Info (Proc);
+ Is_Sensitized : constant Boolean :=
+ Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement;
+ Subprg : O_Dnode;
+ Constr : O_Assoc_List;
+ List : Iir_List;
+ List_Orig : Iir_List;
+ Final : Boolean;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Proc));
+
+ -- Register process.
+ if Is_Sensitized then
+ if Get_Postponed_Flag (Proc) then
+ Subprg := Ghdl_Postponed_Sensitized_Process_Register;
+ else
+ Subprg := Ghdl_Sensitized_Process_Register;
+ end if;
+ else
+ if Get_Postponed_Flag (Proc) then
+ Subprg := Ghdl_Postponed_Process_Register;
+ else
+ Subprg := Ghdl_Process_Register;
+ end if;
+ end if;
+
+ Start_Association (Constr, Subprg);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Process_Subprg,
+ Ghdl_Ptr_Type)));
+ Rtis.Associate_Rti_Context (Constr, Proc);
+ New_Procedure_Call (Constr);
+
+ -- First elaborate declarations since a driver may depend on
+ -- an alias declaration.
+ -- Also, with vhdl 08 a sensitivity element may depend on an alias.
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Proc, Final);
+ Close_Temp;
+
+ -- Register drivers.
+ if Flag_Direct_Drivers then
+ Chap9.Set_Direct_Drivers (Proc);
+
+ declare
+ Sig : Iir;
+ Base : Iir;
+ Sig_Node, Drv_Node : Mnode;
+ begin
+ for I in Info.Process_Drivers.all'Range loop
+ Sig := Info.Process_Drivers (I).Sig;
+ Open_Temp;
+ Base := Get_Object_Prefix (Sig);
+ if Info.Process_Drivers (I).Var /= Null_Var then
+ -- Elaborate direct driver. Done only once.
+ Chap4.Elab_Direct_Driver_Declaration_Storage (Base);
+ end if;
+ if Chap4.Has_Direct_Driver (Base) then
+ -- Signal has a direct driver.
+ Chap6.Translate_Direct_Driver (Sig, Sig_Node, Drv_Node);
+ Gen_Register_Direct_Driver
+ (Sig_Node, Get_Type (Sig), Drv_Node);
+ else
+ Register_Signal (Chap6.Translate_Name (Sig),
+ Get_Type (Sig),
+ Ghdl_Process_Add_Driver);
+ end if;
+ Close_Temp;
+ end loop;
+ end;
+
+ Chap9.Reset_Direct_Drivers (Proc);
+ else
+ List := Trans_Analyzes.Extract_Drivers (Proc);
+ Destroy_Types_In_List (List);
+ Register_Signal_List (List, Ghdl_Process_Add_Driver);
+ if Flag_Dump_Drivers then
+ Trans_Analyzes.Dump_Drivers (Proc, List);
+ end if;
+ Trans_Analyzes.Free_Drivers_List (List);
+ end if;
+
+ if Is_Sensitized then
+ List_Orig := Get_Sensitivity_List (Proc);
+ if List_Orig = Iir_List_All then
+ List := Canon.Canon_Extract_Process_Sensitivity (Proc);
+ else
+ List := List_Orig;
+ end if;
+ Destroy_Types_In_List (List);
+ Register_Signal_List (List, Ghdl_Process_Add_Sensitivity);
+ if List_Orig = Iir_List_All then
+ Destroy_Iir_List (List);
+ end if;
+ end if;
+ end Elab_Process;
+
+ -- PROC: the process to be elaborated
+ -- BLOCK: the block containing the process (its parent)
+ -- BASE_INFO: info for the global block
+ procedure Elab_Psl_Directive (Stmt : Iir;
+ Base_Info : Block_Info_Acc)
+ is
+ Info : constant Psl_Info_Acc := Get_Info (Stmt);
+ Constr : O_Assoc_List;
+ List : Iir_List;
+ Clk : PSL_Node;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Stmt));
+
+ -- Register process.
+ Start_Association (Constr, Ghdl_Sensitized_Process_Register);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg,
+ Ghdl_Ptr_Type)));
+ Rtis.Associate_Rti_Context (Constr, Stmt);
+ New_Procedure_Call (Constr);
+
+ -- Register clock sensitivity.
+ Clk := Get_PSL_Clock (Stmt);
+ List := Create_Iir_List;
+ Canon_PSL.Canon_Extract_Sensitivity (Clk, List);
+ Destroy_Types_In_List (List);
+ Register_Signal_List (List, Ghdl_Process_Add_Sensitivity);
+ Destroy_Iir_List (List);
+
+ -- Register finalizer (if any).
+ if Info.Psl_Proc_Final_Subprg /= O_Dnode_Null then
+ Start_Association (Constr, Ghdl_Finalize_Register);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Base_Info.Block_Scope),
+ Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Psl_Proc_Final_Subprg,
+ Ghdl_Ptr_Type)));
+ New_Procedure_Call (Constr);
+ end if;
+
+ -- Initialize state vector.
+ Start_Declare_Stmt;
+ New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type);
+ New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Lit (Ghdl_Index_0)),
+ New_Lit (Std_Boolean_True_Node));
+ New_Assign_Stmt (New_Obj (Var_I), New_Lit (Ghdl_Index_1));
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Var_I),
+ New_Lit (New_Unsigned_Literal
+ (Ghdl_Index_Type,
+ Unsigned_64 (Info.Psl_Vect_Len))),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Indexed_Element (Get_Var (Info.Psl_Vect_Var),
+ New_Obj_Value (Var_I)),
+ New_Lit (Std_Boolean_False_Node));
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Finish_Declare_Stmt;
+
+ if Info.Psl_Bool_Var /= Null_Var then
+ New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var),
+ New_Lit (Ghdl_Bool_False_Node));
+ end if;
+ end Elab_Psl_Directive;
+
+ procedure Elab_Implicit_Guard_Signal
+ (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc)
+ is
+ Guard : Iir;
+ Type_Info : Type_Info_Acc;
+ Info : Object_Info_Acc;
+ Constr : O_Assoc_List;
+ begin
+ -- Create the guard signal.
+ Guard := Get_Guard_Decl (Block);
+ Info := Get_Info (Guard);
+ Type_Info := Get_Info (Get_Type (Guard));
+ Start_Association (Constr, Ghdl_Signal_Create_Guard);
+ New_Association
+ (Constr, New_Unchecked_Address
+ (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type));
+ New_Association
+ (Constr,
+ New_Lit (New_Subprogram_Address (Info.Object_Function,
+ Ghdl_Ptr_Type)));
+-- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block));
+ New_Assign_Stmt (Get_Var (Info.Object_Var),
+ New_Convert_Ov (New_Function_Call (Constr),
+ Type_Info.Ortho_Type (Mode_Signal)));
+
+ -- Register sensitivity list of the guard signal.
+ Register_Signal_List (Get_Guard_Sensitivity_List (Guard),
+ Ghdl_Signal_Guard_Dependence);
+ end Elab_Implicit_Guard_Signal;
+
+ procedure Translate_Entity_Instantiation
+ (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir)
+ is
+ Entity_Unit : Iir_Design_Unit;
+ Config : Iir;
+ Arch : Iir;
+ Entity : Iir_Entity_Declaration;
+ Entity_Info : Block_Info_Acc;
+ Arch_Info : Block_Info_Acc;
+
+ Instance_Size : O_Dnode;
+ Arch_Elab : O_Dnode;
+ Arch_Config : O_Dnode;
+ Arch_Config_Type : O_Tnode;
+
+ Var_Sub : O_Dnode;
+ begin
+ -- Extract entity, architecture and configuration from
+ -- binding aspect.
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Entity := Get_Entity (Aspect);
+ Arch := Get_Architecture (Aspect);
+ if Flags.Flag_Elaborate and then Arch = Null_Iir then
+ -- This is valid only during elaboration.
+ Arch := Libraries.Get_Latest_Architecture (Entity);
+ end if;
+ Config := Null_Iir;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Config := Get_Configuration (Aspect);
+ Entity := Get_Entity (Config);
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (Config));
+ when Iir_Kind_Entity_Aspect_Open =>
+ return;
+ when others =>
+ Error_Kind ("translate_entity_instantiation", Aspect);
+ end case;
+ Entity_Unit := Get_Design_Unit (Entity);
+ Entity_Info := Get_Info (Entity);
+ if Config_Override /= Null_Iir then
+ Config := Config_Override;
+ if Get_Kind (Arch) = Iir_Kind_Simple_Name then
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (Config));
+ end if;
+ end if;
+
+ -- 1) Create instance for the arch
+ if Arch /= Null_Iir then
+ Arch_Info := Get_Info (Arch);
+ if Config = Null_Iir
+ and then Get_Kind (Arch) = Iir_Kind_Architecture_Body
+ then
+ Config := Get_Default_Configuration_Declaration (Arch);
+ if Config /= Null_Iir then
+ Config := Get_Library_Unit (Config);
+ end if;
+ end if;
+ else
+ Arch_Info := null;
+ end if;
+ if Arch_Info = null or Config = Null_Iir then
+ declare
+ function Get_Arch_Name return String is
+ begin
+ if Arch /= Null_Iir then
+ return "ARCH__" & Image_Identifier (Arch);
+ else
+ return "LASTARCH";
+ end if;
+ end Get_Arch_Name;
+
+ Str : constant String :=
+ Image_Identifier (Get_Library (Get_Design_File (Entity_Unit)))
+ & "__" & Image_Identifier (Entity) & "__"
+ & Get_Arch_Name & "__";
+ Sub_Inter : O_Inter_List;
+ Arg : O_Dnode;
+ begin
+ if Arch_Info = null then
+ New_Const_Decl
+ (Instance_Size, Get_Identifier (Str & "INSTSIZE"),
+ O_Storage_External, Ghdl_Index_Type);
+
+ Start_Procedure_Decl
+ (Sub_Inter, Get_Identifier (Str & "ELAB"),
+ O_Storage_External);
+ New_Interface_Decl (Sub_Inter, Arg, Wki_Instance,
+ Entity_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Sub_Inter, Arch_Elab);
+ end if;
+
+ if Config = Null_Iir then
+ Start_Procedure_Decl
+ (Sub_Inter, Get_Identifier (Str & "DEFAULT_CONFIG"),
+ O_Storage_External);
+ New_Interface_Decl (Sub_Inter, Arg, Wki_Instance,
+ Entity_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Sub_Inter, Arch_Config);
+
+ Arch_Config_Type := Entity_Info.Block_Decls_Ptr_Type;
+ end if;
+ end;
+ end if;
+
+ if Arch_Info = null then
+ if Config /= Null_Iir then
+ -- Architecture is unknown, but we know how to configure
+ -- the block inside it.
+ raise Internal_Error;
+ end if;
+ else
+ Instance_Size := Arch_Info.Block_Instance_Size;
+ Arch_Elab := Arch_Info.Block_Elab_Subprg;
+ if Config /= Null_Iir then
+ Arch_Config := Get_Info (Config).Config_Subprg;
+ Arch_Config_Type := Arch_Info.Block_Decls_Ptr_Type;
+ end if;
+ end if;
+
+ -- Create the instance variable and allocate storage.
+ New_Var_Decl (Var_Sub, Get_Identifier ("SUB_INSTANCE"),
+ O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type);
+
+ New_Assign_Stmt
+ (New_Obj (Var_Sub),
+ Gen_Alloc (Alloc_System, New_Obj_Value (Instance_Size),
+ Entity_Info.Block_Decls_Ptr_Type));
+
+ -- 1.5) link instance.
+ declare
+ procedure Set_Links (Ref_Scope : Var_Scope_Type;
+ Link_Field : O_Fnode)
+ is
+ begin
+ -- Set the ghdl_component_link_instance field.
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Selected_Element (Get_Instance_Ref (Ref_Scope),
+ Link_Field),
+ Rtis.Ghdl_Component_Link_Instance),
+ New_Address (New_Selected_Acc_Value
+ (New_Obj (Var_Sub),
+ Entity_Info.Block_Link_Field),
+ Rtis.Ghdl_Entity_Link_Acc));
+ -- Set the ghdl_entity_link_parent field.
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Selected_Acc_Value (New_Obj (Var_Sub),
+ Entity_Info.Block_Link_Field),
+ Rtis.Ghdl_Entity_Link_Parent),
+ New_Address
+ (New_Selected_Element (Get_Instance_Ref (Ref_Scope),
+ Link_Field),
+ Rtis.Ghdl_Component_Link_Acc));
+ end Set_Links;
+ begin
+ case Get_Kind (Parent) is
+ when Iir_Kind_Component_Declaration =>
+ -- Instantiation via a component declaration.
+ declare
+ Comp_Info : constant Comp_Info_Acc := Get_Info (Parent);
+ begin
+ Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link);
+ end;
+ when Iir_Kind_Component_Instantiation_Statement =>
+ -- Direct instantiation.
+ declare
+ Parent_Info : constant Block_Info_Acc :=
+ Get_Info (Get_Parent (Parent));
+ begin
+ Set_Links (Parent_Info.Block_Scope,
+ Get_Info (Parent).Block_Link_Field);
+ end;
+ when others =>
+ Error_Kind ("translate_entity_instantiation(1)", Parent);
+ end case;
+ end;
+
+ -- Elab entity packages.
+ declare
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg);
+ New_Procedure_Call (Assoc);
+ end;
+
+ -- Elab map aspects.
+ Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub);
+ Chap5.Elab_Map_Aspect (Mapping, Entity);
+ Clear_Scope (Entity_Info.Block_Scope);
+
+ -- 3) Elab instance.
+ declare
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Arch_Elab);
+ New_Association (Assoc, New_Obj_Value (Var_Sub));
+ New_Procedure_Call (Assoc);
+ end;
+
+ -- 5) Configure
+ declare
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Arch_Config);
+ New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Var_Sub),
+ Arch_Config_Type));
+ New_Procedure_Call (Assoc);
+ end;
+ end Translate_Entity_Instantiation;
+
+ procedure Elab_Conditionnal_Generate_Statement
+ (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir)
+ is
+ Scheme : constant Iir := Get_Generation_Scheme (Stmt);
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+ Parent_Info : constant Block_Info_Acc := Get_Info (Parent);
+ Var : O_Dnode;
+ Blk : O_If_Block;
+ V : O_Lnode;
+ begin
+ Open_Temp;
+
+ Var := Create_Temp (Info.Block_Decls_Ptr_Type);
+ Start_If_Stmt (Blk, Chap7.Translate_Expression (Scheme));
+ New_Assign_Stmt
+ (New_Obj (Var),
+ Gen_Alloc (Alloc_System,
+ New_Lit (Get_Scope_Size (Info.Block_Scope)),
+ Info.Block_Decls_Ptr_Type));
+ New_Else_Stmt (Blk);
+ New_Assign_Stmt
+ (New_Obj (Var),
+ New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)));
+ Finish_If_Stmt (Blk);
+
+ -- Add a link to child in parent.
+ V := Get_Instance_Ref (Parent_Info.Block_Scope);
+ V := New_Selected_Element (V, Info.Block_Parent_Field);
+ New_Assign_Stmt (V, New_Obj_Value (Var));
+
+ Start_If_Stmt
+ (Blk,
+ New_Compare_Op
+ (ON_Neq,
+ New_Obj_Value (Var),
+ New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)),
+ Ghdl_Bool_Type));
+ -- Add a link to parent in child.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field),
+ Get_Instance_Access (Base_Block));
+ -- Elaborate block
+ Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var);
+ Elab_Block_Declarations (Stmt, Stmt);
+ Clear_Scope (Info.Block_Scope);
+ Finish_If_Stmt (Blk);
+ Close_Temp;
+ end Elab_Conditionnal_Generate_Statement;
+
+ procedure Elab_Iterative_Generate_Statement
+ (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir)
+ is
+ Scheme : constant Iir := Get_Generation_Scheme (Stmt);
+ Iter_Type : constant Iir := Get_Type (Scheme);
+ Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type);
+ Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type);
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+ Parent_Info : constant Block_Info_Acc := Get_Info (Parent);
+-- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block);
+ Var_Inst : O_Dnode;
+ Var_I : O_Dnode;
+ Label : O_Snode;
+ V : O_Lnode;
+ Var : O_Dnode;
+ Range_Ptr : O_Dnode;
+ begin
+ Open_Temp;
+
+ -- Evaluate iterator range.
+ Chap3.Elab_Object_Subtype (Iter_Type);
+
+ Range_Ptr := Create_Temp_Ptr
+ (Iter_Type_Info.T.Range_Ptr_Type,
+ Get_Var (Get_Info (Iter_Type).T.Range_Var));
+
+ -- Allocate instances.
+ Var_Inst := Create_Temp (Info.Block_Decls_Array_Ptr_Type);
+ New_Assign_Stmt
+ (New_Obj (Var_Inst),
+ Gen_Alloc
+ (Alloc_System,
+ New_Dyadic_Op (ON_Mul_Ov,
+ New_Value_Selected_Acc_Value
+ (New_Obj (Range_Ptr),
+ Iter_Type_Info.T.Range_Length),
+ New_Lit (Get_Scope_Size (Info.Block_Scope))),
+ Info.Block_Decls_Array_Ptr_Type));
+
+ -- Add a link to child in parent.
+ V := Get_Instance_Ref (Parent_Info.Block_Scope);
+ V := New_Selected_Element (V, Info.Block_Parent_Field);
+ New_Assign_Stmt (V, New_Obj_Value (Var_Inst));
+
+ -- Start loop.
+ Var_I := Create_Temp (Ghdl_Index_Type);
+ Init_Var (Var_I);
+ Start_Loop_Stmt (Label);
+ Gen_Exit_When
+ (Label,
+ New_Compare_Op (ON_Eq,
+ New_Obj_Value (Var_I),
+ New_Value_Selected_Acc_Value
+ (New_Obj (Range_Ptr),
+ Iter_Type_Info.T.Range_Length),
+ Ghdl_Bool_Type));
+
+ Var := Create_Temp_Ptr
+ (Info.Block_Decls_Ptr_Type,
+ New_Indexed_Element (New_Acc_Value (New_Obj (Var_Inst)),
+ New_Obj_Value (Var_I)));
+ -- Add a link to parent in child.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field),
+ Get_Instance_Access (Base_Block));
+ -- Mark the block as not (yet) configured.
+ New_Assign_Stmt
+ (New_Selected_Acc_Value (New_Obj (Var),
+ Info.Block_Configured_Field),
+ New_Lit (Ghdl_Bool_False_Node));
+
+ -- Elaborate block
+ Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var);
+ -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope,
+ -- Info.Block_Origin_Field,
+ -- Info.Block_Scope'Access);
+
+ -- Set iterator value.
+ -- FIXME: this could be slighly optimized...
+ declare
+ Val : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Val := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value));
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Eq,
+ New_Value_Selected_Acc_Value
+ (New_Obj (Range_Ptr),
+ Iter_Type_Info.T.Range_Dir),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value
+ (New_Obj (Range_Ptr),
+ Iter_Type_Info.T.Range_Left));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value
+ (New_Obj (Range_Ptr),
+ Iter_Type_Info.T.Range_Right));
+ Finish_If_Stmt (If_Blk);
+
+ New_Assign_Stmt
+ (Get_Var (Get_Info (Scheme).Iterator_Var),
+ New_Dyadic_Op
+ (ON_Add_Ov,
+ New_Obj_Value (Val),
+ New_Convert_Ov (New_Obj_Value (Var_I),
+ Iter_Type_Info.Ortho_Type (Mode_Value))));
+ end;
+
+ -- Elaboration.
+ Elab_Block_Declarations (Stmt, Stmt);
+
+-- Clear_Scope (Base_Info.Block_Scope);
+ Clear_Scope (Info.Block_Scope);
+
+ Inc_Var (Var_I);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ end Elab_Iterative_Generate_Statement;
+
+ type Merge_Signals_Data is record
+ Sig : Iir;
+ Set_Init : Boolean;
+ Has_Val : Boolean;
+ Val : Mnode;
+ end record;
+
+ procedure Merge_Signals_Rti_Non_Composite (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Merge_Signals_Data)
+ is
+ Type_Info : Type_Info_Acc;
+ Sig : Mnode;
+
+ Init_Subprg : O_Dnode;
+ Conv : O_Tnode;
+ Assoc : O_Assoc_List;
+ Init_Val : O_Enode;
+ begin
+ Type_Info := Get_Info (Targ_Type);
+
+ Open_Temp;
+
+ if Data.Set_Init then
+ case Type_Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Init_Subprg := Ghdl_Signal_Init_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Init_Subprg := Ghdl_Signal_Init_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Init_Subprg := Ghdl_Signal_Init_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Init_Subprg := Ghdl_Signal_Init_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Init_Subprg := Ghdl_Signal_Init_I64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Init_Subprg := Ghdl_Signal_Init_F64;
+ Conv := Ghdl_Real_Type;
+ when others =>
+ Error_Kind ("merge_signals_rti_non_composite", Targ_Type);
+ end case;
+
+ Sig := Stabilize (Targ, True);
+
+ -- Init the signal.
+ Start_Association (Assoc, Init_Subprg);
+ New_Association
+ (Assoc,
+ New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr));
+ if Data.Has_Val then
+ Init_Val := M2E (Data.Val);
+ else
+ Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type);
+ end if;
+ New_Association (Assoc, New_Convert_Ov (Init_Val, Conv));
+ New_Procedure_Call (Assoc);
+ else
+ Sig := Targ;
+ end if;
+
+ Start_Association (Assoc, Ghdl_Signal_Merge_Rti);
+
+ New_Association
+ (Assoc, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr));
+ New_Association
+ (Assoc,
+ New_Lit (New_Global_Unchecked_Address
+ (Get_Info (Data.Sig).Object_Rti,
+ Rtis.Ghdl_Rti_Access)));
+ New_Procedure_Call (Assoc);
+ Close_Temp;
+ end Merge_Signals_Rti_Non_Composite;
+
+ function Merge_Signals_Rti_Prepare (Targ : Mnode;
+ Targ_Type : Iir;
+ Data : Merge_Signals_Data)
+ return Merge_Signals_Data
+ is
+ pragma Unreferenced (Targ);
+ pragma Unreferenced (Targ_Type);
+ Res : Merge_Signals_Data;
+ begin
+ Res := Data;
+ if Data.Has_Val then
+ if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then
+ Res.Val := Stabilize (Data.Val);
+ else
+ Res.Val := Chap3.Get_Array_Base (Data.Val);
+ end if;
+ end if;
+
+ return Res;
+ end Merge_Signals_Rti_Prepare;
+
+ function Merge_Signals_Rti_Update_Data_Array
+ (Data : Merge_Signals_Data; Targ_Type : Iir; Index : O_Dnode)
+ return Merge_Signals_Data
+ is
+ begin
+ if not Data.Has_Val then
+ return Data;
+ else
+ return Merge_Signals_Data'
+ (Sig => Data.Sig,
+ Val => Chap3.Index_Base (Data.Val, Targ_Type,
+ New_Obj_Value (Index)),
+ Has_Val => True,
+ Set_Init => Data.Set_Init);
+ end if;
+ end Merge_Signals_Rti_Update_Data_Array;
+
+ procedure Merge_Signals_Rti_Finish_Data_Composite
+ (Data : in out Merge_Signals_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Merge_Signals_Rti_Finish_Data_Composite;
+
+ function Merge_Signals_Rti_Update_Data_Record
+ (Data : Merge_Signals_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration) return Merge_Signals_Data
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ if not Data.Has_Val then
+ return Data;
+ else
+ return Merge_Signals_Data'
+ (Sig => Data.Sig,
+ Val => Chap6.Translate_Selected_Element (Data.Val, El),
+ Has_Val => True,
+ Set_Init => Data.Set_Init);
+ end if;
+ end Merge_Signals_Rti_Update_Data_Record;
+
+ pragma Inline (Merge_Signals_Rti_Finish_Data_Composite);
+
+ procedure Merge_Signals_Rti is new Foreach_Non_Composite
+ (Data_Type => Merge_Signals_Data,
+ Composite_Data_Type => Merge_Signals_Data,
+ Do_Non_Composite => Merge_Signals_Rti_Non_Composite,
+ Prepare_Data_Array => Merge_Signals_Rti_Prepare,
+ Update_Data_Array => Merge_Signals_Rti_Update_Data_Array,
+ Finish_Data_Array => Merge_Signals_Rti_Finish_Data_Composite,
+ Prepare_Data_Record => Merge_Signals_Rti_Prepare,
+ Update_Data_Record => Merge_Signals_Rti_Update_Data_Record,
+ Finish_Data_Record => Merge_Signals_Rti_Finish_Data_Composite);
+
+ procedure Merge_Signals_Rti_Of_Port_Chain (Chain : Iir)
+ is
+ Port : Iir;
+ Port_Type : Iir;
+ Data : Merge_Signals_Data;
+ Val : Iir;
+ begin
+ Port := Chain;
+ while Port /= Null_Iir loop
+ Port_Type := Get_Type (Port);
+ Data.Sig := Port;
+ case Get_Mode (Port) is
+ when Iir_Buffer_Mode
+ | Iir_Out_Mode
+ | Iir_Inout_Mode =>
+ Data.Set_Init := True;
+ when others =>
+ Data.Set_Init := False;
+ end case;
+
+ Open_Temp;
+ Val := Get_Default_Value (Port);
+ if Val = Null_Iir then
+ Data.Has_Val := False;
+ else
+ Data.Has_Val := True;
+ Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type),
+ Get_Info (Port_Type),
+ Mode_Value);
+ end if;
+
+ Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data);
+ Close_Temp;
+
+ Port := Get_Chain (Port);
+ end loop;
+ end Merge_Signals_Rti_Of_Port_Chain;
+
+ procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir)
+ is
+ Base_Info : constant Block_Info_Acc := Get_Info (Base_Block);
+ Stmt : Iir;
+ Final : Boolean;
+ begin
+ New_Debug_Line_Stmt (Get_Line_Number (Block));
+
+ case Get_Kind (Block) is
+ when Iir_Kind_Entity_Declaration =>
+ Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Block));
+ when Iir_Kind_Architecture_Body =>
+ null;
+ when Iir_Kind_Block_Statement =>
+ declare
+ Header : constant Iir_Block_Header :=
+ Get_Block_Header (Block);
+ Guard : constant Iir := Get_Guard_Decl (Block);
+ begin
+ if Guard /= Null_Iir then
+ New_Debug_Line_Stmt (Get_Line_Number (Guard));
+ Elab_Implicit_Guard_Signal (Block, Base_Info);
+ end if;
+ if Header /= Null_Iir then
+ New_Debug_Line_Stmt (Get_Line_Number (Header));
+ Chap5.Elab_Map_Aspect (Header, Block);
+ Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Header));
+ end if;
+ end;
+ when Iir_Kind_Generate_Statement =>
+ null;
+ when others =>
+ Error_Kind ("elab_block_declarations", Block);
+ end case;
+
+ Open_Temp;
+ Chap4.Elab_Declaration_Chain (Block, Final);
+ Close_Temp;
+
+ Stmt := Get_Concurrent_Statement_Chain (Block);
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Elab_Process (Stmt, Base_Info);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Elab_Psl_Directive (Stmt, Base_Info);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ declare
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+ Constr : O_Assoc_List;
+ begin
+ Start_Association (Constr, Info.Block_Elab_Subprg);
+ New_Association
+ (Constr, Get_Instance_Access (Base_Block));
+ New_Procedure_Call (Constr);
+ end;
+ when Iir_Kind_Block_Statement =>
+ declare
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Elab_Block_Declarations (Stmt, Base_Block);
+ Pop_Identifier_Prefix (Mark);
+ end;
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+
+ if Get_Kind (Get_Generation_Scheme (Stmt))
+ = Iir_Kind_Iterator_Declaration
+ then
+ Elab_Iterative_Generate_Statement
+ (Stmt, Block, Base_Block);
+ else
+ Elab_Conditionnal_Generate_Statement
+ (Stmt, Block, Base_Block);
+ end if;
+ Pop_Identifier_Prefix (Mark);
+ end;
+ when others =>
+ Error_Kind ("elab_block_declarations", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Elab_Block_Declarations;
+ end Chap9;
+
+ package body Chap10 is
+ -- Identifiers.
+ -- The following functions are helpers to create ortho identifiers.
+ Identifier_Buffer : String (1 .. 512);
+ Identifier_Len : Natural := 0;
+ Identifier_Start : Natural := 1;
+ Identifier_Local : Local_Identifier_Type := 0;
+
+
+ Inst_Build : Inst_Build_Acc := null;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Object => Inst_Build_Type, Name => Inst_Build_Acc);
+
+ procedure Set_Global_Storage (Storage : O_Storage) is
+ begin
+ Global_Storage := Storage;
+ end Set_Global_Storage;
+
+ procedure Pop_Build_Instance
+ is
+ Old : Inst_Build_Acc;
+ begin
+ Old := Inst_Build;
+ Identifier_Start := Old.Prev_Id_Start;
+ Inst_Build := Old.Prev;
+ Unchecked_Deallocation (Old);
+ end Pop_Build_Instance;
+
+ function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is
+ begin
+ pragma Assert (Scope.Scope_Type /= O_Tnode_Null);
+ return Scope.Scope_Type;
+ end Get_Scope_Type;
+
+ function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is
+ begin
+ pragma Assert (Scope.Scope_Type /= O_Tnode_Null);
+ return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type);
+ end Get_Scope_Size;
+
+ function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is
+ begin
+ return Scope.Scope_Type /= O_Tnode_Null;
+ end Has_Scope_Type;
+
+ procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident)
+ is
+ begin
+ pragma Assert (Scope.Scope_Type = O_Tnode_Null);
+ New_Uncomplete_Record_Type (Scope.Scope_Type);
+ New_Type_Decl (Name, Scope.Scope_Type);
+ end Predeclare_Scope_Type;
+
+ procedure Declare_Scope_Acc
+ (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is
+ begin
+ Ptr_Type := New_Access_Type (Get_Scope_Type (Scope));
+ New_Type_Decl (Name, Ptr_Type);
+ end Declare_Scope_Acc;
+
+ procedure Push_Instance_Factory (Scope : Var_Scope_Acc)
+ is
+ Inst : Inst_Build_Acc;
+ begin
+ if Inst_Build /= null and then Inst_Build.Kind /= Instance then
+ raise Internal_Error;
+ end if;
+ Inst := new Inst_Build_Type (Instance);
+ Inst.Prev := Inst_Build;
+ Inst.Prev_Id_Start := Identifier_Start;
+ Inst.Scope := Scope;
+
+ Identifier_Start := Identifier_Len + 1;
+
+ if Scope.Scope_Type /= O_Tnode_Null then
+ Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements);
+ else
+ Start_Record_Type (Inst.Elements);
+ end if;
+ Inst_Build := Inst;
+ end Push_Instance_Factory;
+
+ function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode)
+ return O_Fnode
+ is
+ Res : O_Fnode;
+ begin
+ New_Record_Field (Inst_Build.Elements, Res, Name, Ftype);
+ return Res;
+ end Add_Instance_Factory_Field;
+
+ procedure Add_Scope_Field
+ (Name : O_Ident; Child : in out Var_Scope_Type)
+ is
+ Field : O_Fnode;
+ begin
+ Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child));
+ Set_Scope_Via_Field (Child, Field, Inst_Build.Scope);
+ end Add_Scope_Field;
+
+ function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode)
+ return O_Cnode is
+ begin
+ return New_Offsetof (Get_Scope_Type (Child.Up_Link.all),
+ Child.Field, Otype);
+ end Get_Scope_Offset;
+
+ procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc)
+ is
+ Res : O_Tnode;
+ begin
+ if Inst_Build.Kind /= Instance then
+ -- Not matching.
+ raise Internal_Error;
+ end if;
+ Finish_Record_Type (Inst_Build.Elements, Res);
+ Pop_Build_Instance;
+ Scope.Scope_Type := Res;
+ end Pop_Instance_Factory;
+
+ procedure Push_Local_Factory
+ is
+ Inst : Inst_Build_Acc;
+ begin
+ if Inst_Build /= null
+ and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local)
+ then
+ -- Cannot create a local factory on an instance.
+ raise Internal_Error;
+ end if;
+ Inst := new Inst_Build_Type (Kind => Local);
+ Inst.Prev := Inst_Build;
+ Inst.Prev_Global_Storage := Global_Storage;
+
+ Inst.Prev_Id_Start := Identifier_Start;
+ Identifier_Start := Identifier_Len + 1;
+
+ Inst_Build := Inst;
+ case Global_Storage is
+ when O_Storage_Public =>
+ Global_Storage := O_Storage_Private;
+ when O_Storage_Private
+ | O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ raise Internal_Error;
+ end case;
+ end Push_Local_Factory;
+
+ -- Return TRUE is the current scope is local.
+ function Is_Local_Scope return Boolean is
+ begin
+ if Inst_Build = null then
+ return False;
+ end if;
+ case Inst_Build.Kind is
+ when Local
+ | Instance =>
+ return True;
+ when Global =>
+ return False;
+ end case;
+ end Is_Local_Scope;
+
+ procedure Pop_Local_Factory is
+ begin
+ if Inst_Build.Kind /= Local then
+ -- Not matching.
+ raise Internal_Error;
+ end if;
+ Global_Storage := Inst_Build.Prev_Global_Storage;
+ Pop_Build_Instance;
+ end Pop_Local_Factory;
+
+ procedure Set_Scope_Via_Field
+ (Scope : in out Var_Scope_Type;
+ Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is
+ begin
+ pragma Assert (Scope.Kind = Var_Scope_None);
+ Scope := (Scope_Type => Scope.Scope_Type,
+ Kind => Var_Scope_Field,
+ Field => Scope_Field, Up_Link => Scope_Parent);
+ end Set_Scope_Via_Field;
+
+ procedure Set_Scope_Via_Field_Ptr
+ (Scope : in out Var_Scope_Type;
+ Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is
+ begin
+ pragma Assert (Scope.Kind = Var_Scope_None);
+ Scope := (Scope_Type => Scope.Scope_Type,
+ Kind => Var_Scope_Field_Ptr,
+ Field => Scope_Field, Up_Link => Scope_Parent);
+ end Set_Scope_Via_Field_Ptr;
+
+ procedure Set_Scope_Via_Var_Ptr
+ (Scope : in out Var_Scope_Type; Var : Var_Type) is
+ begin
+ pragma Assert (Scope.Kind = Var_Scope_None);
+ pragma Assert (Var.Kind = Var_Scope);
+ Scope := (Scope_Type => Scope.Scope_Type,
+ Kind => Var_Scope_Field_Ptr,
+ Field => Var.I_Field, Up_Link => Var.I_Scope);
+ end Set_Scope_Via_Var_Ptr;
+
+ procedure Set_Scope_Via_Param_Ptr
+ (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is
+ begin
+ pragma Assert (Scope.Kind = Var_Scope_None);
+ Scope := (Scope_Type => Scope.Scope_Type,
+ Kind => Var_Scope_Ptr, D => Scope_Param);
+ end Set_Scope_Via_Param_Ptr;
+
+ procedure Set_Scope_Via_Decl
+ (Scope : in out Var_Scope_Type; Decl : O_Dnode) is
+ begin
+ pragma Assert (Scope.Kind = Var_Scope_None);
+ Scope := (Scope_Type => Scope.Scope_Type,
+ Kind => Var_Scope_Decl, D => Decl);
+ end Set_Scope_Via_Decl;
+
+ procedure Clear_Scope (Scope : in out Var_Scope_Type) is
+ begin
+ pragma Assert (Scope.Kind /= Var_Scope_None);
+ Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None);
+ end Clear_Scope;
+
+ function Create_Global_Var
+ (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage)
+ return Var_Type
+ is
+ Var : O_Dnode;
+ begin
+ New_Var_Decl (Var, Name, Storage, Vtype);
+ return Var_Type'(Kind => Var_Global, E => Var);
+ end Create_Global_Var;
+
+ function Create_Global_Const
+ (Name : O_Ident;
+ Vtype : O_Tnode;
+ Storage : O_Storage;
+ Initial_Value : O_Cnode)
+ return Var_Type
+ is
+ Res : O_Dnode;
+ begin
+ New_Const_Decl (Res, Name, Storage, Vtype);
+ if Storage /= O_Storage_External
+ and then Initial_Value /= O_Cnode_Null
+ then
+ Start_Const_Value (Res);
+ Finish_Const_Value (Res, Initial_Value);
+ end if;
+ return Var_Type'(Kind => Var_Global, E => Res);
+ end Create_Global_Const;
+
+ procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is
+ begin
+ Start_Const_Value (Const.E);
+ Finish_Const_Value (Const.E, Val);
+ end Define_Global_Const;
+
+ function Create_Var
+ (Name : Var_Ident_Type;
+ Vtype : O_Tnode;
+ Storage : O_Storage := Global_Storage)
+ return Var_Type
+ is
+ Res : O_Dnode;
+ Field : O_Fnode;
+ K : Inst_Build_Kind_Type;
+ begin
+ if Inst_Build = null then
+ K := Global;
+ else
+ K := Inst_Build.Kind;
+ end if;
+ case K is
+ when Global =>
+ -- The global scope is in use...
+ return Create_Global_Var (Name.Id, Vtype, Storage);
+ when Local =>
+ -- It is always possible to create a variable in a local scope.
+ -- Create a var.
+ New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype);
+ return Var_Type'(Kind => Var_Local, E => Res);
+ when Instance =>
+ -- Create a field.
+ New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype);
+ return Var_Type'(Kind => Var_Scope, I_Field => Field,
+ I_Scope => Inst_Build.Scope);
+ end case;
+ end Create_Var;
+
+ -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access
+ -- to the scope, otherwise RES directly designates the scope.
+ procedure Find_Scope (Scope : Var_Scope_Type;
+ Res : out O_Lnode;
+ Is_Ptr : out Boolean) is
+ begin
+ case Scope.Kind is
+ when Var_Scope_None =>
+ raise Internal_Error;
+ when Var_Scope_Ptr
+ | Var_Scope_Decl =>
+ Res := New_Obj (Scope.D);
+ Is_Ptr := Scope.Kind = Var_Scope_Ptr;
+ when Var_Scope_Field
+ | Var_Scope_Field_Ptr =>
+ declare
+ Parent : O_Lnode;
+ Parent_Ptr : Boolean;
+ begin
+ Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr);
+ if Parent_Ptr then
+ Parent := New_Acc_Value (Parent);
+ end if;
+ Res := New_Selected_Element (Parent, Scope.Field);
+ Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr;
+ end;
+ end case;
+ end Find_Scope;
+
+ procedure Check_Not_Building is
+ begin
+ -- Variables cannot be referenced if there is an instance being
+ -- built.
+ if Inst_Build /= null and then Inst_Build.Kind = Instance then
+ raise Internal_Error;
+ end if;
+ end Check_Not_Building;
+
+ function Get_Instance_Access (Block : Iir) return O_Enode
+ is
+ Info : constant Block_Info_Acc := Get_Info (Block);
+ Res : O_Lnode;
+ Is_Ptr : Boolean;
+ begin
+ Check_Not_Building;
+ Find_Scope (Info.Block_Scope, Res, Is_Ptr);
+ if Is_Ptr then
+ return New_Value (Res);
+ else
+ return New_Address (Res, Info.Block_Decls_Ptr_Type);
+ end if;
+ end Get_Instance_Access;
+
+ function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode
+ is
+ Res : O_Lnode;
+ Is_Ptr : Boolean;
+ begin
+ Check_Not_Building;
+ Find_Scope (Scope, Res, Is_Ptr);
+ if Is_Ptr then
+ return New_Acc_Value (Res);
+ else
+ return Res;
+ end if;
+ end Get_Instance_Ref;
+
+ function Get_Var (Var : Var_Type) return O_Lnode
+ is
+ begin
+ case Var.Kind is
+ when Var_None =>
+ raise Internal_Error;
+ when Var_Local
+ | Var_Global =>
+ return New_Obj (Var.E);
+ when Var_Scope =>
+ return New_Selected_Element
+ (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field);
+ end case;
+ end Get_Var;
+
+ function Get_Alloc_Kind_For_Var (Var : Var_Type)
+ return Allocation_Kind is
+ begin
+ case Var.Kind is
+ when Var_Local =>
+ return Alloc_Stack;
+ when Var_Global
+ | Var_Scope =>
+ return Alloc_System;
+ when Var_None =>
+ raise Internal_Error;
+ end case;
+ end Get_Alloc_Kind_For_Var;
+
+ function Is_Var_Stable (Var : Var_Type) return Boolean is
+ begin
+ case Var.Kind is
+ when Var_Local
+ | Var_Global =>
+ return True;
+ when Var_Scope =>
+ return False;
+ when Var_None =>
+ raise Internal_Error;
+ end case;
+ end Is_Var_Stable;
+
+ function Is_Var_Field (Var : Var_Type) return Boolean is
+ begin
+ case Var.Kind is
+ when Var_Local
+ | Var_Global =>
+ return False;
+ when Var_Scope =>
+ return True;
+ when Var_None =>
+ raise Internal_Error;
+ end case;
+ end Is_Var_Field;
+
+ function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode
+ is
+ begin
+ return New_Offsetof (Get_Scope_Type (Var.I_Scope.all),
+ Var.I_Field, Otype);
+ end Get_Var_Offset;
+
+ function Get_Var_Label (Var : Var_Type) return O_Dnode is
+ begin
+ case Var.Kind is
+ when Var_Local
+ | Var_Global =>
+ return Var.E;
+ when Var_Scope
+ | Var_None =>
+ raise Internal_Error;
+ end case;
+ end Get_Var_Label;
+
+ procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is
+ begin
+ Id := Identifier_Local;
+ end Save_Local_Identifier;
+
+ procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is
+ begin
+ if Identifier_Local > Id then
+ -- If the value is restored with a smaller value, some identifiers
+ -- will be reused. This is certainly an internal error.
+ raise Internal_Error;
+ end if;
+ Identifier_Local := Id;
+ end Restore_Local_Identifier;
+
+ -- Reset the identifier.
+ procedure Reset_Identifier_Prefix is
+ begin
+ if Identifier_Len /= 0 or else Identifier_Local /= 0 then
+ raise Internal_Error;
+ end if;
+ end Reset_Identifier_Prefix;
+
+ procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is
+ begin
+ Identifier_Len := Mark.Len;
+ Identifier_Local := Mark.Local_Id;
+ end Pop_Identifier_Prefix;
+
+ procedure Add_String (Len : in out Natural; Str : String) is
+ begin
+ Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str;
+ Len := Len + Str'Length;
+ end Add_String;
+
+ procedure Add_Nat (Len : in out Natural; Val : Natural)
+ is
+ Num : String (1 .. 10);
+ V : Natural;
+ P : Natural;
+ begin
+ P := Num'Last;
+ V := Val;
+ loop
+ Num (P) := Character'Val (Character'Pos ('0') + V mod 10);
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ Add_String (Len, Num (P .. Num'Last));
+ end Add_Nat;
+
+ -- Convert name_id NAME to a string stored to
+ -- NAME_BUFFER (1 .. NAME_LENGTH).
+ --
+ -- This encodes extended identifiers.
+ --
+ -- Extended identifier encoding:
+ -- They start with 'X'.
+ -- Non extended character [0-9a-zA-Z] are left as is,
+ -- others are encoded to _XX, where XX is the character position in hex.
+ -- They finish with "__".
+ procedure Name_Id_To_String (Name : Name_Id)
+ is
+ use Name_Table;
+
+ type Bool_Array_Type is array (Character) of Boolean;
+ pragma Pack (Bool_Array_Type);
+ Is_Extended_Char : constant Bool_Array_Type :=
+ ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False,
+ others => True);
+
+ N_Len : Natural;
+ P : Natural;
+ C : Character;
+ begin
+ if Is_Character (Name) then
+ P := Character'Pos (Name_Table.Get_Character (Name));
+ Name_Buffer (1) := 'C';
+ Name_Buffer (2) := N2hex (P / 16);
+ Name_Buffer (3) := N2hex (P mod 16);
+ Name_Length := 3;
+ return;
+ else
+ Image (Name);
+ end if;
+ if Name_Buffer (1) /= '\' then
+ return;
+ end if;
+ -- Extended identifier.
+ -- Supress trailing backslash.
+ Name_Length := Name_Length - 1;
+
+ -- Count number of characters in the extended string.
+ N_Len := Name_Length;
+ for I in 2 .. Name_Length loop
+ if Is_Extended_Char (Name_Buffer (I)) then
+ N_Len := N_Len + 2;
+ end if;
+ end loop;
+
+ -- Convert.
+ Name_Buffer (1) := 'X';
+ P := N_Len;
+ for J in reverse 2 .. Name_Length loop
+ C := Name_Buffer (J);
+ if Is_Extended_Char (C) then
+ Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16);
+ Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16);
+ Name_Buffer (P - 2) := '_';
+ P := P - 3;
+ else
+ Name_Buffer (P) := C;
+ P := P - 1;
+ end if;
+ end loop;
+ Name_Buffer (N_Len + 1) := '_';
+ Name_Buffer (N_Len + 2) := '_';
+ Name_Length := N_Len + 2;
+ end Name_Id_To_String;
+
+ procedure Add_Name (Len : in out Natural; Name : Name_Id)
+ is
+ use Name_Table;
+ begin
+ Name_Id_To_String (Name);
+ Add_String (Len, Name_Buffer (1 .. Name_Length));
+ end Add_Name;
+
+ procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type;
+ Name : String;
+ Val : Iir_Int32 := 0)
+ is
+ P : Natural;
+ begin
+ Mark.Len := Identifier_Len;
+ Mark.Local_Id := Identifier_Local;
+ Identifier_Local := 0;
+ P := Identifier_Len;
+ Add_String (P, Name);
+ if Val > 0 then
+ Add_String (P, "O");
+ Add_Nat (P, Natural (Val));
+ end if;
+ Add_String (P, "__");
+ Identifier_Len := P;
+ end Push_Identifier_Prefix;
+
+ -- Add a suffix to the prefix (!!!).
+ procedure Push_Identifier_Prefix
+ (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0)
+ is
+ use Name_Table;
+ begin
+ Name_Id_To_String (Name);
+ Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val);
+ end Push_Identifier_Prefix;
+
+ procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type)
+ is
+ Str : String := Local_Identifier_Type'Image (Identifier_Local);
+ begin
+ Identifier_Local := Identifier_Local + 1;
+ Str (1) := 'U';
+ Push_Identifier_Prefix (Mark, Str, 0);
+ end Push_Identifier_Prefix_Uniq;
+
+ procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is
+ begin
+ if Id /= Null_Identifier then
+ Add_Name (Len, Id);
+ end if;
+ end Add_Identifier;
+
+ -- Create an identifier from IIR node ID without the prefix.
+ function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident
+ is
+ use Name_Table;
+ begin
+ Name_Id_To_String (Get_Identifier (Id));
+ return Get_Identifier (Name_Buffer (1 .. Name_Length));
+ end Create_Identifier_Without_Prefix;
+
+ function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String)
+ return O_Ident
+ is
+ use Name_Table;
+ begin
+ Name_Id_To_String (Id);
+ Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str;
+ return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length));
+ end Create_Identifier_Without_Prefix;
+
+ -- Create an identifier from IIR node ID with prefix.
+ function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean)
+ return O_Ident
+ is
+ L : Natural;
+ begin
+ L := Identifier_Len;
+ Add_Identifier (L, Id);
+ Add_String (L, Str);
+ --Identifier_Buffer (L + Str'Length + 1) := Nul;
+ if Is_Local then
+ return Get_Identifier
+ (Identifier_Buffer (Identifier_Start .. L));
+ else
+ return Get_Identifier (Identifier_Buffer (1 .. L));
+ end if;
+ end Create_Id;
+
+ function Create_Identifier (Id : Name_Id; Str : String := "")
+ return O_Ident
+ is
+ begin
+ return Create_Id (Id, Str, False);
+ end Create_Identifier;
+
+ function Create_Identifier (Id : Iir; Str : String := "")
+ return O_Ident
+ is
+ begin
+ return Create_Id (Get_Identifier (Id), Str, False);
+ end Create_Identifier;
+
+ function Create_Identifier
+ (Id : Iir; Val : Iir_Int32; Str : String := "")
+ return O_Ident
+ is
+ Len : Natural;
+ begin
+ Len := Identifier_Len;
+ Add_Identifier (Len, Get_Identifier (Id));
+
+ if Val > 0 then
+ Add_String (Len, "O");
+ Add_Nat (Len, Natural (Val));
+ end if;
+ Add_String (Len, Str);
+ return Get_Identifier (Identifier_Buffer (1 .. Len));
+ end Create_Identifier;
+
+ function Create_Identifier (Str : String)
+ return O_Ident
+ is
+ Len : Natural;
+ begin
+ Len := Identifier_Len;
+ Add_String (Len, Str);
+ return Get_Identifier (Identifier_Buffer (1 .. Len));
+ end Create_Identifier;
+
+ function Create_Identifier return O_Ident
+ is
+ begin
+ return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2));
+ end Create_Identifier;
+
+ function Create_Var_Identifier_From_Buffer (L : Natural)
+ return Var_Ident_Type
+ is
+ Start : Natural;
+ begin
+ if Is_Local_Scope then
+ Start := Identifier_Start;
+ else
+ Start := 1;
+ end if;
+ return (Id => Get_Identifier (Identifier_Buffer (Start .. L)));
+ end Create_Var_Identifier_From_Buffer;
+
+ function Create_Var_Identifier (Id : Iir)
+ return Var_Ident_Type
+ is
+ L : Natural := Identifier_Len;
+ begin
+ Add_Identifier (L, Get_Identifier (Id));
+ return Create_Var_Identifier_From_Buffer (L);
+ end Create_Var_Identifier;
+
+ function Create_Var_Identifier (Id : String)
+ return Var_Ident_Type
+ is
+ L : Natural := Identifier_Len;
+ begin
+ Add_String (L, Id);
+ return Create_Var_Identifier_From_Buffer (L);
+ end Create_Var_Identifier;
+
+ function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural)
+ return Var_Ident_Type
+ is
+ L : Natural := Identifier_Len;
+ begin
+ Add_Identifier (L, Get_Identifier (Id));
+ Add_String (L, Str);
+ if Val > 0 then
+ Add_String (L, "O");
+ Add_Nat (L, Val);
+ end if;
+ return Create_Var_Identifier_From_Buffer (L);
+ end Create_Var_Identifier;
+
+ function Create_Uniq_Identifier return Var_Ident_Type
+ is
+ Res : Var_Ident_Type;
+ begin
+ Res.Id := Create_Uniq_Identifier;
+ return Res;
+ end Create_Uniq_Identifier;
+
+ type Instantiate_Var_Stack;
+ type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack;
+
+ type Instantiate_Var_Stack is record
+ Orig_Scope : Var_Scope_Acc;
+ Inst_Scope : Var_Scope_Acc;
+ Prev : Instantiate_Var_Stack_Acc;
+ end record;
+
+ Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null;
+ Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null;
+
+ procedure Push_Instantiate_Var_Scope
+ (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc)
+ is
+ Inst : Instantiate_Var_Stack_Acc;
+ begin
+ if Free_Instantiate_Var_Stack = null then
+ Inst := new Instantiate_Var_Stack;
+ else
+ Inst := Free_Instantiate_Var_Stack;
+ Free_Instantiate_Var_Stack := Inst.Prev;
+ end if;
+ Inst.all := (Orig_Scope => Orig_Scope,
+ Inst_Scope => Inst_Scope,
+ Prev => Top_Instantiate_Var_Stack);
+ Top_Instantiate_Var_Stack := Inst;
+ end Push_Instantiate_Var_Scope;
+
+ procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc)
+ is
+ Item : constant Instantiate_Var_Stack_Acc :=
+ Top_Instantiate_Var_Stack;
+ begin
+ pragma Assert (Item /= null);
+ pragma Assert (Item.Inst_Scope = Inst_Scope);
+ Top_Instantiate_Var_Stack := Item.Prev;
+ Item.all := (Orig_Scope => null,
+ Inst_Scope => null,
+ Prev => Free_Instantiate_Var_Stack);
+ Free_Instantiate_Var_Stack := Item;
+ end Pop_Instantiate_Var_Scope;
+
+ function Instantiated_Var_Scope (Scope : Var_Scope_Acc)
+ return Var_Scope_Acc
+ is
+ Item : Instantiate_Var_Stack_Acc;
+ begin
+ if Scope = null then
+ return null;
+ end if;
+
+ Item := Top_Instantiate_Var_Stack;
+ loop
+ pragma Assert (Item /= null);
+ if Item.Orig_Scope = Scope then
+ return Item.Inst_Scope;
+ end if;
+ Item := Item.Prev;
+ end loop;
+ end Instantiated_Var_Scope;
+
+ function Instantiate_Var (Var : Var_Type) return Var_Type is
+ begin
+ case Var.Kind is
+ when Var_None
+ | Var_Global
+ | Var_Local =>
+ return Var;
+ when Var_Scope =>
+ return Var_Type'
+ (Kind => Var_Scope,
+ I_Field => Var.I_Field,
+ I_Scope => Instantiated_Var_Scope (Var.I_Scope));
+ end case;
+ end Instantiate_Var;
+
+ function Instantiate_Var_Scope (Scope : Var_Scope_Type)
+ return Var_Scope_Type is
+ begin
+ case Scope.Kind is
+ when Var_Scope_None
+ | Var_Scope_Ptr
+ | Var_Scope_Decl =>
+ return Scope;
+ when Var_Scope_Field =>
+ return Var_Scope_Type'
+ (Kind => Var_Scope_Field,
+ Scope_Type => Scope.Scope_Type,
+ Field => Scope.Field,
+ Up_Link => Instantiated_Var_Scope (Scope.Up_Link));
+ when Var_Scope_Field_Ptr =>
+ return Var_Scope_Type'
+ (Kind => Var_Scope_Field_Ptr,
+ Scope_Type => Scope.Scope_Type,
+ Field => Scope.Field,
+ Up_Link => Instantiated_Var_Scope (Scope.Up_Link));
+ end case;
+ end Instantiate_Var_Scope;
+ end Chap10;
+
+ package body Chap14 is
+ function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode
+ is
+ Prefix : constant Iir := Get_Prefix (Expr);
+ Type_Name : constant Iir := Is_Type_Name (Prefix);
+ Arr : Mnode;
+ Dim : Natural;
+ begin
+ if Type_Name /= Null_Iir then
+ -- Prefix denotes a type name
+ Arr := T2M (Type_Name, Mode_Value);
+ else
+ -- Prefix is an object.
+ Arr := Chap6.Translate_Name (Prefix);
+ end if;
+ Dim := Natural (Get_Value (Get_Parameter (Expr)));
+ return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim);
+ end Translate_Array_Attribute_To_Range;
+
+ function Translate_Range_Array_Attribute (Expr : Iir)
+ return O_Lnode is
+ begin
+ return M2Lv (Translate_Array_Attribute_To_Range (Expr));
+ end Translate_Range_Array_Attribute;
+
+ function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir)
+ return O_Enode
+ is
+ Rng : Mnode;
+ Val : O_Enode;
+ begin
+ Rng := Translate_Array_Attribute_To_Range (Expr);
+ Val := M2E (Chap3.Range_To_Length (Rng));
+ if Rtype /= Null_Iir then
+ Val := New_Convert_Ov (Val, Get_Ortho_Type (Rtype, Mode_Value));
+ end if;
+ return Val;
+ end Translate_Length_Array_Attribute;
+
+ -- Extract high or low bound of RANGE_VAR.
+ function Range_To_High_Low
+ (Range_Var : Mnode; Range_Type : Iir; Is_High : Boolean)
+ return Mnode
+ is
+ Op : ON_Op_Kind;
+ If_Blk : O_If_Block;
+ Range_Svar : constant Mnode := Stabilize (Range_Var);
+ Res : O_Dnode;
+ Tinfo : constant Ortho_Info_Acc :=
+ Get_Info (Get_Base_Type (Range_Type));
+ begin
+ Res := Create_Temp (Tinfo.Ortho_Type (Mode_Value));
+ Open_Temp;
+ if Is_High then
+ Op := ON_Neq;
+ else
+ Op := ON_Eq;
+ end if;
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (Op,
+ M2E (Chap3.Range_To_Dir (Range_Svar)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Res),
+ M2E (Chap3.Range_To_Left (Range_Svar)));
+ New_Else_Stmt (If_Blk);
+ New_Assign_Stmt (New_Obj (Res),
+ M2E (Chap3.Range_To_Right (Range_Svar)));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ return Dv2M (Res, Tinfo, Mode_Value);
+ end Range_To_High_Low;
+
+ function Translate_High_Low_Type_Attribute
+ (Atype : Iir; Is_High : Boolean) return O_Enode
+ is
+ Cons : constant Iir := Get_Range_Constraint (Atype);
+ begin
+ -- FIXME: improve code if constraint is a range expression.
+ if Get_Type_Staticness (Atype) = Locally then
+ if Get_Direction (Cons) = Iir_To xor Is_High then
+ return New_Lit
+ (Chap7.Translate_Static_Range_Left (Cons, Atype));
+ else
+ return New_Lit
+ (Chap7.Translate_Static_Range_Right (Cons, Atype));
+ end if;
+ else
+ return M2E (Range_To_High_Low
+ (Chap3.Type_To_Range (Atype), Atype, Is_High));
+ end if;
+ end Translate_High_Low_Type_Attribute;
+
+ function Translate_High_Low_Array_Attribute (Expr : Iir;
+ Is_High : Boolean)
+ return O_Enode
+ is
+ begin
+ -- FIXME: improve code if index is a range expression.
+ return M2E (Range_To_High_Low
+ (Translate_Array_Attribute_To_Range (Expr),
+ Get_Type (Expr), Is_High));
+ end Translate_High_Low_Array_Attribute;
+
+ function Translate_Low_Array_Attribute (Expr : Iir)
+ return O_Enode
+ is
+ begin
+ return Translate_High_Low_Array_Attribute (Expr, False);
+ end Translate_Low_Array_Attribute;
+
+ function Translate_High_Array_Attribute (Expr : Iir)
+ return O_Enode
+ is
+ begin
+ return Translate_High_Low_Array_Attribute (Expr, True);
+ end Translate_High_Array_Attribute;
+
+ function Translate_Left_Array_Attribute (Expr : Iir)
+ return O_Enode
+ is
+ Rng : Mnode;
+ begin
+ Rng := Translate_Array_Attribute_To_Range (Expr);
+ return M2E (Chap3.Range_To_Left (Rng));
+ end Translate_Left_Array_Attribute;
+
+ function Translate_Right_Array_Attribute (Expr : Iir)
+ return O_Enode
+ is
+ Rng : Mnode;
+ begin
+ Rng := Translate_Array_Attribute_To_Range (Expr);
+ return M2E (Chap3.Range_To_Right (Rng));
+ end Translate_Right_Array_Attribute;
+
+ function Translate_Ascending_Array_Attribute (Expr : Iir)
+ return O_Enode
+ is
+ Rng : Mnode;
+ begin
+ Rng := Translate_Array_Attribute_To_Range (Expr);
+ return New_Compare_Op (ON_Eq,
+ M2E (Chap3.Range_To_Dir (Rng)),
+ New_Lit (Ghdl_Dir_To_Node),
+ Std_Boolean_Type_Node);
+ end Translate_Ascending_Array_Attribute;
+
+ function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is
+ begin
+ if Get_Type_Staticness (Atype) = Locally then
+ return New_Lit (Chap7.Translate_Static_Range_Left
+ (Get_Range_Constraint (Atype), Atype));
+ else
+ return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype)));
+ end if;
+ end Translate_Left_Type_Attribute;
+
+ function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is
+ begin
+ if Get_Type_Staticness (Atype) = Locally then
+ return New_Lit (Chap7.Translate_Static_Range_Right
+ (Get_Range_Constraint (Atype), Atype));
+ else
+ return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype)));
+ end if;
+ end Translate_Right_Type_Attribute;
+
+ function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode
+ is
+ Info : Type_Info_Acc;
+ begin
+ if Get_Type_Staticness (Atype) = Locally then
+ return New_Lit (Chap7.Translate_Static_Range_Dir
+ (Get_Range_Constraint (Atype)));
+ else
+ Info := Get_Info (Atype);
+ return New_Value
+ (New_Selected_Element (Get_Var (Info.T.Range_Var),
+ Info.T.Range_Dir));
+ end if;
+ end Translate_Dir_Type_Attribute;
+
+ function Translate_Val_Attribute (Attr : Iir) return O_Enode
+ is
+ Val : O_Enode;
+ Attr_Type : Iir;
+ Res_Var : O_Dnode;
+ Res_Type : O_Tnode;
+ begin
+ Attr_Type := Get_Type (Attr);
+ Res_Type := Get_Ortho_Type (Attr_Type, Mode_Value);
+ Res_Var := Create_Temp (Res_Type);
+ Val := Chap7.Translate_Expression (Get_Parameter (Attr));
+
+ case Get_Kind (Attr_Type) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ -- For enumeration, always check the value is in the enum
+ -- range.
+ declare
+ Val_Type : O_Tnode;
+ Val_Var : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Val_Type := Get_Ortho_Type (Get_Type (Get_Parameter (Attr)),
+ Mode_Value);
+ Val_Var := Create_Temp_Init (Val_Type, Val);
+ Start_If_Stmt
+ (If_Blk,
+ New_Dyadic_Op
+ (ON_Or,
+ New_Compare_Op (ON_Lt,
+ New_Obj_Value (Val_Var),
+ New_Lit (New_Signed_Literal
+ (Val_Type, 0)),
+ Ghdl_Bool_Type),
+ New_Compare_Op (ON_Ge,
+ New_Obj_Value (Val_Var),
+ New_Lit (New_Signed_Literal
+ (Val_Type,
+ Integer_64
+ (Get_Nbr_Elements
+ (Get_Enumeration_Literal_List
+ (Attr_Type))))),
+ Ghdl_Bool_Type)));
+ Chap6.Gen_Bound_Error (Attr);
+ Finish_If_Stmt (If_Blk);
+ Val := New_Obj_Value (Val_Var);
+ end;
+ when others =>
+ null;
+ end case;
+
+ New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type));
+ Chap3.Check_Range
+ (Res_Var, Attr, Get_Type (Get_Prefix (Attr)), Attr);
+ return New_Obj_Value (Res_Var);
+ end Translate_Val_Attribute;
+
+ function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir)
+ return O_Enode
+ is
+ T : O_Dnode;
+ Ttype : O_Tnode;
+ begin
+ Ttype := Get_Ortho_Type (Res_Type, Mode_Value);
+ T := Create_Temp (Ttype);
+ New_Assign_Stmt
+ (New_Obj (T),
+ New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)),
+ Ttype));
+ Chap3.Check_Range (T, Attr, Res_Type, Attr);
+ return New_Obj_Value (T);
+ end Translate_Pos_Attribute;
+
+ function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode
+ is
+ Expr_Type : Iir;
+ Tinfo : Type_Info_Acc;
+ Ttype : O_Tnode;
+ Expr : O_Enode;
+ List : Iir_List;
+ Limit : Iir;
+ Is_Succ : Boolean;
+ Op : ON_Op_Kind;
+ begin
+ -- FIXME: should check bounds.
+ Expr_Type := Get_Type (Attr);
+ Tinfo := Get_Info (Expr_Type);
+ Expr := Chap7.Translate_Expression (Get_Parameter (Attr), Expr_Type);
+ Ttype := Tinfo.Ortho_Type (Mode_Value);
+ Is_Succ := Get_Kind (Attr) = Iir_Kind_Succ_Attribute;
+ if Is_Succ then
+ Op := ON_Add_Ov;
+ else
+ Op := ON_Sub_Ov;
+ end if;
+ case Tinfo.Type_Mode is
+ when Type_Mode_B1
+ | Type_Mode_E8
+ | Type_Mode_E32 =>
+ -- Should check it is not the last.
+ declare
+ L : O_Dnode;
+ begin
+ List := Get_Enumeration_Literal_List (Get_Base_Type
+ (Expr_Type));
+ L := Create_Temp_Init (Ttype, Expr);
+ if Is_Succ then
+ Limit := Get_Last_Element (List);
+ else
+ Limit := Get_First_Element (List);
+ end if;
+ Chap6.Check_Bound_Error
+ (New_Compare_Op (ON_Eq,
+ New_Obj_Value (L),
+ New_Lit (Get_Ortho_Expr (Limit)),
+ Ghdl_Bool_Type),
+ Attr, 0);
+ return New_Convert_Ov
+ (New_Dyadic_Op
+ (Op,
+ New_Convert_Ov (New_Obj_Value (L), Ghdl_I32_Type),
+ New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1))),
+ Ttype);
+ end;
+ when Type_Mode_I32
+ | Type_Mode_P64 =>
+ return New_Dyadic_Op
+ (Op, Expr, New_Lit (New_Signed_Literal (Ttype, 1)));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Translate_Succ_Pred_Attribute;
+
+ type Bool_Sigattr_Data_Type is record
+ Label : O_Snode;
+ Field : O_Fnode;
+ end record;
+
+ procedure Bool_Sigattr_Non_Composite_Signal
+ (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type)
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ Gen_Exit_When (Data.Label,
+ New_Value (Get_Signal_Field (Targ, Data.Field)));
+ end Bool_Sigattr_Non_Composite_Signal;
+
+ function Bool_Sigattr_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type)
+ return Bool_Sigattr_Data_Type
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Data;
+ end Bool_Sigattr_Prepare_Data_Composite;
+
+ function Bool_Sigattr_Update_Data_Array (Data : Bool_Sigattr_Data_Type;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Bool_Sigattr_Data_Type
+ is
+ pragma Unreferenced (Targ_Type, Index);
+ begin
+ return Data;
+ end Bool_Sigattr_Update_Data_Array;
+
+ function Bool_Sigattr_Update_Data_Record (Data : Bool_Sigattr_Data_Type;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Bool_Sigattr_Data_Type
+ is
+ pragma Unreferenced (Targ_Type, El);
+ begin
+ return Data;
+ end Bool_Sigattr_Update_Data_Record;
+
+ procedure Bool_Sigattr_Finish_Data_Composite
+ (Data : in out Bool_Sigattr_Data_Type)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Bool_Sigattr_Finish_Data_Composite;
+
+ procedure Bool_Sigattr_Foreach is new Foreach_Non_Composite
+ (Data_Type => Bool_Sigattr_Data_Type,
+ Composite_Data_Type => Bool_Sigattr_Data_Type,
+ Do_Non_Composite => Bool_Sigattr_Non_Composite_Signal,
+ Prepare_Data_Array => Bool_Sigattr_Prepare_Data_Composite,
+ Update_Data_Array => Bool_Sigattr_Update_Data_Array,
+ Finish_Data_Array => Bool_Sigattr_Finish_Data_Composite,
+ Prepare_Data_Record => Bool_Sigattr_Prepare_Data_Composite,
+ Update_Data_Record => Bool_Sigattr_Update_Data_Record,
+ Finish_Data_Record => Bool_Sigattr_Finish_Data_Composite);
+
+ function Translate_Bool_Signal_Attribute (Attr : Iir; Field : O_Fnode)
+ return O_Enode
+ is
+ Data : Bool_Sigattr_Data_Type;
+ Res : O_Dnode;
+ Name : Mnode;
+ Prefix : constant Iir := Get_Prefix (Attr);
+ Prefix_Type : constant Iir := Get_Type (Prefix);
+ begin
+ if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then
+ -- Effecient handling for a scalar signal.
+ Name := Chap6.Translate_Name (Prefix);
+ return New_Value (Get_Signal_Field (Name, Field));
+ else
+ -- Element per element handling for composite signals.
+ Res := Create_Temp (Std_Boolean_Type_Node);
+ Open_Temp;
+ New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node));
+ Name := Chap6.Translate_Name (Prefix);
+ Start_Loop_Stmt (Data.Label);
+ Data.Field := Field;
+ Bool_Sigattr_Foreach (Name, Prefix_Type, Data);
+ New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node));
+ New_Exit_Stmt (Data.Label);
+ Finish_Loop_Stmt (Data.Label);
+ Close_Temp;
+ return New_Obj_Value (Res);
+ end if;
+ end Translate_Bool_Signal_Attribute;
+
+ function Translate_Event_Attribute (Attr : Iir) return O_Enode is
+ begin
+ return Translate_Bool_Signal_Attribute
+ (Attr, Ghdl_Signal_Event_Field);
+ end Translate_Event_Attribute;
+
+ function Translate_Active_Attribute (Attr : Iir) return O_Enode is
+ begin
+ return Translate_Bool_Signal_Attribute
+ (Attr, Ghdl_Signal_Active_Field);
+ end Translate_Active_Attribute;
+
+ -- Read signal value FIELD of signal SIG.
+ function Get_Signal_Value_Field
+ (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode)
+ return O_Lnode
+ is
+ S_Type : O_Tnode;
+ T : O_Lnode;
+ begin
+ S_Type := Get_Ortho_Type (Sig_Type, Mode_Signal);
+ T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr));
+ return New_Access_Element
+ (New_Unchecked_Address (New_Selected_Element (T, Field), S_Type));
+ end Get_Signal_Value_Field;
+
+ function Get_Signal_Field (Sig : Mnode; Field : O_Fnode)
+ return O_Lnode
+ is
+ S : O_Enode;
+ begin
+ S := New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr);
+ return New_Selected_Element (New_Access_Element (S), Field);
+ end Get_Signal_Field;
+
+ function Read_Last_Value (Sig : O_Enode; Sig_Type : Iir) return O_Enode
+ is
+ begin
+ return New_Value (Get_Signal_Value_Field
+ (Sig, Sig_Type, Ghdl_Signal_Last_Value_Field));
+ end Read_Last_Value;
+
+ function Translate_Last_Value is new Chap7.Translate_Signal_Value
+ (Read_Value => Read_Last_Value);
+
+ function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode
+ is
+ Name : Mnode;
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ begin
+ Prefix := Get_Prefix (Attr);
+ Prefix_Type := Get_Type (Prefix);
+
+ Name := Chap6.Translate_Name (Prefix);
+ if Get_Object_Kind (Name) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+ return Translate_Last_Value (M2E (Name), Prefix_Type);
+ end Translate_Last_Value_Attribute;
+
+ function Read_Last_Time (Sig : O_Enode; Field : O_Fnode) return O_Enode
+ is
+ T : O_Lnode;
+ begin
+ T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr));
+ return New_Value (New_Selected_Element (T, Field));
+ end Read_Last_Time;
+
+ type Last_Time_Data is record
+ Var : O_Dnode;
+ Field : O_Fnode;
+ end record;
+
+ procedure Translate_Last_Time_Non_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data)
+ is
+ pragma Unreferenced (Targ_Type);
+ Val : O_Dnode;
+ If_Blk : O_If_Block;
+ begin
+ Open_Temp;
+ Val := Create_Temp_Init
+ (Std_Time_Otype,
+ Read_Last_Time (New_Value (M2Lv (Targ)), Data.Field));
+ Start_If_Stmt (If_Blk,
+ New_Compare_Op (ON_Gt,
+ New_Obj_Value (Val),
+ New_Obj_Value (Data.Var),
+ Ghdl_Bool_Type));
+ New_Assign_Stmt (New_Obj (Data.Var), New_Obj_Value (Val));
+ Finish_If_Stmt (If_Blk);
+ Close_Temp;
+ end Translate_Last_Time_Non_Composite;
+
+ function Last_Time_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data)
+ return Last_Time_Data
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Data;
+ end Last_Time_Prepare_Data_Composite;
+
+ function Last_Time_Update_Data_Array (Data : Last_Time_Data;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return Last_Time_Data
+ is
+ pragma Unreferenced (Targ_Type, Index);
+ begin
+ return Data;
+ end Last_Time_Update_Data_Array;
+
+ function Last_Time_Update_Data_Record (Data : Last_Time_Data;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return Last_Time_Data
+ is
+ pragma Unreferenced (Targ_Type, El);
+ begin
+ return Data;
+ end Last_Time_Update_Data_Record;
+
+ procedure Last_Time_Finish_Data_Composite
+ (Data : in out Last_Time_Data)
+ is
+ pragma Unreferenced (Data);
+ begin
+ null;
+ end Last_Time_Finish_Data_Composite;
+
+ procedure Translate_Last_Time is new Foreach_Non_Composite
+ (Data_Type => Last_Time_Data,
+ Composite_Data_Type => Last_Time_Data,
+ Do_Non_Composite => Translate_Last_Time_Non_Composite,
+ Prepare_Data_Array => Last_Time_Prepare_Data_Composite,
+ Update_Data_Array => Last_Time_Update_Data_Array,
+ Finish_Data_Array => Last_Time_Finish_Data_Composite,
+ Prepare_Data_Record => Last_Time_Prepare_Data_Composite,
+ Update_Data_Record => Last_Time_Update_Data_Record,
+ Finish_Data_Record => Last_Time_Finish_Data_Composite);
+
+ function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode)
+ return O_Enode
+ is
+ Prefix_Type : Iir;
+ Name : Mnode;
+ Info : Type_Info_Acc;
+ Var : O_Dnode;
+ Data : Last_Time_Data;
+ Right_Bound : Iir_Int64;
+ If_Blk : O_If_Block;
+ begin
+ Prefix_Type := Get_Type (Prefix);
+ Name := Chap6.Translate_Name (Prefix);
+ Info := Get_Info (Prefix_Type);
+ Var := Create_Temp (Std_Time_Otype);
+
+ if Info.Type_Mode in Type_Mode_Scalar then
+ New_Assign_Stmt (New_Obj (Var),
+ Read_Last_Time (M2E (Name), Field));
+ else
+ -- Init with a negative value.
+ New_Assign_Stmt
+ (New_Obj (Var),
+ New_Lit (New_Signed_Literal (Std_Time_Otype, -1)));
+ Data := Last_Time_Data'(Var => Var, Field => Field);
+ Translate_Last_Time (Name, Prefix_Type, Data);
+ end if;
+
+ Right_Bound := Get_Value
+ (Get_Right_Limit (Get_Range_Constraint (Time_Subtype_Definition)));
+
+ -- VAR < 0 ?
+ Start_If_Stmt
+ (If_Blk,
+ New_Compare_Op (ON_Lt,
+ New_Obj_Value (Var),
+ New_Lit (New_Signed_Literal (Std_Time_Otype, 0)),
+ Ghdl_Bool_Type));
+ -- LRM 14.1 Predefined attributes
+ -- [...]; otherwise, it returns TIME'HIGH.
+ New_Assign_Stmt
+ (New_Obj (Var),
+ New_Lit (New_Signed_Literal
+ (Std_Time_Otype, Integer_64 (Right_Bound))));
+ New_Else_Stmt (If_Blk);
+ -- Returns NOW - Var.
+ New_Assign_Stmt (New_Obj (Var),
+ New_Dyadic_Op (ON_Sub_Ov,
+ New_Obj_Value (Ghdl_Now),
+ New_Obj_Value (Var)));
+ Finish_If_Stmt (If_Blk);
+ return New_Obj_Value (Var);
+ end Translate_Last_Time_Attribute;
+
+ -- Return TRUE if the scalar signal SIG is being driven.
+ function Read_Driving_Attribute (Sig : O_Enode) return O_Enode
+ is
+ Assoc : O_Assoc_List;
+ begin
+ Start_Association (Assoc, Ghdl_Signal_Driving);
+ New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr));
+ return New_Function_Call (Assoc);
+ end Read_Driving_Attribute;
+
+ procedure Driving_Non_Composite_Signal
+ (Targ : Mnode; Targ_Type : Iir; Label : O_Snode)
+ is
+ pragma Unreferenced (Targ_Type);
+ begin
+ Gen_Exit_When
+ (Label,
+ New_Monadic_Op
+ (ON_Not, Read_Driving_Attribute (New_Value (M2Lv (Targ)))));
+ end Driving_Non_Composite_Signal;
+
+ function Driving_Prepare_Data_Composite
+ (Targ : Mnode; Targ_Type : Iir; Label : O_Snode)
+ return O_Snode
+ is
+ pragma Unreferenced (Targ, Targ_Type);
+ begin
+ return Label;
+ end Driving_Prepare_Data_Composite;
+
+ function Driving_Update_Data_Array (Label : O_Snode;
+ Targ_Type : Iir;
+ Index : O_Dnode)
+ return O_Snode
+ is
+ pragma Unreferenced (Targ_Type, Index);
+ begin
+ return Label;
+ end Driving_Update_Data_Array;
+
+ function Driving_Update_Data_Record (Label : O_Snode;
+ Targ_Type : Iir;
+ El : Iir_Element_Declaration)
+ return O_Snode
+ is
+ pragma Unreferenced (Targ_Type, El);
+ begin
+ return Label;
+ end Driving_Update_Data_Record;
+
+ procedure Driving_Finish_Data_Composite (Label : in out O_Snode)
+ is
+ pragma Unreferenced (Label);
+ begin
+ null;
+ end Driving_Finish_Data_Composite;
+
+ procedure Driving_Foreach is new Foreach_Non_Composite
+ (Data_Type => O_Snode,
+ Composite_Data_Type => O_Snode,
+ Do_Non_Composite => Driving_Non_Composite_Signal,
+ Prepare_Data_Array => Driving_Prepare_Data_Composite,
+ Update_Data_Array => Driving_Update_Data_Array,
+ Finish_Data_Array => Driving_Finish_Data_Composite,
+ Prepare_Data_Record => Driving_Prepare_Data_Composite,
+ Update_Data_Record => Driving_Update_Data_Record,
+ Finish_Data_Record => Driving_Finish_Data_Composite);
+
+ function Translate_Driving_Attribute (Attr : Iir) return O_Enode
+ is
+ Label : O_Snode;
+ Res : O_Dnode;
+ Name : Mnode;
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ begin
+ Prefix := Get_Prefix (Attr);
+ Prefix_Type := Get_Type (Prefix);
+
+ if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then
+ -- Effecient handling for a scalar signal.
+ Name := Chap6.Translate_Name (Prefix);
+ return Read_Driving_Attribute (New_Value (M2Lv (Name)));
+ else
+ -- Element per element handling for composite signals.
+ Res := Create_Temp (Std_Boolean_Type_Node);
+ Open_Temp;
+ New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node));
+ Name := Chap6.Translate_Name (Prefix);
+ Start_Loop_Stmt (Label);
+ Driving_Foreach (Name, Prefix_Type, Label);
+ New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node));
+ New_Exit_Stmt (Label);
+ Finish_Loop_Stmt (Label);
+ Close_Temp;
+ return New_Obj_Value (Res);
+ end if;
+ end Translate_Driving_Attribute;
+
+ function Read_Driving_Value (Sig : O_Enode; Sig_Type : Iir)
+ return O_Enode
+ is
+ Tinfo : Type_Info_Acc;
+ Subprg : O_Dnode;
+ Assoc : O_Assoc_List;
+ begin
+ Tinfo := Get_Info (Sig_Type);
+ case Tinfo.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Signal_Driving_Value_B1;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Signal_Driving_Value_E8;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Signal_Driving_Value_E32;
+ when Type_Mode_I32
+ | Type_Mode_P32 =>
+ Subprg := Ghdl_Signal_Driving_Value_I32;
+ when Type_Mode_P64
+ | Type_Mode_I64 =>
+ Subprg := Ghdl_Signal_Driving_Value_I64;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Signal_Driving_Value_F64;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr));
+ return New_Convert_Ov (New_Function_Call (Assoc),
+ Tinfo.Ortho_Type (Mode_Value));
+ end Read_Driving_Value;
+
+ function Translate_Driving_Value is new Chap7.Translate_Signal_Value
+ (Read_Value => Read_Driving_Value);
+
+ function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode
+ is
+ Name : Mnode;
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ begin
+ Prefix := Get_Prefix (Attr);
+ Prefix_Type := Get_Type (Prefix);
+
+ Name := Chap6.Translate_Name (Prefix);
+ if Get_Object_Kind (Name) /= Mode_Signal then
+ raise Internal_Error;
+ end if;
+ return Translate_Driving_Value (M2E (Name), Prefix_Type);
+ end Translate_Driving_Value_Attribute;
+
+ function Translate_Image_Attribute (Attr : Iir) return O_Enode
+ is
+ Prefix_Type : constant Iir :=
+ Get_Base_Type (Get_Type (Get_Prefix (Attr)));
+ Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type);
+ Res : O_Dnode;
+ Subprg : O_Dnode;
+ Assoc : O_Assoc_List;
+ Conv : O_Tnode;
+ begin
+ Res := Create_Temp (Std_String_Node);
+ Create_Temp_Stack2_Mark;
+ case Pinfo.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Image_B1;
+ Conv := Ghdl_Bool_Type;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Image_E8;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Image_E32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_I32 =>
+ Subprg := Ghdl_Image_I32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P32 =>
+ Subprg := Ghdl_Image_P32;
+ Conv := Ghdl_I32_Type;
+ when Type_Mode_P64 =>
+ Subprg := Ghdl_Image_P64;
+ Conv := Ghdl_I64_Type;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Image_F64;
+ Conv := Ghdl_Real_Type;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Start_Association (Assoc, Subprg);
+ New_Association (Assoc,
+ New_Address (New_Obj (Res), Std_String_Ptr_Node));
+ New_Association
+ (Assoc,
+ New_Convert_Ov
+ (Chap7.Translate_Expression (Get_Parameter (Attr), Prefix_Type),
+ Conv));
+ case Pinfo.Type_Mode is
+ when Type_Mode_B1
+ | Type_Mode_E8
+ | Type_Mode_E32
+ | Type_Mode_P32
+ | Type_Mode_P64 =>
+ New_Association
+ (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti)));
+ when Type_Mode_I32
+ | Type_Mode_F64 =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ New_Procedure_Call (Assoc);
+ return New_Address (New_Obj (Res), Std_String_Ptr_Node);
+ end Translate_Image_Attribute;
+
+ function Translate_Value_Attribute (Attr : Iir) return O_Enode
+ is
+ Prefix_Type : constant Iir :=
+ Get_Base_Type (Get_Type (Get_Prefix (Attr)));
+ Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type);
+ Subprg : O_Dnode;
+ Assoc : O_Assoc_List;
+ begin
+ case Pinfo.Type_Mode is
+ when Type_Mode_B1 =>
+ Subprg := Ghdl_Value_B1;
+ when Type_Mode_E8 =>
+ Subprg := Ghdl_Value_E8;
+ when Type_Mode_E32 =>
+ Subprg := Ghdl_Value_E32;
+ when Type_Mode_I32 =>
+ Subprg := Ghdl_Value_I32;
+ when Type_Mode_P32 =>
+ Subprg := Ghdl_Value_P32;
+ when Type_Mode_P64 =>
+ Subprg := Ghdl_Value_P64;
+ when Type_Mode_F64 =>
+ Subprg := Ghdl_Value_F64;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Start_Association (Assoc, Subprg);
+ New_Association
+ (Assoc,
+ Chap7.Translate_Expression (Get_Parameter (Attr),
+ String_Type_Definition));
+ case Pinfo.Type_Mode is
+ when Type_Mode_B1
+ | Type_Mode_E8
+ | Type_Mode_E32
+ | Type_Mode_P32
+ | Type_Mode_P64 =>
+ New_Association
+ (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti)));
+ when Type_Mode_I32
+ | Type_Mode_F64 =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ return New_Convert_Ov (New_Function_Call (Assoc),
+ Pinfo.Ortho_Type (Mode_Value));
+ end Translate_Value_Attribute;
+
+ function Translate_Path_Instance_Name_Attribute (Attr : Iir)
+ return O_Enode
+ is
+ Name : constant Path_Instance_Name_Type :=
+ Get_Path_Instance_Name_Suffix (Attr);
+ Res : O_Dnode;
+ Name_Cst : O_Dnode;
+ Str_Cst : O_Cnode;
+ Constr : O_Assoc_List;
+ Is_Instance : constant Boolean :=
+ Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute;
+ begin
+ Create_Temp_Stack2_Mark;
+
+ Res := Create_Temp (Std_String_Node);
+ Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier);
+ New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private,
+ Ghdl_Str_Len_Type_Node);
+ Start_Const_Value (Name_Cst);
+ Finish_Const_Value (Name_Cst, Str_Cst);
+ if Is_Instance then
+ Start_Association (Constr, Ghdl_Get_Instance_Name);
+ else
+ Start_Association (Constr, Ghdl_Get_Path_Name);
+ end if;
+ New_Association
+ (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node));
+ if Name.Path_Instance = Null_Iir then
+ Rtis.Associate_Null_Rti_Context (Constr);
+ else
+ Rtis.Associate_Rti_Context (Constr, Name.Path_Instance);
+ end if;
+ New_Association (Constr,
+ New_Address (New_Obj (Name_Cst),
+ Ghdl_Str_Len_Ptr_Node));
+ New_Procedure_Call (Constr);
+ return New_Address (New_Obj (Res), Std_String_Ptr_Node);
+ end Translate_Path_Instance_Name_Attribute;
+ end Chap14;
+
+ package body Rtis is
+ -- Node for package, body, entity, architecture, block, generate,
+ -- processes.
+ Ghdl_Rtin_Block : O_Tnode;
+ Ghdl_Rtin_Block_Common : O_Fnode;
+ Ghdl_Rtin_Block_Name : O_Fnode;
+ Ghdl_Rtin_Block_Loc : O_Fnode;
+ Ghdl_Rtin_Block_Parent : O_Fnode;
+ Ghdl_Rtin_Block_Size : O_Fnode;
+ Ghdl_Rtin_Block_Nbr_Child : O_Fnode;
+ Ghdl_Rtin_Block_Children : O_Fnode;
+
+ -- Node for scalar type decls.
+ Ghdl_Rtin_Type_Scalar : O_Tnode;
+ Ghdl_Rtin_Type_Scalar_Common : O_Fnode;
+ Ghdl_Rtin_Type_Scalar_Name : O_Fnode;
+
+ -- Node for an enumeration type definition.
+ Ghdl_Rtin_Type_Enum : O_Tnode;
+ Ghdl_Rtin_Type_Enum_Common : O_Fnode;
+ Ghdl_Rtin_Type_Enum_Name : O_Fnode;
+ Ghdl_Rtin_Type_Enum_Nbr : O_Fnode;
+ Ghdl_Rtin_Type_Enum_Lits : O_Fnode;
+
+ -- Node for an unit64.
+ Ghdl_Rtin_Unit64 : O_Tnode;
+ Ghdl_Rtin_Unit64_Common : O_Fnode;
+ Ghdl_Rtin_Unit64_Name : O_Fnode;
+ Ghdl_Rtin_Unit64_Value : O_Fnode;
+
+ -- Node for an unitptr.
+ Ghdl_Rtin_Unitptr : O_Tnode;
+ Ghdl_Rtin_Unitptr_Common : O_Fnode;
+ Ghdl_Rtin_Unitptr_Name : O_Fnode;
+ Ghdl_Rtin_Unitptr_Value : O_Fnode;
+
+ -- Node for a physical type
+ Ghdl_Rtin_Type_Physical : O_Tnode;
+ Ghdl_Rtin_Type_Physical_Common : O_Fnode;
+ Ghdl_Rtin_Type_Physical_Name : O_Fnode;
+ Ghdl_Rtin_Type_Physical_Nbr : O_Fnode;
+ Ghdl_Rtin_Type_Physical_Units : O_Fnode;
+
+ -- Node for a scalar subtype definition.
+ Ghdl_Rtin_Subtype_Scalar : O_Tnode;
+ Ghdl_Rtin_Subtype_Scalar_Common : O_Fnode;
+ Ghdl_Rtin_Subtype_Scalar_Name : O_Fnode;
+ Ghdl_Rtin_Subtype_Scalar_Base : O_Fnode;
+ Ghdl_Rtin_Subtype_Scalar_Range : O_Fnode;
+
+ -- Node for an access or a file type.
+ Ghdl_Rtin_Type_Fileacc : O_Tnode;
+ Ghdl_Rtin_Type_Fileacc_Common : O_Fnode;
+ Ghdl_Rtin_Type_Fileacc_Name : O_Fnode;
+ Ghdl_Rtin_Type_Fileacc_Base : O_Fnode;
+
+ -- Node for an array type.
+ Ghdl_Rtin_Type_Array : O_Tnode;
+ Ghdl_Rtin_Type_Array_Common : O_Fnode;
+ Ghdl_Rtin_Type_Array_Name : O_Fnode;
+ Ghdl_Rtin_Type_Array_Element : O_Fnode;
+ Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode;
+ Ghdl_Rtin_Type_Array_Indexes : O_Fnode;
+
+ -- Node for an array subtype.
+ Ghdl_Rtin_Subtype_Array : O_Tnode;
+ Ghdl_Rtin_Subtype_Array_Common : O_Fnode;
+ Ghdl_Rtin_Subtype_Array_Name : O_Fnode;
+ Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode;
+ Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode;
+ Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode;
+ Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode;
+
+ -- Node for a record element.
+ Ghdl_Rtin_Element : O_Tnode;
+ Ghdl_Rtin_Element_Common : O_Fnode;
+ Ghdl_Rtin_Element_Name : O_Fnode;
+ Ghdl_Rtin_Element_Type : O_Fnode;
+ Ghdl_Rtin_Element_Valoff : O_Fnode;
+ Ghdl_Rtin_Element_Sigoff : O_Fnode;
+
+ -- Node for a record type.
+ Ghdl_Rtin_Type_Record : O_Tnode;
+ Ghdl_Rtin_Type_Record_Common : O_Fnode;
+ Ghdl_Rtin_Type_Record_Name : O_Fnode;
+ Ghdl_Rtin_Type_Record_Nbrel : O_Fnode;
+ Ghdl_Rtin_Type_Record_Elements : O_Fnode;
+ --Ghdl_Rtin_Type_Record_Valsize : O_Fnode;
+ --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode;
+
+ -- Node for an object.
+ Ghdl_Rtin_Object : O_Tnode;
+ Ghdl_Rtin_Object_Common : O_Fnode;
+ Ghdl_Rtin_Object_Name : O_Fnode;
+ Ghdl_Rtin_Object_Loc : O_Fnode;
+ Ghdl_Rtin_Object_Type : O_Fnode;
+
+ -- Node for an instance.
+ Ghdl_Rtin_Instance : O_Tnode;
+ Ghdl_Rtin_Instance_Common : O_Fnode;
+ Ghdl_Rtin_Instance_Name : O_Fnode;
+ Ghdl_Rtin_Instance_Loc : O_Fnode;
+ Ghdl_Rtin_Instance_Parent : O_Fnode;
+ Ghdl_Rtin_Instance_Type : O_Fnode;
+
+ -- Node for a component.
+ Ghdl_Rtin_Component : O_Tnode;
+ Ghdl_Rtin_Component_Common : O_Fnode;
+ Ghdl_Rtin_Component_Name : O_Fnode;
+ Ghdl_Rtin_Component_Nbr_Child : O_Fnode;
+ Ghdl_Rtin_Component_Children : O_Fnode;
+
+ procedure Rti_Initialize
+ is
+ begin
+ -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...)
+ declare
+ Constr : O_Enum_List;
+ begin
+ Start_Enum_Type (Constr, 8);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_top"),
+ Ghdl_Rtik_Top);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_library"),
+ Ghdl_Rtik_Library);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_package"),
+ Ghdl_Rtik_Package);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_package_body"),
+ Ghdl_Rtik_Package_Body);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_entity"),
+ Ghdl_Rtik_Entity);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_architecture"),
+ Ghdl_Rtik_Architecture);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_process"),
+ Ghdl_Rtik_Process);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_block"),
+ Ghdl_Rtik_Block);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_if_generate"),
+ Ghdl_Rtik_If_Generate);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_for_generate"),
+ Ghdl_Rtik_For_Generate);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_instance"),
+ Ghdl_Rtik_Instance);
+
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_constant"),
+ Ghdl_Rtik_Constant);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_iterator"),
+ Ghdl_Rtik_Iterator);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_variable"),
+ Ghdl_Rtik_Variable);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_signal"),
+ Ghdl_Rtik_Signal);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_file"),
+ Ghdl_Rtik_File);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_port"),
+ Ghdl_Rtik_Port);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_generic"),
+ Ghdl_Rtik_Generic);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_alias"),
+ Ghdl_Rtik_Alias);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_guard"),
+ Ghdl_Rtik_Guard);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_component"),
+ Ghdl_Rtik_Component);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_attribute"),
+ Ghdl_Rtik_Attribute);
+
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_b1"),
+ Ghdl_Rtik_Type_B1);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_e8"),
+ Ghdl_Rtik_Type_E8);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_e32"),
+ Ghdl_Rtik_Type_E32);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_i32"),
+ Ghdl_Rtik_Type_I32);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_i64"),
+ Ghdl_Rtik_Type_I64);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_f64"),
+ Ghdl_Rtik_Type_F64);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_p32"),
+ Ghdl_Rtik_Type_P32);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_p64"),
+ Ghdl_Rtik_Type_P64);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_access"),
+ Ghdl_Rtik_Type_Access);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_array"),
+ Ghdl_Rtik_Type_Array);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_record"),
+ Ghdl_Rtik_Type_Record);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_file"),
+ Ghdl_Rtik_Type_File);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_subtype_scalar"),
+ Ghdl_Rtik_Subtype_Scalar);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"),
+ Ghdl_Rtik_Subtype_Array);
+ New_Enum_Literal
+ (Constr,
+ Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"),
+ Ghdl_Rtik_Subtype_Unconstrained_Array);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"),
+ Ghdl_Rtik_Subtype_Record);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"),
+ Ghdl_Rtik_Subtype_Access);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_type_protected"),
+ Ghdl_Rtik_Type_Protected);
+
+ New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_element"),
+ Ghdl_Rtik_Element);
+ New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unit64"),
+ Ghdl_Rtik_Unit64);
+ New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unitptr"),
+ Ghdl_Rtik_Unitptr);
+
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_attribute_transaction"),
+ Ghdl_Rtik_Attribute_Transaction);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_attribute_quiet"),
+ Ghdl_Rtik_Attribute_Quiet);
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_attribute_stable"),
+ Ghdl_Rtik_Attribute_Stable);
+
+ New_Enum_Literal
+ (Constr, Get_Identifier ("__ghdl_rtik_psl_assert"),
+ Ghdl_Rtik_Psl_Assert);
+
+ New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_error"),
+ Ghdl_Rtik_Error);
+ Finish_Enum_Type (Constr, Ghdl_Rtik);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtik"), Ghdl_Rtik);
+ end;
+
+ -- Create type ghdl_rti_depth.
+ Ghdl_Rti_Depth := New_Unsigned_Type (8);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_depth"), Ghdl_Rti_Depth);
+ Ghdl_Rti_U8 := New_Unsigned_Type (8);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_u8"), Ghdl_Rti_U8);
+
+ -- Create type ghdl_rti_common.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rti_Common_Kind,
+ Get_Identifier ("kind"), Ghdl_Rtik);
+ New_Record_Field (Constr, Ghdl_Rti_Common_Depth,
+ Get_Identifier ("depth"), Ghdl_Rti_Depth);
+ New_Record_Field (Constr, Ghdl_Rti_Common_Mode,
+ Get_Identifier ("mode"), Ghdl_Rti_U8);
+ New_Record_Field (Constr, Ghdl_Rti_Common_Max_Depth,
+ Get_Identifier ("max_depth"), Ghdl_Rti_Depth);
+ Finish_Record_Type (Constr, Ghdl_Rti_Common);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_common"),
+ Ghdl_Rti_Common);
+ end;
+
+ Ghdl_Rti_Access := New_Access_Type (Ghdl_Rti_Common);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_access"), Ghdl_Rti_Access);
+
+ Ghdl_Rti_Array := New_Array_Type (Ghdl_Rti_Access, Ghdl_Index_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_array"), Ghdl_Rti_Array);
+
+ Ghdl_Rti_Arr_Acc := New_Access_Type (Ghdl_Rti_Array);
+ New_Type_Decl (Get_Identifier ("__ghdl_rti_arr_acc"),
+ Ghdl_Rti_Arr_Acc);
+
+ -- Ghdl_Component_Link_Type.
+ New_Uncomplete_Record_Type (Ghdl_Component_Link_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_component_link_type"),
+ Ghdl_Component_Link_Type);
+
+ Ghdl_Component_Link_Acc := New_Access_Type (Ghdl_Component_Link_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_component_link_acc"),
+ Ghdl_Component_Link_Acc);
+
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Entity_Link_Rti,
+ Get_Identifier ("rti"), Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Entity_Link_Parent,
+ Wki_Parent, Ghdl_Component_Link_Acc);
+ Finish_Record_Type (Constr, Ghdl_Entity_Link_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_entity_link_type"),
+ Ghdl_Entity_Link_Type);
+ end;
+
+ Ghdl_Entity_Link_Acc := New_Access_Type (Ghdl_Entity_Link_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_entity_link_acc"),
+ Ghdl_Entity_Link_Acc);
+
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Uncomplete_Record_Type (Ghdl_Component_Link_Type, Constr);
+ New_Record_Field (Constr, Ghdl_Component_Link_Instance,
+ Wki_Instance, Ghdl_Entity_Link_Acc);
+ New_Record_Field (Constr, Ghdl_Component_Link_Stmt,
+ Get_Identifier ("stmt"), Ghdl_Rti_Access);
+ Finish_Record_Type (Constr, Ghdl_Component_Link_Type);
+ end;
+
+ -- Create type ghdl_rtin_block
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Loc,
+ Get_Identifier ("loc"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Parent,
+ Wki_Parent, Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Size,
+ Get_Identifier ("size"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Nbr_Child,
+ Get_Identifier ("nbr_child"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Block_Children,
+ Get_Identifier ("children"), Ghdl_Rti_Arr_Acc);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Block);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_block"),
+ Ghdl_Rtin_Block);
+ end;
+
+ -- type (type and subtype declarations).
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Scalar);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_scalar"),
+ Ghdl_Rtin_Type_Scalar);
+ end;
+
+ -- Type_Enum
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Nbr,
+ Get_Identifier ("nbr"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Lits,
+ Get_Identifier ("lits"),
+ Char_Ptr_Array_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Enum);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_enum"),
+ Ghdl_Rtin_Type_Enum);
+ end;
+
+ -- subtype_scalar
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Base,
+ Get_Identifier ("base"), Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Range,
+ Get_Identifier ("range"), Ghdl_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"),
+ Ghdl_Rtin_Subtype_Scalar);
+ end;
+
+ -- Unit64
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Unit64_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value,
+ Wki_Val, Ghdl_I64_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Unit64);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"),
+ Ghdl_Rtin_Unit64);
+ end;
+
+ -- Unitptr
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Value,
+ Get_Identifier ("addr"), Ghdl_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Unitptr);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_unitptr"),
+ Ghdl_Rtin_Unitptr);
+ end;
+
+ -- Physical type.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Nbr,
+ Get_Identifier ("nbr"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Units,
+ Get_Identifier ("units"), Ghdl_Rti_Arr_Acc);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Physical);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_physical"),
+ Ghdl_Rtin_Type_Physical);
+ end;
+
+ -- file and access type.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Base,
+ Get_Identifier ("base"), Ghdl_Rti_Access);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Fileacc);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_fileacc"),
+ Ghdl_Rtin_Type_Fileacc);
+ end;
+
+ -- arraytype.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Element,
+ Get_Identifier ("element"), Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Nbrdim,
+ Get_Identifier ("nbr_dim"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Indexes,
+ Get_Identifier ("indexes"), Ghdl_Rti_Arr_Acc);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Array);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_array"),
+ Ghdl_Rtin_Type_Array);
+ end;
+
+ -- subtype_Array.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype,
+ Get_Identifier ("basetype"), Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds,
+ Get_Identifier ("bounds"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize,
+ Get_Identifier ("val_size"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize,
+ Get_Identifier ("sig_size"), Ghdl_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"),
+ Ghdl_Rtin_Subtype_Array);
+ end;
+
+ -- type record.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Nbrel,
+ Get_Identifier ("nbrel"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements,
+ Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"),
+ Ghdl_Rtin_Type_Record);
+ end;
+
+ -- record element.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Type,
+ Get_Identifier ("eltype"), Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Valoff,
+ Get_Identifier ("val_off"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff,
+ Get_Identifier ("sig_off"), Ghdl_Index_Type);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Element);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"),
+ Ghdl_Rtin_Element);
+ end;
+
+ -- Object.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Object_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Object_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Object_Loc,
+ Get_Identifier ("loc"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Object_Type,
+ Get_Identifier ("obj_type"), Ghdl_Rti_Access);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Object);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"),
+ Ghdl_Rtin_Object);
+ end;
+
+ -- Instance.
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Instance_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Instance_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc,
+ Get_Identifier ("loc"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent,
+ Wki_Parent, Ghdl_Rti_Access);
+ New_Record_Field (Constr, Ghdl_Rtin_Instance_Type,
+ Get_Identifier ("instance"), Ghdl_Rti_Access);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Instance);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_instance"),
+ Ghdl_Rtin_Instance);
+ end;
+
+ -- Component
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Rtin_Component_Common,
+ Get_Identifier ("common"), Ghdl_Rti_Common);
+ New_Record_Field (Constr, Ghdl_Rtin_Component_Name,
+ Get_Identifier ("name"), Char_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Component_Nbr_Child,
+ Get_Identifier ("nbr_child"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Component_Children,
+ Get_Identifier ("children"), Ghdl_Rti_Arr_Acc);
+ Finish_Record_Type (Constr, Ghdl_Rtin_Component);
+ New_Type_Decl (Get_Identifier ("__ghdl_rtin_component"),
+ Ghdl_Rtin_Component);
+ end;
+
+ end Rti_Initialize;
+
+ type Rti_Array is array (1 .. 8) of O_Dnode;
+ type Rti_Array_List;
+ type Rti_Array_List_Acc is access Rti_Array_List;
+ type Rti_Array_List is record
+ Rtis : Rti_Array;
+ Next : Rti_Array_List_Acc;
+ end record;
+
+ type Rti_Block is record
+ Depth : Rti_Depth_Type;
+ Nbr : Integer;
+ List : Rti_Array_List;
+ Last_List : Rti_Array_List_Acc;
+ Last_Nbr : Integer;
+ end record;
+
+ Cur_Block : Rti_Block := (Depth => 0,
+ Nbr => 0,
+ List => (Rtis => (others => O_Dnode_Null),
+ Next => null),
+ Last_List => null,
+ Last_Nbr => 0);
+
+ Free_List : Rti_Array_List_Acc := null;
+
+ procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True)
+ is
+ Ndepth : Rti_Depth_Type;
+ begin
+ if Deeper then
+ Ndepth := Cur_Block.Depth + 1;
+ else
+ Ndepth := Cur_Block.Depth;
+ end if;
+ Prev := Cur_Block;
+ Cur_Block := (Depth => Ndepth,
+ Nbr => 0,
+ List => (Rtis => (others => O_Dnode_Null),
+ Next => null),
+ Last_List => null,
+ Last_Nbr => 0);
+ end Push_Rti_Node;
+
+ procedure Add_Rti_Node (Node : O_Dnode)
+ is
+ begin
+ if Node = O_Dnode_Null then
+ -- FIXME: temporary for not yet handled types.
+ return;
+ end if;
+ if Cur_Block.Last_Nbr = Rti_Array'Last then
+ declare
+ N : Rti_Array_List_Acc;
+ begin
+ if Free_List = null then
+ N := new Rti_Array_List;
+ else
+ N := Free_List;
+ Free_List := N.Next;
+ end if;
+ N.Next := null;
+ if Cur_Block.Last_List = null then
+ Cur_Block.List.Next := N;
+ else
+ Cur_Block.Last_List.Next := N;
+ end if;
+ Cur_Block.Last_List := N;
+ end;
+ Cur_Block.Last_Nbr := 1;
+ else
+ Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1;
+ end if;
+ if Cur_Block.Last_List = null then
+ Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node;
+ else
+ Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node;
+ end if;
+ Cur_Block.Nbr := Cur_Block.Nbr + 1;
+ end Add_Rti_Node;
+
+ function Generate_Rti_Array (Id : O_Ident) return O_Dnode
+ is
+ Arr_Type : O_Tnode;
+ List : O_Array_Aggr_List;
+ L : Rti_Array_List_Acc;
+ Nbr : Integer;
+ Val : O_Cnode;
+ Res : O_Dnode;
+ begin
+ Arr_Type := New_Constrained_Array_Type
+ (Ghdl_Rti_Array,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Cur_Block.Nbr + 1)));
+ New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type);
+ Start_Const_Value (Res);
+ Start_Array_Aggr (List, Arr_Type);
+ Nbr := Cur_Block.Nbr;
+ for I in Cur_Block.List.Rtis'Range loop
+ exit when I > Nbr;
+ New_Array_Aggr_El
+ (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I),
+ Ghdl_Rti_Access));
+ end loop;
+ L := Cur_Block.List.Next;
+ while L /= null loop
+ Nbr := Nbr - Cur_Block.List.Rtis'Length;
+ for I in L.Rtis'Range loop
+ exit when I > Nbr;
+ New_Array_Aggr_El
+ (List, New_Global_Unchecked_Address (L.Rtis (I),
+ Ghdl_Rti_Access));
+ end loop;
+ L := L.Next;
+ end loop;
+ New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access));
+ Finish_Array_Aggr (List, Val);
+ Finish_Const_Value (Res, Val);
+ return Res;
+ end Generate_Rti_Array;
+
+ procedure Pop_Rti_Node (Prev : Rti_Block)
+ is
+ L : Rti_Array_List_Acc;
+ begin
+ L := Cur_Block.List.Next;
+ if L /= null then
+ Cur_Block.Last_List.Next := Free_List;
+ Free_List := Cur_Block.List.Next;
+ Cur_Block.List.Next := null;
+ end if;
+ Cur_Block := Prev;
+ end Pop_Rti_Node;
+
+ function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type
+ is
+ begin
+ if Var = Null_Var or else Is_Var_Field (Var) then
+ return Cur_Block.Depth;
+ else
+ return 0;
+ end if;
+ end Get_Depth_From_Var;
+
+ function Generate_Common
+ (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0)
+ return O_Cnode
+ is
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ Val : Unsigned_64;
+ begin
+ Start_Record_Aggr (List, Ghdl_Rti_Common);
+ New_Record_Aggr_El (List, Kind);
+ Val := Unsigned_64 (Get_Depth_From_Var (Var));
+ New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, Val));
+ New_Record_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode)));
+ New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, 0));
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Generate_Common;
+
+ -- Same as Generat_Common but for types.
+ function Generate_Common_Type (Kind : O_Cnode;
+ Depth : Rti_Depth_Type;
+ Max_Depth : Rti_Depth_Type;
+ Mode : Natural := 0)
+ return O_Cnode
+ is
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Start_Record_Aggr (List, Ghdl_Rti_Common);
+ New_Record_Aggr_El (List, Kind);
+ New_Record_Aggr_El
+ (List,
+ New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Depth)));
+ New_Record_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode)));
+ New_Record_Aggr_El
+ (List,
+ New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Max_Depth)));
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Generate_Common_Type;
+
+ function Generate_Name (Node : Iir) return O_Dnode
+ is
+ use Name_Table;
+ Id : Name_Id;
+ begin
+ Id := Get_Identifier (Node);
+ if Is_Character (Id) then
+ Name_Buffer (1) := ''';
+ Name_Buffer (2) := Get_Character (Id);
+ Name_Buffer (3) := ''';
+ Name_Length := 3;
+ else
+ Image (Id);
+ end if;
+ return Create_String (Name_Buffer (1 .. Name_Length),
+ Create_Identifier ("RTISTR"));
+ end Generate_Name;
+
+ function Get_Null_Loc return O_Cnode is
+ begin
+ return New_Null_Access (Ghdl_Ptr_Type);
+ end Get_Null_Loc;
+
+ function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode
+ is
+ begin
+ if Is_Var_Field (Var) then
+ return Get_Var_Offset (Var, Ghdl_Ptr_Type);
+ else
+ return New_Global_Unchecked_Address (Get_Var_Label (Var),
+ Ghdl_Ptr_Type);
+ end if;
+ end Var_Acc_To_Loc;
+
+ -- Generate a name constant for the name of type definition DEF.
+ -- If DEF is an anonymous subtype, returns O_LNODE_NULL.
+ -- Use function NEW_NAME_ADDRESS (defined below) to convert the
+ -- result into an address expression.
+ function Generate_Type_Name (Def : Iir) return O_Dnode
+ is
+ Decl : Iir;
+ begin
+ Decl := Get_Type_Declarator (Def);
+ if Decl /= Null_Iir then
+ return Generate_Name (Decl);
+ else
+ return O_Dnode_Null;
+ end if;
+ end Generate_Type_Name;
+
+ -- Convert a name constant NAME into an address.
+ -- If NAME is O_LNODE_NULL, return a null address.
+ -- To be used with GENERATE_TYPE_NAME.
+ function New_Name_Address (Name : O_Dnode) return O_Cnode
+ is
+ begin
+ if Name = O_Dnode_Null then
+ return New_Null_Access (Char_Ptr_Type);
+ else
+ return New_Global_Unchecked_Address (Name, Char_Ptr_Type);
+ end if;
+ end New_Name_Address;
+
+ function New_Rti_Address (Rti : O_Dnode) return O_Cnode is
+ begin
+ return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access);
+ end New_Rti_Address;
+
+ -- Declare the RTI constant for type definition attached to INFO.
+ -- The only feature is not to declare it if it was already declared.
+ -- (due to an incomplete type declaration).
+ procedure Generate_Type_Rti (Info : Type_Info_Acc; Rti_Type : O_Tnode)
+ is
+ begin
+ if Info.Type_Rti = O_Dnode_Null then
+ New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"),
+ Global_Storage, Rti_Type);
+ end if;
+ end Generate_Type_Rti;
+
+ function Generate_Type_Definition (Atype : Iir; Force : Boolean := False)
+ return O_Dnode;
+
+ procedure Generate_Enumeration_Type_Definition (Atype : Iir)
+ is
+ Info : constant Type_Info_Acc := Get_Info (Atype);
+ Val : O_Cnode;
+ begin
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum);
+ Info.T.Rti_Max_Depth := 0;
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ declare
+ Lit_List : constant Iir_List :=
+ Get_Enumeration_Literal_List (Atype);
+ Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List);
+ Lit : Iir;
+
+ type Dnode_Array is array (Natural range <>) of O_Dnode;
+ Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1);
+ Mark : Id_Mark_Type;
+ Name_Arr_Type : O_Tnode;
+ Name_Arr : O_Dnode;
+
+ Arr_Aggr : O_Array_Aggr_List;
+ Rec_Aggr : O_Record_Aggr_List;
+ Kind : O_Cnode;
+ Name : O_Dnode;
+ begin
+ -- Generate name for each literal.
+ for I in Name_Lits'Range loop
+ Lit := Get_Nth_Element (Lit_List, I);
+ Push_Identifier_Prefix (Mark, Get_Identifier (Lit));
+ Name_Lits (I) := Generate_Name (Lit);
+ Pop_Identifier_Prefix (Mark);
+ end loop;
+
+ -- Generate array of names.
+ Name_Arr_Type := New_Constrained_Array_Type
+ (Char_Ptr_Array_Type,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Lit)));
+ New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"),
+ O_Storage_Private, Name_Arr_Type);
+ Start_Const_Value (Name_Arr);
+ Start_Array_Aggr (Arr_Aggr, Name_Arr_Type);
+ for I in Name_Lits'Range loop
+ New_Array_Aggr_El
+ (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type));
+ end loop;
+ Finish_Array_Aggr (Arr_Aggr, Val);
+ Finish_Const_Value (Name_Arr, Val);
+
+ Name := Generate_Type_Name (Atype);
+
+ Start_Const_Value (Info.Type_Rti);
+ case Info.Type_Mode is
+ when Type_Mode_B1 =>
+ Kind := Ghdl_Rtik_Type_B1;
+ when Type_Mode_E8 =>
+ Kind := Ghdl_Rtik_Type_E8;
+ when Type_Mode_E32 =>
+ Kind := Ghdl_Rtik_Type_E32;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum);
+ New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0));
+ New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El
+ (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Lit)));
+ New_Record_Aggr_El
+ (Rec_Aggr,
+ New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type));
+ Finish_Record_Aggr (Rec_Aggr, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end;
+ end Generate_Enumeration_Type_Definition;
+
+ procedure Generate_Scalar_Type_Definition (Atype : Iir; Name : O_Dnode)
+ is
+ Info : Type_Info_Acc;
+ Kind : O_Cnode;
+ Val : O_Cnode;
+ List : O_Record_Aggr_List;
+ begin
+ Info := Get_Info (Atype);
+
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar);
+ Info.T.Rti_Max_Depth := 0;
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Start_Const_Value (Info.Type_Rti);
+ case Info.Type_Mode is
+ when Type_Mode_I32 =>
+ Kind := Ghdl_Rtik_Type_I32;
+ when Type_Mode_I64 =>
+ Kind := Ghdl_Rtik_Type_I64;
+ when Type_Mode_F64 =>
+ Kind := Ghdl_Rtik_Type_F64;
+ when Type_Mode_P64 =>
+ Kind := Ghdl_Rtik_Type_P64;
+ when others =>
+ Error_Kind ("generate_scalar_type_definition", Atype);
+ end case;
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar);
+ New_Record_Aggr_El (List, Generate_Common_Type (Kind, 0, 0));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Scalar_Type_Definition;
+
+ procedure Generate_Unit_Declaration (Unit : Iir_Unit_Declaration)
+ is
+ Name : O_Dnode;
+ Mark : Id_Mark_Type;
+ Aggr : O_Record_Aggr_List;
+ Val : O_Cnode;
+ Const : O_Dnode;
+ Info : constant Object_Info_Acc := Get_Info (Unit);
+ Rti_Type : O_Tnode;
+ Rtik : O_Cnode;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Unit));
+ Name := Generate_Name (Unit);
+ if Info /= null then
+ -- Non-static units. The only possibility is a unit of
+ -- std.standard.time.
+ Rti_Type := Ghdl_Rtin_Unitptr;
+ Rtik := Ghdl_Rtik_Unitptr;
+ else
+ Rti_Type := Ghdl_Rtin_Unit64;
+ Rtik := Ghdl_Rtik_Unit64;
+ end if;
+ New_Const_Decl (Const, Create_Identifier ("RTI"),
+ Global_Storage, Rti_Type);
+ Start_Const_Value (Const);
+ Start_Record_Aggr (Aggr, Rti_Type);
+ New_Record_Aggr_El (Aggr, Generate_Common (Rtik));
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ if Info /= null then
+ -- Handle non-static units. The only possibility is a unit of
+ -- std.standard.time.
+ Val := New_Global_Unchecked_Address
+ (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type);
+ else
+ Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type);
+ end if;
+ New_Record_Aggr_El (Aggr, Val);
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (Const, Val);
+ Add_Rti_Node (Const);
+ Pop_Identifier_Prefix (Mark);
+ end Generate_Unit_Declaration;
+
+ procedure Generate_Physical_Type_Definition (Atype : Iir; Name : O_Dnode)
+ is
+ Info : Type_Info_Acc;
+ Val : O_Cnode;
+ List : O_Record_Aggr_List;
+ Prev : Rti_Block;
+ Unit : Iir_Unit_Declaration;
+ Nbr_Units : Integer;
+ Unit_Arr : O_Dnode;
+ Rti_Kind : O_Cnode;
+ begin
+ Info := Get_Info (Atype);
+
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Physical);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Push_Rti_Node (Prev, False);
+ Unit := Get_Unit_Chain (Atype);
+ Nbr_Units := 0;
+ while Unit /= Null_Iir loop
+ Generate_Unit_Declaration (Unit);
+ Nbr_Units := Nbr_Units + 1;
+ Unit := Get_Chain (Unit);
+ end loop;
+ Unit_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY"));
+ Pop_Rti_Node (Prev);
+
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Physical);
+ case Info.Type_Mode is
+ when Type_Mode_P64 =>
+ Rti_Kind := Ghdl_Rtik_Type_P64;
+ when Type_Mode_P32 =>
+ Rti_Kind := Ghdl_Rtik_Type_P32;
+ when others =>
+ raise Internal_Error;
+ end case;
+ New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ New_Record_Aggr_El
+ (List,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Units)));
+ New_Record_Aggr_El
+ (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc));
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Physical_Type_Definition;
+
+ procedure Generate_Scalar_Subtype_Definition (Atype : Iir)
+ is
+ Base_Type : Iir;
+ Base_Info : Type_Info_Acc;
+ Info : Type_Info_Acc;
+ Aggr : O_Record_Aggr_List;
+ Val : O_Cnode;
+ Name : O_Dnode;
+ begin
+ Info := Get_Info (Atype);
+
+ if Global_Storage = O_Storage_External then
+ Name := O_Dnode_Null;
+ else
+ Name := Generate_Type_Name (Atype);
+ end if;
+
+ -- Generate base type definition, if necessary.
+ -- (do it even in packages).
+ Base_Type := Get_Base_Type (Atype);
+ Base_Info := Get_Info (Base_Type);
+ if Base_Info.Type_Rti = O_Dnode_Null then
+ declare
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, "BT");
+ if Get_Kind (Base_Type) = Iir_Kind_Physical_Type_Definition then
+ Generate_Physical_Type_Definition (Base_Type, Name);
+ else
+ Generate_Scalar_Type_Definition (Base_Type, Name);
+ end if;
+ Pop_Identifier_Prefix (Mark);
+ end;
+ end if;
+
+ Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Scalar);
+ Info.T.Rti_Max_Depth := Get_Depth_From_Var (Info.T.Range_Var);
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Scalar);
+ New_Record_Aggr_El
+ (Aggr, Generate_Common_Type (Ghdl_Rtik_Subtype_Scalar,
+ Info.T.Rti_Max_Depth,
+ Info.T.Rti_Max_Depth));
+
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti));
+ New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Info.T.Range_Var));
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Scalar_Subtype_Definition;
+
+ procedure Generate_Fileacc_Type_Definition (Atype : Iir)
+ is
+ Info : Type_Info_Acc;
+ Kind : O_Cnode;
+ Val : O_Cnode;
+ List : O_Record_Aggr_List;
+ Name : O_Dnode;
+ Base : O_Dnode;
+ Base_Type : Iir;
+ begin
+ Info := Get_Info (Atype);
+
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Fileacc);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ case Get_Kind (Atype) is
+ when Iir_Kind_Access_Type_Definition =>
+ declare
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, "AT");
+ Base := Generate_Type_Definition
+ (Get_Designated_Type (Atype));
+ Pop_Identifier_Prefix (Mark);
+ end;
+ if Get_Kind (Atype) = Iir_Kind_Access_Subtype_Definition then
+ Kind := Ghdl_Rtik_Subtype_Access;
+ else
+ Kind := Ghdl_Rtik_Type_Access;
+ end if;
+ -- Don't bother with designated type. This at least avoid
+ -- loops.
+ Base_Type := Null_Iir;
+ when Iir_Kind_File_Type_Definition =>
+ Base_Type := Get_Type (Get_File_Type_Mark (Atype));
+ Base := Generate_Type_Definition (Base_Type);
+ Kind := Ghdl_Rtik_Type_File;
+ when Iir_Kind_Record_Subtype_Definition =>
+ Base_Type := Get_Base_Type (Atype);
+ Base := Get_Info (Base_Type).Type_Rti;
+ Kind := Ghdl_Rtik_Subtype_Record;
+ when Iir_Kind_Access_Subtype_Definition =>
+ Base_Type := Get_Base_Type (Atype);
+ Base := Get_Info (Base_Type).Type_Rti;
+ Kind := Ghdl_Rtik_Subtype_Access;
+ when others =>
+ Error_Kind ("rti.generate_fileacc_type_definition", Atype);
+ end case;
+ if Base_Type = Null_Iir then
+ Info.T.Rti_Max_Depth := 0;
+ else
+ Info.T.Rti_Max_Depth := Get_Info (Base_Type).T.Rti_Max_Depth;
+ end if;
+ Name := Generate_Type_Name (Atype);
+
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Fileacc);
+ New_Record_Aggr_El
+ (List, Generate_Common_Type (Kind, 0, Info.T.Rti_Max_Depth));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ New_Record_Aggr_El (List, New_Rti_Address (Base));
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Fileacc_Type_Definition;
+
+ procedure Generate_Array_Type_Indexes
+ (Atype : Iir; Res : out O_Dnode; Max_Depth : in out Rti_Depth_Type)
+ is
+ List : constant Iir_List := Get_Index_Subtype_List (Atype);
+ Nbr_Indexes : constant Natural := Get_Nbr_Elements (List);
+ Index : Iir;
+ Tmp : O_Dnode;
+ pragma Unreferenced (Tmp);
+ Arr_Type : O_Tnode;
+ Arr_Aggr : O_Array_Aggr_List;
+ Val : O_Cnode;
+ Mark : Id_Mark_Type;
+ begin
+ -- Translate each index.
+ for I in 1 .. Nbr_Indexes loop
+ Index := Get_Index_Type (List, I - 1);
+ Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I));
+ Tmp := Generate_Type_Definition (Index);
+ Max_Depth := Rti_Depth_Type'Max (Max_Depth,
+ Get_Info (Index).T.Rti_Max_Depth);
+ Pop_Identifier_Prefix (Mark);
+ end loop;
+
+ -- Generate array of index.
+ Arr_Type := New_Constrained_Array_Type
+ (Ghdl_Rti_Array,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Indexes)));
+ New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"),
+ Global_Storage, Arr_Type);
+ Start_Const_Value (Res);
+
+ Start_Array_Aggr (Arr_Aggr, Arr_Type);
+ for I in 1 .. Nbr_Indexes loop
+ Index := Get_Index_Type (List, I - 1);
+ New_Array_Aggr_El
+ (Arr_Aggr, New_Rti_Address (Generate_Type_Definition (Index)));
+ end loop;
+ Finish_Array_Aggr (Arr_Aggr, Val);
+ Finish_Const_Value (Res, Val);
+ end Generate_Array_Type_Indexes;
+
+ function Type_To_Mode (Atype : Iir) return Natural is
+ Res : Natural := 0;
+ begin
+ if Is_Complex_Type (Get_Info (Atype)) then
+ Res := Res + 1;
+ end if;
+ if Is_Anonymous_Type_Definition (Atype)
+ or else (Get_Kind (Get_Type_Declarator (Atype))
+ = Iir_Kind_Anonymous_Type_Declaration)
+ then
+ Res := Res + 2;
+ end if;
+ return Res;
+ end Type_To_Mode;
+
+ procedure Generate_Array_Type_Definition
+ (Atype : Iir_Array_Type_Definition)
+ is
+ Info : Type_Info_Acc;
+ Aggr : O_Record_Aggr_List;
+ Val : O_Cnode;
+ List : Iir_List;
+ Arr : O_Dnode;
+ Element : Iir;
+ Name : O_Dnode;
+ El_Info : Type_Info_Acc;
+ Max_Depth : Rti_Depth_Type;
+ begin
+ Info := Get_Info (Atype);
+
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Array);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Name := Generate_Type_Name (Atype);
+ Element := Get_Element_Subtype (Atype);
+ El_Info := Get_Info (Element);
+ if El_Info.Type_Rti = O_Dnode_Null then
+ declare
+ Mark : Id_Mark_Type;
+ El_Rti : O_Dnode;
+ pragma Unreferenced (El_Rti);
+ begin
+ Push_Identifier_Prefix (Mark, "EL");
+ El_Rti := Generate_Type_Definition (Element);
+ Pop_Identifier_Prefix (Mark);
+ end;
+ end if;
+ Max_Depth := El_Info.T.Rti_Max_Depth;
+
+ -- Translate each index.
+ Generate_Array_Type_Indexes (Atype, Arr, Max_Depth);
+ Info.T.Rti_Max_Depth := Max_Depth;
+ List := Get_Index_Subtype_List (Atype);
+
+ -- Generate node.
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Array);
+ New_Record_Aggr_El
+ (Aggr,
+ Generate_Common_Type
+ (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype)));
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti));
+ New_Record_Aggr_El
+ (Aggr,
+ New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Get_Nbr_Elements (List))));
+ New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Array_Type_Definition;
+
+ procedure Generate_Array_Subtype_Definition
+ (Atype : Iir_Array_Subtype_Definition)
+ is
+ Base_Type : Iir;
+ Base_Info : Type_Info_Acc;
+ Info : Type_Info_Acc;
+ Aggr : O_Record_Aggr_List;
+ Val : O_Cnode;
+ Base_Rti : O_Dnode;
+ pragma Unreferenced (Base_Rti);
+ Bounds : Var_Type;
+ Name : O_Dnode;
+ Kind : O_Cnode;
+ Mark : Id_Mark_Type;
+ Depth : Rti_Depth_Type;
+ begin
+ -- FIXME: temporary work-around
+ if Get_Constraint_State (Atype) /= Fully_Constrained then
+ return;
+ end if;
+
+ Info := Get_Info (Atype);
+
+ Base_Type := Get_Base_Type (Atype);
+ Base_Info := Get_Info (Base_Type);
+ if Base_Info.Type_Rti = O_Dnode_Null then
+ Push_Identifier_Prefix (Mark, "BT");
+ Base_Rti := Generate_Type_Definition (Base_Type);
+ Pop_Identifier_Prefix (Mark);
+ end if;
+
+ Bounds := Info.T.Array_Bounds;
+ Depth := Get_Depth_From_Var (Bounds);
+ Info.T.Rti_Max_Depth :=
+ Rti_Depth_Type'Max (Depth, Base_Info.T.Rti_Max_Depth);
+
+ -- Generate node.
+ Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array);
+
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Name := Generate_Type_Name (Atype);
+
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array);
+ case Info.Type_Mode is
+ when Type_Mode_Array =>
+ Kind := Ghdl_Rtik_Subtype_Array;
+ when Type_Mode_Fat_Array =>
+ Kind := Ghdl_Rtik_Subtype_Unconstrained_Array;
+ when others =>
+ Error_Kind ("generate_array_subtype_definition", Atype);
+ end case;
+ New_Record_Aggr_El
+ (Aggr,
+ Generate_Common_Type
+ (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype)));
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti));
+ if Bounds = Null_Var then
+ Val := Get_Null_Loc;
+ else
+ Val := Var_Acc_To_Loc (Bounds);
+ end if;
+ New_Record_Aggr_El (Aggr, Val);
+ for I in Mode_Value .. Mode_Signal loop
+ case Info.Type_Mode is
+ when Type_Mode_Array =>
+ Val := Get_Null_Loc;
+ if Info.Ortho_Type (I) /= O_Tnode_Null then
+ if Is_Complex_Type (Info) then
+ if Info.C (I).Size_Var /= Null_Var then
+ Val := Var_Acc_To_Loc (Info.C (I).Size_Var);
+ end if;
+ else
+ Val := New_Sizeof (Info.Ortho_Type (I),
+ Ghdl_Ptr_Type);
+ end if;
+ end if;
+ when Type_Mode_Fat_Array =>
+ Val := Get_Null_Loc;
+ when others =>
+ Error_Kind ("generate_array_subtype_definition", Atype);
+ end case;
+ New_Record_Aggr_El (Aggr, Val);
+ end loop;
+
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Array_Subtype_Definition;
+
+ procedure Generate_Record_Type_Definition (Atype : Iir)
+ is
+ El_List : Iir_List;
+ El : Iir;
+ Prev : Rti_Block;
+ El_Arr : O_Dnode;
+ Res : O_Cnode;
+ Info : constant Type_Info_Acc := Get_Info (Atype);
+ Max_Depth : Rti_Depth_Type;
+ begin
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record);
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ El_List := Get_Elements_Declaration_List (Atype);
+ Max_Depth := 0;
+
+ -- Generate elements.
+ Push_Rti_Node (Prev, False);
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ declare
+ Type_Rti : O_Dnode;
+ El_Name : O_Dnode;
+ El_Type : constant Iir := Get_Type (El);
+ Aggr : O_Record_Aggr_List;
+ Field_Info : constant Field_Info_Acc := Get_Info (El);
+ Val : O_Cnode;
+ El_Const : O_Dnode;
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (El));
+
+ Type_Rti := Generate_Type_Definition (El_Type);
+ Max_Depth :=
+ Rti_Depth_Type'Max (Max_Depth,
+ Get_Info (El_Type).T.Rti_Max_Depth);
+
+ El_Name := Generate_Name (El);
+ New_Const_Decl (El_Const, Create_Identifier ("RTIEL"),
+ Global_Storage, Ghdl_Rtin_Element);
+ Start_Const_Value (El_Const);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Element);
+ New_Record_Aggr_El (Aggr,
+ Generate_Common (Ghdl_Rtik_Element));
+ New_Record_Aggr_El (Aggr, New_Name_Address (El_Name));
+ New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti));
+ for I in Object_Kind_Type loop
+ if Field_Info.Field_Node (I) /= O_Fnode_Null then
+ Val := New_Offsetof (Info.Ortho_Type (I),
+ Field_Info.Field_Node (I),
+ Ghdl_Index_Type);
+ else
+ Val := Ghdl_Index_0;
+ end if;
+ New_Record_Aggr_El (Aggr, Val);
+ end loop;
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (El_Const, Val);
+ Add_Rti_Node (El_Const);
+
+ Pop_Identifier_Prefix (Mark);
+ end;
+ end loop;
+ El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY"));
+ Pop_Rti_Node (Prev);
+
+ Info.T.Rti_Max_Depth := Max_Depth;
+ -- Generate record.
+ declare
+ Aggr : O_Record_Aggr_List;
+ Name : O_Dnode;
+ begin
+ Name := Generate_Type_Name (Atype);
+
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record);
+ New_Record_Aggr_El
+ (Aggr,
+ Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth,
+ Type_To_Mode (Atype)));
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El
+ (Aggr, New_Unsigned_Literal
+ (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List))));
+ New_Record_Aggr_El (Aggr,
+ New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc));
+ Finish_Record_Aggr (Aggr, Res);
+ Finish_Const_Value (Info.Type_Rti, Res);
+ end;
+ end Generate_Record_Type_Definition;
+
+ procedure Generate_Protected_Type_Declaration (Atype : Iir)
+ is
+ Info : Type_Info_Acc;
+ Name : O_Dnode;
+ Val : O_Cnode;
+ List : O_Record_Aggr_List;
+ begin
+ Info := Get_Info (Atype);
+ Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar);
+ if Global_Storage = O_Storage_External then
+ return;
+ end if;
+
+ Name := Generate_Type_Name (Atype);
+ Start_Const_Value (Info.Type_Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar);
+ New_Record_Aggr_El
+ (List,
+ Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0,
+ Type_To_Mode (Atype)));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Info.Type_Rti, Val);
+ end Generate_Protected_Type_Declaration;
+
+ -- If FORCE is true, force the creation of the type RTI.
+ -- Otherwise, only the declaration (and not the definition) may have
+ -- been created.
+ function Generate_Type_Definition (Atype : Iir; Force : Boolean := False)
+ return O_Dnode
+ is
+ Info : constant Type_Info_Acc := Get_Info (Atype);
+ begin
+ if not Force and then Info.Type_Rti /= O_Dnode_Null then
+ return Info.Type_Rti;
+ end if;
+ case Get_Kind (Atype) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ raise Internal_Error;
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Generate_Enumeration_Type_Definition (Atype);
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Generate_Scalar_Subtype_Definition (Atype);
+ when Iir_Kind_Array_Type_Definition =>
+ Generate_Array_Type_Definition (Atype);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Generate_Array_Subtype_Definition (Atype);
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_File_Type_Definition =>
+ Generate_Fileacc_Type_Definition (Atype);
+ when Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ -- FIXME: No separate infos (yet).
+ null;
+ when Iir_Kind_Record_Type_Definition =>
+ Generate_Record_Type_Definition (Atype);
+ when Iir_Kind_Protected_Type_Declaration =>
+ Generate_Protected_Type_Declaration (Atype);
+ when others =>
+ Error_Kind ("rti.generate_type_definition", Atype);
+ return O_Dnode_Null;
+ end case;
+ return Info.Type_Rti;
+ end Generate_Type_Definition;
+
+ function Generate_Incomplete_Type_Definition (Def : Iir)
+ return O_Dnode
+ is
+ Ndef : constant Iir := Get_Type (Get_Type_Declarator (Def));
+ Info : constant Type_Info_Acc := Get_Info (Ndef);
+ Rti_Type : O_Tnode;
+ begin
+ case Get_Kind (Ndef) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Scalar;
+ when Iir_Kind_Physical_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Physical;
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Enum;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Rti_Type := Ghdl_Rtin_Subtype_Scalar;
+ when Iir_Kind_Array_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Array;
+ when Iir_Kind_Array_Subtype_Definition =>
+ Rti_Type := Ghdl_Rtin_Subtype_Array;
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_File_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Fileacc;
+ when Iir_Kind_Record_Type_Definition =>
+ Rti_Type := Ghdl_Rtin_Type_Record;
+ when others =>
+ Error_Kind ("rti.generate_incomplete_type_definition", Ndef);
+ end case;
+ New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"),
+ Global_Storage, Rti_Type);
+ return Info.Type_Rti;
+ end Generate_Incomplete_Type_Definition;
+
+ function Generate_Type_Decl (Decl : Iir) return O_Dnode
+ is
+ Id : constant Name_Id := Get_Identifier (Decl);
+ Def : constant Iir := Get_Type (Decl);
+ Rti : O_Dnode;
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Id);
+ if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then
+ Rti := Generate_Incomplete_Type_Definition (Def);
+ else
+ Rti := Generate_Type_Definition (Def, True);
+ end if;
+ Pop_Identifier_Prefix (Mark);
+ return Rti;
+ end Generate_Type_Decl;
+
+ procedure Generate_Signal_Rti (Sig : Iir)
+ is
+ Info : Object_Info_Acc;
+ begin
+ Info := Get_Info (Sig);
+ New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"),
+ Global_Storage, Ghdl_Rtin_Object);
+ end Generate_Signal_Rti;
+
+ procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode)
+ is
+ Decl_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ Name : O_Dnode;
+ Comm : O_Cnode;
+ Val : O_Cnode;
+ List : O_Record_Aggr_List;
+ Info : Ortho_Info_Acc;
+ Mark : Id_Mark_Type;
+ Var : Var_Type;
+ Mode : Natural;
+ Has_Id : Boolean;
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute =>
+ Has_Id := False;
+ Push_Identifier_Prefix_Uniq (Mark);
+ when others =>
+ Has_Id := True;
+ Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ end case;
+
+ if Rti = O_Dnode_Null then
+ New_Const_Decl (Rti, Create_Identifier ("RTI"),
+ Global_Storage, Ghdl_Rtin_Object);
+ end if;
+
+ if Global_Storage /= O_Storage_External then
+ Decl_Type := Get_Type (Decl);
+ Type_Info := Get_Info (Decl_Type);
+ if Type_Info.Type_Rti = O_Dnode_Null then
+ declare
+ Mark : Id_Mark_Type;
+ Tmp : O_Dnode;
+ pragma Unreferenced (Tmp);
+ begin
+ Push_Identifier_Prefix (Mark, "OT");
+ Tmp := Generate_Type_Definition (Decl_Type);
+ Pop_Identifier_Prefix (Mark);
+ end;
+ end if;
+
+ if Has_Id then
+ Name := Generate_Name (Decl);
+ else
+ Name := O_Dnode_Null;
+ end if;
+
+ Info := Get_Info (Decl);
+
+ Start_Const_Value (Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Object);
+ Mode := 0;
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Declaration =>
+ Comm := Ghdl_Rtik_Signal;
+ Var := Info.Object_Var;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ Comm := Ghdl_Rtik_Port;
+ Var := Info.Object_Var;
+ Mode := Iir_Mode'Pos (Get_Mode (Decl));
+ when Iir_Kind_Constant_Declaration =>
+ Comm := Ghdl_Rtik_Constant;
+ Var := Info.Object_Var;
+ when Iir_Kind_Interface_Constant_Declaration =>
+ Comm := Ghdl_Rtik_Generic;
+ Var := Info.Object_Var;
+ when Iir_Kind_Variable_Declaration =>
+ Comm := Ghdl_Rtik_Variable;
+ Var := Info.Object_Var;
+ when Iir_Kind_Guard_Signal_Declaration =>
+ Comm := Ghdl_Rtik_Guard;
+ Var := Info.Object_Var;
+ when Iir_Kind_Iterator_Declaration =>
+ Comm := Ghdl_Rtik_Iterator;
+ Var := Info.Iterator_Var;
+ when Iir_Kind_File_Declaration =>
+ Comm := Ghdl_Rtik_File;
+ Var := Info.Object_Var;
+ when Iir_Kind_Attribute_Declaration =>
+ Comm := Ghdl_Rtik_Attribute;
+ Var := Null_Var;
+ when Iir_Kind_Transaction_Attribute =>
+ Comm := Ghdl_Rtik_Attribute_Transaction;
+ Var := Info.Object_Var;
+ when Iir_Kind_Quiet_Attribute =>
+ Comm := Ghdl_Rtik_Attribute_Quiet;
+ Var := Info.Object_Var;
+ when Iir_Kind_Stable_Attribute =>
+ Comm := Ghdl_Rtik_Attribute_Stable;
+ Var := Info.Object_Var;
+ when Iir_Kind_Object_Alias_Declaration =>
+ Comm := Ghdl_Rtik_Alias;
+ Var := Info.Alias_Var;
+ Mode := Object_Kind_Type'Pos (Info.Alias_Kind);
+ when others =>
+ Error_Kind ("rti.generate_object", Decl);
+ end case;
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Mode := Mode
+ + 16 * Iir_Signal_Kind'Pos (Get_Signal_Kind (Decl));
+ when others =>
+ null;
+ end case;
+ case Get_Kind (Decl) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute =>
+ if Get_Has_Active_Flag (Decl) then
+ Mode := Mode + 64;
+ end if;
+ when others =>
+ null;
+ end case;
+ New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ if Var = Null_Var then
+ Val := Get_Null_Loc;
+ else
+ Val := Var_Acc_To_Loc (Var);
+ end if;
+ New_Record_Aggr_El (List, Val);
+ New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti));
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Rti, Val);
+ end if;
+ Pop_Identifier_Prefix (Mark);
+ end Generate_Object;
+
+ procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode);
+ procedure Generate_Declaration_Chain (Chain : Iir);
+
+ procedure Generate_Component_Declaration (Comp : Iir)
+ is
+ Prev : Rti_Block;
+ Name : O_Dnode;
+ Arr : O_Dnode;
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ Mark : Id_Mark_Type;
+ Info : Comp_Info_Acc;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Comp));
+ Info := Get_Info (Comp);
+
+ New_Const_Decl (Info.Comp_Rti_Const, Create_Identifier ("RTI"),
+ Global_Storage, Ghdl_Rtin_Component);
+
+ if Global_Storage /= O_Storage_External then
+ Push_Rti_Node (Prev);
+
+ Generate_Declaration_Chain (Get_Generic_Chain (Comp));
+ Generate_Declaration_Chain (Get_Port_Chain (Comp));
+
+ Name := Generate_Name (Comp);
+
+ Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY"));
+
+ Start_Const_Value (Info.Comp_Rti_Const);
+ Start_Record_Aggr (List, Ghdl_Rtin_Component);
+ New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component));
+ New_Record_Aggr_El (List,
+ New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Cur_Block.Nbr)));
+ New_Record_Aggr_El (List,
+ New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ Finish_Record_Aggr (List, Res);
+ Finish_Const_Value (Info.Comp_Rti_Const, Res);
+ Pop_Rti_Node (Prev);
+ end if;
+
+ Pop_Identifier_Prefix (Mark);
+ Add_Rti_Node (Info.Comp_Rti_Const);
+ end Generate_Component_Declaration;
+
+ -- Generate RTIs only for types.
+ procedure Generate_Declaration_Chain_Depleted (Chain : Iir)
+ is
+ Decl : Iir;
+ begin
+ Decl := Chain;
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Type_Declaration =>
+ -- FIXME: physicals ?
+ if Get_Kind (Get_Type_Definition (Decl))
+ = Iir_Kind_Enumeration_Type_Definition
+ then
+ Add_Rti_Node (Generate_Type_Decl (Decl));
+ end if;
+ when Iir_Kind_Subtype_Declaration =>
+ -- In a subprogram, a subtype may depends on parameters.
+ -- Eg: array subtypes.
+ null;
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Stable_Attribute =>
+ null;
+ when Iir_Kind_Delayed_Attribute =>
+ -- FIXME: to be added.
+ null;
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Attribute_Declaration =>
+ null;
+ when Iir_Kind_Component_Declaration =>
+ null;
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- FIXME: to be added (for foreign).
+ null;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ null;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ -- Handled in subtype declaration.
+ null;
+ when Iir_Kind_Configuration_Specification
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Disconnection_Specification =>
+ null;
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("rti.generate_declaration_chain_depleted", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Generate_Declaration_Chain_Depleted;
+
+ procedure Generate_Subprogram_Body (Bod : Iir)
+ is
+ --Decl : Iir;
+ --Mark : Id_Mark_Type;
+ begin
+ --Decl := Get_Subprogram_Specification (Bod);
+
+ --Push_Identifier_Prefix (Mark, Get_Identifier (Decl));
+ -- Generate RTI only for types.
+ Generate_Declaration_Chain_Depleted (Get_Declaration_Chain (Bod));
+ --Pop_Identifier_Prefix (Mark);
+ end Generate_Subprogram_Body;
+
+ procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode)
+ is
+ Name : O_Dnode;
+ List : O_Record_Aggr_List;
+ Val : O_Cnode;
+ Inst : constant Iir := Get_Instantiated_Unit (Stmt);
+ Info : constant Block_Info_Acc := Get_Info (Stmt);
+ begin
+ Name := Generate_Name (Stmt);
+
+ New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"),
+ Global_Storage, Ghdl_Rtin_Instance);
+
+ Start_Const_Value (Info.Block_Rti_Const);
+ Start_Record_Aggr (List, Ghdl_Rtin_Instance);
+ New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance));
+ New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El
+ (List, New_Offsetof (Get_Scope_Type
+ (Get_Info (Get_Parent (Stmt)).Block_Scope),
+ Info.Block_Link_Field,
+ Ghdl_Ptr_Type));
+ New_Record_Aggr_El (List, New_Rti_Address (Parent));
+ if Is_Component_Instantiation (Stmt) then
+ Val := New_Rti_Address
+ (Get_Info (Get_Named_Entity (Inst)).Comp_Rti_Const);
+ else
+ declare
+ Ent : constant Iir := Get_Entity_From_Entity_Aspect (Inst);
+ begin
+ Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const);
+ end;
+ end if;
+
+ New_Record_Aggr_El (List, Val);
+ Finish_Record_Aggr (List, Val);
+ Finish_Const_Value (Info.Block_Rti_Const, Val);
+ Add_Rti_Node (Info.Block_Rti_Const);
+ end Generate_Instance;
+
+ procedure Generate_Psl_Directive (Stmt : Iir)
+ is
+ Name : O_Dnode;
+ List : O_Record_Aggr_List;
+
+ Rti : O_Dnode;
+ Res : O_Cnode;
+ Info : constant Psl_Info_Acc := Get_Info (Stmt);
+ Mark : Id_Mark_Type;
+ begin
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Name := Generate_Name (Stmt);
+
+ New_Const_Decl (Rti, Create_Identifier ("RTI"),
+ O_Storage_Public, Ghdl_Rtin_Type_Scalar);
+
+ Start_Const_Value (Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar);
+ New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Psl_Assert));
+ New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ Finish_Record_Aggr (List, Res);
+ Finish_Const_Value (Rti, Res);
+ Info.Psl_Rti_Const := Rti;
+ Pop_Identifier_Prefix (Mark);
+ end Generate_Psl_Directive;
+
+ procedure Generate_Declaration_Chain (Chain : Iir)
+ is
+ Decl : Iir;
+ begin
+ Decl := Chain;
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ -- Handled in subtype declaration.
+ null;
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ Add_Rti_Node (Generate_Type_Decl (Decl));
+ when Iir_Kind_Constant_Declaration =>
+ -- Do not generate RTIs for full declarations.
+ -- (RTI will be generated for the deferred declaration).
+ if Get_Deferred_Declaration (Decl) = Null_Iir
+ or else Get_Deferred_Declaration_Flag (Decl)
+ then
+ declare
+ Info : Object_Info_Acc;
+ begin
+ Info := Get_Info (Decl);
+ Generate_Object (Decl, Info.Object_Rti);
+ Add_Rti_Node (Info.Object_Rti);
+ end;
+ end if;
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Stable_Attribute =>
+ declare
+ Info : Object_Info_Acc;
+ begin
+ Info := Get_Info (Decl);
+ Generate_Object (Decl, Info.Object_Rti);
+ Add_Rti_Node (Info.Object_Rti);
+ end;
+ when Iir_Kind_Delayed_Attribute =>
+ -- FIXME: to be added.
+ null;
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Attribute_Declaration =>
+ declare
+ Rti : O_Dnode := O_Dnode_Null;
+ begin
+ Generate_Object (Decl, Rti);
+ Add_Rti_Node (Rti);
+ end;
+ when Iir_Kind_Component_Declaration =>
+ Generate_Component_Declaration (Decl);
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- FIXME: to be added (for foreign).
+ null;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ -- Already handled by Translate_Subprogram_Body.
+ null;
+ when Iir_Kind_Configuration_Specification
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Disconnection_Specification =>
+ null;
+ when Iir_Kind_Protected_Type_Body =>
+ null;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("rti.generate_declaration_chain", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Generate_Declaration_Chain;
+
+ procedure Generate_Concurrent_Statement_Chain
+ (Chain : Iir; Parent_Rti : O_Dnode)
+ is
+ Stmt : Iir;
+ Mark : Id_Mark_Type;
+ begin
+ Stmt := Chain;
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Generate_Block (Stmt, Parent_Rti);
+ Pop_Identifier_Prefix (Mark);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Push_Identifier_Prefix (Mark, Get_Identifier (Stmt));
+ Generate_Instance (Stmt, Parent_Rti);
+ Pop_Identifier_Prefix (Mark);
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when Iir_Kind_Psl_Assert_Statement =>
+ Generate_Psl_Directive (Stmt);
+ when Iir_Kind_Psl_Cover_Statement =>
+ Generate_Psl_Directive (Stmt);
+ when others =>
+ Error_Kind ("rti.generate_concurrent_statement_chain", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Generate_Concurrent_Statement_Chain;
+
+ procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode)
+ is
+ Name : O_Dnode;
+ Arr : O_Dnode;
+ List : O_Record_Aggr_List;
+
+ Rti : O_Dnode;
+
+ Kind : O_Cnode;
+ Res : O_Cnode;
+
+ Prev : Rti_Block;
+ Info : Ortho_Info_Acc;
+
+ Field_Off : O_Cnode;
+ Inst : O_Tnode;
+ begin
+ -- The type of a generator iterator is elaborated in the parent.
+ if Get_Kind (Blk) = Iir_Kind_Generate_Statement then
+ declare
+ Scheme : Iir;
+ Iter_Type : Iir;
+ Type_Info : Type_Info_Acc;
+ Mark : Id_Mark_Type;
+ Tmp : O_Dnode;
+ begin
+ Scheme := Get_Generation_Scheme (Blk);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Iter_Type := Get_Type (Scheme);
+ Type_Info := Get_Info (Iter_Type);
+ if Type_Info.Type_Rti = O_Dnode_Null then
+ Push_Identifier_Prefix (Mark, "ITERATOR");
+ Tmp := Generate_Type_Definition (Iter_Type);
+ Add_Rti_Node (Tmp);
+ Pop_Identifier_Prefix (Mark);
+ end if;
+ end if;
+ end;
+ end if;
+
+ New_Const_Decl (Rti, Create_Identifier ("RTI"),
+ O_Storage_Public, Ghdl_Rtin_Block);
+ Push_Rti_Node (Prev);
+
+ Field_Off := O_Cnode_Null;
+ Inst := O_Tnode_Null;
+ Info := Get_Info (Blk);
+ case Get_Kind (Blk) is
+ when Iir_Kind_Package_Declaration =>
+ Kind := Ghdl_Rtik_Package;
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ when Iir_Kind_Package_Body =>
+ Kind := Ghdl_Rtik_Package_Body;
+ -- Required at least for 'image
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ when Iir_Kind_Architecture_Body =>
+ Kind := Ghdl_Rtik_Architecture;
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ Generate_Concurrent_Statement_Chain
+ (Get_Concurrent_Statement_Chain (Blk), Rti);
+ Inst := Get_Scope_Type (Info.Block_Scope);
+ Field_Off := New_Offsetof
+ (Get_Scope_Type (Info.Block_Scope),
+ Info.Block_Parent_Field, Ghdl_Ptr_Type);
+ when Iir_Kind_Entity_Declaration =>
+ Kind := Ghdl_Rtik_Entity;
+ Generate_Declaration_Chain (Get_Generic_Chain (Blk));
+ Generate_Declaration_Chain (Get_Port_Chain (Blk));
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ Generate_Concurrent_Statement_Chain
+ (Get_Concurrent_Statement_Chain (Blk), Rti);
+ Inst := Get_Scope_Type (Info.Block_Scope);
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Kind := Ghdl_Rtik_Process;
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ Field_Off :=
+ Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type);
+ Inst := Get_Scope_Type (Info.Process_Scope);
+ when Iir_Kind_Block_Statement =>
+ Kind := Ghdl_Rtik_Block;
+ declare
+ Guard : constant Iir := Get_Guard_Decl (Blk);
+ Header : constant Iir := Get_Block_Header (Blk);
+ Guard_Info : Object_Info_Acc;
+ begin
+ if Guard /= Null_Iir then
+ Guard_Info := Get_Info (Guard);
+ Generate_Object (Guard, Guard_Info.Object_Rti);
+ Add_Rti_Node (Guard_Info.Object_Rti);
+ end if;
+ if Header /= Null_Iir then
+ Generate_Declaration_Chain (Get_Generic_Chain (Header));
+ Generate_Declaration_Chain (Get_Port_Chain (Header));
+ end if;
+ end;
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ Generate_Concurrent_Statement_Chain
+ (Get_Concurrent_Statement_Chain (Blk), Rti);
+ Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type);
+ Inst := Get_Scope_Type (Info.Block_Scope);
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Scheme : constant Iir := Get_Generation_Scheme (Blk);
+ Scheme_Rti : O_Dnode := O_Dnode_Null;
+ begin
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Generate_Object (Scheme, Scheme_Rti);
+ Add_Rti_Node (Scheme_Rti);
+ Kind := Ghdl_Rtik_For_Generate;
+ else
+ Kind := Ghdl_Rtik_If_Generate;
+ end if;
+ end;
+ Generate_Declaration_Chain (Get_Declaration_Chain (Blk));
+ Generate_Concurrent_Statement_Chain
+ (Get_Concurrent_Statement_Chain (Blk), Rti);
+ Inst := Get_Scope_Type (Info.Block_Scope);
+ Field_Off := New_Offsetof
+ (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope),
+ Info.Block_Parent_Field, Ghdl_Ptr_Type);
+ when others =>
+ Error_Kind ("rti.generate_block", Blk);
+ end case;
+
+ Name := Generate_Name (Blk);
+
+ Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY"));
+
+ Start_Const_Value (Rti);
+ Start_Record_Aggr (List, Ghdl_Rtin_Block);
+ New_Record_Aggr_El (List, Generate_Common (Kind));
+ New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ if Field_Off = O_Cnode_Null then
+ Field_Off := Get_Null_Loc;
+ end if;
+ New_Record_Aggr_El (List, Field_Off);
+ if Parent_Rti = O_Dnode_Null then
+ Res := New_Null_Access (Ghdl_Rti_Access);
+ else
+ Res := New_Rti_Address (Parent_Rti);
+ end if;
+ New_Record_Aggr_El (List, Res);
+ if Inst = O_Tnode_Null then
+ Res := Ghdl_Index_0;
+ else
+ Res := New_Sizeof (Inst, Ghdl_Index_Type);
+ end if;
+ New_Record_Aggr_El (List, Res);
+ New_Record_Aggr_El
+ (List, New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Cur_Block.Nbr)));
+ New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ Finish_Record_Aggr (List, Res);
+ Finish_Const_Value (Rti, Res);
+
+ Pop_Rti_Node (Prev);
+
+ -- Put children in the parent list.
+ case Get_Kind (Blk) is
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Add_Rti_Node (Rti);
+ when others =>
+ null;
+ end case;
+
+ -- Store the RTI.
+ case Get_Kind (Blk) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Info.Block_Rti_Const := Rti;
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Info.Process_Rti_Const := Rti;
+ when Iir_Kind_Package_Declaration =>
+ Info.Package_Rti_Const := Rti;
+ when Iir_Kind_Package_Body =>
+ -- Replace package declaration RTI with the body one.
+ Get_Info (Get_Package (Blk)).Package_Rti_Const := Rti;
+ when others =>
+ Error_Kind ("rti.generate_block", Blk);
+ end case;
+ end Generate_Block;
+
+ procedure Generate_Library (Lib : Iir_Library_Declaration;
+ Public : Boolean)
+ is
+ use Name_Table;
+ Info : Library_Info_Acc;
+ Id : Name_Id;
+ Val : O_Cnode;
+ Aggr : O_Record_Aggr_List;
+ Name : O_Dnode;
+ Storage : O_Storage;
+ begin
+ Info := Get_Info (Lib);
+ if Info /= null then
+ return;
+ end if;
+ Info := Add_Info (Lib, Kind_Library);
+
+ if Lib = Libraries.Work_Library then
+ Id := Libraries.Work_Library_Name;
+ else
+ Id := Get_Identifier (Lib);
+ end if;
+
+ if Public then
+ Storage := O_Storage_Public;
+ else
+ Storage := O_Storage_External;
+ end if;
+
+ New_Const_Decl (Info.Library_Rti_Const,
+ Create_Identifier_Without_Prefix (Id, "__RTI"),
+ Storage, Ghdl_Rtin_Type_Scalar);
+
+ if Public then
+ Image (Id);
+ Name := Create_String
+ (Name_Buffer (1 .. Name_Length),
+ Create_Identifier_Without_Prefix (Id, "__RTISTR"));
+ Start_Const_Value (Info.Library_Rti_Const);
+ Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Scalar);
+ New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Library));
+ New_Record_Aggr_El (Aggr, New_Name_Address (Name));
+ Finish_Record_Aggr (Aggr, Val);
+ Finish_Const_Value (Info.Library_Rti_Const, Val);
+ end if;
+ end Generate_Library;
+
+ procedure Generate_Unit (Lib_Unit : Iir)
+ is
+ Rti : O_Dnode;
+ Info : Ortho_Info_Acc;
+ Mark : Id_Mark_Type;
+ begin
+ Info := Get_Info (Lib_Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Configuration_Declaration =>
+ return;
+ when Iir_Kind_Architecture_Body =>
+ if Info.Block_Rti_Const /= O_Dnode_Null then
+ return;
+ end if;
+ when Iir_Kind_Package_Body =>
+ Push_Identifier_Prefix (Mark, "BODY");
+ when others =>
+ null;
+ end case;
+
+ -- Declare node.
+ if Global_Storage = O_Storage_External then
+ New_Const_Decl (Rti, Create_Identifier ("RTI"),
+ O_Storage_External, Ghdl_Rtin_Block);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Declaration =>
+ declare
+ Prev : Rti_Block;
+ begin
+ Push_Rti_Node (Prev);
+ Generate_Declaration_Chain
+ (Get_Declaration_Chain (Lib_Unit));
+ Pop_Rti_Node (Prev);
+ end;
+ when others =>
+ null;
+ end case;
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body =>
+ Info.Block_Rti_Const := Rti;
+ when Iir_Kind_Package_Declaration =>
+ Info.Package_Rti_Const := Rti;
+ when Iir_Kind_Package_Body =>
+ -- Replace package declaration RTI with the body one.
+ Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const := Rti;
+ when others =>
+ null;
+ end case;
+ else
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration =>
+ declare
+ Lib : Iir_Library_Declaration;
+ begin
+ Lib := Get_Library (Get_Design_File
+ (Get_Design_Unit (Lib_Unit)));
+ Generate_Library (Lib, False);
+ Rti := Get_Info (Lib).Library_Rti_Const;
+ end;
+ when Iir_Kind_Package_Body =>
+ Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const;
+ when Iir_Kind_Architecture_Body =>
+ Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Generate_Block (Lib_Unit, Rti);
+ end if;
+
+ if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then
+ Pop_Identifier_Prefix (Mark);
+ end if;
+ end Generate_Unit;
+
+ procedure Generate_Top (Nbr_Pkgs : out Natural)
+ is
+ use Configuration;
+
+ Unit : Iir_Design_Unit;
+ Lib : Iir_Library_Declaration;
+ Prev : Rti_Block;
+ begin
+ Push_Rti_Node (Prev);
+
+ -- Generate RTI for libraries, count number of packages.
+ Nbr_Pkgs := 1; -- At least std.standard.
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+
+ -- Generate RTI for the library.
+ Lib := Get_Library (Get_Design_File (Unit));
+ Generate_Library (Lib, True);
+
+ if Get_Kind (Get_Library_Unit (Unit))
+ = Iir_Kind_Package_Declaration
+ then
+ Nbr_Pkgs := Nbr_Pkgs + 1;
+ end if;
+ end loop;
+
+ Pop_Rti_Node (Prev);
+ end Generate_Top;
+
+ function Get_Context_Rti (Node : Iir) return O_Cnode
+ is
+ Node_Info : Ortho_Info_Acc;
+
+ Rti_Const : O_Dnode;
+ begin
+ Node_Info := Get_Info (Node);
+
+ case Get_Kind (Node) is
+ when Iir_Kind_Component_Declaration =>
+ Rti_Const := Node_Info.Comp_Rti_Const;
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Rti_Const := Node_Info.Block_Rti_Const;
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Rti_Const := Node_Info.Block_Rti_Const;
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body =>
+ Rti_Const := Node_Info.Package_Rti_Const;
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Rti_Const := Node_Info.Process_Rti_Const;
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Rti_Const := Node_Info.Psl_Rti_Const;
+ when others =>
+ Error_Kind ("get_context_rti", Node);
+ end case;
+ return New_Rti_Address (Rti_Const);
+ end Get_Context_Rti;
+
+ function Get_Context_Addr (Node : Iir) return O_Enode
+ is
+ Node_Info : constant Ortho_Info_Acc := Get_Info (Node);
+ Ref : O_Lnode;
+ begin
+ case Get_Kind (Node) is
+ when Iir_Kind_Component_Declaration =>
+ Ref := Get_Instance_Ref (Node_Info.Comp_Scope);
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ Ref := Get_Instance_Ref (Node_Info.Block_Scope);
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body =>
+ return New_Lit (New_Null_Access (Ghdl_Ptr_Type));
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ Ref := Get_Instance_Ref (Node_Info.Process_Scope);
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ Ref := Get_Instance_Ref (Node_Info.Psl_Scope);
+ when others =>
+ Error_Kind ("get_context_addr", Node);
+ end case;
+ return New_Unchecked_Address (Ref, Ghdl_Ptr_Type);
+ end Get_Context_Addr;
+
+ procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir)
+ is
+ begin
+ New_Association (Assoc, New_Lit (Get_Context_Rti (Node)));
+ New_Association (Assoc, Get_Context_Addr (Node));
+ end Associate_Rti_Context;
+
+ procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is
+ begin
+ New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access)));
+ New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type)));
+ end Associate_Null_Rti_Context;
+ end Rtis;
+
+ procedure Gen_Filename (Design_File : Iir)
+ is
+ Info : Design_File_Info_Acc;
+ begin
+ if Current_Filename_Node /= O_Dnode_Null then
+ raise Internal_Error;
+ end if;
+ Info := Get_Info (Design_File);
+ if Info = null then
+ Info := Add_Info (Design_File, Kind_Design_File);
+ Info.Design_Filename := Create_String
+ (Get_Design_File_Filename (Design_File),
+ Create_Uniq_Identifier, O_Storage_Private);
+ end if;
+ Current_Filename_Node := Info.Design_Filename;
+ end Gen_Filename;
+
+ -- Decorate the tree in order to be usable with the internal simulator.
+ procedure Translate (Unit : Iir_Design_Unit; Main : Boolean)
+ is
+ Design_File : Iir_Design_File;
+ El : Iir;
+ Lib : Iir_Library_Declaration;
+ Lib_Mark, Ent_Mark, Sep_Mark, Unit_Mark : Id_Mark_Type;
+ Id : Name_Id;
+ begin
+ Update_Node_Infos;
+
+ Design_File := Get_Design_File (Unit);
+
+ if False then
+ El := Get_Context_Items (Unit);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Library_Clause =>
+ null;
+ when others =>
+ Error_Kind ("translate1", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end if;
+
+ El := Get_Library_Unit (Unit);
+ if Flags.Verbose then
+ Ada.Text_IO.Put ("translating ");
+ if Main then
+ Ada.Text_IO.Put ("(with code generation) ");
+ end if;
+ Ada.Text_IO.Put_Line (Disp_Node (El));
+ end if;
+
+ -- Create the prefix for identifiers.
+ Lib := Get_Library (Get_Design_File (Unit));
+ Reset_Identifier_Prefix;
+ if Lib = Libraries.Work_Library then
+ Id := Libraries.Work_Library_Name;
+ else
+ Id := Get_Identifier (Lib);
+ end if;
+ Push_Identifier_Prefix (Lib_Mark, Id);
+
+ if Get_Kind (El) = Iir_Kind_Architecture_Body then
+ -- Put 'ARCH' between the entity name and the architecture name, to
+ -- avoid a name clash with names from entity (eg an entity port with
+ -- the same name as an architecture).
+ Push_Identifier_Prefix (Ent_Mark, Get_Identifier (Get_Entity (El)));
+ Push_Identifier_Prefix (Sep_Mark, "ARCH");
+ end if;
+ Id := Get_Identifier (El);
+ if Id /= Null_Identifier then
+ Push_Identifier_Prefix (Unit_Mark, Id);
+ end if;
+
+ if Main then
+ Set_Global_Storage (O_Storage_Public);
+ -- Create the variable containing the current file name.
+ Gen_Filename (Get_Design_File (Unit));
+ else
+ Set_Global_Storage (O_Storage_External);
+ end if;
+
+ New_Debug_Filename_Decl
+ (Name_Table.Image (Get_Design_File_Filename (Design_File)));
+
+ Current_Library_Unit := El;
+
+ case Get_Kind (El) is
+ when Iir_Kind_Package_Declaration =>
+ New_Debug_Comment_Decl
+ ("package declaration " & Image_Identifier (El));
+ Chap2.Translate_Package_Declaration (El);
+ when Iir_Kind_Package_Body =>
+ New_Debug_Comment_Decl ("package body " & Image_Identifier (El));
+ Chap2.Translate_Package_Body (El);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ New_Debug_Comment_Decl
+ ("package instantiation " & Image_Identifier (El));
+ Chap2.Translate_Package_Instantiation_Declaration (El);
+ when Iir_Kind_Entity_Declaration =>
+ New_Debug_Comment_Decl ("entity " & Image_Identifier (El));
+ Chap1.Translate_Entity_Declaration (El);
+ when Iir_Kind_Architecture_Body =>
+ New_Debug_Comment_Decl ("architecture " & Image_Identifier (El));
+ Chap1.Translate_Architecture_Body (El);
+ when Iir_Kind_Configuration_Declaration =>
+ New_Debug_Comment_Decl ("configuration " & Image_Identifier (El));
+ if Id = Null_Identifier then
+ declare
+ Mark : Id_Mark_Type;
+ Mark_Entity : Id_Mark_Type;
+ Mark_Arch : Id_Mark_Type;
+ Mark_Sep : Id_Mark_Type;
+ Arch : Iir;
+ Entity : constant Iir := Get_Entity (El);
+ begin
+ -- Note: this is done inside the architecture identifier.
+ Push_Identifier_Prefix
+ (Mark_Entity, Get_Identifier (Entity));
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (El));
+ Push_Identifier_Prefix (Mark_Sep, "ARCH");
+ Push_Identifier_Prefix (Mark_Arch, Get_Identifier (Arch));
+ Push_Identifier_Prefix
+ (Mark, Name_Table.Get_Identifier ("DEFAULT_CONFIG"));
+ Chap1.Translate_Configuration_Declaration (El);
+ Pop_Identifier_Prefix (Mark);
+ Pop_Identifier_Prefix (Mark_Arch);
+ Pop_Identifier_Prefix (Mark_Sep);
+ Pop_Identifier_Prefix (Mark_Entity);
+ end;
+ else
+ Chap1.Translate_Configuration_Declaration (El);
+ end if;
+ when others =>
+ Error_Kind ("translate", El);
+ end case;
+
+ Current_Filename_Node := O_Dnode_Null;
+ Current_Library_Unit := Null_Iir;
+
+ --Pop_Global_Factory;
+ if Id /= Null_Identifier then
+ Pop_Identifier_Prefix (Unit_Mark);
+ end if;
+ if Get_Kind (El) = Iir_Kind_Architecture_Body then
+ Pop_Identifier_Prefix (Sep_Mark);
+ Pop_Identifier_Prefix (Ent_Mark);
+ end if;
+ Pop_Identifier_Prefix (Lib_Mark);
+ end Translate;
+
+ procedure Initialize
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ -- Create the node extension for translate.
+ Node_Infos.Init;
+ Node_Infos.Set_Last (4);
+ Node_Infos.Table (0 .. 4) := (others => null);
+
+ -- Force to unnest subprograms is the code generator doesn't support
+ -- nested subprograms.
+ if not Ortho_Nodes.Has_Nested_Subprograms then
+ Flag_Unnest_Subprograms := True;
+ end if;
+
+ New_Debug_Comment_Decl ("internal declarations, part 1");
+
+ -- Create well known identifiers.
+ Wki_This := Get_Identifier ("this");
+ Wki_Size := Get_Identifier ("size");
+ Wki_Res := Get_Identifier ("res");
+ Wki_Dir_To := Get_Identifier ("dir_to");
+ Wki_Dir_Downto := Get_Identifier ("dir_downto");
+ Wki_Left := Get_Identifier ("left");
+ Wki_Right := Get_Identifier ("right");
+ Wki_Dir := Get_Identifier ("dir");
+ Wki_Length := Get_Identifier ("length");
+ Wki_I := Get_Identifier ("I");
+ Wki_Instance := Get_Identifier ("INSTANCE");
+ Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE");
+ Wki_Name := Get_Identifier ("NAME");
+ Wki_Sig := Get_Identifier ("sig");
+ Wki_Obj := Get_Identifier ("OBJ");
+ Wki_Rti := Get_Identifier ("RTI");
+ Wki_Parent := Get_Identifier ("parent");
+ Wki_Filename := Get_Identifier ("filename");
+ Wki_Line := Get_Identifier ("line");
+ Wki_Lo := Get_Identifier ("lo");
+ Wki_Hi := Get_Identifier ("hi");
+ Wki_Mid := Get_Identifier ("mid");
+ Wki_Cmp := Get_Identifier ("cmp");
+ Wki_Upframe := Get_Identifier ("UPFRAME");
+ Wki_Frame := Get_Identifier ("FRAME");
+ Wki_Val := Get_Identifier ("val");
+ Wki_L_Len := Get_Identifier ("l_len");
+ Wki_R_Len := Get_Identifier ("r_len");
+
+ Sizetype := New_Unsigned_Type (32);
+ New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype);
+
+ -- Create __ghdl_index_type, which is the type for *all* array index.
+ Ghdl_Index_Type := New_Unsigned_Type (32);
+ New_Type_Decl (Get_Identifier ("__ghdl_index_type"), Ghdl_Index_Type);
+
+ Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0);
+ Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1);
+
+ Ghdl_I32_Type := New_Signed_Type (32);
+ New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type);
+
+ Ghdl_Real_Type := New_Float_Type;
+ New_Type_Decl (Get_Identifier ("__ghdl_real"), Ghdl_Real_Type);
+
+ if not Flag_Only_32b then
+ Ghdl_I64_Type := New_Signed_Type (64);
+ New_Type_Decl (Get_Identifier ("__ghdl_i64"), Ghdl_I64_Type);
+ end if;
+
+ -- File index for elaborated file object.
+ Ghdl_File_Index_Type := New_Unsigned_Type (32);
+ New_Type_Decl (Get_Identifier ("__ghdl_file_index"),
+ Ghdl_File_Index_Type);
+ Ghdl_File_Index_Ptr_Type := New_Access_Type (Ghdl_File_Index_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_file_index_ptr"),
+ Ghdl_File_Index_Ptr_Type);
+
+ -- Create char, char [] and char *.
+ Char_Type_Node := New_Unsigned_Type (8);
+ New_Type_Decl (Get_Identifier ("__ghdl_char"), Char_Type_Node);
+
+ Chararray_Type := New_Array_Type (Char_Type_Node, Ghdl_Index_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_chararray"), Chararray_Type);
+
+ Char_Ptr_Type := New_Access_Type (Chararray_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type);
+
+ Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"),
+ Char_Ptr_Array_Type);
+
+ Char_Ptr_Array_Ptr_Type := New_Access_Type (Char_Ptr_Array_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array_ptr"),
+ Char_Ptr_Array_Ptr_Type);
+
+ -- Generic pointer.
+ Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type);
+
+ -- Create record
+ -- len : natural;
+ -- str : C_String;
+ -- end record;
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Ghdl_Str_Len_Type_Len_Field,
+ Get_Identifier ("len"), Ghdl_Index_Type);
+ New_Record_Field
+ (Constr, Ghdl_Str_Len_Type_Str_Field,
+ Get_Identifier ("str"), Char_Ptr_Type);
+ Finish_Record_Type (Constr, Ghdl_Str_Len_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_str_len"),
+ Ghdl_Str_Len_Type_Node);
+ end;
+
+ Ghdl_Str_Len_Array_Type_Node := New_Array_Type
+ (Ghdl_Str_Len_Type_Node, Ghdl_Index_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_str_len_array"),
+ Ghdl_Str_Len_Array_Type_Node);
+
+ -- Create type __ghdl_str_len_ptr is access all __ghdl_str_len
+ Ghdl_Str_Len_Ptr_Node := New_Access_Type (Ghdl_Str_Len_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_str_len_ptr"),
+ Ghdl_Str_Len_Ptr_Node);
+
+ -- Create type __ghdl_bool_type is (false, true)
+ New_Boolean_Type (Ghdl_Bool_Type,
+ Get_Identifier ("false"),
+ Ghdl_Bool_False_Node,
+ Get_Identifier ("true"),
+ Ghdl_Bool_True_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_bool_type"),
+ Ghdl_Bool_Type);
+
+ -- __ghdl_bool_array is array (ghdl_index_type) of ghdl_bool_type
+ Ghdl_Bool_Array_Type :=
+ New_Array_Type (Ghdl_Bool_Type, Ghdl_Index_Type);
+ New_Type_Decl
+ (Get_Identifier ("__ghdl_bool_array_type"), Ghdl_Bool_Array_Type);
+
+ -- __ghdl_bool_array_ptr is access __ghdl_bool_array;
+ Ghdl_Bool_Array_Ptr := New_Access_Type (Ghdl_Bool_Array_Type);
+ New_Type_Decl
+ (Get_Identifier ("__ghdl_bool_array_ptr"), Ghdl_Bool_Array_Ptr);
+
+ -- Create type ghdl_compare_type is (lt, eq, ge);
+ declare
+ Constr : O_Enum_List;
+ begin
+ Start_Enum_Type (Constr, 8);
+ New_Enum_Literal (Constr, Get_Identifier ("lt"), Ghdl_Compare_Lt);
+ New_Enum_Literal (Constr, Get_Identifier ("eq"), Ghdl_Compare_Eq);
+ New_Enum_Literal (Constr, Get_Identifier ("gt"), Ghdl_Compare_Gt);
+ Finish_Enum_Type (Constr, Ghdl_Compare_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_compare_type"),
+ Ghdl_Compare_Type);
+ end;
+
+ -- Create:
+ -- type __ghdl_location is record
+ -- file : char_ptr_type;
+ -- line : ghdl_i32;
+ -- col : ghdl_i32;
+ -- end record;
+ declare
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field
+ (Constr, Ghdl_Location_Filename_Node, Wki_Filename, Char_Ptr_Type);
+ New_Record_Field
+ (Constr, Ghdl_Location_Line_Node, Wki_Line, Ghdl_I32_Type);
+ New_Record_Field (Constr, Ghdl_Location_Col_Node,
+ Get_Identifier ("col"),
+ Ghdl_I32_Type);
+ Finish_Record_Type (Constr, Ghdl_Location_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_location"),
+ Ghdl_Location_Type_Node);
+ end;
+ -- Create type __ghdl_location_ptr is access __ghdl_location;
+ Ghdl_Location_Ptr_Node := New_Access_Type (Ghdl_Location_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_location_ptr"),
+ Ghdl_Location_Ptr_Node);
+
+ -- Create type ghdl_dir_type is (dir_to, dir_downto);
+ declare
+ Constr : O_Enum_List;
+ begin
+ Start_Enum_Type (Constr, 8);
+ New_Enum_Literal (Constr, Wki_Dir_To, Ghdl_Dir_To_Node);
+ New_Enum_Literal (Constr, Wki_Dir_Downto, Ghdl_Dir_Downto_Node);
+ Finish_Enum_Type (Constr, Ghdl_Dir_Type_Node);
+ New_Type_Decl (Get_Identifier ("__ghdl_dir_type"),
+ Ghdl_Dir_Type_Node);
+ end;
+
+ -- Create void* __ghdl_alloc (unsigned size);
+ Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_alloc"),
+ O_Storage_External, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Size, Sizetype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Alloc_Ptr);
+
+ -- procedure __ghdl_program_error (filename : char_ptr_type;
+ -- line : ghdl_i32;
+ -- code : ghdl_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_program_error"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Filename, Char_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Line, Ghdl_I32_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("code"), Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error);
+
+ -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type;
+ -- line : ghdl_i32);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l1"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L1);
+
+ -- Secondary stack subprograms.
+ -- function __ghdl_stack2_allocate (size : ghdl_index_type)
+ -- return ghdl_ptr_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_stack2_allocate"),
+ O_Storage_External, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Size, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Allocate);
+
+ -- function __ghdl_stack2_mark return ghdl_ptr_type;
+ Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_stack2_mark"),
+ O_Storage_External, Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Mark);
+
+ -- procedure __ghdl_stack2_release (mark : ghdl_ptr_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_stack2_release"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("mark"),
+ Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Release);
+
+ -- procedure __ghdl_memcpy (dest : ghdl_ptr_type;
+ -- src : ghdl_ptr_type;
+ -- length : ghdl_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_memcpy"), O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("dest"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Memcpy);
+
+ -- procedure __ghdl_deallocate (ptr : ghdl_ptr_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_deallocate"), O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Deallocate);
+
+ -- function __ghdl_malloc (length : ghdl_index_type)
+ -- return ghdl_ptr_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_malloc"), O_Storage_External,
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc);
+
+ -- function __ghdl_malloc0 (length : ghdl_index_type)
+ -- return ghdl_ptr_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_malloc0"), O_Storage_External,
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc0);
+
+ -- function __ghdl_text_file_elaborate return file_index_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_file_elaborate"),
+ O_Storage_External, Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Elaborate);
+
+ -- function __ghdl_file_elaborate (name : char_ptr_type)
+ -- return file_index_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_file_elaborate"),
+ O_Storage_External, Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Name, Char_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Elaborate);
+
+ -- procedure __ghdl_file_finalize (file : file_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_file_finalize"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Finalize);
+
+ -- procedure __ghdl_text_file_finalize (file : file_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_file_finalize"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Finalize);
+
+ declare
+ procedure Create_Protected_Subprg
+ (Name : String; Subprg : out O_Dnode)
+ is
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_Protected_Subprg;
+ begin
+ -- procedure __ghdl_protected_enter (obj : ghdl_ptr_type);
+ Create_Protected_Subprg
+ ("__ghdl_protected_enter", Ghdl_Protected_Enter);
+
+ -- procedure __ghdl_protected_leave (obj : ghdl_ptr_type);
+ Create_Protected_Subprg
+ ("__ghdl_protected_leave", Ghdl_Protected_Leave);
+
+ Create_Protected_Subprg
+ ("__ghdl_protected_init", Ghdl_Protected_Init);
+
+ Create_Protected_Subprg
+ ("__ghdl_protected_fini", Ghdl_Protected_Fini);
+ end;
+
+ if Flag_Rti then
+ Rtis.Rti_Initialize;
+ end if;
+
+ -- procedure __ghdl_signal_name_rti
+ -- (obj : ghdl_rti_access;
+ -- ctxt : ghdl_rti_access;
+ -- addr : ghdl_ptr_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_name_rti"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Obj, Rtis.Ghdl_Rti_Access);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"),
+ Rtis.Ghdl_Rti_Access);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"),
+ Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Name_Rti);
+
+ declare
+ -- procedure NAME (this : ghdl_ptr_type;
+ -- proc : ghdl_ptr_type;
+ -- ctxt : ghdl_rti_access;
+ -- addr : ghdl_ptr_type);
+ procedure Create_Process_Register (Name : String; Res : out O_Dnode)
+ is
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_This, Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"),
+ Rtis.Ghdl_Rti_Access);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"),
+ Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Res);
+ end Create_Process_Register;
+ begin
+ Create_Process_Register ("__ghdl_process_register",
+ Ghdl_Process_Register);
+ Create_Process_Register ("__ghdl_sensitized_process_register",
+ Ghdl_Sensitized_Process_Register);
+ Create_Process_Register ("__ghdl_postponed_process_register",
+ Ghdl_Postponed_Process_Register);
+ Create_Process_Register
+ ("__ghdl_postponed_sensitized_process_register",
+ Ghdl_Postponed_Sensitized_Process_Register);
+ end;
+
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_finalize_register"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_This, Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Finalize_Register);
+ end Initialize;
+
+ procedure Create_Signal_Subprograms
+ (Suffix : String;
+ Val_Type : O_Tnode;
+ Create_Signal : out O_Dnode;
+ Init_Signal : out O_Dnode;
+ Simple_Assign : out O_Dnode;
+ Start_Assign : out O_Dnode;
+ Next_Assign : out O_Dnode;
+ Associate_Value : out O_Dnode;
+ Driving_Value : out O_Dnode)
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ -- function __ghdl_create_signal_XXX (init_val : VAL_TYPE)
+ -- resolv_func : ghdl_ptr_type;
+ -- resolv_inst : ghdl_ptr_type;
+ -- return __ghdl_signal_ptr;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_create_signal_" & Suffix),
+ O_Storage_External, Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("init_val"), Val_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_func"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_inst"),
+ Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Create_Signal);
+
+ -- procedure __ghdl_signal_init_XXX (sign : __ghdl_signal_ptr;
+ -- val : VAL_TYPE);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type);
+ Finish_Subprogram_Decl (Interfaces, Init_Signal);
+
+ -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr;
+ -- val : VAL_TYPE);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type);
+ Finish_Subprogram_Decl (Interfaces, Simple_Assign);
+
+ -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr;
+ -- reject : std_time;
+ -- val : VAL_TYPE;
+ -- after : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_" & Suffix),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"),
+ Std_Time_Otype);
+ New_Interface_Decl (Interfaces, Param, Wki_Val,
+ Val_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Start_Assign);
+
+ -- procedure __ghdl_signal_next_assign_XXX (sign : __ghdl_signal_ptr;
+ -- val : VAL_TYPE;
+ -- after : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val,
+ Val_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Next_Assign);
+
+ -- procedure __ghdl_signal_associate_XXX (sign : __ghdl_signal_ptr;
+ -- val : VAL_TYPE);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val,
+ Val_Type);
+ Finish_Subprogram_Decl (Interfaces, Associate_Value);
+
+ -- function __ghdl_signal_driving_value_XXX (sign : __ghdl_signal_ptr)
+ -- return VAL_TYPE;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_driving_value_" & Suffix),
+ O_Storage_External, Val_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Driving_Value);
+ end Create_Signal_Subprograms;
+
+ -- procedure __ghdl_image_NAME (res : std_string_ptr_node;
+ -- val : VAL_TYPE;
+ -- rti : ghdl_rti_access);
+ --
+ -- function __ghdl_value_NAME (val : std_string_ptr_node;
+ -- rti : ghdl_rti_access);
+ -- return VAL_TYPE;
+ procedure Create_Image_Value_Subprograms (Name : String;
+ Val_Type : O_Tnode;
+ Has_Td : Boolean;
+ Image_Subprg : out O_Dnode;
+ Value_Subprg : out O_Dnode)
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_image_" & Name),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Val, Val_Type);
+ if Has_Td then
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+ end if;
+ Finish_Subprogram_Decl (Interfaces, Image_Subprg);
+
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_value_" & Name),
+ O_Storage_External, Val_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Val, Std_String_Ptr_Node);
+ if Has_Td then
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access);
+ end if;
+ Finish_Subprogram_Decl (Interfaces, Value_Subprg);
+ end Create_Image_Value_Subprograms;
+
+ -- function __ghdl_std_ulogic_match_NAME (l : __ghdl_e8; r : __ghdl_e8)
+ -- return __ghdl_e8;
+ procedure Create_Std_Ulogic_Match_Subprogram (Name : String;
+ Subprg : out O_Dnode)
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name),
+ O_Storage_External, Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_I32_Type);
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_Std_Ulogic_Match_Subprogram;
+
+ -- function __ghdl_std_ulogic_array_match_NAME
+ -- (l : __ghdl_ptr; l_len : ghdl_index_type;
+ -- r : __ghdl_ptr; r_len : ghdl_index_type)
+ -- return __ghdl_i32;
+ procedure Create_Std_Ulogic_Array_Match_Subprogram (Name : String;
+ Subprg : out O_Dnode)
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_std_ulogic_array_match_" & Name),
+ O_Storage_External, Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_L_Len, Ghdl_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_R_Len, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_Std_Ulogic_Array_Match_Subprogram;
+
+ -- procedure NAME (res : std_string_ptr_node;
+ -- val : VAL_TYPE;
+ -- ARG2_NAME : ARG2_TYPE);
+ procedure Create_To_String_Subprogram (Name : String;
+ Subprg : out O_Dnode;
+ Val_Type : O_Tnode;
+ Arg2_Type : O_Tnode := O_Tnode_Null;
+ Arg2_Id : O_Ident := O_Ident_Nul;
+ Arg3_Type : O_Tnode := O_Tnode_Null;
+ Arg3_Id : O_Ident := O_Ident_Nul)
+ is
+ Interfaces : O_Inter_List;
+ Param : O_Dnode;
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Res, Std_String_Ptr_Node);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Val, Val_Type);
+ if Arg2_Type /= O_Tnode_Null then
+ New_Interface_Decl
+ (Interfaces, Param, Arg2_Id, Arg2_Type);
+ if Arg3_Type /= O_Tnode_Null then
+ New_Interface_Decl
+ (Interfaces, Param, Arg3_Id, Arg3_Type);
+ end if;
+ end if;
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_To_String_Subprogram;
+
+ -- Do internal declarations that need std.standard declarations.
+ procedure Post_Initialize
+ is
+ Interfaces : O_Inter_List;
+ Rec : O_Element_List;
+ Param : O_Dnode;
+ Info : Type_Info_Acc;
+ begin
+ New_Debug_Comment_Decl ("internal declarations, part 2");
+
+ -- Remember some pervasive types.
+ Info := Get_Info (String_Type_Definition);
+ Std_String_Node := Info.Ortho_Type (Mode_Value);
+ Std_String_Ptr_Node := Info.Ortho_Ptr_Type (Mode_Value);
+
+ Std_Integer_Otype :=
+ Get_Ortho_Type (Integer_Type_Definition, Mode_Value);
+ Std_Real_Otype :=
+ Get_Ortho_Type (Real_Type_Definition, Mode_Value);
+ Std_Time_Otype := Get_Ortho_Type (Time_Type_Definition, Mode_Value);
+
+ -- __ghdl_now : time;
+ -- ??? maybe this should be a function ?
+ New_Var_Decl (Ghdl_Now, Get_Identifier ("__ghdl_now"),
+ O_Storage_External, Std_Time_Otype);
+
+ -- procedure __ghdl_assert_failed (str : __ghdl_array_template;
+ -- severity : ghdl_int);
+ -- loc : __ghdl_location_acc);
+
+ -- procedure __ghdl_report (str : __ghdl_array_template;
+ -- severity : ghdl_int);
+ -- loc : __ghdl_location_acc);
+ declare
+ procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode)
+ is
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("msg"), Std_String_Ptr_Node);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("severity"),
+ Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value));
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"),
+ Ghdl_Location_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_Report_Subprg;
+ begin
+ Create_Report_Subprg
+ ("__ghdl_assert_failed", Ghdl_Assert_Failed);
+ Create_Report_Subprg
+ ("__ghdl_ieee_assert_failed", Ghdl_Ieee_Assert_Failed);
+ Create_Report_Subprg ("__ghdl_psl_assert_failed",
+ Ghdl_Psl_Assert_Failed);
+ Create_Report_Subprg ("__ghdl_psl_cover", Ghdl_Psl_Cover);
+ Create_Report_Subprg ("__ghdl_psl_cover_failed",
+ Ghdl_Psl_Cover_Failed);
+ Create_Report_Subprg ("__ghdl_report", Ghdl_Report);
+ end;
+
+ -- procedure __ghdl_text_write (file : __ghdl_file_index;
+ -- str : std_string_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_write"), O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Write);
+
+ -- function __ghdl_text_read_length (file : __ghdl_file_index;
+ -- str : std_string_ptr)
+ -- return std__standard_integer;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_read_length"),
+ O_Storage_External, Std_Integer_Otype);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Read_Length);
+
+ -- procedure __ghdl_write_scalar (file : __ghdl_file_index;
+ -- ptr : __ghdl_ptr_type;
+ -- length : __ghdl_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_write_scalar"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Write_Scalar);
+
+ -- procedure __ghdl_read_scalar (file : __ghdl_file_index;
+ -- ptr : __ghdl_ptr_type;
+ -- length : __ghdl_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_read_scalar"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Read_Scalar);
+
+ -- function __ghdl_real_exp (left : std__standard__real;
+ -- right : std__standard__integer)
+ -- return std__standard__real;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_real_exp"), O_Storage_External,
+ Std_Real_Otype);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("left"),
+ Std_Real_Otype);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("right"),
+ Std_Integer_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp);
+
+ -- function __ghdl_integer_exp (left : std__standard__integer;
+ -- right : std__standard__integer)
+ -- return std__standard__integer;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External,
+ Std_Integer_Otype);
+ New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype);
+ New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp);
+
+
+ -- procedure __ghdl_image_b1 (res : std_string_ptr_node;
+ -- val : ghdl_bool_type;
+ -- rti : ghdl_rti_access);
+ Create_Image_Value_Subprograms
+ ("b1", Ghdl_Bool_Type, True, Ghdl_Image_B1, Ghdl_Value_B1);
+
+ -- procedure __ghdl_image_e8 (res : std_string_ptr_node;
+ -- val : ghdl_i32_type;
+ -- rti : ghdl_rti_access);
+ Create_Image_Value_Subprograms
+ ("e8", Ghdl_I32_Type, True, Ghdl_Image_E8, Ghdl_Value_E8);
+
+ -- procedure __ghdl_image_e32 (res : std_string_ptr_node;
+ -- val : ghdl_i32_type;
+ -- rti : ghdl_rti_access);
+ Create_Image_Value_Subprograms
+ ("e32", Ghdl_I32_Type, True, Ghdl_Image_E32, Ghdl_Value_E32);
+
+ -- procedure __ghdl_image_i32 (res : std_string_ptr_node;
+ -- val : ghdl_i32_type);
+ Create_Image_Value_Subprograms
+ ("i32", Ghdl_I32_Type, False, Ghdl_Image_I32, Ghdl_Value_I32);
+
+ -- procedure __ghdl_image_p32 (res : std_string_ptr_node;
+ -- val : ghdl_i32_type;
+ -- rti : ghdl_rti_access);
+ Create_Image_Value_Subprograms
+ ("p32", Ghdl_I32_Type, True, Ghdl_Image_P32, Ghdl_Value_P32);
+
+ -- procedure __ghdl_image_p64 (res : std_string_ptr_node;
+ -- val : ghdl_i64_type;
+ -- rti : ghdl_rti_access);
+ if not Flag_Only_32b then
+ Create_Image_Value_Subprograms
+ ("p64", Ghdl_I64_Type, True, Ghdl_Image_P64, Ghdl_Value_P64);
+ end if;
+
+ -- procedure __ghdl_image_f64 (res : std_string_ptr_node;
+ -- val : ghdl_real_type);
+ Create_Image_Value_Subprograms
+ ("f64", Ghdl_Real_Type, False, Ghdl_Image_F64, Ghdl_Value_F64);
+
+ -------------
+ -- files --
+ -------------
+
+ -- procedure __ghdl_text_file_open (file : file_index_type;
+ -- mode : Ghdl_I32_Type;
+ -- str : std__standard__string_PTR);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_file_open"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"),
+ Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open);
+
+ -- procedure __ghdl_file_open (file : file_index_type;
+ -- mode : Ghdl_I32_Type;
+ -- str : std__standard__string_PTR);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_file_open"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"),
+ Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open);
+
+ -- function __ghdl_text_file_open_status
+ -- (file : file_index_type;
+ -- mode : Ghdl_I32_Type;
+ -- str : std__standard__string_PTR)
+ -- return ghdl_i32_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_file_open_status"),
+ O_Storage_External, Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"),
+ Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open_Status);
+
+ -- function __ghdl_file_open_status (file : file_index_type;
+ -- mode : Ghdl_I32_Type;
+ -- str : std__standard__string_PTR)
+ -- return ghdl_i32_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_file_open_status"),
+ O_Storage_External, Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"),
+ Ghdl_I32_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"),
+ Std_String_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open_Status);
+
+ -- function __ghdl_file_endfile (file : file_index_type)
+ -- return std_boolean_type_node;
+ Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_file_endfile"),
+ O_Storage_External, Std_Boolean_Type_Node);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Endfile);
+
+ -- procedure __ghdl_text_file_close (file : file_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_text_file_close"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Close);
+
+ -- procedure __ghdl_file_close (file : file_index_type);
+ Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_close"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Close);
+
+ -- procedure __ghdl_file_flush (file : file_index_type);
+ Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_flush"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"),
+ Ghdl_File_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_File_Flush);
+
+ ---------------
+ -- signals --
+ ---------------
+
+ -- procedure __ghdl_signal_create_resolution
+ -- (func : ghdl_ptr_type;
+ -- instance : ghdl_ptr_type;
+ -- sig : ghdl_ptr_type;
+ -- nbr_sig : ghdl_index_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_create_resolution"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("nbr_sig"), Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Resolution);
+
+ -- Declarations for signals.
+ -- Max length of a scalar type.
+ -- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8);
+ Ghdl_Scalar_Bytes := New_Constrained_Array_Type
+ (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8));
+ New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"),
+ Ghdl_Scalar_Bytes);
+
+ New_Uncomplete_Record_Type (Ghdl_Signal_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_signal"), Ghdl_Signal_Type);
+
+ Ghdl_Signal_Ptr := New_Access_Type (Ghdl_Signal_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr"), Ghdl_Signal_Ptr);
+
+ -- Type __signal_signal is record
+ Start_Uncomplete_Record_Type (Ghdl_Signal_Type, Rec);
+ New_Record_Field (Rec, Ghdl_Signal_Value_Field,
+ Get_Identifier ("value"),
+ Ghdl_Scalar_Bytes);
+ New_Record_Field (Rec, Ghdl_Signal_Driving_Value_Field,
+ Get_Identifier ("driving_value"),
+ Ghdl_Scalar_Bytes);
+ New_Record_Field (Rec, Ghdl_Signal_Last_Value_Field,
+ Get_Identifier ("last_value"),
+ Ghdl_Scalar_Bytes);
+ New_Record_Field (Rec, Ghdl_Signal_Last_Event_Field,
+ Get_Identifier ("last_event"),
+ Std_Time_Otype);
+ New_Record_Field (Rec, Ghdl_Signal_Last_Active_Field,
+ Get_Identifier ("last_active"),
+ Std_Time_Otype);
+ New_Record_Field (Rec, Ghdl_Signal_Event_Field,
+ Get_Identifier ("event"),
+ Std_Boolean_Type_Node);
+ New_Record_Field (Rec, Ghdl_Signal_Active_Field,
+ Get_Identifier ("active"),
+ Std_Boolean_Type_Node);
+ New_Record_Field (Rec, Ghdl_Signal_Has_Active_Field,
+ Get_Identifier ("has_active"),
+ Ghdl_Bool_Type);
+ Finish_Record_Type (Rec, Ghdl_Signal_Type);
+
+ Ghdl_Signal_Ptr_Ptr := New_Access_Type (Ghdl_Signal_Ptr);
+ New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"),
+ Ghdl_Signal_Ptr_Ptr);
+
+ -- procedure __ghdl_signal_merge_rti
+ -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access)
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_merge_rti"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Merge_Rti);
+
+ -- procedure __ghdl_signal_add_source (targ : __ghdl_signal_ptr;
+ -- src : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_add_source"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"),
+ Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"),
+ Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Source);
+
+ -- procedure __ghdl_signal_effective_value (targ : __ghdl_signal_ptr;
+ -- src : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_effective_value"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"),
+ Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"),
+ Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Effective_Value);
+
+ -- procedure __ghdl_signal_set_disconnect (sig : __ghdl_signal_ptr;
+ -- val : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_set_disconnect"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("time"), Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Set_Disconnect);
+
+ -- procedure __ghdl_signal_disconnect (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_disconnect"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Disconnect);
+
+ -- function __ghdl_signal_get_nbr_drivers (sig : __ghdl_signal_ptr)
+ -- return ghdl_index_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_drivers"),
+ O_Storage_External, Ghdl_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Drivers);
+
+ -- function __ghdl_signal_get_nbr_sources (sig : __ghdl_signal_ptr)
+ -- return ghdl_index_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_ports"),
+ O_Storage_External, Ghdl_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Ports);
+
+ -- function __ghdl_signal_read_driver (sig : __ghdl_signal_ptr;
+ -- num : ghdl_index_type)
+ -- return ghdl_ptr_type;
+ declare
+ procedure Create_Signal_Read (Name : String; Subprg : out O_Dnode) is
+ begin
+ Start_Function_Decl
+ (Interfaces, Get_Identifier (Name),
+ O_Storage_External, Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("num"), Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Subprg);
+ end Create_Signal_Read;
+ begin
+ Create_Signal_Read
+ ("__ghdl_signal_read_driver", Ghdl_Signal_Read_Driver);
+ Create_Signal_Read
+ ("__ghdl_signal_read_port", Ghdl_Signal_Read_Port);
+ end;
+
+ -- function __ghdl_signal_driving (sig : __ghdl_signal_ptr)
+ -- return std_boolean;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_driving"),
+ O_Storage_External, Std_Boolean_Type_Node);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Driving);
+
+ -- procedure __ghdl_signal_simple_assign_error
+ -- (sig : __ghdl_signal_ptr;
+ -- filename : char_ptr_type;
+ -- line : ghdl_i32);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_error"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Simple_Assign_Error);
+
+ -- procedure __ghdl_signal_start_assign_error (sign : __ghdl_signal_ptr;
+ -- reject : std_time;
+ -- after : std_time;
+ -- filename : char_ptr_type;
+ -- line : ghdl_i32);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_error"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"),
+ Std_Time_Otype);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Error);
+
+ -- procedure __ghdl_signal_next_assign_error (sig : __ghdl_signal_ptr;
+ -- after : std_time;
+ -- filename : char_ptr_type;
+ -- line : ghdl_i32);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_error"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Error);
+
+ -- procedure __ghdl_signal_start_assign_null (sig : __ghdl_signal_ptr;
+ -- reject : std_time;
+ -- after : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_null"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"),
+ Std_Time_Otype);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Null);
+
+ -- procedure __ghdl_signal_next_assign_null (sig : __ghdl_signal_ptr;
+ -- after : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_null"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Null);
+
+ -- function __ghdl_create_signal_e8 (init_val : ghdl_i32_type)
+ -- return __ghdl_signal_ptr;
+ -- procedure __ghdl_signal_simple_assign_e8 (sign : __ghdl_signal_ptr;
+ -- val : __ghdl_integer);
+ Create_Signal_Subprograms ("e8", Ghdl_I32_Type,
+ Ghdl_Create_Signal_E8,
+ Ghdl_Signal_Init_E8,
+ Ghdl_Signal_Simple_Assign_E8,
+ Ghdl_Signal_Start_Assign_E8,
+ Ghdl_Signal_Next_Assign_E8,
+ Ghdl_Signal_Associate_E8,
+ Ghdl_Signal_Driving_Value_E8);
+
+ -- function __ghdl_create_signal_e32 (init_val : ghdl_i32_type)
+ -- return __ghdl_signal_ptr;
+ -- procedure __ghdl_signal_simple_assign_e32 (sign : __ghdl_signal_ptr;
+ -- val : __ghdl_integer);
+ Create_Signal_Subprograms ("e32", Ghdl_I32_Type,
+ Ghdl_Create_Signal_E32,
+ Ghdl_Signal_Init_E32,
+ Ghdl_Signal_Simple_Assign_E32,
+ Ghdl_Signal_Start_Assign_E32,
+ Ghdl_Signal_Next_Assign_E32,
+ Ghdl_Signal_Associate_E32,
+ Ghdl_Signal_Driving_Value_E32);
+
+ -- function __ghdl_create_signal_b1 (init_val : ghdl_bool_type)
+ -- return __ghdl_signal_ptr;
+ -- procedure __ghdl_signal_simple_assign_b1 (sign : __ghdl_signal_ptr;
+ -- val : ghdl_bool_type);
+ Create_Signal_Subprograms ("b1", Ghdl_Bool_Type,
+ Ghdl_Create_Signal_B1,
+ Ghdl_Signal_Init_B1,
+ Ghdl_Signal_Simple_Assign_B1,
+ Ghdl_Signal_Start_Assign_B1,
+ Ghdl_Signal_Next_Assign_B1,
+ Ghdl_Signal_Associate_B1,
+ Ghdl_Signal_Driving_Value_B1);
+
+ Create_Signal_Subprograms ("i32", Ghdl_I32_Type,
+ Ghdl_Create_Signal_I32,
+ Ghdl_Signal_Init_I32,
+ Ghdl_Signal_Simple_Assign_I32,
+ Ghdl_Signal_Start_Assign_I32,
+ Ghdl_Signal_Next_Assign_I32,
+ Ghdl_Signal_Associate_I32,
+ Ghdl_Signal_Driving_Value_I32);
+
+ Create_Signal_Subprograms ("f64", Ghdl_Real_Type,
+ Ghdl_Create_Signal_F64,
+ Ghdl_Signal_Init_F64,
+ Ghdl_Signal_Simple_Assign_F64,
+ Ghdl_Signal_Start_Assign_F64,
+ Ghdl_Signal_Next_Assign_F64,
+ Ghdl_Signal_Associate_F64,
+ Ghdl_Signal_Driving_Value_F64);
+
+ if not Flag_Only_32b then
+ Create_Signal_Subprograms ("i64", Ghdl_I64_Type,
+ Ghdl_Create_Signal_I64,
+ Ghdl_Signal_Init_I64,
+ Ghdl_Signal_Simple_Assign_I64,
+ Ghdl_Signal_Start_Assign_I64,
+ Ghdl_Signal_Next_Assign_I64,
+ Ghdl_Signal_Associate_I64,
+ Ghdl_Signal_Driving_Value_I64);
+ end if;
+
+ -- procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_add_sensitivity"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Sensitivity);
+
+ -- procedure __ghdl_process_add_driver (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_add_driver"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver);
+
+ -- procedure __ghdl_signal_add_direct_driver (sig : __ghdl_signal_ptr;
+ -- Drv : Ghdl_Ptr_type);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_add_direct_driver"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("drv"), Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Direct_Driver);
+
+ -- procedure __ghdl_signal_direct_assign (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_direct_assign"),
+ O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Assign);
+
+ declare
+ procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode)
+ is
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("src"), Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("src_len"), Ghdl_Index_Type);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("dst"), Ghdl_Signal_Ptr);
+ New_Interface_Decl
+ (Interfaces, Param, Get_Identifier ("dst_len"), Ghdl_Index_Type);
+ Finish_Subprogram_Decl (Interfaces, Res);
+ end Create_Signal_Conversion;
+ begin
+ -- procedure __ghdl_signal_in_conversion (func : ghdl_ptr_type;
+ -- instance : ghdl_ptr_type;
+ -- src : ghdl_signal_ptr;
+ -- src_len : ghdl_index_type;
+ -- dst : ghdl_signal_ptr;
+ -- dst_len : ghdl_index_type);
+ Create_Signal_Conversion
+ ("__ghdl_signal_in_conversion", Ghdl_Signal_In_Conversion);
+ Create_Signal_Conversion
+ ("__ghdl_signal_out_conversion", Ghdl_Signal_Out_Conversion);
+ end;
+
+ declare
+ -- function __ghdl_create_XXX_signal (val : std_time)
+ -- return __ghdl_signal_ptr;
+ procedure Create_Signal_Attribute (Name : String; Res : out O_Dnode)
+ is
+ begin
+ Start_Function_Decl (Interfaces, Get_Identifier (Name),
+ O_Storage_External, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Res);
+ end Create_Signal_Attribute;
+ begin
+ -- function __ghdl_create_stable_signal (val : std_time)
+ -- return __ghdl_signal_ptr;
+ Create_Signal_Attribute
+ ("__ghdl_create_stable_signal", Ghdl_Create_Stable_Signal);
+
+ -- function __ghdl_create_quiet_signal (val : std_time)
+ -- return __ghdl_signal_ptr;
+ Create_Signal_Attribute
+ ("__ghdl_create_quiet_signal", Ghdl_Create_Quiet_Signal);
+
+ -- function __ghdl_create_transaction_signal
+ -- return __ghdl_signal_ptr;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_create_transaction_signal"),
+ O_Storage_External, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Transaction_Signal);
+ end;
+
+ -- procedure __ghdl_signal_attribute_register_prefix
+ -- (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces,
+ Get_Identifier ("__ghdl_signal_attribute_register_prefix"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl
+ (Interfaces, Ghdl_Signal_Attribute_Register_Prefix);
+
+ -- function __ghdl_create_delayed_signal (sig : __ghdl_signal_ptr;
+ -- val : std_time)
+ -- return __ghdl_signal_ptr;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_create_delayed_signal"),
+ O_Storage_External, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"),
+ Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal);
+
+ -- function __ghdl_signal_create_guard
+ -- (this : ghdl_ptr_type;
+ -- proc : ghdl_ptr_type;
+ -- instance_name : __ghdl_instance_name_acc)
+ -- return __ghdl_signal_ptr;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_create_guard"),
+ O_Storage_External, Ghdl_Signal_Ptr);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("this"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("proc"),
+ Ghdl_Ptr_Type);
+-- New_Interface_Decl (Interfaces, Param, Get_Identifier ("instance_name"),
+-- Ghdl_Instance_Name_Acc);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Guard);
+
+ -- procedure __ghdl_signal_guard_dependence (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_signal_guard_dependence"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Guard_Dependence);
+
+ -- procedure __ghdl_process_wait_exit (void);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_exit"),
+ O_Storage_External);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Exit);
+
+ -- void __ghdl_process_wait_timeout (time : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_timeout"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timeout);
+
+ -- void __ghdl_process_wait_set_timeout (time : std_time);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_set_timeout"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"),
+ Std_Time_Otype);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Set_Timeout);
+
+ -- void __ghdl_process_wait_add_sensitivity (sig : __ghdl_signal_ptr);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_add_sensitivity"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity);
+
+ -- function __ghdl_process_wait_suspend return __ghdl_bool_type;
+ Start_Function_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"),
+ O_Storage_External, Ghdl_Bool_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend);
+
+ -- void __ghdl_process_wait_close (void);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_process_wait_close"),
+ O_Storage_External);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Close);
+
+ declare
+ procedure Create_Get_Name (Name : String; Res : out O_Dnode)
+ is
+ begin
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier (Name), O_Storage_External);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Res, Std_String_Ptr_Node);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"),
+ Rtis.Ghdl_Rti_Access);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"),
+ Ghdl_Ptr_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("name"),
+ Ghdl_Str_Len_Ptr_Node);
+ Finish_Subprogram_Decl (Interfaces, Res);
+ end Create_Get_Name;
+ begin
+ -- procedure __ghdl_get_path_name (res : std_string_ptr_node;
+ -- ctxt : ghdl_rti_access;
+ -- addr : ghdl_ptr_type;
+ -- name : __ghdl_str_len_ptr);
+ Create_Get_Name ("__ghdl_get_path_name", Ghdl_Get_Path_Name);
+
+ -- procedure __ghdl_get_instance_name (res : std_string_ptr_node;
+ -- ctxt : ghdl_rti_access;
+ -- addr : ghdl_ptr_type;
+ -- name : __ghdl_str_len_ptr);
+ Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name);
+ end;
+
+ -- procedure __ghdl_rti_add_package (rti : ghdl_rti_access)
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_rti_add_package"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Package);
+
+ -- procedure __ghdl_rti_add_top (max_pkgs : ghdl_index_type;
+ -- pkgs : ghdl_rti_arr_acc);
+ Start_Procedure_Decl
+ (Interfaces, Get_Identifier ("__ghdl_rti_add_top"),
+ O_Storage_External);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("max_pkgs"),
+ Ghdl_Index_Type);
+ New_Interface_Decl (Interfaces, Param, Get_Identifier ("pkgs"),
+ Rtis.Ghdl_Rti_Arr_Acc);
+ New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+ New_Interface_Decl
+ (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type);
+ Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Top);
+
+ -- Create match subprograms for std_ulogic type.
+ Create_Std_Ulogic_Match_Subprogram ("eq", Ghdl_Std_Ulogic_Match_Eq);
+ Create_Std_Ulogic_Match_Subprogram ("ne", Ghdl_Std_Ulogic_Match_Ne);
+ Create_Std_Ulogic_Match_Subprogram ("lt", Ghdl_Std_Ulogic_Match_Lt);
+ Create_Std_Ulogic_Match_Subprogram ("le", Ghdl_Std_Ulogic_Match_Le);
+
+ Create_Std_Ulogic_Array_Match_Subprogram
+ ("eq", Ghdl_Std_Ulogic_Array_Match_Eq);
+ Create_Std_Ulogic_Array_Match_Subprogram
+ ("ne", Ghdl_Std_Ulogic_Array_Match_Ne);
+
+ -- Create To_String subprograms.
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_i32", Ghdl_To_String_I32, Ghdl_I32_Type);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_f64", Ghdl_To_String_F64, Ghdl_Real_Type);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_f64_digits", Ghdl_To_String_F64_Digits,
+ Ghdl_Real_Type, Ghdl_I32_Type, Get_Identifier ("nbr_digits"));
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_f64_format", Ghdl_To_String_F64_Format,
+ Ghdl_Real_Type, Std_String_Ptr_Node, Get_Identifier ("format"));
+ declare
+ Bv_Base_Ptr : constant O_Tnode :=
+ Get_Info (Bit_Vector_Type_Definition).T.Base_Ptr_Type (Mode_Value);
+ begin
+ Create_To_String_Subprogram
+ ("__ghdl_bv_to_ostring", Ghdl_BV_To_Ostring,
+ Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length);
+ Create_To_String_Subprogram
+ ("__ghdl_bv_to_hstring", Ghdl_BV_To_Hstring,
+ Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length);
+ end;
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_b1", Ghdl_To_String_B1, Ghdl_Bool_Type,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_char", Ghdl_To_String_Char,
+ Get_Ortho_Type (Character_Type_Definition, Mode_Value));
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_p32", Ghdl_To_String_P32, Ghdl_I32_Type,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_to_string_p64", Ghdl_To_String_P64, Ghdl_I64_Type,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_timue_to_string_unit", Ghdl_Time_To_String_Unit,
+ Std_Time_Otype, Std_Time_Otype, Get_Identifier ("unit"),
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_array_char_to_string_b1", Ghdl_Array_Char_To_String_B1,
+ Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_array_char_to_string_e8", Ghdl_Array_Char_To_String_E8,
+ Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+ Create_To_String_Subprogram
+ ("__ghdl_array_char_to_string_e32", Ghdl_Array_Char_To_String_E32,
+ Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length,
+ Rtis.Ghdl_Rti_Access, Wki_Rti);
+
+ end Post_Initialize;
+
+ procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir)
+ is
+ Infos : Chap7.Implicit_Subprogram_Infos;
+ begin
+ -- Skip type declaration.
+ pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration);
+ Decl := Get_Chain (Decl);
+
+ Chap7.Init_Implicit_Subprogram_Infos (Infos);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Chap7.Translate_Implicit_Subprogram (Decl, Infos);
+ Decl := Get_Chain (Decl);
+ when others =>
+ exit;
+ end case;
+ end loop;
+ end Translate_Type_Implicit_Subprograms;
+
+ procedure Translate_Standard (Main : Boolean)
+ is
+ Lib_Mark, Unit_Mark : Id_Mark_Type;
+ Info : Ortho_Info_Acc;
+ pragma Unreferenced (Info);
+ Decl : Iir;
+ Time_Type_Staticness : Iir_Staticness;
+ Time_Subtype_Staticness : Iir_Staticness;
+ begin
+ Update_Node_Infos;
+
+ New_Debug_Comment_Decl ("package std.standard");
+ if Main then
+ Gen_Filename (Std_Standard_File);
+ Set_Global_Storage (O_Storage_Public);
+ else
+ Set_Global_Storage (O_Storage_External);
+ end if;
+
+ Info := Add_Info (Standard_Package, Kind_Package);
+
+ Reset_Identifier_Prefix;
+ Push_Identifier_Prefix
+ (Lib_Mark, Get_Identifier (Libraries.Std_Library));
+ Push_Identifier_Prefix
+ (Unit_Mark, Get_Identifier (Standard_Package));
+
+ -- With VHDL93 and later, time type is globally static. As a result,
+ -- it will be elaborated at run-time (and not statically).
+ -- However, there is no elaboration of std.standard. Furthermore,
+ -- time type can be pre-elaborated without any difficulties.
+ -- There is a kludge here: set type staticess of time type locally
+ -- and then revert it just after its translation.
+ Time_Type_Staticness := Get_Type_Staticness (Time_Type_Definition);
+ Time_Subtype_Staticness := Get_Type_Staticness (Time_Subtype_Definition);
+ if Flags.Flag_Time_64 then
+ Set_Type_Staticness (Time_Type_Definition, Locally);
+ end if;
+ Set_Type_Staticness (Time_Subtype_Definition, Locally);
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Set_Type_Staticness (Delay_Length_Subtype_Definition, Locally);
+ end if;
+
+ Decl := Get_Declaration_Chain (Standard_Package);
+
+ -- The first (and one of the most important) declaration is the
+ -- boolean type declaration.
+ pragma Assert (Decl = Boolean_Type_Declaration);
+ Chap4.Translate_Bool_Type_Declaration (Boolean_Type_Declaration);
+ -- We need this type very early, for predefined functions.
+ Std_Boolean_Type_Node :=
+ Get_Ortho_Type (Boolean_Type_Definition, Mode_Value);
+ Std_Boolean_True_Node := Get_Ortho_Expr (Boolean_True);
+ Std_Boolean_False_Node := Get_Ortho_Expr (Boolean_False);
+
+ Std_Boolean_Array_Type :=
+ New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type);
+ New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"),
+ Std_Boolean_Array_Type);
+ Translate_Type_Implicit_Subprograms (Decl);
+
+ -- Second declaration: bit.
+ pragma Assert (Decl = Bit_Type_Declaration);
+ Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration);
+ Translate_Type_Implicit_Subprograms (Decl);
+
+ -- Nothing special for other declarations.
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Type_Declaration =>
+ Chap4.Translate_Type_Declaration (Decl);
+ Translate_Type_Implicit_Subprograms (Decl);
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Chap4.Translate_Anonymous_Type_Declaration (Decl);
+ Translate_Type_Implicit_Subprograms (Decl);
+ when Iir_Kind_Subtype_Declaration =>
+ Chap4.Translate_Subtype_Declaration (Decl);
+ Decl := Get_Chain (Decl);
+ when Iir_Kind_Attribute_Declaration =>
+ Decl := Get_Chain (Decl);
+ when Iir_Kind_Implicit_Function_Declaration =>
+ case Get_Implicit_Definition (Decl) is
+ when Iir_Predefined_Now_Function =>
+ null;
+ when Iir_Predefined_Enum_To_String
+ | Iir_Predefined_Integer_To_String
+ | Iir_Predefined_Floating_To_String
+ | Iir_Predefined_Real_To_String_Digits
+ | Iir_Predefined_Real_To_String_Format
+ | Iir_Predefined_Physical_To_String
+ | Iir_Predefined_Time_To_String_Unit =>
+ -- These are defined after the types.
+ null;
+ when others =>
+ Error_Kind
+ ("translate_standard ("
+ & Iir_Predefined_Functions'Image
+ (Get_Implicit_Definition (Decl)) & ")",
+ Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ when others =>
+ Error_Kind ("translate_standard", Decl);
+ end case;
+ -- DECL was updated by Translate_Type_Implicit_Subprograms or
+ -- explicitly in other branches.
+ end loop;
+
+ -- These types don't appear in std.standard.
+ Chap4.Translate_Anonymous_Type_Declaration
+ (Convertible_Integer_Type_Declaration);
+ Chap4.Translate_Anonymous_Type_Declaration
+ (Convertible_Real_Type_Declaration);
+
+ -- Restore time type staticness.
+
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Set_Type_Staticness (Delay_Length_Subtype_Definition,
+ Time_Subtype_Staticness);
+ end if;
+ Set_Type_Staticness (Time_Type_Definition, Time_Type_Staticness);
+ Set_Type_Staticness (Time_Subtype_Definition, Time_Subtype_Staticness);
+
+ if Flag_Rti then
+ Rtis.Generate_Unit (Standard_Package);
+ Std_Standard_Boolean_Rti
+ := Get_Info (Boolean_Type_Definition).Type_Rti;
+ Std_Standard_Bit_Rti
+ := Get_Info (Bit_Type_Definition).Type_Rti;
+ end if;
+
+ -- Std_Ulogic indexed array of STD.Boolean.
+ -- Used by PSL to convert Std_Ulogic to boolean.
+ Std_Ulogic_Boolean_Array_Type :=
+ New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9));
+ New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"),
+ Std_Ulogic_Boolean_Array_Type);
+ New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array,
+ Get_Identifier ("__ghdl_std_ulogic_to_boolean_array"),
+ O_Storage_External, Std_Ulogic_Boolean_Array_Type);
+
+ Pop_Identifier_Prefix (Unit_Mark);
+ Pop_Identifier_Prefix (Lib_Mark);
+
+ Post_Initialize;
+ Current_Filename_Node := O_Dnode_Null;
+ --Pop_Global_Factory;
+ end Translate_Standard;
+
+ procedure Finalize
+ is
+ Info : Ortho_Info_Acc;
+ Prev_Info : Ortho_Info_Acc;
+ begin
+ Prev_Info := null;
+ for I in Node_Infos.First .. Node_Infos.Last loop
+ Info := Get_Info (I);
+ if Info /= null and then Info /= Prev_Info then
+ case Get_Kind (I) is
+ when Iir_Kind_Constant_Declaration =>
+ if Get_Deferred_Declaration_Flag (I) = False
+ and then Get_Deferred_Declaration (I) /= Null_Iir
+ then
+ -- Info are copied from incomplete constant declaration
+ -- to full constant declaration.
+ Clear_Info (I);
+ else
+ Free_Info (I);
+ end if;
+ when Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Free_Type_Info (Info);
+ when Iir_Kind_Array_Subtype_Definition =>
+ if Get_Index_Constraint_Flag (I) then
+ Info.T := Ortho_Info_Type_Array_Init;
+ Free_Type_Info (Info);
+ end if;
+ when Iir_Kind_Implicit_Function_Declaration =>
+ case Get_Implicit_Definition (I) is
+ when Iir_Predefined_Bit_Array_Match_Equality
+ | Iir_Predefined_Bit_Array_Match_Inequality =>
+ -- Not in sequence.
+ null;
+ when others =>
+ -- By default, info are not shared.
+ -- The exception is infos for implicit subprograms,
+ -- but they are always consecutive and not free twice
+ -- due to prev_info mechanism.
+ Free_Info (I);
+ end case;
+ when others =>
+ -- By default, info are not shared.
+ Free_Info (I);
+ end case;
+ Prev_Info := Info;
+ end if;
+ end loop;
+ Node_Infos.Free;
+ Free_Old_Temp;
+ end Finalize;
+
+ package body Chap12 is
+ -- Create __ghdl_ELABORATE
+ procedure Gen_Main (Entity : Iir_Entity_Declaration;
+ Arch : Iir_Architecture_Body;
+ Config_Subprg : O_Dnode;
+ Nbr_Pkgs : Natural)
+ is
+ Entity_Info : Block_Info_Acc;
+ Arch_Info : Block_Info_Acc;
+ Inter_List : O_Inter_List;
+ Assoc : O_Assoc_List;
+ Instance : O_Dnode;
+ Arch_Instance : O_Dnode;
+ Mark : Id_Mark_Type;
+ Arr_Type : O_Tnode;
+ Arr : O_Dnode;
+ begin
+ Arch_Info := Get_Info (Arch);
+ Entity_Info := Get_Info (Entity);
+
+ -- We need to create code.
+ Set_Global_Storage (O_Storage_Private);
+
+ -- Create the array of RTIs for packages (as a variable, initialized
+ -- during elaboration).
+ Arr_Type := New_Constrained_Array_Type
+ (Rtis.Ghdl_Rti_Array,
+ New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs)));
+ New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"),
+ O_Storage_Private, Arr_Type);
+
+ -- The elaboration entry point.
+ Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"),
+ O_Storage_Public);
+ Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate);
+
+ Start_Subprogram_Body (Ghdl_Elaborate);
+ New_Var_Decl (Arch_Instance, Wki_Arch_Instance,
+ O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type);
+
+ New_Var_Decl (Instance, Wki_Instance, O_Storage_Local,
+ Entity_Info.Block_Decls_Ptr_Type);
+
+ -- Create instance for the architecture.
+ New_Assign_Stmt
+ (New_Obj (Arch_Instance),
+ Gen_Alloc (Alloc_System,
+ New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)),
+ Arch_Info.Block_Decls_Ptr_Type));
+
+ -- Set the top instance.
+ New_Assign_Stmt
+ (New_Obj (Instance),
+ New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance),
+ Arch_Info.Block_Parent_Field),
+ Entity_Info.Block_Decls_Ptr_Type));
+
+ -- Clear parent field of entity link.
+ New_Assign_Stmt
+ (New_Selected_Element
+ (New_Selected_Acc_Value (New_Obj (Instance),
+ Entity_Info.Block_Link_Field),
+ Rtis.Ghdl_Entity_Link_Parent),
+ New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc)));
+
+ -- Set top instances and RTI.
+ -- Do it before the elaboration code, since it may be used to
+ -- diagnose errors.
+ -- Call ghdl_rti_add_top
+ Start_Association (Assoc, Ghdl_Rti_Add_Top);
+ New_Association
+ (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+ Unsigned_64 (Nbr_Pkgs))));
+ New_Association
+ (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc)));
+ New_Association
+ (Assoc,
+ New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const)));
+ New_Association
+ (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance),
+ Ghdl_Ptr_Type));
+ New_Procedure_Call (Assoc);
+
+ -- Add std.standard rti
+ Start_Association (Assoc, Ghdl_Rti_Add_Package);
+ New_Association
+ (Assoc,
+ New_Lit (Rtis.New_Rti_Address
+ (Get_Info (Standard_Package).Package_Rti_Const)));
+ New_Procedure_Call (Assoc);
+
+ Gen_Filename (Get_Design_File (Get_Design_Unit (Entity)));
+
+ -- Elab package dependences of top entity (so that default
+ -- expressions can be evaluated).
+ Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg);
+ New_Procedure_Call (Assoc);
+
+ -- init instance
+ Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance);
+ Push_Identifier_Prefix (Mark, "");
+ Chap1.Translate_Entity_Init (Entity);
+
+ -- elab instance
+ Start_Association (Assoc, Arch_Info.Block_Elab_Subprg);
+ New_Association (Assoc, New_Obj_Value (Instance));
+ New_Procedure_Call (Assoc);
+
+ --Chap6.Link_Instance_Name (Null_Iir, Entity);
+
+ -- configure instance.
+ Start_Association (Assoc, Config_Subprg);
+ New_Association (Assoc, New_Obj_Value (Arch_Instance));
+ New_Procedure_Call (Assoc);
+
+ Pop_Identifier_Prefix (Mark);
+ Clear_Scope (Entity_Info.Block_Scope);
+ Finish_Subprogram_Body;
+
+ Current_Filename_Node := O_Dnode_Null;
+ end Gen_Main;
+
+ procedure Gen_Setup_Info
+ is
+ Cst : O_Dnode;
+ pragma Unreferenced (Cst);
+ begin
+ Cst := Create_String (Flags.Flag_String,
+ Get_Identifier ("__ghdl_flag_string"),
+ O_Storage_Public);
+ end Gen_Setup_Info;
+
+ procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration)
+ is
+ Entity_Info : Block_Info_Acc;
+
+ Arch : Iir_Architecture_Body;
+ Arch_Info : Block_Info_Acc;
+
+ Lib : Iir_Library_Declaration;
+ Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type;
+
+ Config : Iir_Configuration_Declaration;
+ Config_Info : Config_Info_Acc;
+
+ Const : O_Dnode;
+ Instance : O_Dnode;
+ Inter_List : O_Inter_List;
+ Constr : O_Assoc_List;
+ Subprg : O_Dnode;
+ begin
+ Arch := Libraries.Get_Latest_Architecture (Entity);
+ if Arch = Null_Iir then
+ Error_Msg_Elab ("no architecture for " & Disp_Node (Entity));
+ end if;
+ Arch_Info := Get_Info (Arch);
+ if Arch_Info = null then
+ -- Nothing to do here, since the architecture is not used.
+ return;
+ end if;
+ Entity_Info := Get_Info (Entity);
+
+ -- Create trampoline for elab, default_architecture
+ -- re-create instsize.
+ Reset_Identifier_Prefix;
+ Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity)));
+ Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib));
+ Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity));
+ Push_Identifier_Prefix (Arch_Mark, "LASTARCH");
+
+ -- Instance size.
+ New_Const_Decl
+ (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public,
+ Ghdl_Index_Type);
+ Start_Const_Value (Const);
+ Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope));
+
+ -- Elaborator.
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public);
+ New_Interface_Decl
+ (Inter_List, Instance, Wki_Instance,
+ Entity_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Subprg);
+
+ Start_Subprogram_Body (Subprg);
+ Start_Association (Constr, Arch_Info.Block_Elab_Subprg);
+ New_Association (Constr, New_Obj_Value (Instance));
+ New_Procedure_Call (Constr);
+ Finish_Subprogram_Body;
+
+ -- Default config.
+ Config := Get_Library_Unit
+ (Get_Default_Configuration_Declaration (Arch));
+ Config_Info := Get_Info (Config);
+ if Config_Info /= null then
+ -- Do not create a trampoline for the default_config if it is not
+ -- used.
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier ("DEFAULT_CONFIG"),
+ O_Storage_Public);
+ New_Interface_Decl (Inter_List, Instance, Wki_Instance,
+ Arch_Info.Block_Decls_Ptr_Type);
+ Finish_Subprogram_Decl (Inter_List, Subprg);
+
+ Start_Subprogram_Body (Subprg);
+ Start_Association (Constr, Config_Info.Config_Subprg);
+ New_Association (Constr, New_Obj_Value (Instance));
+ New_Procedure_Call (Constr);
+ Finish_Subprogram_Body;
+ end if;
+
+ Pop_Identifier_Prefix (Arch_Mark);
+ Pop_Identifier_Prefix (Entity_Mark);
+ Pop_Identifier_Prefix (Lib_Mark);
+ end Gen_Last_Arch;
+
+ procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body)
+ is
+ Entity : Iir_Entity_Declaration;
+ Lib : Iir_Library_Declaration;
+ Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type;
+
+ Inter_List : O_Inter_List;
+
+ Subprg : O_Dnode;
+ begin
+ Reset_Identifier_Prefix;
+ Entity := Get_Entity (Arch);
+ Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch)));
+ Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib));
+ Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity));
+ Push_Identifier_Prefix (Sep_Mark, "ARCH");
+ Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch));
+
+ -- Elaborator.
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier ("DEFAULT_CONFIG"),
+ O_Storage_Public);
+ Finish_Subprogram_Decl (Inter_List, Subprg);
+
+ Start_Subprogram_Body (Subprg);
+ Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config);
+ Finish_Subprogram_Body;
+
+ Pop_Identifier_Prefix (Arch_Mark);
+ Pop_Identifier_Prefix (Sep_Mark);
+ Pop_Identifier_Prefix (Entity_Mark);
+ Pop_Identifier_Prefix (Lib_Mark);
+ end Gen_Dummy_Default_Config;
+
+ procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit)
+ is
+ Pkg : Iir_Package_Declaration;
+ Lib : Iir_Library_Declaration;
+ Lib_Mark, Pkg_Mark : Id_Mark_Type;
+
+ Decl : Iir;
+ begin
+ Libraries.Load_Design_Unit (Unit, Null_Iir);
+ Pkg := Get_Library_Unit (Unit);
+ Reset_Identifier_Prefix;
+ Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg)));
+ Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib));
+ Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg));
+
+ if Get_Need_Body (Pkg) then
+ Decl := Get_Declaration_Chain (Pkg);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ -- Generate empty body.
+
+ -- Never a second spec, as this is within a package
+ -- declaration.
+ pragma Assert
+ (not Is_Second_Subprogram_Specification (Decl));
+
+ if not Get_Foreign_Flag (Decl) then
+ declare
+ Mark : Id_Mark_Type;
+ Inter_List : O_Inter_List;
+ Proc : O_Dnode;
+ begin
+ Chap2.Push_Subprg_Identifier (Decl, Mark);
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier, O_Storage_Public);
+ Finish_Subprogram_Decl (Inter_List, Proc);
+ Start_Subprogram_Body (Proc);
+ Finish_Subprogram_Body;
+ Pop_Identifier_Prefix (Mark);
+ end;
+ end if;
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end if;
+
+ -- Create the body elaborator.
+ declare
+ Inter_List : O_Inter_List;
+ Proc : O_Dnode;
+ begin
+ Start_Procedure_Decl
+ (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public);
+ Finish_Subprogram_Decl (Inter_List, Proc);
+ Start_Subprogram_Body (Proc);
+ Finish_Subprogram_Body;
+ end;
+
+ Pop_Identifier_Prefix (Pkg_Mark);
+ Pop_Identifier_Prefix (Lib_Mark);
+ end Gen_Dummy_Package_Declaration;
+
+ procedure Write_File_List (Filelist : String)
+ is
+ use Interfaces.C_Streams;
+ use System;
+ use Configuration;
+ use Name_Table;
+
+ -- Add all dependences of UNIT.
+ -- UNIT is not used, but added during link.
+ procedure Add_Unit_Dependences (Unit : Iir_Design_Unit)
+ is
+ Dep_List : Iir_List;
+ Dep : Iir;
+ Dep_Unit : Iir_Design_Unit;
+ Lib_Unit : Iir;
+ begin
+ -- Load the unit in memory to compute the dependence list.
+ Libraries.Load_Design_Unit (Unit, Null_Iir);
+ Update_Node_Infos;
+
+ Set_Elab_Flag (Unit, True);
+ Design_Units.Append (Unit);
+
+ if Flag_Rti then
+ Rtis.Generate_Library
+ (Get_Library (Get_Design_File (Unit)), True);
+ end if;
+
+ Lib_Unit := Get_Library_Unit (Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Package_Declaration =>
+ -- The body may be required due to incomplete constant
+ -- declarations, or to call to a subprogram.
+ declare
+ Pack_Body : Iir;
+ begin
+ Pack_Body := Libraries.Find_Secondary_Unit
+ (Unit, Null_Identifier);
+ if Pack_Body /= Null_Iir then
+ Add_Unit_Dependences (Pack_Body);
+ else
+ Gen_Dummy_Package_Declaration (Unit);
+ end if;
+ end;
+ when Iir_Kind_Architecture_Body =>
+ Gen_Dummy_Default_Config (Lib_Unit);
+ when others =>
+ null;
+ end case;
+
+ Dep_List := Get_Dependence_List (Unit);
+ for I in Natural loop
+ Dep := Get_Nth_Element (Dep_List, I);
+ exit when Dep = Null_Iir;
+ Dep_Unit := Libraries.Find_Design_Unit (Dep);
+ if Dep_Unit = Null_Iir then
+ Error_Msg_Elab
+ ("could not find design unit " & Disp_Node (Dep));
+ elsif not Get_Elab_Flag (Dep_Unit) then
+ Add_Unit_Dependences (Dep_Unit);
+ end if;
+ end loop;
+ end Add_Unit_Dependences;
+
+ -- Add not yet added units of FILE.
+ procedure Add_File_Units (File : Iir_Design_File)
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ if not Get_Elab_Flag (Unit) then
+ -- Unit not used.
+ Add_Unit_Dependences (Unit);
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end Add_File_Units;
+
+ Nul : constant Character := Character'Val (0);
+ Fname : String := Filelist & Nul;
+ Mode : constant String := "wt" & Nul;
+ F : FILEs;
+ R : int;
+ S : size_t;
+ pragma Unreferenced (R, S); -- FIXME
+ Id : Name_Id;
+ Lib : Iir_Library_Declaration;
+ File : Iir_Design_File;
+ Unit : Iir_Design_Unit;
+ J : Natural;
+ begin
+ F := fopen (Fname'Address, Mode'Address);
+ if F = NULL_Stream then
+ Error_Msg_Elab ("cannot open " & Filelist);
+ end if;
+
+ -- Set elab flags on units, and remove it on design files.
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Set_Elab_Flag (Unit, True);
+ File := Get_Design_File (Unit);
+ Set_Elab_Flag (File, False);
+ end loop;
+
+ J := Design_Units.First;
+ while J <= Design_Units.Last loop
+ Unit := Design_Units.Table (J);
+ File := Get_Design_File (Unit);
+ if not Get_Elab_Flag (File) then
+ Set_Elab_Flag (File, True);
+
+ -- Add dependences of unused design units, otherwise the object
+ -- link case failed.
+ Add_File_Units (File);
+
+ Lib := Get_Library (File);
+ R := fputc (Character'Pos ('>'), F);
+ Id := Get_Library_Directory (Lib);
+ S := fwrite (Get_Address (Id),
+ size_t (Get_Name_Length (Id)), 1, F);
+ R := fputc (10, F);
+
+ Id := Get_Design_File_Filename (File);
+ S := fwrite (Get_Address (Id),
+ size_t (Get_Name_Length (Id)), 1, F);
+ R := fputc (10, F);
+ end if;
+ J := J + 1;
+ end loop;
+ end Write_File_List;
+
+ procedure Elaborate
+ (Primary : String;
+ Secondary : String;
+ Filelist : String;
+ Whole : Boolean)
+ is
+ use Name_Table;
+ use Configuration;
+
+ Primary_Id : Name_Id;
+ Secondary_Id : Name_Id;
+ Unit : Iir_Design_Unit;
+ Lib_Unit : Iir;
+ Config : Iir_Design_Unit;
+ Config_Lib : Iir_Configuration_Declaration;
+ Entity : Iir_Entity_Declaration;
+ Arch : Iir_Architecture_Body;
+ Conf_Info : Config_Info_Acc;
+ Last_Design_Unit : Natural;
+ Nbr_Pkgs : Natural;
+ begin
+ Primary_Id := Get_Identifier (Primary);
+ if Secondary /= "" then
+ Secondary_Id := Get_Identifier (Secondary);
+ else
+ Secondary_Id := Null_Identifier;
+ end if;
+ Config := Configure (Primary_Id, Secondary_Id);
+ if Config = Null_Iir then
+ return;
+ end if;
+ Config_Lib := Get_Library_Unit (Config);
+ Entity := Get_Entity (Config_Lib);
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (Config_Lib));
+
+ -- Be sure the entity can be at the top of a design.
+ Check_Entity_Declaration_Top (Entity);
+
+ -- If all design units are loaded, late semantic checks can be
+ -- performed.
+ if Flag_Load_All_Design_Units then
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Sem.Sem_Analysis_Checks_List (Unit, False);
+ -- There cannot be remaining checks to do.
+ pragma Assert
+ (Get_Analysis_Checks_List (Unit) = Null_Iir_List);
+ end loop;
+ end if;
+
+ -- Return now in case of errors.
+ if Nbr_Errors /= 0 then
+ return;
+ end if;
+
+ if Flags.Verbose then
+ Ada.Text_IO.Put_Line ("List of units in the hierarchy design:");
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Lib_Unit := Get_Library_Unit (Unit);
+ Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit));
+ end loop;
+ end if;
+
+ if Whole then
+ -- In compile-and-elaborate mode, do not generate code for
+ -- unused subprograms.
+ -- FIXME: should be improved by creating a span-tree.
+ Flag_Discard_Unused := True;
+ Flag_Discard_Unused_Implicit := True;
+ end if;
+
+ -- Generate_Library add infos, therefore the info array must be
+ -- adjusted.
+ Update_Node_Infos;
+ Rtis.Generate_Library (Libraries.Std_Library, True);
+ Translate_Standard (Whole);
+
+ -- Translate all configurations needed.
+ -- Also, set the ELAB_FLAG on package with body.
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Lib_Unit := Get_Library_Unit (Unit);
+
+ if Whole then
+ -- In whole compilation mode, force to generate RTIS of
+ -- libraries.
+ Rtis.Generate_Library
+ (Get_Library (Get_Design_File (Unit)), True);
+ end if;
+
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Configuration_Declaration =>
+ -- Always generate code for configuration.
+ -- Because default binding may be changed between analysis
+ -- and elaboration.
+ Translate (Unit, True);
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ -- For package spec, mark it as 'body is not present', this
+ -- flag will be set below when the body is translated.
+ Set_Elab_Flag (Unit, False);
+ Translate (Unit, Whole);
+ when Iir_Kind_Package_Body =>
+ -- Mark the spec with 'body is present' flag.
+ Set_Elab_Flag
+ (Get_Design_Unit (Get_Package (Lib_Unit)), True);
+ Translate (Unit, Whole);
+ when others =>
+ Error_Kind ("elaborate", Lib_Unit);
+ end case;
+ end loop;
+
+ -- Generate code to elaboration body-less package.
+ --
+ -- When a package is analyzed, we don't know wether there is body
+ -- or not. Therefore, we assume there is always a body, and will
+ -- elaborate the body (which elaborates its spec). If a package
+ -- has no body, create the body elaboration procedure.
+ for I in Design_Units.First .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Lib_Unit := Get_Library_Unit (Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Package_Declaration =>
+ if not Get_Elab_Flag (Unit) then
+ Chap2.Elab_Package_Body (Lib_Unit, Null_Iir);
+ end if;
+ when Iir_Kind_Entity_Declaration =>
+ Gen_Last_Arch (Lib_Unit);
+ when Iir_Kind_Architecture_Body
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("elaborate(2)", Lib_Unit);
+ end case;
+ end loop;
+
+ Rtis.Generate_Top (Nbr_Pkgs);
+
+ -- Create main code.
+ Conf_Info := Get_Info (Config_Lib);
+ Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs);
+
+ Gen_Setup_Info;
+
+ -- Index of the last design unit, required by the design.
+ Last_Design_Unit := Design_Units.Last;
+
+ -- Disp list of files needed.
+ -- FIXME: extract the link completion part of WRITE_FILE_LIST.
+ if Filelist /= "" then
+ Write_File_List (Filelist);
+ end if;
+
+ if Flags.Verbose then
+ Ada.Text_IO.Put_Line ("List of units not used:");
+ for I in Last_Design_Unit + 1 .. Design_Units.Last loop
+ Unit := Design_Units.Table (I);
+ Lib_Unit := Get_Library_Unit (Unit);
+ Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit));
+ end loop;
+ end if;
+ end Elaborate;
+ end Chap12;
+end Translation;
diff --git a/src/translate/translation.ads b/src/translate/translation.ads
new file mode 100644
index 000000000..e779685f2
--- /dev/null
+++ b/src/translate/translation.ads
@@ -0,0 +1,120 @@
+-- Iir to ortho translator.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+with Ortho_Nodes;
+
+package Translation is
+ -- Initialize the package: create internal nodes.
+ procedure Initialize;
+
+ -- Translate (generate code) for design unit UNIT.
+ -- If MAIN is true, the unit is really the unit being compiled (not an
+ -- external unit). Code shouldn't be generated for external units.
+ procedure Translate (Unit : Iir_Design_Unit; Main : Boolean);
+
+ -- Translate std.standard.
+ procedure Translate_Standard (Main : Boolean);
+
+ -- Get the ortho node for subprogram declaration DECL.
+ function Get_Ortho_Decl (Subprg : Iir) return Ortho_Nodes.O_Dnode;
+
+ -- Get the internal _RESOLV function for FUNC.
+ function Get_Resolv_Ortho_Decl (Func : Iir) return Ortho_Nodes.O_Dnode;
+
+ procedure Finalize;
+
+ package Chap12 is
+ -- Primary unit + secondary unit (architecture name which may be null)
+ -- to elaborate.
+ procedure Elaborate (Primary : String;
+ Secondary : String;
+ Filelist : String;
+ Whole : Boolean);
+ end Chap12;
+
+ -- If set, generate Run-Time Information nodes.
+ Flag_Rti : Boolean := True;
+
+ -- If set, do not generate 64 bits integer types and operations.
+ Flag_Only_32b : Boolean := False;
+
+ -- If set, do not generate code for unused subprograms.
+ -- Be careful: unless you are in whole compilation mode, this
+ -- flag shouldn't be set for packages and entities.
+ Flag_Discard_Unused : Boolean := False;
+
+ -- If set, do not generate code for unused implicit subprograms.
+ Flag_Discard_Unused_Implicit : Boolean := False;
+
+ -- If set, dump drivers per process during compilation.
+ Flag_Dump_Drivers : Boolean := False;
+
+ -- If set, try to create direct drivers.
+ Flag_Direct_Drivers : Boolean := True;
+
+ -- If set, checks ranges (subtype ranges).
+ Flag_Range_Checks : Boolean := True;
+
+ -- If set, checks indexes (arrays index and slice).
+ Flag_Index_Checks : Boolean := True;
+
+ -- If set, do not create identifiers (for in memory compilation).
+ Flag_Discard_Identifiers : Boolean := False;
+
+ -- If true, do not create nested subprograms.
+ -- This flag is forced during initialization if the code generated doesn't
+ -- support nested subprograms.
+ Flag_Unnest_Subprograms : Boolean := False;
+
+ type Foreign_Kind_Type is (Foreign_Unknown,
+ Foreign_Vhpidirect,
+ Foreign_Intrinsic);
+
+ type Foreign_Info_Type (Kind : Foreign_Kind_Type := Foreign_Unknown)
+ is record
+ case Kind is
+ when Foreign_Unknown =>
+ null;
+ when Foreign_Vhpidirect =>
+ -- Positions in name_table.name_buffer.
+ Lib_First : Natural;
+ Lib_Last : Natural;
+ Subprg_First : Natural;
+ Subprg_Last : Natural;
+ when Foreign_Intrinsic =>
+ null;
+ end case;
+ end record;
+
+ Foreign_Bad : constant Foreign_Info_Type := (Kind => Foreign_Unknown);
+
+ -- Return a foreign_info for DECL.
+ -- Can generate error messages, if the attribute expression is ill-formed.
+ -- If EXTRACT_NAME is set, internal fields of foreign_info are set.
+ -- Otherwise, only KIND discriminent is set.
+ -- EXTRACT_NAME should be set only inside translation itself, since the
+ -- name can be based on the prefix.
+ function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type;
+
+ -- If not null, this procedure is called when a foreign subprogram is
+ -- created.
+ type Foreign_Hook_Access is access procedure (Decl : Iir;
+ Info : Foreign_Info_Type;
+ Ortho : Ortho_Nodes.O_Dnode);
+ Foreign_Hook : Foreign_Hook_Access := null;
+end Translation;
diff --git a/src/types.ads b/src/types.ads
new file mode 100644
index 000000000..4775484ff
--- /dev/null
+++ b/src/types.ads
@@ -0,0 +1,127 @@
+-- Common types.
+-- 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;
+
+package Types is
+ pragma Preelaborate (Types);
+
+ -- A tri state type.
+ type Tri_State_Type is (Unknown, False, True);
+
+ -- 32 bits integer.
+ type Int32 is range -2**31 .. 2**31 - 1;
+ for Int32'Size use 32;
+
+ subtype Nat32 is Int32 range 0 .. Int32'Last;
+ subtype Pos32 is Nat32 range 1 .. Nat32'Last;
+
+ type Uns32 is new Interfaces.Unsigned_32;
+
+ type Fp64 is new Interfaces.IEEE_Float_64;
+
+ -- iir_int32 is aimed at containing integer literal values.
+ type Iir_Int32 is new Interfaces.Integer_32;
+
+ -- iir_int64 is aimed at containing units values.
+ type Iir_Int64 is new Interfaces.Integer_64;
+
+ -- iir_fp32 is aimed at containing floating point values.
+ type Iir_Fp32 is new Interfaces.IEEE_Float_32;
+
+ -- iir_fp64 is aimed at containing floating point values.
+ subtype Iir_Fp64 is Fp64;
+
+ -- iir_index32 is aimed at containing an array index.
+ type Iir_Index32 is new Nat32;
+
+ -- Useful type.
+ type String_Acc is access String;
+ type String_Cst is access constant String;
+ type String_Acc_Array is array (Natural range <>) of String_Acc;
+
+ type String_Fat is array (Pos32) of Character;
+ type String_Fat_Acc is access String_Fat;
+
+ -- Type of a name table element.
+ -- The name table is defined in the name_table package.
+ type Name_Id is new Nat32;
+
+ -- null entry in the name table.
+ -- It is sure that this entry is never allocated.
+ Null_Identifier: constant Name_Id := 0;
+
+ -- Type of a string stored into the string table.
+ type String_Id is new Nat32;
+ for String_Id'Size use 32;
+
+ Null_String : constant String_Id := 0;
+
+ -- Index type is the source file table.
+ -- This table is defined in the files_map package.
+ type Source_File_Entry is new Nat32;
+ No_Source_File_Entry: constant Source_File_Entry := 0;
+
+ -- FIXME: additional source file entries to create:
+ -- *std.standard*: for those created in std.standard
+ -- *error*: for erroneous one
+ -- *command-line*: used for identifiers from command line
+ -- (eg: unit to elab)
+
+ -- Index into a file buffer.
+ type Source_Ptr is new Int32;
+
+ -- Lower boundary of any file buffer.
+ Source_Ptr_Org : constant Source_Ptr := 0;
+
+ -- Bad file buffer index (used to mark no line).
+ Source_Ptr_Bad : constant Source_Ptr := -1;
+
+ -- This type contains everything necessary to get a file name, a line
+ -- number and a column number.
+ type Location_Type is new Nat32;
+ for Location_Type'Size use 32;
+ Location_Nil : constant Location_Type := 0;
+
+ -- Type of a file buffer.
+ type File_Buffer is array (Source_Ptr range <>) of Character;
+ type File_Buffer_Acc is access File_Buffer;
+
+ -- PSL Node.
+ type PSL_Node is new Int32;
+
+ -- PSL NFA
+ type PSL_NFA is new Int32;
+
+ -- Indentation.
+ -- This is used by all packages that display vhdl code or informations.
+ Indentation : constant := 2;
+
+ -- String representing a date/time (format is YYYYMMDDHHmmSS.sss).
+ subtype Time_Stamp_String is String (1 .. 18);
+ type Time_Stamp_Id is new String_Id;
+ Null_Time_Stamp : constant Time_Stamp_Id := 0;
+
+ -- Self-explaining: raised when an internal error (such as consistency)
+ -- is detected.
+ Internal_Error: exception;
+
+ -- In some case, a low level subprogram can't handle error
+ -- (e.g eval_pos). In this case it is easier to raise an exception and
+ -- let upper level subprograms handle the case.
+ Node_Error : exception;
+end Types;
diff --git a/src/version.ads b/src/version.ads
new file mode 100644
index 000000000..11b2a0b72
--- /dev/null
+++ b/src/version.ads
@@ -0,0 +1,5 @@
+package Version is
+ Ghdl_Release : constant String :=
+ "GHDL 0.33dev (20141104) [Dunoon edition]";
+ Ghdl_Ver : constant String := "0.33dev";
+end Version;
diff --git a/src/xrefs.adb b/src/xrefs.adb
new file mode 100644
index 000000000..15696696b
--- /dev/null
+++ b/src/xrefs.adb
@@ -0,0 +1,279 @@
+-- Cross references.
+-- 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;
+with GNAT.Heap_Sort_A;
+with Flags;
+with Std_Package;
+with Errorout; use Errorout;
+with Nodes;
+
+package body Xrefs is
+ type Xref_Type is record
+ -- Where the cross-reference (or the name) appears.
+ Loc : Location_Type;
+
+ -- What the name refer to.
+ Ref : Iir;
+
+ -- Kind of reference (See package specification).
+ Kind : Xref_Kind;
+ end record;
+
+ package Xref_Table is new GNAT.Table
+ (Table_Index_Type => Natural,
+ Table_Component_Type => Xref_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ function Get_Xref_Location (N : Xref) return Location_Type is
+ begin
+ return Xref_Table.Table (N).Loc;
+ end Get_Xref_Location;
+
+ function Get_Xref_Kind (N : Xref) return Xref_Kind is
+ begin
+ return Xref_Table.Table (N).Kind;
+ end Get_Xref_Kind;
+
+ function Get_Xref_Node (N : Xref) return Iir is
+ begin
+ return Xref_Table.Table (N).Ref;
+ end Get_Xref_Node;
+
+ function Get_Last_Xref return Xref is
+ begin
+ return Xref_Table.Last;
+ end Get_Last_Xref;
+
+ procedure Init is
+ begin
+ Xref_Table.Set_Last (Bad_Xref);
+ end Init;
+
+ procedure Add_Xref (Loc : Location_Type; Ref : Iir; Kind : Xref_Kind) is
+ begin
+ -- Check there is no xref for the same location to the same reference.
+ -- (Note that a designatore may reference several declarations, this
+ -- is possible in attribute specification for an overloadable name).
+ -- This is a simple heuristic as this catch only two referenced in the
+ -- row but efficient and should be enough to catch errors.
+ pragma Assert
+ (Xref_Table.Last < Xref_Table.First
+ or else Xref_Table.Table (Xref_Table.Last).Loc /= Loc
+ or else Xref_Table.Table (Xref_Table.Last).Ref /= Ref);
+
+ Xref_Table.Append (Xref_Type'(Loc => Loc,
+ Ref => Ref,
+ Kind => Kind));
+ end Add_Xref;
+
+ procedure Xref_Decl (Decl : Iir) is
+ begin
+ if Flags.Flag_Xref then
+ Add_Xref (Get_Location (Decl), Decl, Xref_Decl);
+ end if;
+ end Xref_Decl;
+
+ procedure Xref_Ref (Name : Iir; Decl : Iir) is
+ begin
+ if Flags.Flag_Xref then
+ Add_Xref (Get_Location (Name), Decl, Xref_Ref);
+ end if;
+ end Xref_Ref;
+
+ procedure Xref_Body (Bod : Iir; Spec : Iir) is
+ begin
+ if Flags.Flag_Xref then
+ Add_Xref (Get_Location (Bod), Spec, Xref_Body);
+ end if;
+ end Xref_Body;
+
+ procedure Xref_End (Loc : Location_Type; Decl : Iir) is
+ begin
+ if Flags.Flag_Xref then
+ Add_Xref (Loc, Decl, Xref_End);
+ end if;
+ end Xref_End;
+
+ procedure Xref_Name_1 (Name : Iir) is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Character_Literal =>
+ declare
+ Res : constant Iir := Get_Named_Entity (Name);
+ begin
+ if Res = Std_Package.Error_Mark then
+ return;
+ end if;
+ Add_Xref (Get_Location (Name), Res, Xref_Ref);
+ end;
+ when Iir_Kind_Selected_Element =>
+ Add_Xref (Get_Location (Name),
+ Get_Selected_Element (Name), Xref_Ref);
+ when Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Function_Call =>
+ null;
+ when Iir_Kinds_Attribute =>
+ null;
+ when Iir_Kind_Attribute_Name =>
+ -- FIXME: user defined attributes.
+ null;
+ when Iir_Kind_Type_Conversion =>
+ return;
+ when others =>
+ Error_Kind ("xref_name_1", Name);
+ end case;
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Character_Literal =>
+ null;
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Attribute_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kinds_Attribute
+ | Iir_Kind_Function_Call =>
+ Xref_Name_1 (Get_Prefix (Name));
+ when others =>
+ Error_Kind ("xref_name_1", Name);
+ end case;
+ end Xref_Name_1;
+
+ procedure Xref_Name (Name : Iir) is
+ begin
+ if Flags.Flag_Xref and Name /= Null_Iir then
+ Xref_Name_1 (Name);
+ end if;
+ end Xref_Name;
+
+ procedure Move (From : Natural; To : Natural)
+ is
+ Tmp : Xref_Type;
+ begin
+ Tmp := Xref_Table.Table (To);
+ Xref_Table.Table (To) := Xref_Table.Table (From);
+ Xref_Table.Table (From) := Tmp;
+ end Move;
+
+ function Loc_Lt (Op1, Op2 : Natural) return Boolean
+ is
+ L1 : constant Location_Type := Xref_Table.Table (Op1).Loc;
+ L2 : constant Location_Type := Xref_Table.Table (Op2).Loc;
+ begin
+ return L1 < L2;
+ end Loc_Lt;
+
+ procedure Sort_By_Location is
+ begin
+ GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Loc_Lt'Access);
+ end Sort_By_Location;
+
+ -- Sorting function by ref field.
+ -- If ref fields are the same, then compare by location.
+ function Node_Lt (Op1, Op2 : Natural) return Boolean
+ is
+ L1, L2 : Location_Type;
+ N1, N2 : Iir;
+ K1, K2 : Xref_Kind;
+ begin
+ L1 := Get_Location (Get_Xref_Node (Op1));
+ L2 := Get_Location (Get_Xref_Node (Op2));
+
+ if L1 /= L2 then
+ return L1 < L2;
+ end if;
+
+ -- L1 = L2.
+ -- Note: nodes of std_standard have the same location. FIXME ?
+ N1 := Get_Xref_Node (Op1);
+ N2 := Get_Xref_Node (Op2);
+ if Iirs."/=" (N1, N2) then
+ return Nodes."<" (N1, N2);
+ end if;
+
+ -- Try to get declaration first.
+ K1 := Get_Xref_Kind (Op1);
+ K2 := Get_Xref_Kind (Op2);
+ if K1 /= K2 then
+ return K1 < K2;
+ end if;
+ L1 := Get_Xref_Location (Op1);
+ L2 := Get_Xref_Location (Op2);
+ return L1 < L2;
+ end Node_Lt;
+
+ procedure Sort_By_Node_Location is
+ begin
+ GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Node_Lt'Access);
+ end Sort_By_Node_Location;
+
+ function Find (Loc : Location_Type) return Xref
+ is
+ Low : Xref;
+ High : Xref;
+ Mid : Xref;
+ Mid_Loc : Location_Type;
+ begin
+ Low := First_Xref;
+ High := Xref_Table.Last;
+ loop
+ Mid := (Low + High + 1) / 2;
+ Mid_Loc := Xref_Table.Table (Mid).Loc;
+ if Loc = Mid_Loc then
+ return Mid;
+ end if;
+ if Mid = Low then
+ return Bad_Xref;
+ end if;
+ if Loc > Mid_Loc then
+ Low := Mid + 1;
+ else
+ High := Mid - 1;
+ end if;
+ end loop;
+ end Find;
+
+ procedure Fix_End_Xrefs
+ is
+ N : Iir;
+ begin
+ for I in First_Xref .. Get_Last_Xref loop
+ if Get_Xref_Kind (I) = Xref_End then
+ N := Get_Xref_Node (I);
+ case Get_Kind (N) is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ Xref_Table.Table (I).Ref := Get_Subprogram_Specification (N);
+ when others =>
+ null;
+ end case;
+ end if;
+ end loop;
+ end Fix_End_Xrefs;
+end Xrefs;
diff --git a/src/xrefs.ads b/src/xrefs.ads
new file mode 100644
index 000000000..74f2d0c7e
--- /dev/null
+++ b/src/xrefs.ads
@@ -0,0 +1,108 @@
+-- Cross references.
+-- 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 Xrefs is
+ type Xref_Kind is
+ (
+ -- Declaration of an identifier.
+ Xref_Decl,
+
+ -- Use of a named entity.
+ Xref_Ref,
+
+ -- Identifier after the 'end' keyword.
+ Xref_End,
+
+ -- Body of a declaration (for package, subprograms or protected type).
+ Xref_Body
+ );
+
+ -- Initialize the xref table.
+ -- Must be called once.
+ procedure Init;
+
+ -- Low level xref addition.
+ -- An entity at LOC references REF with the KIND way.
+ procedure Add_Xref (Loc : Location_Type; Ref : Iir; Kind : Xref_Kind);
+
+ -- Add a declaration of an identifier.
+ -- This is somewhat a self-reference.
+ procedure Xref_Decl (Decl : Iir);
+ pragma Inline (Xref_Decl);
+
+ -- NAME refers to DECL.
+ procedure Xref_Ref (Name : Iir; Decl : Iir);
+ pragma Inline (Xref_Ref);
+
+ -- BODy refers to SPEC.
+ procedure Xref_Body (Bod : Iir; Spec : Iir);
+ pragma Inline (Xref_Body);
+
+ -- Just resolved NAME refers to its named entity.
+ procedure Xref_Name (Name : Iir);
+ pragma Inline (Xref_Name);
+
+ -- LOC is the location of the simple_name after 'end' for DECL.
+ procedure Xref_End (Loc : Location_Type; Decl : Iir);
+ pragma Inline (Xref_End);
+
+ -- Sort the xref table by location. This is required before searching with
+ -- Find.
+ procedure Sort_By_Location;
+
+ -- Sort the xref table by location of the nodes.
+ procedure Sort_By_Node_Location;
+
+ subtype Xref is Natural;
+
+ -- A bad xref.
+ -- May be returned by Find.
+ Bad_Xref : constant Xref := 0;
+
+ -- First xref.
+ -- May be used to size a table.
+ First_Xref : constant Xref := 1;
+
+ -- Find a reference by location.
+ -- The table must already be sorted with Sort_By_Location.
+ -- Returns BAD_REF is does not exist.
+ function Find (Loc : Location_Type) return Xref;
+
+ -- End_Xrefs are added by parse and points to the subprogram_body.
+ -- This procedure make them points to the subprogram_decl node.
+ -- This is done so that every node has a name.
+ procedure Fix_End_Xrefs;
+
+ -- Get the last possible xref available.
+ -- May be used to size tables.
+ function Get_Last_Xref return Xref;
+
+ -- Get the location of N, ie where a name (or operator) appears.
+ function Get_Xref_Location (N : Xref) return Location_Type;
+ pragma Inline (Get_Xref_Location);
+
+ -- Get the kind of cross-reference.
+ function Get_Xref_Kind (N : Xref) return Xref_Kind;
+ pragma Inline (Get_Xref_Kind);
+
+ -- Get the node referenced by the name.
+ function Get_Xref_Node (N : Xref) return Iir;
+ pragma Inline (Get_Xref_Node);
+end Xrefs;
diff --git a/src/xtools/Makefile b/src/xtools/Makefile
new file mode 100644
index 000000000..6504fbc84
--- /dev/null
+++ b/src/xtools/Makefile
@@ -0,0 +1,35 @@
+# 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.
+
+DEPS=../iirs.ads ../nodes.ads ./pnodes.py
+
+all: ../iirs.adb ../nodes_meta.ads ../nodes_meta.adb
+
+../iirs.adb: ../iirs.adb.in $(DEPS)
+ $(RM) $@
+ ./pnodes.py body > $@
+ chmod -w $@
+
+../nodes_meta.ads: ../nodes_meta.ads.in $(DEPS)
+ $(RM) $@
+ ./pnodes.py meta_specs > $@
+ chmod -w $@
+
+../nodes_meta.adb: ../nodes_meta.adb.in $(DEPS)
+ $(RM) $@
+ ./pnodes.py meta_body > $@
+ chmod -w $@
diff --git a/src/xtools/pnodes.py b/src/xtools/pnodes.py
new file mode 100755
index 000000000..364f1254e
--- /dev/null
+++ b/src/xtools/pnodes.py
@@ -0,0 +1,716 @@
+#!/usr/bin/env python
+
+import re
+import sys
+import argparse
+
+field_file = "../nodes.ads"
+spec_file = "../iirs.ads"
+template_file = "../iirs.adb.in"
+meta_base_file = "../nodes_meta"
+prefix_name = "Iir_Kind_"
+prefix_range_name = "Iir_Kinds_"
+type_name = "Iir_Kind"
+conversions = ['uc', 'pos']
+
+class FuncDesc:
+ def __init__(self, name, field, conv, acc,
+ pname, ptype, rname, rtype):
+ self.name = name
+ self.field = field
+ self.conv = conv
+ self.acc = acc # access: Chain, Chain_Next, Ref, Of_Ref, Maybe_Ref
+ self.pname = pname # Parameter mame
+ self.ptype = ptype # Parameter type
+ self.rname = rname # value name (for procedure)
+ self.rtype = rtype # value type
+
+class NodeDesc:
+ def __init__(self, name, format, fields, attrs):
+ self.name = name
+ self.format = format
+ self.fields = fields # {field: FuncDesc} dict, defined for all fields
+ self.attrs = attrs # A {attr: FuncDesc} dict
+
+class line:
+ def __init__(self, string, no):
+ self.l = string
+ self.n = no
+
+class EndOfFile(Exception):
+ def __init__(self,filename):
+ self.filename = filename
+
+ def __str__(self):
+ return "end of file " + self.filename
+
+class linereader:
+ def __init__(self, filename):
+ self.filename = filename
+ self.f = open (filename)
+ self.lineno = 0
+ self.l = ''
+
+ def get(self):
+ self.l = self.f.readline()
+ if not self.l:
+ raise EndOfFile(self.filename)
+ self.lineno = self.lineno + 1
+ return self.l
+
+class ParseError(Exception):
+ def __init__(self, lr, msg):
+ self.lr = lr;
+ self.msg = msg
+
+ def __str__(self):
+ return 'Error: ' + self.msg
+ return 'Parse error at ' + self.lr.filname + ':' + self.lr.lineno + \
+ ': ' + self.msg
+
+# Return fields description.
+# This is a dictionary. The keys represent the possible format of a node.
+# The values are dictionnaries representing fields. Keys are fields name, and
+# values are fields type.
+def read_fields(file):
+ fields = {}
+ formats = []
+ lr = linereader(file)
+
+ # Search for 'type Format_Type is'
+ while lr.get() != ' type Format_Type is\n':
+ pass
+
+ # Skip '('
+ if lr.get() != ' (\n':
+ raise 'no open parenthesis after Format_Type';
+
+ # Read formats
+ l = lr.get()
+ pat_field_name = re.compile(' Format_(\w+),?\n')
+ while l != ' );\n':
+ m = pat_field_name.match(l)
+ if m == None:
+ print l
+ raise 'bad literal within Format_Type'
+ name = m.group(1)
+ formats.append(name)
+ fields[name] = {}
+ l = lr.get()
+
+ # Read fields
+ l = lr.get()
+ pat_fields = re.compile(' -- Fields of Format_(\w+):\n')
+ pat_field_desc = re.compile(' -- (\w+) : (\w+).*\n')
+ format_name = ''
+ common_desc = {}
+
+ # Read until common fields.
+ while l != ' -- Common fields are:\n':
+ l = lr.get()
+ format_name = 'Common'
+ nbr_formats = 0
+
+ while True:
+ # 1) Read field description
+ l = lr.get()
+ desc = common_desc.copy()
+ while True:
+ m = pat_field_desc.match(l)
+ if m == None:
+ break
+ desc[m.group(1)] = m.group(2)
+ l = lr.get()
+ # print 'For: ' + format_name + ': ' + m.group(1)
+
+ # 2) Disp
+ if format_name == 'Common':
+ common_desc = desc
+ else:
+ fields[format_name] = desc
+
+ # 3) Read next format
+ if l == '\n':
+ if nbr_formats == len(fields):
+ break
+ else:
+ l = lr.get()
+
+ # One for a format
+ m = pat_fields.match(l)
+ if m != None:
+ format_name = m.group(1)
+ if not format_name in fields:
+ raise ParseError(
+ lr, 'Format ' + format_name + ' is unknown')
+ nbr_formats = nbr_formats + 1
+ else:
+ raise ParseError(lr, 'unhandled format line')
+
+ return (formats, fields)
+
+# Read kinds, kinds ranges and methods
+def read_kinds(filename):
+ lr = linereader(filename)
+ kinds = []
+ # Search for 'type Iir_Kind is'
+ while lr.get() != ' type ' + type_name + ' is\n':
+ pass
+ # Skip '('
+ if lr.get() != ' (\n':
+ raise ParseError(lr,
+ 'no open parenthesis after "type ' + type_name +'"')
+
+ # Read literals
+ pat_node = re.compile(' ' + prefix_name + '(\w+),?( +-- .*)?\n')
+ pat_comment = re.compile('( +-- .*)?\n')
+ while True:
+ l = lr.get()
+ if l == ' );\n':
+ break
+ m = pat_node.match(l)
+ if m:
+ kinds.append(m.group(1))
+ continue
+ m = pat_comment.match(l)
+ if not m:
+ raise ParseError(lr, 'Unknow line within kind declaration')
+
+ # Check subtypes
+ pat_subtype = re.compile(' subtype ' + prefix_range_name \
+ + '(\w+) is ' + type_name + ' range\n')
+ pat_first = re.compile(' ' + prefix_name + '(\w+) ..\n')
+ pat_last = re.compile(' ' + prefix_name + '(\w+);\n')
+ pat_middle = re.compile(' --' + prefix_name + '(\w+)\n')
+ kinds_ranges={}
+ while True:
+ l = lr.get()
+ # Start of methods is also end of subtypes.
+ if l == ' -- General methods.\n':
+ break
+ # Found a subtype.
+ m = pat_subtype.match(l)
+ if m:
+ # Check first bound
+ name = m.group(1)
+ l = lr.get()
+ mf = pat_first.match(l)
+ if not mf:
+ raise ParseError(lr, 'badly formated first bound of subtype')
+ first = kinds.index(mf.group(1))
+ idx = first
+ has_middle = None
+ # Read until last bound
+ while True:
+ l = lr.get()
+ ml = pat_middle.match(l)
+ if ml:
+ # Check element in the middle
+ if kinds.index(ml.group(1)) != idx + 1:
+ raise ParseError(lr,
+ "missing " + kinds[idx] + " in subtype")
+ has_middle = True
+ idx = idx + 1
+ else:
+ # Check last bound
+ ml = pat_last.match(l)
+ if ml:
+ last = kinds.index(ml.group(1))
+ if last != idx + 1 and has_middle:
+ raise ParseError(lr,
+ "missing " + kinds[idx] + " in subtype")
+ break
+ raise ParseError(lr,
+ "unhandled line in subtype")
+ kinds_ranges[name] = kinds[first:last+1]
+
+ # Read functions
+ funcs = []
+ pat_field = re.compile(
+ ' -- Field: (\w+)'
+ + '( Of_Ref| Ref| Maybe_Ref| Chain_Next| Chain)?( .*)?\n')
+ pat_conv = re.compile('^ \((\w+)\)$')
+ pat_func = \
+ re.compile(' function Get_(\w+) \((\w+) : (\w+)\) return (\w+);\n')
+ pat_proc = \
+ re.compile(' procedure Set_(\w+) \((\w+) : (\w+); (\w+) : (\w+)\);\n')
+ while True:
+ l = lr.get()
+ if l == 'end Iirs;\n':
+ break
+ m = pat_field.match(l)
+ if m:
+ # Extract conversion
+ acc = m.group(2)
+ if acc:
+ acc = acc.strip()
+ conv = m.group(3)
+ if conv:
+ mc = pat_conv.match(conv)
+ if not mc:
+ raise ParseError(lr, 'conversion ill formed')
+ conv = mc.group(1)
+ if conv not in conversions:
+ raise ParseError(lr, 'unknown conversion ' + conv)
+ else:
+ conv = None
+
+ # Read function
+ l = lr.get()
+ mf = pat_func.match(l)
+ if not mf:
+ raise ParseError(lr,
+ 'function declaration expected after Field')
+ # Read procedure
+ l = lr.get()
+ mp = pat_proc.match(l)
+ if not mp:
+ raise ParseError(lr,
+ 'procedure declaration expected after function')
+ # Consistency check between function and procedure
+ if mf.group(1) != mp.group(1):
+ raise ParseError(lr, 'function and procedure name mismatch')
+ if mf.group(2) != mp.group(2):
+ raise ParseError(lr, 'parameter name mismatch with function')
+ if mf.group(3) != mp.group(3):
+ raise ParseError(lr, 'parameter type mismatch with function')
+ if mf.group(4) != mp.group(5):
+ raise ParseError(lr, 'result type mismatch with function')
+ funcs.append(FuncDesc(mf.group(1), m.group(1), conv, acc,
+ mp.group(2), mp.group(3),
+ mp.group(4), mp.group(5)))
+
+ return (kinds, kinds_ranges, funcs)
+
+# Read description for one node
+def read_nodes_fields(lr, names, fields, nodes, funcs_dict):
+ pat_only = re.compile(' -- Only for ' + prefix_name + '(\w+):\n')
+ pat_field = re.compile(' -- Get/Set_(\w+) \((Alias )?(\w+)\)\n')
+ pat_comment = re.compile(' --.*\n')
+ pat_start = re.compile (' -- \w.*\n')
+
+ # Create nodes
+ cur_nodes = []
+ for (nm, fmt) in names:
+ if fmt not in fields:
+ raise ParseError(lr, 'unknown format')
+ n = NodeDesc(nm, fmt, {x: None for x in fields[fmt]}, {})
+ nodes[nm] = n
+ cur_nodes.append(n)
+
+ # Look for fields
+ only_nodes = cur_nodes
+ l = lr.l
+ while l != '\n':
+ # Handle 'Only ...'
+ while True:
+ m = pat_only.match(l)
+ if not m:
+ break
+ name = m.group(1)
+ if name not in [x.name for x in cur_nodes]:
+ raise ParseError(lr, 'node not currently described')
+ if only_nodes == cur_nodes:
+ only_nodes = []
+ only_nodes.append(nodes[name])
+ l = lr.get()
+ # Handle field
+ m = pat_field.match(l)
+ if m:
+ # 1) Check the function exists
+ func = m.group(1)
+ alias = m.group(2)
+ field = m.group(3)
+ if func not in funcs_dict:
+ raise ParseError(lr, 'unknown function')
+ func = funcs_dict[func]
+ if func.field != field:
+ raise ParseError(lr, 'field mismatch')
+ for c in only_nodes:
+ if field not in c.fields:
+ raise ParseError(lr, 'field ' + field + \
+ ' does not exist in node')
+ if not alias:
+ if c.fields[field]:
+ raise ParseError(lr, 'field already used')
+ c.fields[field] = func
+ c.attrs[func.name] = func
+ only_nodes = cur_nodes
+ elif pat_start.match(l):
+ raise ParseError(lr, 'bad line in node description')
+ elif not pat_comment.match(l):
+ raise ParseError(lr, 'bad line in node description')
+ l = lr.get()
+
+# Read description for all nodes
+def read_nodes(filename, kinds, kinds_ranges, fields, funcs):
+ lr = linereader(filename)
+ funcs_dict = {x.name:x for x in funcs}
+ nodes = {}
+
+ # Skip until start
+ while lr.get() != ' -- Start of ' + type_name + '.\n':
+ pass
+
+ pat_decl = re.compile(' -- ' + prefix_name + '(\w+) \((\w+)\)\n')
+ pat_decls = re.compile(' -- ' + prefix_range_name + '(\w+) \((\w+)\)\n')
+ pat_comment_line = re.compile(' --+\n')
+ pat_comment_box = re.compile(' --( .*)?\n')
+ while True:
+ l = lr.get()
+ if l == ' -- End of ' + type_name + '.\n':
+ return nodes
+ if l == '\n':
+ continue
+ m = pat_decl.match(l)
+ if m:
+ # List of nodes being described by the current description.
+ names = []
+
+ # Declaration of the first node
+ while True:
+ name=m.group(1)
+ if not name in kinds:
+ raise ParseError(lr, 'unknown node')
+ fmt=m.group(2)
+ names.append((name,fmt))
+ # There might be several nodes described at once.
+ l = lr.get()
+ m = pat_decl.match(l)
+ if not m:
+ break
+ read_nodes_fields(lr, names, fields, nodes, funcs_dict)
+ continue
+ m = pat_decls.match(l)
+ if m:
+ # List of nodes being described by the current description.
+ name=m.group(1)
+ fmt=m.group(2)
+ names = [(k,fmt) for k in kinds_ranges[name]]
+ l = lr.get()
+ read_nodes_fields(lr, names, fields, nodes, funcs_dict)
+ continue
+ if pat_comment_line.match(l) or pat_comment_box.match(l):
+ continue
+ raise ParseError(lr, 'bad line in node description')
+ return nodes
+
+# Generate a choice 'when A | B ... Z =>' using elements of CHOICES.
+def gen_choices(choices):
+ is_first=True
+ for c in choices:
+ if is_first:
+ print ' ',
+ print 'when',
+ else:
+ print
+ print ' ',
+ print ' |',
+ print prefix_name + c,
+ is_first=None
+ print '=>'
+
+# Generate the Get_Format function.
+def gen_get_format(formats, nodes, kinds):
+ print ' function Get_Format (Kind : ' + type_name + ') ' + \
+ 'return Format_Type is'
+ print ' begin'
+ print ' case Kind is'
+ for f in formats:
+ choices = [k for k in kinds if nodes[k].format == f]
+ gen_choices(choices)
+ print ' return Format_' + f + ';'
+ print ' end case;'
+ print ' end Get_Format;'
+
+def gen_subprg_header(decl):
+ if len(decl) < 76:
+ print decl + ' is'
+ else:
+ print decl
+ print ' is'
+ print ' begin'
+
+def gen_assert(func):
+ print ' pragma Assert (' + func.pname + ' /= Null_Iir);'
+ cond = '(Has_' + func.name + ' (Get_Kind (' + func.pname + ')));'
+ if len (cond) < 60:
+ print ' pragma Assert ' + cond
+ else:
+ print ' pragma Assert'
+ print ' ' + cond
+
+# Generate Get_XXX/Set_XXX subprograms for FUNC.
+def gen_get_set(func, nodes, fields):
+ g = 'Get_' + func.field + ' (' + func.pname + ')'
+ s = func.rname
+ if func.conv:
+ field_type = None
+ for fld in fields.values():
+ if func.field in fld:
+ field_type = fld[func.field]
+ break
+ if func.conv == 'uc':
+ g = field_type + '_To_' + func.rtype + ' (' + g + ')'
+ s = func.rtype + '_To_' + field_type + ' (' + s + ')'
+ elif func.conv == 'pos':
+ g = func.rtype + "'Val (" + g + ')'
+ s = func.rtype + "'Pos (" + s + ')'
+
+ subprg = ' function Get_' + func.name + ' (' + func.pname \
+ + ' : ' + func.ptype + ') return ' + func.rtype
+ gen_subprg_header(subprg)
+ gen_assert(func)
+ print ' return ' + g + ';'
+ print ' end Get_' + func.name + ';'
+ print
+ subprg = ' procedure Set_' + func.name + ' (' \
+ + func.pname + ' : ' + func.ptype + '; ' \
+ + func.rname + ' : ' + func.rtype + ')'
+ gen_subprg_header(subprg)
+ gen_assert(func)
+ print ' Set_' + func.field + ' (' + func.pname + ', ' + s + ');'
+ print ' end Set_' + func.name + ';'
+ print
+
+def funcs_of_node(n):
+ return sorted([fv.name for fv in n.fields.values() if fv])
+
+def gen_has_func_spec(name, suff):
+ spec=' function Has_' + f.name + ' (K : Iir_Kind)'
+ ret=' return Boolean' + suff;
+ if len(spec) < 60:
+ print spec + ret
+ else:
+ print spec
+ print ' ' + ret
+
+parser = argparse.ArgumentParser(description='Meta-grammar processor')
+parser.add_argument('action', choices=['disp-nodes', 'disp-kinds',
+ 'disp-formats', 'disp-funcs',
+ 'disp-types',
+ 'get_format', 'body',
+ 'meta_specs', 'meta_body'],
+ default='disp-nodes')
+args = parser.parse_args()
+
+try:
+ (formats, fields) = read_fields(field_file)
+ (kinds, kinds_ranges, funcs) = read_kinds(spec_file)
+ nodes = read_nodes(spec_file,kinds,kinds_ranges,fields,funcs)
+
+except ParseError as e:
+ print >> sys.stderr, e
+ print >> sys.stderr, \
+ "in {0}:{1}:{2}".format(e.lr.filename, e.lr.lineno, e.lr.l)
+ sys.exit(1)
+
+if args.action == 'disp-formats':
+ for fmt in fields:
+ print "Fields of Format_"+fmt
+ fld=fields[fmt]
+ for k in fld:
+ print ' ' + k + ' (' + fld[k] + ')'
+elif args.action == 'disp-kinds':
+ print "Kinds are:"
+ for k in kinds:
+ print ' ' + prefix_name + k
+elif args.action == 'disp-funcs':
+ print "Functions are:"
+ for f in funcs:
+ s = '{0} ({1}: {2}'.format(f.name, f.field, f.rtype)
+ if f.acc:
+ s += ' acc:' + f.acc
+ if f.conv:
+ s += ' conv:' + f.conv
+ s += ')'
+ print s
+elif args.action == 'disp-types':
+ print "Types are:"
+ s = set([])
+ for f in funcs:
+ s |= set([f.rtype])
+ for t in sorted(s):
+ print ' ' + t
+elif args.action == 'disp-nodes':
+ for k in kinds:
+ v = nodes[k]
+ print prefix_name + k + ' (' + v.format + ')'
+ flds = [fk for fk, fv in v.fields.items() if fv]
+ for fk in sorted(flds):
+ print ' ' + fk + ': '+ v.fields[fk].name
+elif args.action == 'get_format':
+ gen_get_format(formats, nodes)
+elif args.action == 'body':
+ lr = linereader(template_file)
+ while True:
+ l = lr.get().rstrip()
+ print l
+ if l == ' -- Subprograms':
+ gen_get_format(formats, nodes, kinds)
+ print
+ for f in funcs:
+ gen_get_set(f, nodes, fields)
+ if l[0:3] == 'end':
+ break
+elif args.action == 'meta_specs':
+ lr = linereader(meta_base_file + '.ads.in')
+ # Build list of types
+ s = set([])
+ for f in funcs:
+ s |= set([f.rtype])
+ types = [t for t in sorted(s)]
+ while True:
+ l = lr.get().rstrip()
+ if l == ' -- TYPES':
+ last = None
+ for t in types:
+ if last:
+ print last + ','
+ last = ' Type_' + t
+ print last
+ elif l == ' -- FIELDS':
+ last = None
+ for f in funcs:
+ if last:
+ print last + ','
+ last = ' Field_' + f.name
+ print last
+ elif l == ' -- FUNCS':
+ for t in types:
+ print ' function Get_' + t
+ print ' (N : Iir; F : Fields_Enum) return ' + t + ';'
+ print ' procedure Set_' + t
+ print ' (N : Iir; F : Fields_Enum; V: ' + t + ');'
+ print
+ for f in funcs:
+ gen_has_func_spec(f.name, ';')
+ elif l[0:3] == 'end':
+ print l
+ break
+ else:
+ print l
+elif args.action == 'meta_body':
+ lr = linereader(meta_base_file + '.adb.in')
+ while True:
+ l = lr.get().rstrip()
+ if l == ' -- FIELDS_TYPE':
+ last = None
+ for f in funcs:
+ if last:
+ print last + ','
+ last = ' Field_' + f.name + ' => Type_' + f.rtype
+ print last
+ elif l == ' -- FIELD_IMAGE':
+ for f in funcs:
+ print ' when Field_' + f.name + ' =>'
+ print ' return "' + f.name.lower() + '";'
+ elif l == ' -- IIR_IMAGE':
+ for k in kinds:
+ print ' when ' + prefix_name + k + ' =>'
+ print ' return "' + k.lower() + '";'
+ elif l == ' -- FIELD_ATTRIBUTE':
+ for f in funcs:
+ print ' when Field_' + f.name + ' =>'
+ if f.acc:
+ attr = f.acc
+ else:
+ attr = 'None'
+ print ' return Attr_' + attr + ';'
+ elif l == ' -- FIELDS_ARRAY':
+ last = None
+ nodes_types = ['Iir', 'Iir_List']
+ ref_names = ['Ref', 'Of_Ref', 'Maybe_Ref']
+ for k in kinds:
+ v = nodes[k]
+ if last:
+ print last + ','
+ last = None
+ print ' -- ' + prefix_name + k
+ # Sort fields: first non Iir and non Iir_List,
+ # then Iir and Iir_List that aren't references
+ # then Maybe_Ref
+ # then Ref and Ref_Of
+ flds = sorted([fk for fk, fv in v.fields.items() \
+ if fv and fv.rtype not in nodes_types])
+ flds += sorted([fk for fk, fv in v.fields.items() \
+ if fv and fv.rtype in nodes_types \
+ and fv.acc not in ref_names])
+ flds += sorted([fk for fk, fv in v.fields.items() \
+ if fv and fv.rtype in nodes_types\
+ and fv.acc in ['Maybe_Ref']])
+ flds += sorted([fk for fk, fv in v.fields.items() \
+ if fv and fv.rtype in nodes_types\
+ and fv.acc in ['Ref', 'Of_Ref']])
+ for fk in flds:
+ if last:
+ print last + ','
+ last = ' Field_' + v.fields[fk].name
+ if last:
+ print last
+ elif l == ' -- FIELDS_ARRAY_POS':
+ pos = -1
+ last = None
+ for k in kinds:
+ v = nodes[k]
+ flds = [fk for fk, fv in v.fields.items() if fv]
+ pos += len(flds)
+ if last:
+ print last + ','
+ last = ' ' + prefix_name + k + ' => {}'.format(pos)
+ print last
+ elif l == ' -- FUNCS_BODY':
+ # Build list of types
+ s = set([])
+ for f in funcs:
+ s |= set([f.rtype])
+ types = [t for t in sorted(s)]
+ for t in types:
+ print ' function Get_' + t
+ print ' (N : Iir; F : Fields_Enum) return ' + t + ' is'
+ print ' begin'
+ print ' pragma Assert (Fields_Type (F) = Type_' + t + ');'
+ print ' case F is'
+ for f in funcs:
+ if f.rtype == t:
+ print ' when Field_' + f.name + ' =>'
+ print ' return Get_' + f.name + ' (N);';
+ print ' when others =>'
+ print ' raise Internal_Error;'
+ print ' end case;'
+ print ' end Get_' + t + ';'
+ print
+ print ' procedure Set_' + t
+ print ' (N : Iir; F : Fields_Enum; V: ' + t + ') is'
+ print ' begin'
+ print ' pragma Assert (Fields_Type (F) = Type_' + t + ');'
+ print ' case F is'
+ for f in funcs:
+ if f.rtype == t:
+ print ' when Field_' + f.name + ' =>'
+ print ' Set_' + f.name + ' (N, V);';
+ print ' when others =>'
+ print ' raise Internal_Error;'
+ print ' end case;'
+ print ' end Set_' + t + ';'
+ print
+ for f in funcs:
+ gen_has_func_spec(f.name, ' is')
+ print ' begin'
+ choices = [k for k in kinds if f.name in nodes[k].attrs]
+ if len(choices) == 1:
+ print ' return K = ' + prefix_name + choices[0] + ';'
+ else:
+ print ' case K is'
+ gen_choices(choices)
+ print ' return True;'
+ print ' when others =>'
+ print ' return False;'
+ print ' end case;'
+ print ' end Has_' + f.name + ';'
+ print
+ elif l[0:3] == 'end':
+ print l
+ break
+ else:
+ print l
--
cgit v1.2.3