diff --git a/.drom b/.drom
index 54fb43953..e41293405 100644
--- a/.drom
+++ b/.drom
@@ -5,17 +5,17 @@ version:0.9.0
# hash of toml configuration files
# used for generation of all files
-02ec1db03cfcdaa26f420861e4cbbada:.
+c6ace88d19f3763a350e4a04f2928196:.
# end context for .
# begin context for .github/workflows/workflow.yml
# file .github/workflows/workflow.yml
-d4d64d0996ebf1e854157ace013e0dc4:.github/workflows/workflow.yml
+dec859d35759b2ae3af7975eb7e00f2e:.github/workflows/workflow.yml
# end context for .github/workflows/workflow.yml
# begin context for .gitignore
# file .gitignore
-8d7837a54815c58ebb1de939c8ea312a:.gitignore
+073e803bbf1723d6e227a9fbffe98fb4:.gitignore
# end context for .gitignore
# begin context for CHANGES.md
@@ -30,7 +30,7 @@ d00f73c835ae4a1589d55ebda4ab381b:CHANGES.md
# begin context for Makefile
# file Makefile
-7b235cd906ac2e7c97c9d3254b9b3eef:Makefile
+58b368dfbfaad51a22806a8d5808227c:Makefile
# end context for Makefile
# begin context for README.md
@@ -80,9 +80,59 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css
# begin context for dune-project
# file dune-project
-be4305154328f2ac976081bd8895b75b:dune-project
+d2229cd87c6b600a5c65c94608d33073:dune-project
# end context for dune-project
+# begin context for opam/cobol_ast.opam
+# file opam/cobol_ast.opam
+1c093791236b02c989e11c8e4277e6b7:opam/cobol_ast.opam
+# end context for opam/cobol_ast.opam
+
+# begin context for opam/cobol_common.opam
+# file opam/cobol_common.opam
+2684c65869bf3fb2c73292774c68db80:opam/cobol_common.opam
+# end context for opam/cobol_common.opam
+
+# begin context for opam/cobol_config.opam
+# file opam/cobol_config.opam
+1133aaf02d613ada678aef1c241ff541:opam/cobol_config.opam
+# end context for opam/cobol_config.opam
+
+# begin context for opam/cobol_data.opam
+# file opam/cobol_data.opam
+4bd93877af6f2710de8abcbc63bab7f6:opam/cobol_data.opam
+# end context for opam/cobol_data.opam
+
+# begin context for opam/cobol_indent.opam
+# file opam/cobol_indent.opam
+5ca055edfd5fc90ecfac3b085343f8df:opam/cobol_indent.opam
+# end context for opam/cobol_indent.opam
+
+# begin context for opam/cobol_lsp.opam
+# file opam/cobol_lsp.opam
+78c01ac9d637a0430e4c430d51f4ff6d:opam/cobol_lsp.opam
+# end context for opam/cobol_lsp.opam
+
+# begin context for opam/cobol_parser.opam
+# file opam/cobol_parser.opam
+c3f27a2cce1d474ac28dc4da9705579d:opam/cobol_parser.opam
+# end context for opam/cobol_parser.opam
+
+# begin context for opam/cobol_preproc.opam
+# file opam/cobol_preproc.opam
+5e6c04d126c530509b79a509dc1ada53:opam/cobol_preproc.opam
+# end context for opam/cobol_preproc.opam
+
+# begin context for opam/cobol_typeck.opam
+# file opam/cobol_typeck.opam
+8826cd23206fa658d2cc63beccabb5b1:opam/cobol_typeck.opam
+# end context for opam/cobol_typeck.opam
+
+# begin context for opam/ebcdic_lib.opam
+# file opam/ebcdic_lib.opam
+c365b582bacd1274b4bfb2599d5cd4dc:opam/ebcdic_lib.opam
+# end context for opam/ebcdic_lib.opam
+
# begin context for opam/interop-js-stubs.opam
# file opam/interop-js-stubs.opam
e557ed4bc7c593fac0877c7327facaf6:opam/interop-js-stubs.opam
@@ -103,6 +153,21 @@ dcf0ebaa8b12787df9efcaa0ce8cbbe5:opam/package-json.opam
8f12d7db1569d79ec6043b50df393de3:opam/polka-js-stubs.opam
# end context for opam/polka-js-stubs.opam
+# begin context for opam/ppx_cobcflags.opam
+# file opam/ppx_cobcflags.opam
+a71b8dfe67612b506e31c13e89075556:opam/ppx_cobcflags.opam
+# end context for opam/ppx_cobcflags.opam
+
+# begin context for opam/pretty.opam
+# file opam/pretty.opam
+8cca8f124c3c0a999f8a185f09f4693c:opam/pretty.opam
+# end context for opam/pretty.opam
+
+# begin context for opam/superbol-free.opam
+# file opam/superbol-free.opam
+09da22a50ff0d10a1b21364bc27aa345:opam/superbol-free.opam
+# end context for opam/superbol-free.opam
+
# begin context for opam/superbol-vscode-extension.opam
# file opam/superbol-vscode-extension.opam
38d272283b51b83690fa806b0868b764:opam/superbol-vscode-extension.opam
@@ -113,6 +178,11 @@ dcf0ebaa8b12787df9efcaa0ce8cbbe5:opam/package-json.opam
f4782070d6b32d738ffc3d5435fc879a:opam/superbol-vscode-platform.opam
# end context for opam/superbol-vscode-platform.opam
+# begin context for opam/superbol_free_lib.opam
+# file opam/superbol_free_lib.opam
+e618a6aa0b5f55717ae192be2c854b0f:opam/superbol_free_lib.opam
+# end context for opam/superbol_free_lib.opam
+
# begin context for opam/vscode-debugadapter.opam
# file opam/vscode-debugadapter.opam
49375af72a2ef6a3a464bc88553f1043:opam/vscode-debugadapter.opam
@@ -175,17 +245,17 @@ a4431c32911b7499fbdc49e2e62932d2:sphinx/about.rst
# begin context for sphinx/conf.py
# file sphinx/conf.py
-76061a2f78a52ceeb831977de515cb7a:sphinx/conf.py
+6bf90eb136d7e3eb588a87a4f0c39c35:sphinx/conf.py
# end context for sphinx/conf.py
# begin context for sphinx/index.rst
# file sphinx/index.rst
-eb3deffe184887e5ee0b897028c0f969:sphinx/index.rst
+15f9d714c36b467b4d6bb3eb5bf3ebbb:sphinx/index.rst
# end context for sphinx/index.rst
# begin context for sphinx/install.rst
# file sphinx/install.rst
-721a43bc2478aef9660f49fd0d2def12:sphinx/install.rst
+e26cbe1b90e78660bd7f93418551c1a1:sphinx/install.rst
# end context for sphinx/install.rst
# begin context for sphinx/license.rst
@@ -193,162 +263,252 @@ eb3deffe184887e5ee0b897028c0f969:sphinx/index.rst
f4bbb4a41a8b3b39f19a4fc62a5f4841:sphinx/license.rst
# end context for sphinx/license.rst
-# begin context for src/interop-js-stubs/dune
-# file src/interop-js-stubs/dune
-707a0383f1e544fb37662db29a4f14ad:src/interop-js-stubs/dune
-# end context for src/interop-js-stubs/dune
-
-# begin context for src/interop-js-stubs/package.toml
-# file src/interop-js-stubs/package.toml
-cbce59b282479c51946165a86e98583e:src/interop-js-stubs/package.toml
-# end context for src/interop-js-stubs/package.toml
-
-# begin context for src/interop-js-stubs/version.mlt
-# file src/interop-js-stubs/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/interop-js-stubs/version.mlt
-# end context for src/interop-js-stubs/version.mlt
-
-# begin context for src/node-js-stubs/dune
-# file src/node-js-stubs/dune
-cf30d5557250e864c9020afd9e2389fd:src/node-js-stubs/dune
-# end context for src/node-js-stubs/dune
-
-# begin context for src/node-js-stubs/package.toml
-# file src/node-js-stubs/package.toml
-09a788f8a36173eefb4ea91caf00a4ec:src/node-js-stubs/package.toml
-# end context for src/node-js-stubs/package.toml
-
-# begin context for src/node-js-stubs/version.mlt
-# file src/node-js-stubs/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/node-js-stubs/version.mlt
-# end context for src/node-js-stubs/version.mlt
-
-# begin context for src/polka-js-stubs/dune
-# file src/polka-js-stubs/dune
-569424afbc851a410f6f388591417035:src/polka-js-stubs/dune
-# end context for src/polka-js-stubs/dune
-
-# begin context for src/polka-js-stubs/package.toml
-# file src/polka-js-stubs/package.toml
-a7d6afd419b3a2cc0b4b8c9df2a8e70c:src/polka-js-stubs/package.toml
-# end context for src/polka-js-stubs/package.toml
-
-# begin context for src/polka-js-stubs/version.mlt
-# file src/polka-js-stubs/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/polka-js-stubs/version.mlt
-# end context for src/polka-js-stubs/version.mlt
-
-# begin context for src/superbol-vscode-platform/dune
-# file src/superbol-vscode-platform/dune
-f336ca790e61d4cc6371e8501b902bbd:src/superbol-vscode-platform/dune
-# end context for src/superbol-vscode-platform/dune
-
-# begin context for src/superbol-vscode-platform/package.toml
-# file src/superbol-vscode-platform/package.toml
-52a57c098d260447652f7f0beb2872bc:src/superbol-vscode-platform/package.toml
-# end context for src/superbol-vscode-platform/package.toml
-
-# begin context for src/superbol-vscode-platform/version.mlt
-# file src/superbol-vscode-platform/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/superbol-vscode-platform/version.mlt
-# end context for src/superbol-vscode-platform/version.mlt
-
-# begin context for src/vscode-debugadapter/dune
-# file src/vscode-debugadapter/dune
-12ae4bbbcdd1df098363da163e1cbe4e:src/vscode-debugadapter/dune
-# end context for src/vscode-debugadapter/dune
-
-# begin context for src/vscode-debugadapter/package.toml
-# file src/vscode-debugadapter/package.toml
-dc0d8943797599850bd0180ffadaadaa:src/vscode-debugadapter/package.toml
-# end context for src/vscode-debugadapter/package.toml
-
-# begin context for src/vscode-debugadapter/version.mlt
-# file src/vscode-debugadapter/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-debugadapter/version.mlt
-# end context for src/vscode-debugadapter/version.mlt
-
-# begin context for src/vscode-debugprotocol/dune
-# file src/vscode-debugprotocol/dune
-20bb8bb628d36d6baca51f4a9f54c8f7:src/vscode-debugprotocol/dune
-# end context for src/vscode-debugprotocol/dune
-
-# begin context for src/vscode-debugprotocol/package.toml
-# file src/vscode-debugprotocol/package.toml
-f14b34b55e33de7475b9c54938fec6d7:src/vscode-debugprotocol/package.toml
-# end context for src/vscode-debugprotocol/package.toml
-
-# begin context for src/vscode-debugprotocol/version.mlt
-# file src/vscode-debugprotocol/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-debugprotocol/version.mlt
-# end context for src/vscode-debugprotocol/version.mlt
-
-# begin context for src/vscode-js-stubs/dune
-# file src/vscode-js-stubs/dune
-f8e015ab8ad6d1dc7c7c8d63c86e446d:src/vscode-js-stubs/dune
-# end context for src/vscode-js-stubs/dune
-
-# begin context for src/vscode-js-stubs/package.toml
-# file src/vscode-js-stubs/package.toml
-ebc05174a1892c2e98fe8aee174b5cb9:src/vscode-js-stubs/package.toml
-# end context for src/vscode-js-stubs/package.toml
-
-# begin context for src/vscode-js-stubs/version.mlt
-# file src/vscode-js-stubs/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-js-stubs/version.mlt
-# end context for src/vscode-js-stubs/version.mlt
-
-# begin context for src/vscode-json/dune
-# file src/vscode-json/dune
-a18d965350ea19e9be91b3784887f1ef:src/vscode-json/dune
-# end context for src/vscode-json/dune
-
-# begin context for src/vscode-json/index.mld
-# file src/vscode-json/index.mld
-14bb358dfa3587175fe0ee1a39d81977:src/vscode-json/index.mld
-# end context for src/vscode-json/index.mld
-
-# begin context for src/vscode-json/package.toml
-# file src/vscode-json/package.toml
-9b831fff3824e035b2d9ef1696f89361:src/vscode-json/package.toml
-# end context for src/vscode-json/package.toml
-
-# begin context for src/vscode-json/version.mlt
-# file src/vscode-json/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-json/version.mlt
-# end context for src/vscode-json/version.mlt
-
-# begin context for src/vscode-languageclient-js-stubs/dune
-# file src/vscode-languageclient-js-stubs/dune
-935c7469b455b26a8ec1f08627aae863:src/vscode-languageclient-js-stubs/dune
-# end context for src/vscode-languageclient-js-stubs/dune
-
-# begin context for src/vscode-languageclient-js-stubs/package.toml
-# file src/vscode-languageclient-js-stubs/package.toml
-553168fe21b0362e0d450c5de7f4216e:src/vscode-languageclient-js-stubs/package.toml
-# end context for src/vscode-languageclient-js-stubs/package.toml
-
-# begin context for src/vscode-languageclient-js-stubs/version.mlt
-# file src/vscode-languageclient-js-stubs/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-languageclient-js-stubs/version.mlt
-# end context for src/vscode-languageclient-js-stubs/version.mlt
-
-# begin context for src/vscode-package-json/dune
-# file src/vscode-package-json/dune
-1418db38f60b30eacfab7a22d0cc2ad7:src/vscode-package-json/dune
-# end context for src/vscode-package-json/dune
-
-# begin context for src/vscode-package-json/linking_flags.sh
-# file src/vscode-package-json/linking_flags.sh
-9fdfca3cc53df639758ff04fe09d3243:src/vscode-package-json/linking_flags.sh
-# end context for src/vscode-package-json/linking_flags.sh
-
-# begin context for src/vscode-package-json/package.toml
-# file src/vscode-package-json/package.toml
-4b3c04a3df2a4be1259088d71bc55846:src/vscode-package-json/package.toml
-# end context for src/vscode-package-json/package.toml
-
-# begin context for src/vscode-package-json/version.mlt
-# file src/vscode-package-json/version.mlt
-940d29cde7f16cd0916ed1d5f9c41154:src/vscode-package-json/version.mlt
-# end context for src/vscode-package-json/version.mlt
+# begin context for src/lsp/cobol_ast/dune
+# file src/lsp/cobol_ast/dune
+066a301d0d3a2cc4f1f8eea6e9b48a7f:src/lsp/cobol_ast/dune
+# end context for src/lsp/cobol_ast/dune
+
+# begin context for src/lsp/cobol_ast/version.mlt
+# file src/lsp/cobol_ast/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_ast/version.mlt
+# end context for src/lsp/cobol_ast/version.mlt
+
+# begin context for src/lsp/cobol_common/dune
+# file src/lsp/cobol_common/dune
+85e200450b66aa3e32a935a09370eeee:src/lsp/cobol_common/dune
+# end context for src/lsp/cobol_common/dune
+
+# begin context for src/lsp/cobol_common/version.mlt
+# file src/lsp/cobol_common/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_common/version.mlt
+# end context for src/lsp/cobol_common/version.mlt
+
+# begin context for src/lsp/cobol_config/dune
+# file src/lsp/cobol_config/dune
+631869db8237af96d5ff71c2c8209654:src/lsp/cobol_config/dune
+# end context for src/lsp/cobol_config/dune
+
+# begin context for src/lsp/cobol_config/version.mlt
+# file src/lsp/cobol_config/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_config/version.mlt
+# end context for src/lsp/cobol_config/version.mlt
+
+# begin context for src/lsp/cobol_data/dune
+# file src/lsp/cobol_data/dune
+81bbf8b89cb2c2065539f6c083343849:src/lsp/cobol_data/dune
+# end context for src/lsp/cobol_data/dune
+
+# begin context for src/lsp/cobol_data/version.mlt
+# file src/lsp/cobol_data/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_data/version.mlt
+# end context for src/lsp/cobol_data/version.mlt
+
+# begin context for src/lsp/cobol_indent/dune
+# file src/lsp/cobol_indent/dune
+206291029ab9b39c62663475e37e57cd:src/lsp/cobol_indent/dune
+# end context for src/lsp/cobol_indent/dune
+
+# begin context for src/lsp/cobol_indent/version.mlt
+# file src/lsp/cobol_indent/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_indent/version.mlt
+# end context for src/lsp/cobol_indent/version.mlt
+
+# begin context for src/lsp/cobol_lsp/dune
+# file src/lsp/cobol_lsp/dune
+957f078deb602f8e0114c8abcc771abf:src/lsp/cobol_lsp/dune
+# end context for src/lsp/cobol_lsp/dune
+
+# begin context for src/lsp/cobol_lsp/version.mlt
+# file src/lsp/cobol_lsp/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_lsp/version.mlt
+# end context for src/lsp/cobol_lsp/version.mlt
+
+# begin context for src/lsp/cobol_parser/dune
+# file src/lsp/cobol_parser/dune
+b68ae0e16fe9fde7a4b6b03d84be2680:src/lsp/cobol_parser/dune
+# end context for src/lsp/cobol_parser/dune
+
+# begin context for src/lsp/cobol_parser/version.mlt
+# file src/lsp/cobol_parser/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_parser/version.mlt
+# end context for src/lsp/cobol_parser/version.mlt
+
+# begin context for src/lsp/cobol_preproc/dune
+# file src/lsp/cobol_preproc/dune
+801b4cd6ad70e6c633b48431afb67519:src/lsp/cobol_preproc/dune
+# end context for src/lsp/cobol_preproc/dune
+
+# begin context for src/lsp/cobol_preproc/version.mlt
+# file src/lsp/cobol_preproc/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_preproc/version.mlt
+# end context for src/lsp/cobol_preproc/version.mlt
+
+# begin context for src/lsp/cobol_typeck/dune
+# file src/lsp/cobol_typeck/dune
+bb6994bfe27f29a441abee11c82b032f:src/lsp/cobol_typeck/dune
+# end context for src/lsp/cobol_typeck/dune
+
+# begin context for src/lsp/cobol_typeck/version.mlt
+# file src/lsp/cobol_typeck/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_typeck/version.mlt
+# end context for src/lsp/cobol_typeck/version.mlt
+
+# begin context for src/lsp/ebcdic_lib/dune
+# file src/lsp/ebcdic_lib/dune
+963d41cf5fce1985fce4ba6f43244817:src/lsp/ebcdic_lib/dune
+# end context for src/lsp/ebcdic_lib/dune
+
+# begin context for src/lsp/ebcdic_lib/ebcdic_version.mlt
+# file src/lsp/ebcdic_lib/ebcdic_version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/ebcdic_lib/ebcdic_version.mlt
+# end context for src/lsp/ebcdic_lib/ebcdic_version.mlt
+
+# begin context for src/lsp/ppx_cobcflags/dune
+# file src/lsp/ppx_cobcflags/dune
+86758f07c1c4f6bef04e0520a41cb8f6:src/lsp/ppx_cobcflags/dune
+# end context for src/lsp/ppx_cobcflags/dune
+
+# begin context for src/lsp/ppx_cobcflags/version.mlt
+# file src/lsp/ppx_cobcflags/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/ppx_cobcflags/version.mlt
+# end context for src/lsp/ppx_cobcflags/version.mlt
+
+# begin context for src/lsp/pretty/dune
+# file src/lsp/pretty/dune
+99a706a3180a431ed103230d66dd9013:src/lsp/pretty/dune
+# end context for src/lsp/pretty/dune
+
+# begin context for src/lsp/pretty/version.mlt
+# file src/lsp/pretty/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/pretty/version.mlt
+# end context for src/lsp/pretty/version.mlt
+
+# begin context for src/lsp/superbol-free/dune
+# file src/lsp/superbol-free/dune
+095155be06e2840753e52b3d03d541b9:src/lsp/superbol-free/dune
+# end context for src/lsp/superbol-free/dune
+
+# begin context for src/lsp/superbol-free/linking_flags.sh
+# file src/lsp/superbol-free/linking_flags.sh
+b9a14c96cce8e365e1d7494d078d73fe:src/lsp/superbol-free/linking_flags.sh
+# end context for src/lsp/superbol-free/linking_flags.sh
+
+# begin context for src/lsp/superbol_free_lib/dune
+# file src/lsp/superbol_free_lib/dune
+6625329103c4f2ffacd92354431cce4e:src/lsp/superbol_free_lib/dune
+# end context for src/lsp/superbol_free_lib/dune
+
+# begin context for src/lsp/superbol_free_lib/version.mlt
+# file src/lsp/superbol_free_lib/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/lsp/superbol_free_lib/version.mlt
+# end context for src/lsp/superbol_free_lib/version.mlt
+
+# begin context for src/vscode/interop-js-stubs/dune
+# file src/vscode/interop-js-stubs/dune
+707a0383f1e544fb37662db29a4f14ad:src/vscode/interop-js-stubs/dune
+# end context for src/vscode/interop-js-stubs/dune
+
+# begin context for src/vscode/interop-js-stubs/version.mlt
+# file src/vscode/interop-js-stubs/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/interop-js-stubs/version.mlt
+# end context for src/vscode/interop-js-stubs/version.mlt
+
+# begin context for src/vscode/node-js-stubs/dune
+# file src/vscode/node-js-stubs/dune
+cf30d5557250e864c9020afd9e2389fd:src/vscode/node-js-stubs/dune
+# end context for src/vscode/node-js-stubs/dune
+
+# begin context for src/vscode/node-js-stubs/version.mlt
+# file src/vscode/node-js-stubs/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/node-js-stubs/version.mlt
+# end context for src/vscode/node-js-stubs/version.mlt
+
+# begin context for src/vscode/polka-js-stubs/dune
+# file src/vscode/polka-js-stubs/dune
+569424afbc851a410f6f388591417035:src/vscode/polka-js-stubs/dune
+# end context for src/vscode/polka-js-stubs/dune
+
+# begin context for src/vscode/polka-js-stubs/version.mlt
+# file src/vscode/polka-js-stubs/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/polka-js-stubs/version.mlt
+# end context for src/vscode/polka-js-stubs/version.mlt
+
+# begin context for src/vscode/superbol-vscode-platform/dune
+# file src/vscode/superbol-vscode-platform/dune
+f336ca790e61d4cc6371e8501b902bbd:src/vscode/superbol-vscode-platform/dune
+# end context for src/vscode/superbol-vscode-platform/dune
+
+# begin context for src/vscode/superbol-vscode-platform/version.mlt
+# file src/vscode/superbol-vscode-platform/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/superbol-vscode-platform/version.mlt
+# end context for src/vscode/superbol-vscode-platform/version.mlt
+
+# begin context for src/vscode/vscode-debugadapter/dune
+# file src/vscode/vscode-debugadapter/dune
+12ae4bbbcdd1df098363da163e1cbe4e:src/vscode/vscode-debugadapter/dune
+# end context for src/vscode/vscode-debugadapter/dune
+
+# begin context for src/vscode/vscode-debugadapter/version.mlt
+# file src/vscode/vscode-debugadapter/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-debugadapter/version.mlt
+# end context for src/vscode/vscode-debugadapter/version.mlt
+
+# begin context for src/vscode/vscode-debugprotocol/dune
+# file src/vscode/vscode-debugprotocol/dune
+20bb8bb628d36d6baca51f4a9f54c8f7:src/vscode/vscode-debugprotocol/dune
+# end context for src/vscode/vscode-debugprotocol/dune
+
+# begin context for src/vscode/vscode-debugprotocol/version.mlt
+# file src/vscode/vscode-debugprotocol/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-debugprotocol/version.mlt
+# end context for src/vscode/vscode-debugprotocol/version.mlt
+
+# begin context for src/vscode/vscode-js-stubs/dune
+# file src/vscode/vscode-js-stubs/dune
+f8e015ab8ad6d1dc7c7c8d63c86e446d:src/vscode/vscode-js-stubs/dune
+# end context for src/vscode/vscode-js-stubs/dune
+
+# begin context for src/vscode/vscode-js-stubs/version.mlt
+# file src/vscode/vscode-js-stubs/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-js-stubs/version.mlt
+# end context for src/vscode/vscode-js-stubs/version.mlt
+
+# begin context for src/vscode/vscode-json/dune
+# file src/vscode/vscode-json/dune
+a18d965350ea19e9be91b3784887f1ef:src/vscode/vscode-json/dune
+# end context for src/vscode/vscode-json/dune
+
+# begin context for src/vscode/vscode-json/index.mld
+# file src/vscode/vscode-json/index.mld
+14bb358dfa3587175fe0ee1a39d81977:src/vscode/vscode-json/index.mld
+# end context for src/vscode/vscode-json/index.mld
+
+# begin context for src/vscode/vscode-json/version.mlt
+# file src/vscode/vscode-json/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-json/version.mlt
+# end context for src/vscode/vscode-json/version.mlt
+
+# begin context for src/vscode/vscode-languageclient-js-stubs/dune
+# file src/vscode/vscode-languageclient-js-stubs/dune
+935c7469b455b26a8ec1f08627aae863:src/vscode/vscode-languageclient-js-stubs/dune
+# end context for src/vscode/vscode-languageclient-js-stubs/dune
+
+# begin context for src/vscode/vscode-languageclient-js-stubs/version.mlt
+# file src/vscode/vscode-languageclient-js-stubs/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-languageclient-js-stubs/version.mlt
+# end context for src/vscode/vscode-languageclient-js-stubs/version.mlt
+
+# begin context for src/vscode/vscode-package-json/dune
+# file src/vscode/vscode-package-json/dune
+1418db38f60b30eacfab7a22d0cc2ad7:src/vscode/vscode-package-json/dune
+# end context for src/vscode/vscode-package-json/dune
+
+# begin context for src/vscode/vscode-package-json/linking_flags.sh
+# file src/vscode/vscode-package-json/linking_flags.sh
+9fdfca3cc53df639758ff04fe09d3243:src/vscode/vscode-package-json/linking_flags.sh
+# end context for src/vscode/vscode-package-json/linking_flags.sh
+
+# begin context for src/vscode/vscode-package-json/version.mlt
+# file src/vscode/vscode-package-json/version.mlt
+940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-package-json/version.mlt
+# end context for src/vscode/vscode-package-json/version.mlt
diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml
index ed8f9f31c..91c3db2ff 100644
--- a/.github/workflows/workflow.yml
+++ b/.github/workflows/workflow.yml
@@ -41,22 +41,12 @@ jobs:
# restore-keys: |
# v2-${{ runner.os }}-opam-${{ matrix.ocaml-compiler }}-
- - name: Set-up OCaml on Windows
- uses: ocaml/setup-ocaml@v2
- if: runner.os == 'Windows'
+ - name: Use OCaml ${{ matrix.ocaml-compiler }}
+ uses: avsm/setup-ocaml@v2
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- opam-repositories: |
- opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset
- default: https://github.com/ocaml/opam-repository.git
-
- - name: Set-up OCaml on Unix
- uses: ocaml/setup-ocaml@v2
- if: runner.os != 'Windows'
- with:
- ocaml-compiler: ${{ matrix.ocaml-compiler }}
- opam-repositories: |
- default: https://github.com/ocaml/opam-repository.git
+ opam-pin: false
+ opam-depext: false
- name: Set git user
run: |
@@ -67,8 +57,7 @@ jobs:
- run: opam pin add . -y --no-action
- - run: opam depext -y superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol
- if: matrix.os != 'windows-latest'
+ - run: opam depext -y superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck
# if: steps.cache-opam.outputs.cache-hit != 'true'
- run: opam install -y opam/*.opam --deps-only --with-test
diff --git a/.gitignore b/.gitignore
index 6797b6a9f..22a1578ec 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,6 +8,7 @@
/vscode-json
/vscode-debugadapter
/vscode-debugprotocol
+/superbol-free
*~
_build
.merlin
diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 000000000..2d2ef0b48
--- /dev/null
+++ b/.gitmodules
@@ -0,0 +1,6 @@
+[submodule "import/gnucobol"]
+ path = import/gnucobol
+ url = git@github.com:OcamlPro/gnucobol.git
+[submodule "import/merlin"]
+ path = import/merlin
+ url = git@github.com:nberth/merlin.git
diff --git a/LICENSE.md b/LICENSE.md
index a38392480..87d947048 100644
--- a/LICENSE.md
+++ b/LICENSE.md
@@ -1,3 +1,681 @@
+# Licenses
+
+The sources in this project are distributed:
+
+* Under the terms of the GNU Affero GPL License v3 for files in the
+ src/ directory. The corresponding binary is `superbol-free` that
+ runs the LSP server;
+
+* Under the terms of the MIT License for all other files, in
+ particular the Vscode extension;
+
+## Affero GPL License v3
+
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+ A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+ The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+ An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing under
+this license.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU Affero General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Remote Network Interaction; Use with the GNU General Public License.
+
+ Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your version
+supports such interaction) an opportunity to receive the Corresponding
+Source of your version by providing access to the Corresponding Source
+from a network server at no charge, through some standard or customary
+means of facilitating copying of software. This Corresponding Source
+shall include the Corresponding Source for any work covered by version 3
+of the GNU General Public License that is incorporated pursuant to the
+following paragraph.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU Affero General Public License from time to time. Such new versions
+will be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Affero General Public License as published by
+ the Free Software Foundation, either version 3 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 Affero General Public License for more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for the
+specific requirements.
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU AGPL, see
+.
+
+
+## MIT License
+
Copyright (c) 2023 OCamlPro SAS
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
@@ -6,3 +684,23 @@ The above copyright notice and this permission notice shall be included in all c
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+## Tooling
+
+To verify headers, go to `src/lsp` and run:
+
+```
+header-check --skip-dir ./cobol_parser/recover --skip-dir ./cobol_parser/printer
+```
+
+In 2023, the expected header with AGPL License should be
+00ed0c544befe216344817b359162127.
+
+Use the arguments `--add-default 00ed0c544befe216344817b359162127` and
+`--replace-by 00ed0c544befe216344817b359162127 --from XXX`.
+
+Then, go to `src/vscode` and run:
+
+In 2023, the expected header with MIT License should be:
+7ade9bbb0990f624352994c17e592d0b.
+
+
diff --git a/Makefile b/Makefile
index e88fc1d77..c5e7955f6 100644
--- a/Makefile
+++ b/Makefile
@@ -20,7 +20,7 @@ all: build
build:
./scripts/before.sh build
opam exec -- dune build @install
- ./scripts/copy-bin.sh superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol
+ ./scripts/copy-bin.sh superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck
./scripts/after.sh build
build-deps:
diff --git a/Makefile.header b/Makefile.header
index c76242a11..bf36bf4df 100644
--- a/Makefile.header
+++ b/Makefile.header
@@ -1,9 +1,9 @@
PROJECT=superbol_vscode_platform
-SRCDIR=src/superbol-vscode-platform
+SRCDIR=src/vscode/superbol-vscode-platform
compile:
opam exec -- dune build
- cp -f _build/default/src/vscode-package-json/main.exe vscode-package-json
+ cp -f _build/default/src/vscode/vscode-package-json/main.exe vscode-package-json
yarn esbuild _build/default/$(SRCDIR)/$(PROJECT).bc.js \
--bundle \
--external:vscode \
diff --git a/drom.toml b/drom.toml
index bd08436d3..1ca7bdf12 100644
--- a/drom.toml
+++ b/drom.toml
@@ -87,42 +87,99 @@ ATTIC
"""
[[package]]
-dir = "src/superbol-vscode-platform"
-# edit 'src/superbol-vscode-platform/package.toml' for package-specific options
+dir = "src/vscode/superbol-vscode-platform"
+# edit 'src/vscode/superbol-vscode-platform/package.toml' for package-specific options
[[package]]
-dir = "src/polka-js-stubs"
-# edit 'src/polka-js-stubs/package.toml' for package-specific options
+dir = "src/vscode/polka-js-stubs"
+# edit 'src/vscode/polka-js-stubs/package.toml' for package-specific options
[[package]]
-dir = "src/interop-js-stubs"
-# edit 'src/interop-js-stubs/package.toml' for package-specific options
+dir = "src/vscode/interop-js-stubs"
+# edit 'src/vscode/interop-js-stubs/package.toml' for package-specific options
[[package]]
-dir = "src/node-js-stubs"
-# edit 'src/node-js-stubs/package.toml' for package-specific options
+dir = "src/vscode/node-js-stubs"
+# edit 'src/vscode/node-js-stubs/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-js-stubs"
-# edit 'src/vscode-js-stubs/package.toml' for package-specific options
+dir = "src/vscode/vscode-js-stubs"
+# edit 'src/vscode/vscode-js-stubs/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-languageclient-js-stubs"
-# edit 'src/vscode-languageclient-js-stubs/package.toml' for package-specific options
+dir = "src/vscode/vscode-languageclient-js-stubs"
+# edit 'src/vscode/vscode-languageclient-js-stubs/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-package-json"
-# edit 'src/vscode-package-json/package.toml' for package-specific options
+dir = "src/vscode/vscode-package-json"
+# edit 'src/vscode/vscode-package-json/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-json"
-# edit 'src/vscode-json/package.toml' for package-specific options
+dir = "src/vscode/vscode-json"
+# edit 'src/vscode/vscode-json/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-debugadapter"
-# edit 'src/vscode-debugadapter/package.toml' for package-specific options
+dir = "src/vscode/vscode-debugadapter"
+# edit 'src/vscode/vscode-debugadapter/package.toml' for package-specific options
[[package]]
-dir = "src/vscode-debugprotocol"
-# edit 'src/vscode-debugprotocol/package.toml' for package-specific options
+dir = "src/vscode/vscode-debugprotocol"
+# edit 'src/vscode/vscode-debugprotocol/package.toml' for package-specific options
+
+
+[[package]]
+dir = "src/lsp/superbol-free"
+# edit 'src/lsp/superbol/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/superbol_free_lib"
+# edit 'src/lsp/superbol_lib/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_common"
+# edit 'src/lsp/cobol_common/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_parser"
+# edit 'src/lsp/cobol_parser/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/ebcdic_lib"
+# edit 'src/lsp/ebcdic_lib/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_lsp"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/ppx_cobcflags"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/pretty"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_config"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_ast"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_indent"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_preproc"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_data"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
+
+[[package]]
+dir = "src/lsp/cobol_typeck"
+# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options
diff --git a/dune-project b/dune-project
index a353645a3..d2908bcc2 100644
--- a/dune-project
+++ b/dune-project
@@ -7,6 +7,7 @@
(generate_opam_files false)
(version 0.1.0)
(formatting (enabled_for ocaml reason))
+(using menhir 2.0)
(package
(name superbol-vscode-platform)
@@ -198,4 +199,238 @@
)
)
+(package
+ (name superbol-free)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (superbol_free_lib (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name superbol_free_lib)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ez_file ( >= 0.3 ))
+ (ez_cmdliner (and (>= 0.3.0) (< 1.0.0)))
+ (cobol_typeck (= version))
+ (cobol_parser (= version))
+ (cobol_lsp (= version))
+ (cobol_indent (= version))
+ (cobol_common (= version))
+ (cobol_ast (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_common)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (pretty (= version))
+ (ppx_deriving ( >= 5.2.1 ))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_parser)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppx_deriving ( >= 5.2.1 ))
+ (menhir ( >= 1.2 ))
+ (ez_file ( >= 0.3 ))
+ (ebcdic_lib (= version))
+ (cobol_preproc (= version))
+ (cobol_common (= version))
+ (cobol_ast (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name ebcdic_lib)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_lsp)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (toml (and (>= 7.1.0) (< 8.0.0)))
+ (pretty (= version))
+ (lsp (and ( >= 1.15 )( < 1.16 )))
+ (jsonrpc ( >= 1.15 ))
+ (cobol_typeck (= version))
+ (cobol_parser (= version))
+ (cobol_indent (= version))
+ (cobol_data (= version))
+ (cobol_config (= version))
+ (cobol_common (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name ppx_cobcflags)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppxlib ( >= 0.15 ))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name pretty)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (fmt ( >= 0.9 ))
+ (ez_file ( >= 0.3 ))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_config)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (pretty (= version))
+ (ppx_deriving ( >= 5.2.1 ))
+ (menhir ( >= 1.2 ))
+ (cobol_common (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_ast)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppx_deriving ( >= 5.2.1 ))
+ (cobol_common (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_indent)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (fmt ( >= 0.9 ))
+ (cobol_preproc (= version))
+ (cobol_common (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_preproc)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppx_deriving ( >= 5.2.1 ))
+ (menhir ( >= 1.2 ))
+ (cobol_config (= version))
+ (cobol_common (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_data)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppx_deriving ( >= 5.2.1 ))
+ (cobol_parser (= version))
+ (cobol_ast (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
+(package
+ (name cobol_typeck)
+ (synopsis "The superbol-vscode-platform project")
+ (description "This is the description\nof the superbol-vscode-platform OCaml project\n")
+ (depends
+ (ocaml (>= 4.13.0))
+ (ppx_deriving ( >= 5.2.1 ))
+ (cobol_parser (= version))
+ (cobol_data (= version))
+ (cobol_common (= version))
+ (cobol_ast (= version))
+ ppx_inline_test
+ ppx_expect
+ odoc
+ ocamlformat
+ )
+ )
+
diff --git a/emacs/README.md b/emacs/README.md
new file mode 100644
index 000000000..e57fa0ff7
--- /dev/null
+++ b/emacs/README.md
@@ -0,0 +1,8 @@
+## Emacs `cobol-mode.el`
+
+The `cobol-mode.el` in this directory is forked from ELPA, with the
+following changes:
+
+* The indentation function was modified to prevent the insertion of
+ spaces in the middle of the line being indented
+
diff --git a/emacs/cobol-mode.el b/emacs/cobol-mode.el
new file mode 100644
index 000000000..5415eca3e
--- /dev/null
+++ b/emacs/cobol-mode.el
@@ -0,0 +1,3139 @@
+;;; cobol-mode.el --- Mode for editing COBOL code -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2013-2022 Free Software Foundation, Inc.
+
+;; Author: Edward Hart
+;; Maintainer: Edward Hart
+;; Version: 1.1
+;; Created: 9 November 2013
+;; Keywords: languages
+;; Package-Requires: ((cl-lib "0.5"))
+
+;; 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 3 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, see .
+
+;;; Commentary:
+
+;; This file should not be confused with Rick Bielawski's cobol-mode.el
+;; (http://www.emacswiki.org/emacs/cobol-mode.el), which this mode attempts to
+;; supersede.
+
+;; This COBOL mode features syntax highlighting for most modern COBOL dialects,
+;; indentation, code skeletons, rulers and basic formatting functions.
+;; Highlighting changes with the code format, which can be specified using the
+;; M-x customize menu.
+
+;;;; Installation:
+
+;; To install cobol-mode.el, save it to your .emacs.d/ directory and add the
+;; following to your .emacs:
+;; (autoload 'cobol-mode "cobol-mode" "Major mode for highlighting COBOL files." t nil)
+
+;; To automatically load cobol-mode.el upon opening COBOL files, add this:
+;; (setq auto-mode-alist
+;; (append
+;; '(("\\.cob\\'" . cobol-mode)
+;; ("\\.cbl\\'" . cobol-mode)
+;; ("\\.cpy\\'" . cobol-mode))
+;; auto-mode-alist))
+
+;; Finally, I strongly suggest installing auto-complete-mode, which makes typing
+;; long keywords and variable names a thing of the past. See
+;; https://github.com/auto-complete/auto-complete.
+
+;;;; Known bugs:
+
+;; * Switching source formats requires M-x customize settings to be changed,
+;; saved and cobol-mode to be unloaded then reloaded.
+;; * Copying-and-pasting content in fixed-format sometimes results in content
+;; being pasted in column 1 and spaces inserted in the middle of it.
+;; * The indentation code leaves a lot of trailing whitespace.
+;; * Periods on their own line are sometimes indented strangely.
+;; * String continuation does not work.
+
+;;;; Missing features:
+
+;; * Switch between dialect's reserved word lists via M-x customize (without
+;; unloading cobol-mode).
+;; * Allow users to modify easily reserved word lists.
+;; * Expand copybooks within a buffer.
+;; * String continuation (see above).
+;; * Allow users to modify start of program-name area.
+
+;;; News:
+
+;; - A new submenu for skeletons.
+;; - cobol-mode is now orphaned :-(
+;; We're looking for a generous soul willing to give it loving care.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+(defgroup cobol nil
+ "Major mode for editing COBOL code."
+ :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
+ :prefix 'cobol-
+ :group 'languages)
+
+(eval-and-compile
+(defun cobol--radio-of-list (list)
+ "Return radio with the elements of LIST as its arguments."
+ (cons 'radio (mapcar #'(lambda (elt) (list 'const elt)) list)))
+
+(defun cobol--val-in-list-p (list)
+ "Return a predicate to check whether a value is in the LIST."
+ #'(lambda (value) (memq value list))))
+
+(defcustom cobol-declaration-clause-indent 40
+ "Column to indent data division declaration clauses to."
+ :type 'integer
+ :safe #'integerp)
+
+(eval-and-compile
+(defconst cobol-formats
+ '(fixed-85 fixed-2002 free)
+ "The accepted values for `cobol-source-format'.")
+
+(defcustom cobol-source-format 'fixed-85
+ "Source format of COBOL source code."
+ :type (cobol--radio-of-list cobol-formats)
+ :safe (cobol--val-in-list-p cobol-formats)))
+
+;; Ruler
+;; Code derived from the Emacs fortran.el, rulers from IBM Rational Developer.
+
+(defcustom cobol-fixed-85-ruler
+ "----+-*A-1-B--+----2----+----3----+----4----+----5----+----6----+----7--|-+----\n"
+ "Ruler for COBOL-85-style fixed format code."
+ :type 'string
+ :safe #'stringp)
+
+(defcustom cobol-fixed-2002-ruler
+ "----+-*--1----+----2----+----3----+----4----+----5----+----6----+----7----+----\n"
+ "Ruler for COBOL-2002-style fixed format code."
+ :type 'string
+ :safe #'stringp)
+
+(defcustom cobol-free-ruler
+ "----+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----\n"
+ "Ruler for free format code."
+ :type 'string
+ :safe 'stringp)
+
+(defun cobol-column-ruler ()
+ "Insert a column ruler above the current line until the next keystroke.
+The next key typed is executed unless it is SPC."
+ (interactive)
+ (momentary-string-display
+ (cond ((eq cobol-source-format 'fixed-85)
+ cobol-fixed-85-ruler)
+ ((eq cobol-source-format 'fixed-2002)
+ cobol-fixed-2002-ruler)
+ ((eq cobol-source-format 'free)
+ cobol-free-ruler))
+ (save-excursion
+ (beginning-of-line)
+ (if (eq (window-start (selected-window))
+ (window-point (selected-window)))
+ (line-beginning-position 2)
+ (point)))
+ nil "Type SPC or any command to erase the ruler."))
+
+(defcustom cobol-mode-hook nil
+ "Hook run by `cobol-mode'."
+ :type 'hook)
+
+(defun cobol--remove-strings (l1 l2)
+ "Return a list of strings in L1 not in L2."
+ (cl-set-difference l1 l2 :test #'string-equal))
+
+(defconst cobol-directives
+ '("CALL-CONVENTION"
+ "D"
+ "DEFINE"
+ "ELIF"
+ "ELSE"
+ "END-EVALUATE"
+ "END-IF"
+ "EVALUATE"
+ "FLAG-02"
+ "FLAG-85"
+ "FLAG-NATIVE-ARITHMETIC"
+ "IF"
+ "IMP"
+ "LEAP-SECOND"
+ "LISTING"
+ "PAGE"
+ "PROPAGATE"
+ "SOURCE"
+ "TURN"
+ "WHEN")
+ "List of COBOL compiler directives.")
+
+(defconst cobol-verbs-74
+ '("GO TO"
+ "NEXT SENTENCE"
+ "ACCEPT"
+ "ADD"
+ "ALTER"
+ "CALL"
+ "CANCEL"
+ "CLOSE"
+ "COPY"
+ "COMPUTE"
+ "DELETE"
+ "DISABLE"
+ "DISPLAY"
+ "DIVIDE"
+ "ENABLE"
+ "ENTER"
+ "EXIT"
+ "GENERATE"
+ "GO"
+ "IF"
+ "INITIATE"
+ "INSPECT"
+ "MERGE"
+ "MOVE"
+ "MULTIPLY"
+ "OPEN"
+ "PERFORM"
+ "READ"
+ "RECEIVE"
+ "RELEASE"
+ "RESET"
+ "RETURN"
+ "REWRITE"
+ "SEARCH"
+ "SELECT"
+ "SEND"
+ "SET"
+ "SORT"
+ "START"
+ "STOP"
+ "STRING"
+ "SUBTRACT"
+ "SUPPRESS"
+ "TERMINATE"
+ "UNSTRING"
+ "USE"
+ "WRITE"))
+
+(defconst cobol-verbs-85
+ (append cobol-verbs-74
+ '("CONTINUE"
+ "EVALUATE"
+ "INITIALIZE"
+ "REPLACE")))
+
+(defconst cobol-removed-verbs-2002
+ '("ALTER" "ENTER"))
+
+(defconst cobol-verbs-2002
+ (append (cobol--remove-strings cobol-verbs-85 cobol-removed-verbs-2002)
+ '("ALLOCATE"
+ "FREE"
+ "GOBACK"
+ "INVOKE"
+ "RAISE"
+ "RESUME"
+ "UNLOCK"
+ "VALIDATE")))
+
+(defconst cobol-removed-verbs-2014
+ '("DISABLE"
+ "ENABLE"
+ "SEND"
+ "RECEIVE"))
+
+(defconst cobol-verbs-2014
+ (cobol--remove-strings cobol-verbs-2002
+ cobol-removed-verbs-2014))
+
+(defconst cobol-verbs-extensions
+ '("DELETE FILE"
+ "READY TRACE"
+ "RESET TRACE"
+ "XML GENERATE"
+ "XML PARSE"
+ "ATTACH"
+ "ALLOW" ; Unisys COBOL-74
+ "AWAIT-OPEN" ; Unisys COBOL-74
+ "CAUSE" ; Unisys COBOL-74
+ "CHAIN"
+ "CHANGE" ; Unisys COBOL-74
+ "COLOR"
+ "COMMIT"
+ "CREATE"
+ "DECLARE"
+ "DELEGATE"
+ "DETACH"
+ "DISALLOW" ; Unisys COBOL-74
+ "ENTRY"
+ "EXAMINE"
+ "EXEC"
+ "EXECUTE"
+ "EXHIBIT"
+ ;; "LOCK" ; Unisys COBOL-74 ; Treated as keyword
+ "MODIFY"
+ "NOTE"
+ "ON" ; OS/VS Statement ; Keyword <= COBOL-74
+ "PROCESS" ; Unisys COBOL-74
+ "RESPOND" ; Unisys COBOL-74
+ "ROLLBACK"
+ ;; "RUN" ; Unisys COBOL-74 ; Treated as keyword
+ "SEEK" ; Unisys COBOL-74
+ "SERVICE"
+ "SYNC" ; <= COBOL-74
+ "TRANSFORM"
+ "TRY"
+ "WAIT"))
+
+(defconst cobol-verbs
+ (append cobol-verbs-2014
+ cobol-removed-verbs-2002
+ cobol-removed-verbs-2014
+ cobol-verbs-extensions)
+ "List of COBOL verb keywords.")
+
+(defconst cobol-scope-terminators-85
+ '("END-ADD"
+ "END-CALL"
+ "END-COMPUTE"
+ "END-DELETE"
+ "END-DIVIDE"
+ "END-EVALUATE"
+ "END-IF"
+ "END-MULTIPLY"
+ "END-PERFORM"
+ "END-READ"
+ "END-RECEIVE"
+ "END-RETURN"
+ "END-REWRITE"
+ "END-SEARCH"
+ "END-START"
+ "END-STRING"
+ "END-SUBTRACT"
+ "END-UNSTRING"
+ "END-WRITE"))
+
+(defconst cobol-scope-terminators-2002
+ (append cobol-scope-terminators-85
+ '("END-ACCEPT"
+ "END-DISPLAY")))
+
+(defconst cobol-removed-scope-terminators-2014
+ '("END-RECEIVE"))
+
+(defconst cobol-scope-terminators-2014
+ (cobol--remove-strings cobol-scope-terminators-2002
+ cobol-removed-scope-terminators-2014))
+
+(defconst cobol-scope-terminators-xml-tr
+ '("END-OPEN"))
+
+(defconst cobol-scope-terminators-extensions
+ '("END-CHAIN"
+ "END-COLOR"
+ "END-DELEGATE"
+ "END-EXEC"
+ "END-INVOKE"
+ "END-MODIFY"
+ "END-MOVE"
+ "END-SYNC"
+ "END-TRY"
+ "END-WAIT"
+ "END-XML"))
+
+(defconst cobol-scope-terminators
+ (append cobol-scope-terminators-2014
+ cobol-scope-terminators-xml-tr
+ cobol-scope-terminators-extensions))
+
+(defconst cobol-keywords-74
+ '("ACCESS"
+ "ADVANCING"
+ "AFTER"
+ "ALL"
+ "ALPHABETIC"
+ "ALSO"
+ "ALTERNATE"
+ "AND"
+ "ARE"
+ "AREA"
+ "AREAS"
+ "ASCENDING"
+ "ASSIGN"
+ "AT"
+ "AUTHOR"
+ "BEFORE"
+ "BLANK"
+ "BLOCK"
+ "BOTTOM"
+ "BY"
+ "CD"
+ "CF"
+ "CH"
+ "CHARACTER"
+ "CHARACTERS"
+ "CLOCK-UNITS"
+ "COBOL"
+ "CODE"
+ "CODE-SET"
+ "COLLATING"
+ "COLUMN"
+ "COMMA"
+ "COMMUNICATION"
+ "COMP"
+ "COMPUTATIONAL"
+ "CONFIGURATION"
+ "CONTAINS"
+ "CONTROL"
+ "CONTROLS"
+ "CORR"
+ "CORRESPONDING"
+ "COUNT"
+ "CURRENCY"
+ "DATA"
+ "DATE"
+ "DATE-COMPILED"
+ "DATE-WRITTEN"
+ "DAY"
+ "DE"
+ "DEBUG-CONTENTS"
+ "DEBUG-ITEM"
+ "DEBUG-LINE"
+ "DEBUG-NAME"
+ "DEBUG-SUB-1"
+ "DEBUG-SUB-2"
+ "DEBUG-SUB-3"
+ "DEBUGGING"
+ "DECIMAL-POINT"
+ "DECLARATIVES"
+ "ENVIRONMENT"
+ "DELIMITED"
+ "DELIMITER"
+ "DEPENDING"
+ "DESCENDING"
+ "DESTINATION"
+ "DETAIL"
+ "DIVISION"
+ "DOWN"
+ "DUPLICATES"
+ "DYNAMIC"
+ "EGI"
+ "ELSE"
+ "EMI"
+ "END"
+ "END-OF-PAGE"
+ "EOP"
+ "EQUAL"
+ "ERROR"
+ "ESI"
+ "EVERY"
+ "EXCEPTION"
+ "EXTEND"
+ "FD"
+ "FILE"
+ "FILE-CONTROL"
+ "FILLER"
+ "FINAL"
+ "FIRST"
+ "FOOTING"
+ "FOR"
+ "FROM"
+ "GIVING"
+ "GREATER"
+ "GROUP"
+ "HEADING"
+ "I-O"
+ "I-O-CONTROL"
+ "IDENTIFICATION"
+ "INDEX"
+ "INDEXED"
+ "IN"
+ "INDICATE"
+ "INITIAL"
+ "INPUT"
+ "INPUT-OUTPUT"
+ "INSTALLATION"
+ "INTO"
+ "INVALID"
+ "IS"
+ "JUST"
+ "JUSTIFIED"
+ "KEY"
+ "LABEL"
+ "LAST"
+ "LEADING"
+ "LEFT"
+ ; LENGTH is treated as an intrinsic function.
+ "LESS"
+ "LIMIT"
+ "LIMITS"
+ "LINAGE"
+ "LINAGE-COUNTER"
+ "LINE"
+ "LINE-COUNTER"
+ "LINES"
+ "LINKAGE"
+ "LOCK"
+ "NEXT"
+ "MEMORY"
+ "MESSAGE"
+ "MODE"
+ "MODULES"
+ "MULTIPLE"
+ "NATIVE"
+ "NEGATIVE"
+ "NO"
+ "NOT"
+ "NUMBER"
+ "NUMERIC"
+ "OBJECT-COMPUTER"
+ "OCCURS"
+ "OF"
+ "OFF"
+ "OMITTED"
+ ;; "ON" ; OS/VS Statement ; Keyword <= COBOL-74
+ "OPTIONAL"
+ "OR"
+ "ORGANIZATION"
+ "OUTPUT"
+ "OVERFLOW"
+ "PAGE"
+ "PAGE-COUNTER"
+ "PF"
+ "PH"
+ "PIC"
+ "PICTURE"
+ "PLUS"
+ "POINTER"
+ "POSITION"
+ "POSITIVE"
+ "PRINTING"
+ "PROCEDURE"
+ "PROCEDURES"
+ "PROCEED"
+ "PROGRAM"
+ "PROGRAM-ID"
+ "QUEUE"
+ "RANDOM"
+ "RD"
+ "RECORD"
+ "RECORDS"
+ "REDEFINES"
+ "REEL"
+ "REFERENCES"
+ "RELATIVE"
+ "REMAINDER"
+ "REMOVAL"
+ "RENAMES"
+ "REPLACING"
+ "REPORT"
+ "REPORTING"
+ "REPORT"
+ "RERUN"
+ "RESERVE"
+ "REVERSED"
+ "REWIND"
+ "RF"
+ "RH"
+ "RIGHT"
+ "ROUNDED"
+ "RUN"
+ "SAME"
+ "SD"
+ "SECTION"
+ "SECURITY"
+ "SEGMENT"
+ "SEGMENT-LIMIT"
+ "SEND"
+ "SENTENCE"
+ "SEPARATE"
+ "SEQUENCE"
+ "SEQUENTIAL"
+ "SIZE"
+ "SORT-MERGE"
+ "SOURCE"
+ "SOURCE-COMPUTER"
+ "SPECIAL-NAMES"
+ "STANDARD"
+ "STANDARD-1"
+ "STATUS"
+ "SUB-QUEUE-1"
+ "SUB-QUEUE-2"
+ "SUB-QUEUE-3"
+ "SYMBOLIC"
+ "SYNCHRONIZED"
+ "TABLE"
+ "TALLYING"
+ "TAPE"
+ "TERMINAL"
+ "TEXT"
+ "THAN"
+ "THROUGH"
+ "THRU"
+ "TIME"
+ "TIMES"
+ "TO"
+ "TOP"
+ "TRAILING"
+ "TYPE"
+ "UNIT"
+ "UNTIL"
+ "UP"
+ "UPON"
+ "USAGE"
+ "USING"
+ "VALUE"
+ "VALUES"
+ "VARYING"
+ "WHEN"
+ "WITH"
+ "WORDS"
+ "WORKING-STORAGE"))
+
+(defconst cobol-keywords-85
+ (append cobol-keywords-74
+ '("ALPHABET"
+ "ALPHABETIC-LOWER"
+ "ALPHABETIC-UPPER"
+ "ALPHANUMERIC"
+ "ALPHANUMERIC-EDITED"
+ "ANY"
+ "BINARY"
+ "CLASS"
+ "COMMON"
+ "CONTENT"
+ "CONVERTING"
+ "DAY-OF-WEEK"
+ "EXTERNAL"
+ "FALSE"
+ "FUNCTION"
+ "GLOBAL"
+ "NUMERIC-EDITED"
+ "ORDER"
+ "OTHER"
+ "PACKED-DECIMAL"
+ "PADDING"
+ "PURGE"
+ "REFERENCE"
+ "STANDARD-2"
+ "TEST"
+ "THEN"
+ "TRUE")))
+
+(defconst cobol-removed-keywords-2002
+ '("AUTHOR"
+ "INSTALLATION"
+ "DATE-WRITTEN"
+ "DATE-COMPILED"
+ "SECURITY"
+ "MEMORY"
+ "RERUN"
+ "MULTIPLE"
+ "TAPE"
+ "LABEL"
+ "REVERSED"
+ "DEBUG-CONTENTS"
+ "DEBUG-ITEM"
+ "DEBUG-LINE"
+ "DEBUG-NAME"
+ "DEBUG-SUB-1"
+ "DEBUG-SUB-2"
+ "DEBUG-SUB-3"))
+
+(defconst cobol-keywords-2002
+ (append (cobol--remove-strings cobol-keywords-85
+ cobol-removed-keywords-2002)
+ '("ACTIVE-CLASS"
+ "ADDRESS"
+ "ALIGNED"
+ "ANYCASE"
+ "AS"
+ "B-AND"
+ "B-NOT"
+ "B-OR"
+ "B-XOR"
+ "BASED"
+ "BINARY-CHAR"
+ "BINARY-DOUBLE"
+ "BINARY-LONG"
+ "BINARY-SHORT"
+ "BIT"
+ "BOOLEAN"
+ "CLASS-ID"
+ "COL"
+ "COLS"
+ "COLUMNS"
+ "CONDITION"
+ "CONSTANT"
+ "CRT"
+ "CURSOR"
+ "DATA-POINTER"
+ "DEFAULT"
+ "EC"
+ "EO"
+ "EXCEPTION-OBJECT"
+ "FACTORY"
+ "FLOAT-EXTENDED"
+ "FLOAT-LONG"
+ "FLOAT-SHORT"
+ "FORMAT"
+ "FUNCTION-ID"
+ "GET"
+ "GROUP-USAGE"
+ "INHERITS"
+ "INTERFACE"
+ "INTERFACE-ID"
+ "LAST"
+ "LOCAL-STORAGE"
+ "LOCALE"
+ "METHOD"
+ "METHOD-ID"
+ "MINUS"
+ "NATIONAL"
+ "NATIONAL-EDITED"
+ "NESTED"
+ "OBJECT"
+ "OBJECT-REFERENCE"
+ "OPTIONS"
+ "OVERRIDE"
+ "PRESENT"
+ "PROGRAM-POINTER"
+ "PROPERTY"
+ "PROTOTYPE"
+ "RAISING"
+ "REPOSITORY"
+ "RETRY"
+ "RETURNING"
+ "SCREEN"
+ "SHARING"
+ "SOURCES"
+ "SYSTEM-DEFAULT"
+ "TYPEDEF"
+ "UNIVERSAL"
+ "USER-DEFAULT"
+ "VAL-STATUS"
+ "VALID"
+ "VALIDATE-STATUS")))
+
+(defconst cobol-keywords-finalizer-tr
+ '("AUTO-METHOD"))
+
+(defconst cobol-keywords-xml-tr
+ '("DOCUMENT"
+ "IDENTIFIED"
+ "VERSION-XML"))
+
+(defconst cobol-removed-keywords-2014
+ '("CD"
+ "DEBUGGING"
+ "EGI"
+ "EMI"
+ "ESI"
+ "MESSAGE"
+ "PADDING"
+ "PURGE"
+ "QUEUE"
+ "SEGMENT"
+ "SUB-QUEUE-1"
+ "SUB-QUEUE-2"
+ "SUB-QUEUE-3"
+ "TERMINAL"
+ "TEXT"))
+
+(defconst cobol-keywords-2014
+ (append (cobol--remove-strings cobol-keywords-2002
+ cobol-removed-keywords-2014)
+ '("FARTHEST-FROM-ZERO"
+ "FLOAT-BINARY-32"
+ "FLOAT-BINARY-64"
+ "FLOAT-BINARY-128"
+ "FLOAT-DECIMAL-16"
+ "FLOAT-DECIMAL-34"
+ "FLOAT-INFINITY"
+ "FLOAT-NOT-A-NUMBER"
+ "FLOAT-NOT-A-NUMBER-QUIET"
+ "FLOAT-NOT-A-NUMBER-SIGNALING"
+ "FUNCTION-POINTER"
+ "IN-ARITHMETIC-RANGE"
+ "NEAREST-TO-ZERO")))
+
+(defconst cobol-keywords-extensions
+ '("3-D"
+ "ABSENT"
+ "ABSTRACT"
+ "ACQUIRE"
+ "ACTION"
+ "ACTIVE-X"
+ "ACTUAL"
+ "ACCEPT-CLOSE"
+ "ACCEPT-OPEN"
+ "ADDRESS-ARRAY"
+ "ADDRESS-OFFSET"
+ "ADJUSTABLE-COLUMNS"
+ "AFP-5A"
+ "ALIGNMENT"
+ "ALLOWING"
+ "ANY LENGTH"
+ "APPLY"
+ "ARGUMENT-NUMBER"
+ "ARGUMENT-VALUE"
+ "ASSEMBLY-ATTRIBUTES"
+ "ASSOCIATED-DATA" ; Unisys
+ "ASSOCIATED-DATA-LENGTH" ; Unisys
+ "AUTO-DECIMAL"
+ "AUTO-HYPHEN-SKIP"
+ "AUTO-MINIMIZE"
+ "AUTO-RESIZE"
+ "AUTO-SKIP"
+ "AUTO-SPIN"
+ "AUTOTERMINATE"
+ "AX-EVENT-LIST"
+ "B-EXOR"
+ "B-LEFT"
+ "B-RIGHT"
+ "BACKGROUND-COLOUR"
+ "BACKGROUND-HIGH"
+ "BACKGROUND-LOW"
+ "BACKGROUND-STANDARD"
+ "BACKWARD"
+ "BAR"
+ "BASIS"
+ "BEEP"
+ "BEGINNING"
+ "BINARY-INT"
+ "BINARY-LONG-LONG"
+ "BIND"
+ "BITMAP"
+ "BITMAP-END"
+ "BITMAP-HANDLE"
+ "BITMAP-NUMBER"
+ "BITMAP-RAW-HEIGHT"
+ "BITMAP-RAW-WIDTH"
+ "BITMAP-SCALE"
+ "BITMAP-START"
+ "BITMAP-TIMER"
+ "BITMAP-TRAILING"
+ "BITMAP-WIDTH"
+ "BLINKING"
+ "BLOB"
+ "BLOB-FILE"
+ "BLOB-LOCATOR"
+ "BOLD"
+ "BOX"
+ "BOXED"
+ "BROWSING"
+ "BULK-ADDITION"
+ "BUSY"
+ "BUTTONS"
+ "C01"
+ "C02"
+ "C03"
+ "C04"
+ "C05"
+ "C06"
+ "C07"
+ "C08"
+ "C09"
+ "C10"
+ "C11"
+ "C12"
+ "CALENDAR-FONT"
+ "CALLED"
+ "CANCEL-BUTTON"
+ "CATCH"
+ "CBL"
+ "CBL-CTR"
+ "CCOL"
+ "CELL"
+ "CELL-COLOR"
+ "CELL-DATA"
+ "CELL-FONT"
+ "CELL-PROTECTION"
+ "CELLS"
+ "CENTERED"
+ "CENTERED-HEADINGS"
+ "CENTURY-DATE"
+ "CENTURY-DAY"
+ "CHAINING"
+ "CHANGED"
+ "CHAR-VARYING"
+ "CHART"
+ "CHECK-BOX"
+ "CHECKING"
+ "CLASS-ATTRIBUTES"
+ "CLASS-CONTROL"
+ "CLASS-OBJECT"
+ "CLEAR-SELECTION"
+ "CLINE"
+ "CLINES"
+ "CLOB"
+ "CLOB-FILE"
+ "CLOB-LOCATOR"
+ "CLOSE-DISPOSITION" ; Unisys
+ "CMP" ; Unisys
+ "COERCION"
+ "COLORS"
+ "COLOUR"
+ "COLOURS"
+ "COLUMN-COLOR"
+ "COLUMN-DIVIDERS"
+ "COLUMN-FONT"
+ "COLUMN-HEADINGS"
+ "COLUMN-PROTECTION"
+ "COM-REG"
+ "COMBO-BOX"
+ "COMMAND-LINE"
+ "COMMITMENT"
+ "COMP-0"
+ "COMP-1"
+ "COMP-2"
+ "COMP-3"
+ "COMP-4"
+ "COMP-5"
+ "COMP-6"
+ "COMP-N"
+ "COMP-X"
+ "COMPRESSION"
+ "COMPUTATIONAL-0"
+ "COMPUTATIONAL-1"
+ "COMPUTATIONAL-2"
+ "COMPUTATIONAL-3"
+ "COMPUTATIONAL-4"
+ "COMPUTATIONAL-5"
+ "COMPUTATIONAL-6"
+ "COMPUTATIONAL-N"
+ "COMPUTATIONAL-X"
+ "CONDITION-VALUE"
+ "CONNECT-TIME-LIMIT" ; Unisys
+ "CONSOLE"
+ "CONSTRAIN"
+ "CONSTRAINTS"
+ "CONTROL-AREA"
+ "CONTROL-POINT" ; Unisys
+ "CONTROLS-UNCROPPED"
+ "CONVENTION"
+ "CONVERSION"
+ "CONVERT"
+ "COPY-SELECTION"
+ "CORE-INDEX"
+ "CP" ; Unisys
+ "CREATING"
+ "CRT-UNDER"
+ "CRUNCH" ; Unisys
+ "CSIZE"
+ "CSP"
+ "CURSOR-COL"
+ "CURSOR-COLOR"
+ "CURSOR-FRAME-WIDTH"
+ "CURSOR-ROW"
+ "CURSOR-X"
+ "CURSOR-Y"
+ "CUSTOM-ATTRIBUTE"
+ "CUSTOM-PRINT-TEMPLATE"
+ "CYL-INDEX"
+ "CYL-OVERFLOW"
+ "DASHED"
+ "DATA-COLUMNS"
+ "DATA-TYPES"
+ "DATABASE-KEY"
+ "DATABASE-KEY-LONG"
+ "DATE-ENTRY"
+ "DATE-RECORD"
+ "DBCLOB"
+ "DBCLOB-FILE"
+ "DBCLOB-LOCATOR"
+ "DBCS"
+ "DEBUG"
+ "DECIMAL"
+ "DEFAULT-BUTTON"
+ "DEFAULT-FONT"
+ "DEFINITION"
+ "DELEGATE-ID"
+ "DESTROY"
+ "DICTIONARY"
+ "DISC"
+ "DISJOINING"
+ "DISK"
+ "DISP"
+ "DISPLAY-1"
+ "DISPLAY-COLUMNS"
+ "DISPLAY-FORMAT"
+ "DISPLAY-ST"
+ "DIVIDER-COLOR"
+ "DIVIDERS"
+ "DONT-PARTICIPATE" ; Unisys
+ "DOT-DASH"
+ "DOTTED"
+ "DOUBLE"
+ "DRAG-COLOR"
+ "DRAW"
+ "DROP"
+ "DROP-DOWN"
+ "DROP-LIST"
+ "EBCDIC"
+ "ECHO"
+ "EGCS"
+ "EJECT"
+ "ELEMENTARY"
+ "EMPTY-CHECK"
+ "ENABLED"
+ "ENCRYPTION"
+ "ENDING"
+ "ENGRAVED"
+ "ENSURE-VISIBLE"
+ "ENTRY-FIELD"
+ "ENTRY-REASON"
+ "ENUM"
+ "ENUM-ID"
+ "ENVIRONMENT-NAME"
+ "ENVIRONMENT-VALUE"
+ "EQUALS"
+ "ESCAPE"
+ "ESCAPE-BUTTON"
+ "EVENT"
+ "EVENT-LIST"
+ "EVENT-POINTER"
+ "EXCEEDS"
+ "EXCEPTION-VALUE"
+ "EXCESS-3"
+ "EXCLUDE-EVENT-LIST"
+ "EXCLUSIVE"
+ "EXPAND"
+ "EXTENDED"
+ "EXTENDED-SEARCH"
+ "EXTENSION"
+ "EXTERNAL-FORM"
+ "EXTERNALLY-DESCRIBED-KEY"
+ "FH--FCD"
+ "FH--KEYDEF"
+ "FILE-ID"
+ "FILE-LIMIT"
+ "FILE-LIMITS"
+ "FILE-NAME"
+ "FILE-POS"
+ "FILL-COLOR"
+ "FILL-COLOR2"
+ "FILL-PERCENT"
+ "FINALLY"
+ "FINISH-REASON"
+ "FIXED"
+ "FIXED-FONT"
+ "FIXED-WIDTH"
+ "FLAT"
+ "FLAT-BUTTONS"
+ "FLOAT"
+ "FLOATING"
+ "FONT"
+ "FOREGROUND-COLOUR"
+ "FRAME"
+ "FRAMED"
+ "FULL-HEIGHT"
+ "GETTER"
+ "GO-BACK"
+ "GO-FORWARD"
+ "GO-HOME"
+ "GO-SEARCH"
+ "GRAPHICAL"
+ "GRID"
+ "GRIP"
+ "GROUP-VALUE"
+ "HANDLE"
+ "HAS-CHILDREN"
+ "HEADING-COLOR"
+ "HEADING-DIVIDER-COLOR"
+ "HEADING-FONT"
+ "HEAVY"
+ "HEIGHT"
+ "HEIGHT-IN-CELLS"
+ "HELP-ID"
+ "HIDDEN-DATA"
+ "HIGH"
+ "HIGH-COLOR"
+ "HORIZONTAL"
+ "HOT-TRACK"
+ "HSCROLL"
+ "HSCROLL-POS"
+ "ICON"
+ "ID"
+ "IGNORE"
+ "INDEPENDENT"
+ "INDEXED"
+ "INDEXER"
+ "INDEXER-ID"
+ "INDIC"
+ "INDICATOR"
+ "INDICATORS"
+ "INDIRECT"
+ "INHERITING"
+ "INQUIRE"
+ "INTERRUPT"
+ "INSERT"
+ "INSERT-ROWS"
+ "INSERTION-INDEX"
+ "INSTANCE"
+ "INTERNAL"
+ "INVOKED"
+ "ITEM"
+ "ITEM-BOLD"
+ "ITEM-ID"
+ "ITEM-TEXT"
+ "ITEM-TO-ADD"
+ "ITEM-TO-DELETE"
+ "ITEM-TO-EMPTY"
+ "ITEM-VALUE"
+ "ITERATOR"
+ "ITERATOR-ID"
+ "JOINED"
+ "JOINING"
+ "KANJI"
+ "KEPT"
+ "KEY-YY"
+ "KEYBOARD"
+ "LABEL-OFFSET"
+ "LARGE-FONT"
+ "LAST-ROW"
+ "LAYOUT-DATA"
+ "LAYOUT-MANAGER"
+ "LEADING-SHIFT"
+ "LEAVE"
+ "LEFT-JUSTIFY"
+ "LEFT-TEXT"
+ "LEFTLINE"
+ "LENGTH-CHECK"
+ "LENGTH OF"
+ "LIN"
+ "LINES-AT-ROOT"
+ "LINK"
+ "LIST"
+ "LIST-BOX"
+ "LM-RESIZE"
+ "LANGUAGE"
+ "LOCAL" ; Unisys
+ "LOCKING"
+ "LONG-DATE"
+ "LONG-VARBINARY"
+ "LONG-VARCHAR"
+ "LOW"
+ "LOW-COLOR"
+ "LOWER"
+ "LOWER-BOUND" ; Unisys
+ "LOWER-BOUNDS" ; Unisys
+ "LOWERED"
+ "MASS-UPDATE"
+ "MASTER-INDEX"
+ "MAX-HEIGHT"
+ "MAX-LINES"
+ "MAX-PROGRESS"
+ "MAX-SIZE"
+ "MAX-TEXT"
+ "MAX-VAL"
+ "MAX-WIDTH"
+ "MDI-CHILD"
+ "MDI-FRAME"
+ "MEDIUM-FONT"
+ "MENU"
+ "MESSAGES"
+ "METACLASS"
+ "MIN-HEIGHT"
+ "MIN-LINES"
+ "MIN-SIZE"
+ "MIN-VAL"
+ "MIN-WIDTH"
+ "MMDDYYYY" ; Unisys
+ "MODAL"
+ "MODELESS"
+ "MODIFIED"
+ "MONITOR-POINTER"
+ "MORE-DATA" ; Unisys
+ "MORE-LABELS"
+ "MULTILINE"
+ "MUTEX-POINTER"
+ "MYJOB" ; Unisys
+ "MYSELF" ; Unisys
+ "NAME"
+ "NAMED"
+ "NAVIGATE-URL"
+ "NCHAR"
+ "NET-EVENT-LIST"
+ "NEW"
+ "NEWABLE"
+ "NEXT-ITEM"
+ "NO-AUTO-DEFAULT"
+ "NO-AUTOSEL"
+ "NO-BOX"
+ "NO-CELL-DRAG"
+ "NO-CLOSE"
+ "NO-DIVIDERS"
+ "NO-ECHO"
+ "NO-F4"
+ "NO-FOCUS"
+ "NO-GROUP-TAB"
+ "NO-KEY-LETTER"
+ "NO-SEARCH"
+ "NO-TAB"
+ "NO-UPDOWN"
+ "NOMINAL"
+ "NOTIFY"
+ "NOTIFY-CHANGE"
+ "NOTIFY-DBLCLICK"
+ "NOTIFY-SELCHANGE"
+ "NSTD-REELS"
+ "NUM-COL-HEADINGS"
+ "NUM-ROW-HEADINGS"
+ "NUM-ROWS"
+ "NUMERIC-DATE" ; Unisys
+ "NUMERIC-FILL"
+ "NUMERIC-TIME" ; Unisys
+ "O-FILL"
+ "OBJECT-ID"
+ "OBJECT-STORAGE"
+ "OC" ; Unisys
+ "ODT-INPUT-PRESENT" ; Unisys
+ "OK-BUTTON"
+ "OOSTACKPTR"
+ "OPERATOR"
+ "OPERATOR-ID"
+ "OTHERWISE"
+ "OVERLAP-LEFT"
+ "OVERLAP-TOP"
+ "OVERLAPPED"
+ "OVERLINE"
+ "OWN" ; Unisys
+ "PAGE-SETUP"
+ "PAGE-SIZE"
+ "PAGED"
+ "PANEL-INDEX"
+ "PANEL-STYLE"
+ "PANEL-TEXT"
+ "PANEL-WIDTHS"
+ "PARAMS"
+ "PARENT"
+ "PARSE"
+ "PARTIAL"
+ "PARTICIPATE" ; Unisys
+ "PASSWORD"
+ "PC" ; Unisys
+ "PERMANENT"
+ "PIXEL"
+ "PIXELS"
+ "PLACEMENT"
+ "POP-UP"
+ "POSITION-SHIFT"
+ "POSITIONING"
+ "PREFIXING"
+ "PRINT"
+ "PRINT-CONTROL"
+ "PRINT-NO-PROMPT"
+ "PRINT-PREVIEW"
+ "PRINT-SWITCH"
+ "PRINTER"
+ "PRINTER-1"
+ "PRIOR"
+ "PRIORITY"
+ "PRIVATE"
+ "PROCEDURE-POINTER"
+ "PROCESSING"
+ "PROGRESS"
+ "PROMPT"
+ "PROPERTIES"
+ "PROPERTY-ID"
+ "PROPERTY-VALUE"
+ "PROTECTED"
+ "PUBLIC"
+ "PUSH-BUTTON"
+ "QUERY-INDEX"
+ "RADIO-BUTTON"
+ "RAISED"
+ "READ-OK" ; Unisys
+ "READ-ONLY"
+ "READING"
+ "READY"
+ "REAL" ; Unisys
+ "RECORD-DATA"
+ "RECORD-OVERFLOW"
+ "RECORD-TO-ADD"
+ "RECORD-TO-DELETE"
+ "RECORDING"
+ "REDEFINE"
+ "REDEFINITION"
+ "REF" ; Unisys
+ "REFRESH"
+ "REGION-COLOR"
+ "REJECT-OPEN"
+ "RELOAD"
+ "REMARKS"
+ "REORG-CRITERIA"
+ "REPEATED"
+ "REREAD"
+ "RESET"
+ "RESET-GRID"
+ "RESET-LIST"
+ "RESET-TABS"
+ "RESIDENT"
+ "RESIZABLE"
+ "RESTRICTED"
+ "RESULT-SET-LOCATOR"
+ "RETURN-CODE"
+ "RIGHT-ALIGN"
+ "RIGHT-JUSTIFY"
+ "RIMMED"
+ "ROLLING"
+ "ROW-COLOR"
+ "ROW-COLOR-PATTERN"
+ "ROW-DIVIDERS"
+ "ROW-FONT"
+ "ROW-HEADINGS"
+ "ROW-PROTECTION"
+ "ROWID"
+ "S01"
+ "S02"
+ "S03"
+ "S04"
+ "S05"
+ "SAVE-AS"
+ "SAVE-AS-NO-PROMPT"
+ "SCROLL"
+ "SCROLL-BAR"
+ "SEARCH-OPTIONS"
+ "SEARCH-TEXT"
+ "SELECT-ALL"
+ "SELECTION-INDEX"
+ "SELECTION-TEXT"
+ "SELECTIVE"
+ "SELF-ACT"
+ "SELFCLASS"
+ "SEMAPHORE-POINTER"
+ "SEPARATION"
+ "SETTER"
+ "SHADING"
+ "SHADOW"
+ "SHIFT-IN"
+ "SHIFT-OUT"
+ "SHORT-DATE"
+ "SHOW-LINES"
+ "SHOW-NONE"
+ "SHOW-SEL-ALWAYS"
+ ;; SIGN is treated as an intrinsic function.
+ "SIGNED-INT"
+ "SIGNED-LONG"
+ "SIGNED-SHORT"
+ "SKIP1"
+ "SKIP2"
+ "SKIP3"
+ "SMALL-FONT"
+ "SORT-CONTROL"
+ "SORT-CORE-SIZE"
+ "SORT-FILE-SIZE"
+ "SORT-MESSAGE"
+ "SORT-MODE-SIZE"
+ "SORT-OPTION"
+ "SORT-ORDER"
+ "SORT-RETURN"
+ "SORT-TAPE"
+ "SORT-TAPES"
+ "SPACE-FILL"
+ "SPINNER"
+ "SQL"
+ "SQUARE"
+ "STANDARD-3"
+ "START-X"
+ "START-Y"
+ "STARTING"
+ "STATIC"
+ "STATIC-LIST"
+ "STATIONLIST"
+ "STATUS-BAR"
+ "STATUS-TEXT"
+ "STDCALL"
+ "STOP-BROWSER"
+ "STYLE"
+ "SUBFILE"
+ "SUBWINDOW"
+ "SUFFIXING"
+ ;; SUM is an intrinsic function.
+ "SW0"
+ "SW1"
+ "SW2"
+ "SW3"
+ "SW4"
+ "SW5"
+ "SW6"
+ "SW7"
+ "SW8"
+ "SW9"
+ "SW10"
+ "SW11"
+ "SW12"
+ "SW13"
+ "SW14"
+ "SW15"
+ "SWITCH-0"
+ "SWITCH-1"
+ "SWITCH-2"
+ "SWITCH-3"
+ "SWITCH-4"
+ "SWITCH-5"
+ "SWITCH-6"
+ "SWITCH-7"
+ "SWITCH-8"
+ "SWITCH-9"
+ "SWITCH-10"
+ "SWITCH-11"
+ "SWITCH-12"
+ "SWITCH-13"
+ "SWITCH-14"
+ "SWITCH-15"
+ "SYSIN"
+ "SYSIPT"
+ "SYSLST"
+ "SYSOUT"
+ "SYSPCH"
+ "SYSPUNCH"
+ "SYSTEM"
+ "SYSTEM-INFO"
+ "TAB"
+ "TAB-CONTROL"
+ "TAB-TO-ADD"
+ "TAB-TO-DELETE"
+ "TAG-KEY" ; Unisys
+ "TAG-SEARCH" ; Unisys
+ "TALLY"
+ "TAPES"
+ "TASK"
+ "TEMPORARY"
+ "TERMINAL-INFO"
+ "TERMINATION-VALUE"
+ "THREAD"
+ "THREAD-LOCAL"
+ "THREAD-LOCAL-STORAGE"
+ "THREAD-POINTER"
+ "THUMB-POSITION"
+ "TILED-HEADINGS"
+ "TIME-OF-DAY"
+ "TIME-OUT"
+ "TIME-RECORD"
+ "TIMEOUT"
+ "TIMER" ; Unisys
+ "TIMESTAMP"
+ "TIMESTAMP-OFFSET"
+ "TIMESTAMP-OFFSET-RECORD"
+ "TIMESTAMP-RECORD"
+ "TITLE"
+ "TITLE-BAR"
+ "TITLE-POSITION"
+ "TODAYS-DATE"
+ "TODAYS-NAME"
+ "TOOL-BAR"
+ "TOTALED"
+ "TOTALING"
+ "TRACE"
+ "TRACK-AREA"
+ "TRACK-LIMIT"
+ "TRACK-THUMB"
+ "TRACKS"
+ "TRADITIONAL-FONT"
+ "TRAILING-SHIFT"
+ "TRAILING-SIGN"
+ "TRANSACTION"
+ "TRANSPARENT"
+ "TRANSPARENT-COLOR"
+ "TREE-VIEW"
+ "UNDERLINED"
+ "UNEQUAL"
+ "UNFRAMED"
+ "UNITS"
+ "UNSIGNED-INT"
+ "UNSIGNED-LONG"
+ "UNSIGNED-SHORT"
+ "UNSORTED"
+ "UPDATE"
+ "UPPER"
+ "UPSI-0"
+ "UPSI-1"
+ "UPSI-2"
+ "UPSI-3"
+ "UPSI-4"
+ "UPSI-5"
+ "UPSI-6"
+ "UPSI-7"
+ "URGENT"
+ "USE-ALT"
+ "USE-RETURN"
+ "USE-TAB"
+ "USER"
+ "USER-COLORS"
+ "USER-GRAY"
+ "USER-WHITE"
+ "VA" ; Unisys
+ "VALUE-FORMAT"
+ "VALUETYPE"
+ "VALUETYPE-ID"
+ "VARBINARY"
+ "VARIABLE"
+ "VARIANT"
+ "VERTICAL"
+ "VERY-HEAVY"
+ "VIRTUAL-WIDTH"
+ "VISIBLE"
+ "VPADDING"
+ "VSCROLL"
+ "VSCROLL-BAR"
+ "VSCROLL-POS"
+ "VTOP"
+ "WEB-BROWSER"
+ "WHERE"
+ "WIDTH"
+ "WIDTH-IN-CELLS"
+ "WINDOW"
+ "WRAP"
+ "WRITE-ONLY"
+ "WRITE-VERIFY"
+ "WRITING"
+ "XML"
+ "XML-CODE"
+ "XML-EVENT"
+ "XML-NTEXT"
+ "XML-TEXT"
+ "YIELDING"
+ "ZERO-FILL"))
+
+(defvar cobol-keywords
+ (append cobol-keywords-2014
+ cobol-removed-keywords-2002
+ cobol-removed-keywords-2014
+ cobol-keywords-finalizer-tr
+ cobol-keywords-xml-tr
+ cobol-keywords-extensions
+ cobol-scope-terminators
+ cobol-removed-scope-terminators-2014)
+ "List of COBOL keywords.")
+
+(defconst cobol-context-sensitive-keywords-2002
+ '("ARITHMETIC"
+ "ATTRIBUTE"
+ "AUTO"
+ "AUTOMATIC"
+ "BACKGROUND-COLOR"
+ "BELL"
+ "BLINK"
+ "BYTE-LENGTH"
+ "CENTER"
+ "CLASSIFICATION"
+ "CYCLE"
+ "EC-ALL"
+ "EC-ARGUMENT"
+ "EC-ARGUMENT-FUNCTION"
+ "EC-ARGUMENT-IMP"
+ "EC-BOUND"
+ "EC-BOUND-IMP"
+ "EC-BOUND-ODO"
+ "EC-BOUND-OVERFLOW"
+ "EC-BOUND-PTR"
+ "EC-BOUND-REF-MOD"
+ "EC-BOUND-SET"
+ "EC-BOUND-SUBSCRIPT"
+ "EC-BOUND-TABLE-LIMIT"
+ "EC-DATA"
+ "EC-DATA-CONVERSION"
+ "EC-DATA-IMP"
+ "EC-DATA-INCOMPATIBLE"
+ "EC-DATA-INTEGRITY"
+ "EC-DATA-PTR-NULL"
+ "EC-FLOW"
+ "EC-FLOW-GLOBAL-EXIT"
+ "EC-FLOW-GLOBAL-GOBACK"
+ "EC-FLOW-IMP"
+ "EC-FLOW-RELEASE"
+ "EC-FLOW-REPORT"
+ "EC-FLOW-RETURN"
+ "EC-FLOW-SEARCH"
+ "EC-FLOW-USE"
+ "EC-FUNCTION"
+ "EC-FUNCTION-PTR-INVALID"
+ "EC-FUNCTION-PTR-NULL"
+ "EC-I-O"
+ "EC-I-O-AT-END"
+ "EC-I-O-EOP"
+ "EC-I-O-EOP-OVERFLOW"
+ "EC-I-O-FILE-SHARING"
+ "EC-I-O-IMP"
+ "EC-I-O-INVALID-KEY"
+ "EC-I-O-LINAGE"
+ "EC-I-O-LOGIC-ERROR"
+ "EC-I-O-PERMANENT-ERROR"
+ "EC-I-O-RECORD-OPERATION"
+ "EC-IMP"
+ ;; EC-IMP-suffix is matched separately by
+ ;; cobol-implementor-user-exception-re.
+ "EC-LOCALE"
+ "EC-LOCALE-IMP"
+ "EC-LOCALE-INCOMPATIBLE"
+ "EC-LOCALE-INVALID"
+ "EC-LOCALE-INVALID-PTR"
+ "EC-LOCALE-MISSING"
+ "EC-LOCALE-SIZE"
+ "EC-OO"
+ "EC-OO-CONFORMANCE"
+ "EC-OO-EXCEPTION"
+ "EC-OO-IMP"
+ "EC-OO-METHOD"
+ "EC-OO-NULL"
+ "EC-OO-RESOURCE"
+ "EC-OO-UNIVERSAL"
+ "EC-ORDER"
+ "EC-ORDER-IMP"
+ "EC-ORDER-NOT-SUPPORTED"
+ "EC-OVERFLOW"
+ "EC-OVERFLOW-IMP"
+ "EC-OVERFLOW-STRING"
+ "EC-OVERFLOW-UNSTRING"
+ "EC-PROGRAM"
+ "EC-PROGRAM-ARG-MISMATCH"
+ "EC-PROGRAM-ARG-OMITTED"
+ "EC-PROGRAM-CANCEL-ACTIVE"
+ "EC-PROGRAM-IMP"
+ "EC-PROGRAM-NOT-FOUND"
+ "EC-PROGRAM-PTR-NULL"
+ "EC-PROGRAM-RECURSIVE-CALL"
+ "EC-PROGRAM-RESOURCES"
+ "EC-RAISING"
+ "EC-RAISING-IMP"
+ "EC-RAISING-NOT-SPECIFIED"
+ "EC-RANGE"
+ "EC-RANGE-IMP"
+ "EC-RANGE-INDEX"
+ "EC-RANGE-INSPECT-SIZE"
+ "EC-RANGE-INVALID"
+ "EC-RANGE-PERFORM-VARYING"
+ "EC-RANGE-PTR"
+ "EC-RANGE-SEARCH-INDEX"
+ "EC-RANGE-SEARCH-NO-MATCH"
+ "EC-REPORT"
+ "EC-REPORT-ACTIVE"
+ "EC-REPORT-COLUMN-OVERLAP"
+ "EC-REPORT-FILE-MODE"
+ "EC-REPORT-IMP"
+ "EC-REPORT-INACTIVE"
+ "EC-REPORT-LINE-OVERLAP"
+ "EC-REPORT-NOT-TERMINATED"
+ "EC-REPORT-PAGE-LIMIT"
+ "EC-REPORT-PAGE-WIDTH"
+ "EC-REPORT-SUM-SIZE"
+ "EC-REPORT-VARYING"
+ "EC-SCREEN"
+ "EC-SCREEN-FIELD-OVERLAP"
+ "EC-SCREEN-IMP"
+ "EC-SCREEN-ITEM-TRUNCATED"
+ "EC-SCREEN-LINE-NUMBER"
+ "EC-SCREEN-STARTING-COLUMN"
+ "EC-SIZE"
+ "EC-SIZE-ADDRESS"
+ "EC-SIZE-EXPONENTIATION"
+ "EC-SIZE-IMP"
+ "EC-SIZE-OVERFLOW"
+ "EC-SIZE-TRUNCATION"
+ "EC-SIZE-UNDERFLOW"
+ "EC-SIZE-ZERO-DIVIDE"
+ "EC-SORT-MERGE"
+ "EC-SORT-MERGE-ACTIVE"
+ "EC-SORT-MERGE-FILE-OPEN"
+ "EC-SORT-MERGE-IMP"
+ "EC-SORT-MERGE-RELEASE"
+ "EC-SORT-MERGE-RETURN"
+ "EC-SORT-MERGE-SEQUENCE"
+ "EC-STORAGE"
+ "EC-STORAGE-IMP"
+ "EC-STORAGE-NOT-ALLOC"
+ "EC-STORAGE-NOT-AVAIL"
+ "EC-USER"
+ ;; EC-USER-suffix is matched separately by
+ ;; cobol-implementor-user-exception-re.
+ "EC-VALIDATE"
+ "EC-VALIDATE-CONTENT"
+ "EC-VALIDATE-FORMAT"
+ "EC-VALIDATE-IMP"
+ "EC-VALIDATE-RELATION"
+ "EC-VALIDATE-VARYING"
+ "EOL"
+ "EOS"
+ "ENTRY-CONVENTION"
+ "ERASE"
+ "EXPANDS"
+ "FOREGROUND-COLOR"
+ "FOREVER"
+ "FULL"
+ "HIGHLIGHT"
+ "IGNORING"
+ "IMPLEMENTS"
+ "INITIALIZED"
+ "INTRINSIC"
+ "LC_ALL"
+ "LC_COLLATE"
+ "LC_CTYPE"
+ "LC_MESSAGES"
+ "LC_MONETARY"
+ "LC_NUMERIC"
+ "LC_TIME"
+ "LOWLIGHT"
+ "MANUAL"
+ "MULTIPLE" ; <= COBOL-74
+ "NEGATIVE-INFINITY"
+ "NONE"
+ "NORMAL"
+ "NUMBERS"
+ "ONLY"
+ "PARAGRAPH"
+ "POSITIVE-INFINITY"
+ "PREVIOUS"
+ "RECURSIVE"
+ "RELATION"
+ "REQUIRED"
+ "REVERSE-VIDEO"
+ "SECONDS"
+ "SECURE"
+ "STATEMENT"
+ "STEP"
+ "STRONG"
+ "SYMBOL"
+ "UCS-4"
+ "UNDERLINE"
+ "UNSIGNED"
+ "UTF-8"
+ "UTF-16"
+ ;; XML is treated as a reserved word per IBM implementations.
+ "YYYYDDD"
+ "YYYYMMDD"))
+
+(defconst cobol-context-sensitive-keywords-finalizer-tr
+ '("EC-OO-FINALIZABLE"
+ "FINALIZER"))
+
+(defconst cobol-context-sensitive-keywords-xml-tr
+ '("CHECK"
+ "DISCARD"
+ "DOCUMENTATION"
+ "DTD"
+ "EC-DATA-INFINITY"
+ "EC-DATA-NEGATIVE-INFINITY"
+ "EC-DATA-NOT-A-NUMBER"
+ "EC-XML"
+ "EC-XML-CODESET"
+ "EC-XML-CODESET-CONVERSION"
+ "EC-XML-COUNT"
+ "EC-XML-DOCUMENT-TYPE"
+ "EC-XML-IMPLICIT-CLOSE"
+ "EC-XML-INVALID"
+ "EC-XML-NAMESPACE"
+ "EC-XML-STACKED-OPEN"
+ "EC-XML-RANGE"
+ "ELEMENT"
+ "NAMESPACE"
+ "RAW"
+ "SCHEMA"
+ "STACK"
+ "VALIDITY"))
+
+(defconst cobol-context-sensitive-keywords-2014
+ (append cobol-context-sensitive-keywords-2002
+ '("AWAY-FROM-ZERO"
+ "BINARY-ENCODING"
+ "CAPACITY"
+ "DECIMAL-ENCODING"
+ "EC-FUNCTION-ARG-OMITTED"
+ "EC-FUNCTION-NOT-FOUND"
+ "EC-OO-ARG-OMITTED"
+ "FLOAT-BINARY"
+ "FLOAT-DECIMAL"
+ "HIGH-ORDER-LEFT"
+ "HIGH-ORDER-RIGHT"
+ "INTERMEDIATE"
+ "NEAREST-AWAY-FROM-ZERO"
+ "NEAREST-EVEN-INTERMEDIATE"
+ "NEAREST-TOWARD-ZERO"
+ "PREFIXED"
+ "PROHIBITED"
+ "ROUNDING"
+ "SHORT"
+ "SIGNED"
+ "STANDARD-BINARY"
+ "STANDARD-DECIMAL"
+ "TOWARD-GREATER"
+ "TOWARD-LESSER"
+ "TRUNCATION")))
+
+(defconst cobol-context-sensitive-extensions
+ '("TRUNCATED" ; Unisys
+ ))
+
+(defvar cobol-context-sensitive-keywords
+ (append cobol-context-sensitive-keywords-2014
+ cobol-context-sensitive-keywords-finalizer-tr
+ cobol-context-sensitive-keywords-xml-tr
+ cobol-context-sensitive-extensions)
+ "List of context-sensitive COBOL keywords.")
+
+(defconst cobol-intrinsics-85
+ '("ACOS"
+ "ANNUITY"
+ "ASIN"
+ "ATAN"
+ ;; BYTE-LENGTH is treated as a context-sensitive word.
+ "CHAR"
+ "COS"
+ "CONCATENATE"
+ "CURRENT-DATE"
+ "DATE-OF-INTEGER"
+ "DAY-OF-INTEGER"
+ "FACTORIAL"
+ "INTEGER"
+ "INTEGER-OF-DATE"
+ "INTEGER-OF-DAY"
+ "INTEGER-PART"
+ "LENGTH"
+ "LOG"
+ "LOG10"
+ "LOWER-CASE"
+ "MAX"
+ "MEAN"
+ "MEDIAN"
+ "MIDRANGE"
+ "MIN"
+ "MOD"
+ "NUMVAL"
+ "NUMVAL-C"
+ "ORD"
+ "ORD-MAX"
+ "ORD-MIN"
+ "PRESENT-VALUE"
+ ;; RANDOM is treated as a keyword
+ "RANGE"
+ "REM"
+ "REVERSE"
+ "SIGN" ; Keyword <= COBOL-74
+ "SIN"
+ "SQRT"
+ "STANDARD-DEVIATION"
+ "SUM" ; Keyword <= COBOL-74
+ "TAN"
+ "UPPER-CASE"
+ "VARIANCE"
+ "WHEN-COMPILED"))
+
+(defconst cobol-intrinsics-2002
+ (append cobol-intrinsics-85
+ '("ABS"
+ "BOOLEAN-OF-INTEGER"
+ "CHAR-NATIONAL"
+ "DATE-TO-YYYYMMDD"
+ "DAY-TO-YYYYDDD"
+ "DISPLAY-OF"
+ "E"
+ "EXCEPTION-FILE"
+ "EXCEPTION-FILE-N"
+ "EXCEPTION-LOCATION"
+ "EXCEPTION-LOCATION-N"
+ "EXCEPTION-STATEMENT"
+ "EXCEPTION-STATUS"
+ "EXP"
+ "EXP10"
+ "FRACTION-PART"
+ "HIGHEST-ALGEBRAIC"
+ "INTEGER-OF-BOOLEAN"
+ "LOCALE-COMPARE"
+ "LOCALE-DATE"
+ "LOCALE-TIME"
+ "LOWEST-ALGEBRAIC"
+ "NATIONAL-OF"
+ "NUMVAL-F"
+ "PI"
+ "STANDARD-COMPARE"
+ "TEST-DATE-YYYYMMDD"
+ "TEST-DAY-YYYYDDD"
+ "TEST-NUMVAL"
+ "TEST-NUMVAL-C"
+ "TEST-NUMVAL-F"
+ "YEAR-TO-YYYY")))
+
+(defconst cobol-intrinsics-2014
+ (append cobol-intrinsics-2002
+ '("COMBINED-DATETIME"
+ "FORMATTED-CURRENT-DATE"
+ "FORMATTED-DATE"
+ "FORMATTED-DATETIME"
+ "FORMATTED-TIME"
+ "INTEGER-OF-FORMATTED-DATE"
+ "LOCALE-TIME-FROM-SECONDS"
+ "SECONDS-FROM-FORMATTED-TIME"
+ "SECONDS-PAST-MIDNIGHT"
+ "TEST-FORMATTED-DATETIME"
+ "TRIM")))
+
+(defconst cobol-intrinsics-extensions
+ '("ADDR"
+ "CURRENCY-SYMBOL"
+ "LENGTH-AN"
+ "MODULE-CALLER-ID"
+ "MODULE-DATE"
+ "MODULE-FORMATTED-DATE"
+ "MODULE-ID"
+ "MODULE-PATH"
+ "MODULE-SOURCE"
+ "MONETARY-DECIMAL-POINT"
+ "MONETARY-THOUSANDS-SEPARATOR"
+ "NUMERIC-DECIMAL-POINT"
+ "NUMERIC-THOUSANDS-SEPARATOR"
+ "STORED-CHAR-LENGTH"
+ "SUBSTITUTE"
+ "SUBSTITUTE-CASE"
+ "ULENGTH"
+ "UPOS"
+ "USUBSTR"
+ "USUPPLEMENTARY"
+ "UVALID"
+ "UWIDTH"))
+
+(defvar cobol-intrinsics
+ (append cobol-intrinsics-2014
+ cobol-intrinsics-extensions)
+ "List of COBOL standard functions.")
+
+(defconst cobol-symbolic-literals-74
+ '("HIGH-VALUE"
+ "HIGH-VALUES"
+ "LOW-VALUE"
+ "LOW-VALUES"
+ "QUOTE"
+ "QUOTES"
+ "SPACE"
+ "SPACES"
+ "ZERO"
+ "ZEROES"
+ "ZEROS"))
+
+(defconst cobol-symbolic-literals-85
+ cobol-symbolic-literals-74)
+
+(defconst cobol-symbolic-literals-2002
+ (append cobol-symbolic-literals-85
+ '("NULL"
+ "SELF"
+ "SUPER")))
+
+(defconst cobol-symbolic-literals-2014
+ cobol-symbolic-literals-2002)
+
+(defconst cobol-symbolic-literals-extensions
+ '("NULLS"))
+
+(defvar cobol-symbolic-literals
+ (append cobol-symbolic-literals-2014
+ cobol-symbolic-literals-extensions)
+ "List of COBOL symbolic literals.")
+
+(defface cobol-verb
+ '((t (:inherit font-lock-keyword-face :weight bold)))
+ "Face for COBOL verbs.")
+
+(defface cobol-context-sensitive
+ '((t (:inherit font-lock-keyword-face)))
+ "Face for context-sensitive COBOL words.")
+
+;;; Highlighting regexps
+
+(defconst cobol--fixed-form-sequence-area-re
+ "^.\\{1,6\\}"
+ "Regexp matching the fixed-form sequence area.")
+
+(eval-and-compile
+(defconst cobol--complete-sequence-area-re
+ "^.\\{6\\}"
+ "Regexp matching a complete sequence area.")
+
+(defconst cobol--fixed-comment-indicators
+ "*/"
+ "String containing COBOL fixed-form comment indicator characters.")
+
+(defconst cobol--fixed-form-comment-re
+ (concat cobol--complete-sequence-area-re
+ "\\(["
+ cobol--fixed-comment-indicators
+ "]\\)")
+ "Regexp matching a fixed-form source comment.")
+
+(defconst cobol--continuation-or-debugging-indicator-re
+ (concat cobol--complete-sequence-area-re
+ "\\([d-]\\)")
+ "Regexp matching a continuation or debugging line indicator.")
+
+(defconst cobol--non-fixed-comment-indicators-re
+ (concat "[^" cobol--fixed-comment-indicators "]")
+ "Regexp matching non-fixed-form-comment-indicator characters.")
+
+(defconst cobol--fixed-non-comment-sequence-area-re
+ (concat cobol--complete-sequence-area-re
+ cobol--non-fixed-comment-indicators-re)
+ "Regexp matching the sequence area of a non-comment fixed-form line."))
+
+(defconst cobol--fixed-non-comment-grouped-sequence-area-re
+ (concat "\\(" cobol--fixed-form-sequence-area-re "\\)")
+ "Regexp matching the sequence area of a non-comment fixed-form line in a
+group.")
+
+(defconst cobol--fixed-form-areas-02-re
+ cobol--fixed-non-comment-grouped-sequence-area-re
+ "Regexp matching the ignored fixed-forms area in COBOL 2002 for non-comment
+lines.")
+
+(defconst cobol--fixed-form-areas-85-re
+ (concat cobol--fixed-non-comment-grouped-sequence-area-re
+ ".\\{0,66\\}\\(.*\\)")
+ "Regexp matching the ignored fixed-form areas up to COBOL-85 for non-comment
+lines.")
+
+(defconst cobol--fixed-form-wrong-indicator-re
+ (concat cobol--fixed-form-sequence-area-re "\\([^-\\*/d$]\\)")
+ "Regexp matching incorrect indicators in fixed-form code.")
+
+(defconst cobol--free-form-comment-re
+ "\\*>.*"
+ "Regexp matching a free-form source comment.")
+
+(eval-and-compile
+(defconst cobol--optional-whitespace-re
+ "[ ]*" ; Space and tab
+ "Regexp matching optional whitespace.
+\\w isn't used to avoid matching newlines.")
+
+(defconst cobol--optional-leading-whitespace-line-re
+ (if (not (eq cobol-source-format 'free))
+ (concat cobol--fixed-non-comment-sequence-area-re
+ cobol--optional-whitespace-re)
+ (concat "^" cobol--optional-whitespace-re))
+ "Regexp matching a line perhaps starting with whitespace.")
+
+(defun cobol--with-opt-whitespace-line (&rest strs)
+ "Return STRS concatenated after `cobol--optional-leading-whitespace-line-re'."
+ (apply #'concat cobol--optional-leading-whitespace-line-re strs)))
+
+(defconst cobol--free-form-comment-line-re
+ (cobol--with-opt-whitespace-line cobol--free-form-comment-re)
+ "Regexp matching a free form comment line.")
+
+(defconst cobol--identifier-re
+ "\\s-+\\(\\w+\\)"
+ "Regexp matching an identifier in a separate group preceded by whitespace.")
+
+(defconst cobol--mf-set-directive
+ (cobol--with-opt-whitespace-line "\\$SET\\s-+\\w+")
+ "Regexp matching MF compiler directive with optional whitespace.")
+
+(defconst cobol--mf-compiler-directive-re
+ (if (not (eq cobol-source-format 'free))
+ (concat cobol--fixed-form-sequence-area-re
+ ;; FIXME: cobol--mf-set-directive starts with "^" so it can't
+ ;; match after cobol--fixed-form-sequence-area-re!
+ cobol--mf-set-directive)
+ (concat "^" cobol--mf-set-directive))
+ "Regexp matching Micro Focus compiler directives.")
+
+(defconst cobol--standard-constant-re
+ (cobol--with-opt-whitespace-line "0?1" cobol--identifier-re "\\s-+CONSTANT")
+ "Regexp matching constants declared as specified by the 2002 standard.")
+
+(defconst cobol--mf-constant-re
+ (cobol--with-opt-whitespace-line "78" cobol--identifier-re)
+ "Regexp matching constants declared as specified by Micro Focus.")
+
+(eval-and-compile
+(defconst cobol--directive-indicator-re
+ ">> ?"
+ "Regexp matching a valid directive indicator."))
+
+(defconst cobol--define-directive-re
+ (cobol--with-opt-whitespace-line cobol--directive-indicator-re
+ "DEFINE"
+ cobol--identifier-re)
+ "Regexp matching values defined by the pre-processor.")
+
+(defconst cobol--descriptor-level-re
+ "[FRS]D"
+ "Regexp matching file/report/sort descriptor \"level numbers\".")
+
+(defconst cobol--record-descriptor-re
+ (cobol--with-opt-whitespace-line cobol--descriptor-level-re cobol--identifier-re)
+ "Regexp matching file/report/sort record associations.")
+
+(defconst cobol--typedef-definition-re
+ (cobol--with-opt-whitespace-line "0?1" cobol--identifier-re ".+TYPEDEF")
+ "Regexp matching typedefs.")
+
+(defconst cobol--level-number-re
+ "[[:digit:]]\\{1,2\\}"
+ "Regexp matching level numbers.")
+
+(defconst cobol--variable-declaration-re
+ (cobol--with-opt-whitespace-line cobol--level-number-re cobol--identifier-re)
+ "Regexp matching standard variable declarations.")
+
+(defconst cobol--mf-declare-variable-re
+ (cobol--with-opt-whitespace-line "DECLARE" cobol--identifier-re)
+ "Regexp matching variable declarations using DECLARE verb used in Managed
+COBOL.")
+
+(defconst cobol--id-and-name-re
+ "-ID\\.?\\s-*\\(\\w+\\)"
+ "Regexp matching a construct ID and the name of the declared construct.")
+
+(defun cobol--create-id-re (re)
+ "Create an id regexp using RE."
+ (cobol--with-opt-whitespace-line re cobol--id-and-name-re))
+
+(defun cobol--create-end-marker-re (re)
+ "Create an end marker regexp using RE."
+ (cobol--with-opt-whitespace-line "END\\s-+" re cobol--identifier-re))
+
+(defconst cobol--standard-function-types
+ '("FUNCTION" "METHOD" "PROGRAM")
+ "List containing the names of standard constructs similar to functions.")
+
+(defconst cobol--mf-function-types
+ '("ITERATOR" "OPERATOR" "PROPERTY")
+ "List containing the names of constructs similar to functions created by Micro
+Focus.")
+
+(defconst cobol--function-types-re
+ (regexp-opt (append cobol--standard-function-types cobol--mf-function-types))
+ "Regexp matching the names of constructs similar to functions.")
+
+(defconst cobol--function-id-name-re
+ (cobol--create-id-re (remove "PROPERTY" cobol--function-types-re))
+ "Regexp matching the id and name of a function or similar.")
+
+(defconst cobol--function-end-marker-re
+ (cobol--create-end-marker-re cobol--function-types-re)
+ "Regexp matching the end marker of a function or similar.")
+
+(defconst cobol--standard-type-types
+ '("CLASS" "INTERFACE")
+ "List containing the standard type construct names.")
+
+(defconst cobol--mf-type-types
+ '("DELEGATE" "ENUM" "INDEXER" "VALUETYPE")
+ "List containing the names of type constructs added by Micro Focus.")
+
+(defconst cobol--type-types-re
+ (regexp-opt (append cobol--standard-type-types cobol--mf-type-types))
+ "Regexp matching type construct names.")
+
+(defconst cobol--type-id-name-re
+ (cobol--create-id-re cobol--type-types-re)
+ "Regexp matching the id and name of a type.")
+
+(defconst cobol--type-end-marker-re
+ (cobol--create-end-marker-re cobol--type-types-re)
+ "Regexp matching the end marker of a type.")
+
+(defconst cobol--mf-property-id-name-re
+ (concat "PROPERTY" cobol--id-and-name-re cobol--identifier-re)
+ "Regexp matching the id, name and type of a property using MF's PROPERTY-ID
+syntax.")
+
+(defconst cobol--procedure-re
+ (cobol--with-opt-whitespace-line "\\(\\w+\\)\\(\\s-+SECTION\\)?\\.")
+ "Regexp matching the declaration of a procedure.
+Note that this matches DECLARATIVES.")
+
+(defconst cobol--select-file-re
+ (cobol--with-opt-whitespace-line
+ "SELECT\\(\\s-+OPTIONAL\\)?"
+ cobol--identifier-re)
+ "Regexp matching the declaration of a file.")
+
+(defconst cobol--pic-type-re
+ "PIC\\(TURE\\)?\\(\\s-+IS\\)?\\s-+\\(\\([-$*+,./[:digit:]()ABENPSVXZ]\\|CR\\|DB\\)+?\\)\\(\\s-\\|\\.?
+\\)"
+ "Regexp matching the PICTURE clause of a variable.")
+
+(defconst cobol--string-literal-type-re
+ "\\([ZBN]X?\\|[GHLX]\\)\\(\"\\|\'\\)"
+ "Regexp matching the type of a string-style literal.")
+
+(defconst cobol--function-call-re
+ "\\(\\w+\\)("
+ "Regexp matching a function call.")
+
+(defun cobol--create-specifier-type-re (types)
+ "Create a specifier id regexp for the list of type names TYPES."
+ (cobol--with-opt-whitespace-line
+ "\\("
+ (mapconcat #'identity types "\\|")
+ "\\)"
+ cobol--identifier-re))
+
+(defconst cobol--repository-function-type-clause-re
+ (cobol--create-specifier-type-re cobol--standard-function-types)
+ "Regexp matching a REPOSITORY specifier clause for function types.")
+
+(defconst cobol--repository-type-type-clause-re
+ (cobol--create-specifier-type-re cobol--standard-type-types)
+ "Regexp matching a REPOSITORY specifier clause for type types.")
+
+(defconst cobol--mf-invoked-class-re
+ (concat "TYPE" cobol--identifier-re)
+ "Regexp matching a class being INVOKED.")
+
+(defconst cobol--implementer-user-exception-re
+ "EC-\\(IMP\\|USER\\)-\\w+"
+ "Regexp matching an implementor- or user-defined exception condition.")
+
+(defconst cobol--scope-terminator-re
+ (cobol--with-opt-whitespace-line (regexp-opt cobol-scope-terminators 'words))
+ "Regexp matching a scope terminator.")
+
+(defconst cobol--phrases-with-double-indent-after
+ "\\(IF\\|EVALUATE\\|WHEN\\|ELSE\\|PERFORM\\s-+\\(VARYING\\|UNTIL\\|\\(WITH\\s-+\\)?TEST\\|.+?\\s-+TIMES\\)\\)"
+ "Regexp matching phrases whose conditions/clauses are indented twice.")
+
+(defconst cobol--containing-statement-or-phrase-re
+ (cobol--with-opt-whitespace-line
+ "\\("
+ cobol--phrases-with-double-indent-after
+ "\\|\\(NOT\\s-+\\)?\\(\\(AT\\s-+\\)?END\\(-OF-PAGE\\)?\\>\\|\\(ON\\s-+\\)?\\(OVERFLOW\\|EXCEPTION\\|ESCAPE\\|SIZE\\s-+ERROR\\)\\|INVALID\\s-+KEY\\)\\)")
+ "Regexp matching statements/phrases that contain nested statements.")
+
+(defconst cobol--verb-re
+ (cobol--with-opt-whitespace-line (regexp-opt cobol-verbs 'words))
+ "Regexp matching a verb.")
+
+(defconst cobol--non-id-groups
+ ;; AUTO-METHOD is part of the Finalizer TR.
+ '("AUTO-METHOD" "DECLARATIVES" "FACTORY" "OBJECT" "METHOD")
+ "Groups which do not take a (specifiable) ID.")
+
+(defconst cobol--non-id-group-end-marker-re
+ (cobol--with-opt-whitespace-line
+ "END\\s-+" (regexp-opt cobol--non-id-groups 'words))
+ "Regexp matching the end marker of the groups not taking IDs.")
+
+(defconst cobol--end-marker-re
+ (concat "\\(" cobol--function-end-marker-re
+ "\\|" cobol--type-end-marker-re
+ "\\|" cobol--non-id-group-end-marker-re
+ "\\)")
+ "Regexp matching an end marker.")
+
+(defconst cobol--division-re
+ (cobol--with-opt-whitespace-line "\\(IDENTIFICATION\\|ENVIRONMENT\\|DATA\\|PROCEDURE\\)\\s-+DIVISION")
+ "Regexp matching division header.")
+
+(defconst cobol--procedure-division-re
+ (cobol--with-opt-whitespace-line "PROCEDURE\\s-+DIVISION")
+ "Regexp matching the procedure division header.")
+
+(defconst cobol--env-or-data-div-sections-re
+ (cobol--with-opt-whitespace-line
+ (regexp-opt '("CONFIGURATION" "INPUT-OUTPUT" "FILE" "WORKING-STORAGE" "LOCAL-STORAGE" "LINKAGE" "REPORT" "SCREEN"))
+ "\\s-+SECTION.")
+ "Regexp matching the sections of the environment and data divisions.")
+
+(defconst cobol--generic-declaration-re
+ (cobol--with-opt-whitespace-line
+ "\\("
+ cobol--descriptor-level-re
+ "\\|"
+ cobol--level-number-re
+ "\\)"
+ cobol--identifier-re)
+ "Regexp matching any declaration.")
+
+(defconst cobol--blank-line-re
+ (cobol--with-opt-whitespace-line "\\.?$")
+ "Regexp matching a blank line with optional period.")
+
+;;; Font lock
+
+(defun cobol--fixed-format-p ()
+ "Return whether the current source format is fixed."
+ (memq cobol-source-format '(fixed-85 'fixed-2002)))
+
+;; This is required for indentation to function, because the initial sequence
+;; area is marked as a comment, not whitespace.
+(defun cobol-back-to-indentation ()
+ "Move point to the first non-whitespace character on this line.
+If in fixed-form code, the sequence area and indicators are skipped.
+Code copied from the Emacs source."
+ (interactive "^")
+ (beginning-of-line 1)
+ (when (cobol--fixed-format-p)
+ (forward-char 7))
+ (skip-syntax-forward " " (line-end-position))
+ ;; Move back over chars that have whitespace syntax but have the p flag.
+ (backward-prefix-chars))
+
+(defun cobol--font-lock-sequence-area (end)
+ "Mark text in the sequence area as comments from point up to END."
+ (when (cobol--fixed-format-p)
+ (while (and (< (point) end)
+ (re-search-forward "^.\\{1,6\\}" end t))
+ (put-text-property (match-beginning 0) (point)
+ 'face font-lock-comment-face)))
+ nil)
+
+(eval-when-compile
+ (defconst cobol--syntax-propertize-indicator-area
+ (syntax-propertize-precompile-rules
+ (cobol--fixed-form-comment-re (1 "<"))
+ (cobol--continuation-or-debugging-indicator-re (1 ".")))
+ "Syntax rules to mark fixed-form comments as comments.")
+
+ (defconst cobol--syntax-propertize-program-name-area
+ (syntax-propertize-precompile-rules
+ ;; TODO: Override open strings
+ ("^.\\{72\\}\\(.\\)" (1 "<")))
+ "Syntax rule to mark text in the program name area as comments.")
+
+ (defconst cobol--syntax-propertize-page-directive
+ (syntax-propertize-precompile-rules
+ ((cobol--with-opt-whitespace-line cobol--directive-indicator-re
+ "PAGE\\([ ]\\)")
+ (1 "<")))
+ "Syntax rule to mark text after >>PAGE as a comment.")
+
+ (defconst cobol--syntax-propertize-adjacent-quotes
+ (syntax-propertize-precompile-rules
+ ("\"\"\\|''"
+ (0 (ignore
+ ;; Move to first quote.
+ (backward-char 2)
+ (if (nth 3 (syntax-ppss))
+ (progn
+ (put-text-property (point) (1+ (point))
+ 'syntax-table (string-to-syntax "\\"))
+ ;; Move back to past the escaped quotes.
+ (forward-char 2))
+ ;; If the first quote began a string, then the next quote may be the
+ ;; first character in another escaped quote sequence.
+ (forward-char 1))))))
+ "Syntax rule to mark the first of adjacent quotes.
+It marks the first of \"\" or '' as an escape character."))
+
+(defun cobol--syntax-propertize-function (beg end)
+ "Syntax propertize awkward COBOL features (fixed-form comments, indicators
+and ignored areas) between points BEG and END."
+ ;; TO-DO: Propertize continuation lines.
+ (funcall
+ (pcase cobol-source-format
+ (`fixed-85 (syntax-propertize-rules
+ cobol--syntax-propertize-indicator-area
+ cobol--syntax-propertize-program-name-area
+ cobol--syntax-propertize-page-directive
+ cobol--syntax-propertize-adjacent-quotes))
+ (`fixed-2002 (syntax-propertize-rules
+ cobol--syntax-propertize-indicator-area
+ cobol--syntax-propertize-page-directive
+ cobol--syntax-propertize-adjacent-quotes))
+ (_ (syntax-propertize-rules
+ cobol--syntax-propertize-page-directive
+ cobol--syntax-propertize-adjacent-quotes)))
+ beg end))
+
+;; Change to defconst so it reloads on something?
+(defvar cobol-font-lock-defaults
+ `((;; Sequence area
+ (cobol--font-lock-sequence-area)
+
+ ;; Directives
+ ( ,(concat cobol--directive-indicator-re
+ "\\(" (regexp-opt cobol-directives) "\\>\\)")
+ . font-lock-preprocessor-face)
+ ( ,cobol--mf-compiler-directive-re . font-lock-preprocessor-face)
+
+ ;; TO-DO: Highlight reserved words in directives as reserved words
+
+ ;; Standard language features.
+ ( ,(regexp-opt cobol-verbs 'words) . 'cobol-verb)
+ ( ,(regexp-opt cobol-keywords 'words) . font-lock-keyword-face)
+ ( ,(regexp-opt cobol-context-sensitive-keywords 'words)
+ . 'cobol-context-sensitive)
+ ( ,cobol--implementer-user-exception-re . 'cobol-context-sensitive)
+ ( ,(regexp-opt cobol-intrinsics 'words) . font-lock-builtin-face)
+
+ ;; Constants
+ ( ,(regexp-opt cobol-symbolic-literals 'words) . font-lock-constant-face)
+ ( ,cobol--standard-constant-re
+ (1 'font-lock-constant-face))
+ ( ,cobol--mf-constant-re
+ (1 'font-lock-constant-face))
+ ( ,cobol--define-directive-re
+ (1 'font-lock-constant-face))
+
+ ;; PIC Type
+ ( ,cobol--pic-type-re
+ (3 'font-lock-type-face))
+
+ ;; Functions
+ ( ,cobol--function-call-re
+ (1 'font-lock-function-name-face))
+
+ ;; REPOSITORY clauses
+ ( ,cobol--repository-function-type-clause-re
+ (2 'font-lock-function-name-face))
+ ( ,cobol--repository-type-type-clause-re
+ (2 'font-lock-type-face))
+
+ ;; File declarations
+ ( ,cobol--select-file-re
+ (2 'font-lock-type-face))
+
+ ;; File/Report/Sort record associations
+ ( ,cobol--record-descriptor-re
+ (1 'font-lock-type-face))
+
+ ;; Typedef
+ ( ,cobol--typedef-definition-re
+ (1 'font-lock-type-face))
+
+ ;; Variables
+ ( ,cobol--variable-declaration-re
+ (1 'font-lock-variable-name-face))
+ ( ,cobol--mf-declare-variable-re
+ (1 'font-lock-variable-name-face))
+
+ ;; Construct IDs
+ ( ,cobol--function-id-name-re
+ (1 'font-lock-function-name-face))
+ ( ,cobol--type-id-name-re
+ (1 'font-lock-type-face))
+ ( ,cobol--mf-property-id-name-re
+ (1 'font-lock-variable-name-face)
+ (2 'font-lock-type-face))
+
+ ;; Construct end markers
+ ( ,cobol--function-end-marker-re
+ (1 'font-lock-function-name-face))
+ ( ,cobol--type-end-marker-re
+ (1 'font-lock-type-face))
+
+ ;; Invoked classes
+ ( ,cobol--mf-invoked-class-re
+ (1 'font-lock-type-face))
+
+ ;; Procedures
+ ( ,cobol--procedure-re
+ (1 'font-lock-function-name-face))
+
+ ( ,cobol--string-literal-type-re
+ (1 'font-lock-string-face)))
+ nil
+ t
+ nil
+ nil))
+
+;;; Skeletons
+
+(defvar cobol-skeleton-alist nil
+ "Alist of code templates.
+You can extend this alist to your heart's content. For each additional
+template NAME in the list, declare a keyboard macro or function (or
+interactive command) called `cobol-skeleton-NAME'.
+If `cobol-skeleton-NAME' is a function it takes no arguments and should
+insert the template at point; if this is a command it may accept any
+sensible interactive call arguments; keyboard macros can't take
+arguments at all.")
+
+
+(defmacro cobol--def-skeleton (name doc interactor &rest elements)
+ (declare (indent 1) (doc-string 2))
+ (let ((fsym (intern (concat "cobol-skeleton-" name)))
+ (printname (replace-regexp-in-string "-" " " (upcase name))))
+ `(progn
+ (add-to-list 'cobol-skeleton-alist ',(cons printname fsym))
+ ;; (define-abbrev sml-skel-abbrev-table ,name "" ',fsym :system t)
+ (define-skeleton ,fsym
+ ,doc
+ ,interactor
+ ,@elements))))
+
+(defun cobol-skeleton--menu (_menu)
+ (mapcar (lambda (x) (vector (car x) (cdr x) t))
+ cobol-skeleton-alist))
+
+(cobol--def-skeleton "if-else"
+ "Insert an IF - ELSE - END-IF block." nil
+ > "IF " (skeleton-read "Condition: ") > \n
+ > _ \n
+ "ELSE" > \n
+ > \n
+ "END-IF" > \n)
+
+(cobol--def-skeleton "if"
+ "Insert an IF - END-IF block." nil
+ > "IF " (skeleton-read "Condition: ") > \n
+ > _ \n
+ "END-IF" > \n)
+
+(cobol--def-skeleton "perform-times"
+ "Insert a PERFORM - TIMES - END-PERFORM block." nil
+ > "PERFORM " (skeleton-read "Number: ") " TIMES" > \n
+ > _ \n
+ "END-PERFORM" > \n)
+
+(cobol--def-skeleton "perform-varying"
+ "Insert a PERFORM VARYING - FROM - BY - UNTIL - END-PERFORM block."
+ nil
+ > "PERFORM VARYING "
+ (skeleton-read "Variable: ")
+ " FROM "
+ (skeleton-read "Start: ")
+ " BY "
+ (skeleton-read "Step: ")
+ " UNTIL "
+ (skeleton-read "Condition: ") > \n
+ > _ \n
+ "END-PERFORM" > \n)
+
+(defun cobol-when-with-also (prompt num-also)
+ "Create a WHEN clause skeleton with provided PROMPT and NUM-ALSO ALSOs."
+ `(,prompt "WHEN " str
+ ,@(let ((clauses nil))
+ (dotimes (_ num-also)
+ (push `(" ALSO " (skeleton-read ,prompt)) clauses))
+ clauses)
+ > \n > _ \n))
+
+(defvar cobol--num-conds)
+
+(cobol--def-skeleton "evaluate"
+ "Insert an EVALUATE - END-EVALUATE block."
+ "Variable/TRUE: "
+ ;; This is set like so because cobol--num-conds is incremented even when no str is supplied.
+ '(setf cobol--num-conds -1)
+ > "EVALUATE " str ("Variable/TRUE: "
+ '(setf cobol--num-conds (1+ cobol--num-conds))
+ " ALSO " str)
+ > \n
+ (cobol-when-with-also "Value/Condition: " cobol--num-conds)
+ "END-EVALUATE")
+
+(cobol--def-skeleton "program"
+ "Insert an empty PROGRAM."
+ "Program name: "
+ > "IDENTIFICATION DIVISION." > \n
+ "PROGRAM-ID. " str "." > \n
+ > \n
+ "DATA DIVISION." > \n
+ "WORKING-STORAGE SECTION." > \n
+ > _ \n
+ "PROCEDURE DIVISION." > \n
+ > \n
+ "END PROGRAM " str "." > \n)
+
+(cobol--def-skeleton "function"
+ "Insert an empty FUNCTION."
+ "Function name: "
+ > "IDENTIFICATION DIVISION." > \n
+ "FUNCTION-ID. " str "." > \n
+ > \n
+ "DATA DIVISION." > \n
+ "LOCAL-STORAGE SECTION." > \n
+ > \n
+ "LINKAGE SECTION." > \n
+ > _ \n
+ "PROCEDURE DIVISION RETURNING ." > \n
+ > \n
+ "END FUNCTION " str "." > \n)
+
+(cobol--def-skeleton "method"
+ "Insert an empty METHOD."
+ "Method name: "
+ > "IDENTIFICATION DIVISION." > \n
+ "METHOD-ID. " str "." > \n
+ > \n
+ "DATA DIVISION." > \n
+ "LOCAL-STORAGE SECTION." > \n
+ > _ \n
+ "PROCEDURE DIVISION." > \n
+ > \n
+ "END METHOD " str "." > \n)
+
+(cobol--def-skeleton "class"
+ "Insert an empty CLASS."
+ "Class name: "
+ > "IDENTIFICATION DIVISION." > \n
+ "CLASS-ID. " str "." > \n
+ > _ \n
+ "FACTORY." > \n
+ "END FACTORY." > \n
+ > \n
+ "OBJECT." > \n
+ "END OBJECT." > \n
+ "END CLASS " str "." > \n)
+
+(cobol--def-skeleton "interface"
+ "Insert an empty INTERFACE."
+ "Interface name: "
+ > "IDENTIFICATION DIVISION." > \n
+ "INTERFACE-ID. " str "." > \n
+ > _ \n
+ "FACTORY." > \n
+ "END FACTORY." > \n
+ > \n
+ "OBJECT." > \n
+ "END OBJECT." > \n
+ "END INTERFACE " str "." > \n)
+
+;;; Code formatting
+
+(defconst cobol-formats
+ '(upper-case lower-case capitalised-all capitalised-verbs)
+ "The different formats supported when formatting COBOL code.")
+
+(defcustom cobol-format-style 'upper-case
+ "The type of formatting used when formatting COBOL code."
+ :type (cobol--radio-of-list cobol-formats)
+ :safe (cobol--val-in-list-p cobol-formats))
+
+(defun cobol-format-word (word)
+ "Return WORD formatted according to `cobol-format-style'."
+ (cond
+ ((eql cobol-format-style 'upper-case)
+ (upcase word))
+ ((eql cobol-format-style 'lower-case)
+ (downcase word))
+ ((eql cobol-format-style 'capitalised-all)
+ (capitalize word))
+ ((eql cobol-format-style 'capitalised-verbs)
+ (if (memq word cobol-verbs)
+ (capitalize word)
+ (downcase word)))))
+
+(defun cobol-format-region (beg end)
+ "Format all COBOL words between BEG and END according to
+`cobol-format-style'."
+ (interactive "*r")
+ (cobol-format beg end))
+
+(defun cobol-format-buffer ()
+ "Format all COBOL words in the current buffer according to
+`cobol-format-style'."
+ (interactive "*")
+ (cobol-format (point-min) (point-max)))
+
+(defun cobol-format (beg end)
+ "Format COBOL code between BEG and END according to `cobol-format-style'."
+ (defconst words-to-format
+ (append cobol-directives cobol-verbs cobol-keywords cobol-intrinsics
+ cobol-symbolic-literals))
+
+ (save-excursion
+ (dolist (word words-to-format)
+ (let ((ref-point (point-min)))
+ (goto-char beg)
+ (while (search-forward-regexp (concat "\\<" word "\\>") end t)
+ (when (not (let ((state (parse-partial-sexp ref-point (point))))
+ (or (nth 3 state) (nth 4 state))))
+ (replace-match (cobol-format-word word) t)))))))
+
+;;; Fixed-form formatting
+
+(defun cobol-insert-in-sequence-area (beg end text)
+ "Insert, in the lines between BEG and END, TEXT in the sequence area."
+ (interactive "*r\nsText: ")
+ (when (> (length text) 6)
+ (error "%s is longer than six characters" text))
+ (save-excursion
+ ;; Find rectangle to insert text in.
+ (let (top-left bottom-right)
+ ;; Get top left corner of rectangle.
+ (goto-char beg)
+ (beginning-of-line)
+ (when (< (point) beg)
+ (forward-line 1))
+ (setf top-left (point))
+ ;; Get bottom right corner of rectangle.
+ (while (and (<= (+ (point) 6) end) (not (eobp)))
+ (forward-line 1))
+ (forward-line -1)
+ (setf bottom-right (+ (point) 6))
+ (string-rectangle top-left bottom-right (format "%-6s" text)))))
+
+;;; Indentation
+;; Derived (a long time ago) from the wonderful Emacs Mode Tutorial at
+;; .
+
+(defun cobol--code-start ()
+ "Return the first column code can go in."
+ (if (eq cobol-source-format 'free)
+ 0
+ 7))
+
+;;; Misc
+(defvar cobol-tab-width 4 "Width of a tab for `cobol-mode'.")
+
+(cl-defun cobol--indent (indent &optional (times 1))
+ "Increment INDENT."
+ (+ indent (* times cobol-tab-width)))
+
+(defun cobol--current-indentation ()
+ "Return the indentation of the current line or -1 if the line is within the
+sequence area."
+ (if (< (- (line-end-position) (line-beginning-position)) (cobol--code-start))
+ -1
+ (save-excursion
+ (goto-char (+ (line-beginning-position) (cobol--code-start)))
+ (let ((code-start-position (point)))
+ (skip-syntax-forward " " (line-end-position))
+ (backward-prefix-chars)
+ (- (point) code-start-position)))))
+
+(defun cobol--indent-current ()
+ "Return the current indent level indented once."
+ (cobol--indent (cobol--current-indentation)))
+
+(defun cobol--search-back (fn)
+ "Go back a line at a time, calling FN each time.
+If the car of the return value is non-nil, return the cdr."
+ (save-excursion
+ (cl-do ((ret nil (funcall fn)))
+ ((car ret) (cdr ret))
+ (forward-line -1))))
+
+(cl-defun cobol--search-back-for-indent (str &key with-whitespace)
+ "Return the indent of the previous line starting with the regexp STR (optionally
+after whitespace if WITH-WHITESPACE). If that cannot be found, return 0."
+ (let ((line-re (concat (when with-whitespace cobol--optional-whitespace-re)
+ str)))
+ (cobol--search-back
+ #'(lambda () (cond ((bobp)
+ (cons t 0))
+ ((looking-at line-re)
+ (cons t (cobol--current-indentation))))))))
+
+(defun cobol--indent-of-last-div ()
+ "Return the indent of the last division."
+ (cobol--search-back-for-indent cobol--division-re))
+
+(defun cobol--indent-of-last-div-or-section ()
+ "Return the indent of the preceding division or section."
+ (cobol--search-back-for-indent "\\w+\\s-+\\(DIVISION\\|SECTION\\)\\." :with-whitespace t))
+
+(defun cobol--indent-of-end-marker-match (group)
+ "Return the indent of the start of GROUP."
+ (if (memq (upcase group) cobol--non-id-groups)
+ (cobol--search-back-for-indent
+ (concat group ".") :with-whitespace t)
+ (cobol--search-back-for-indent
+ (cobol--create-id-re group))))
+
+(defun cobol--match-with-leading-whitespace (re str)
+ "Match regexp RE (with optional leading whitespace) against STR."
+ (string-match (concat cobol--optional-leading-whitespace-line-re re)
+ str))
+
+(defun cobol--match-line-with-leading-whitespace (re)
+ "Match regexp RE (with optional leading whitespace) against the current line."
+ (cobol--match-with-leading-whitespace re (thing-at-point 'line)))
+
+(defun cobol--get-level-number (declaration)
+ "Return the level-number of DECLARATION.
+If the declaration does not have a level number, return zero."
+ (string-match cobol--generic-declaration-re declaration)
+ (string-to-number (match-string 1 declaration)))
+
+(defun cobol--indent-of-group-item (wanted-level-num)
+ "Return the indentation of the last item with WANTED-LEVEL-NUM or indented
+from the last item of lower level."
+ (cobol--search-back
+ #'(lambda ()
+ (cond ((looking-at cobol--generic-declaration-re)
+ (let ((level-num (cobol--get-level-number (thing-at-point 'line))))
+ (cond ((eq level-num wanted-level-num)
+ (cons t (cobol--current-indentation)))
+ ((< level-num wanted-level-num)
+ (cons t (cobol--indent-current))))))
+ ((bobp)
+ (cons t 0))))))
+
+(defun cobol--indent-of-declaration (decl)
+ "Return the indentation of the declaration DECL."
+ (let ((level-num (cobol--get-level-number decl)))
+ (if (or (>= 1 level-num) (eq 77 level-num) (eq 66 level-num))
+ ;; If elementary item or FD/SD/RD.
+ (cobol--search-back-for-indent cobol--division-re)
+ ;; Find indent of item with same level or add-indent to previous item of
+ ;; lower level. (This means 88 levels will always be indented to the
+ ;; previous item.)
+ (cobol--indent-of-group-item level-num))))
+
+(defun cobol--indent-from-previous ()
+ "Return what the indent of the current line should be based on previous
+lines."
+ (cobol--search-back
+ #'(lambda ()
+ (cond ((looking-at cobol--env-or-data-div-sections-re)
+ (cons t (cobol--current-indentation)))
+ ((or (looking-at cobol--containing-statement-or-phrase-re)
+ (looking-at cobol--procedure-re)
+ (looking-at cobol--procedure-division-re))
+ (cons t (cobol--indent-current)))
+ ((or (looking-at cobol--verb-re)
+ (looking-at cobol--scope-terminator-re)
+ (looking-at cobol--type-end-marker-re)
+ (looking-at cobol--function-end-marker-re)
+ (looking-at cobol--division-re)
+ (looking-at cobol--generic-declaration-re))
+ (cons t (cobol--current-indentation)))
+ ((bobp)
+ (cons t 0))))))
+
+(defun cobol--phrase-with-not (phrase)
+ "Return regexp matching line with optional NOT and PHRASE."
+ (cobol--with-opt-whitespace-line "\\(NOT\\s-+\\)?" phrase))
+
+(defun cobol--at-phrase (phrase)
+ "Return regexp matching PHRASE with optional AT and NOT."
+ (cobol--phrase-with-not (concat "\\(AT\\s-+\\)?" phrase)))
+
+(defun cobol--on-phrase (phrase)
+ "Return regexp matching PHRASE with optional ON and NOT."
+ (cobol--phrase-with-not (concat "\\(ON\\s-+\\)?" phrase)))
+
+(defun cobol--statements-with-phrase (str)
+ "Return a list of statements taking the phrase STR."
+ (cond ((string-match (cobol--with-opt-whitespace-line "WHEN")
+ str)
+ '("EVALUATE" "SEARCH"))
+ ((string-match (cobol--at-phrase "END-OF-PAGE") str)
+ '("WRITE"))
+ ((string-match (cobol--at-phrase "END") str)
+ ;; An AT END clause is added to OPEN in the XML TR.
+ '("OPEN" "READ" "RETURN" "SEARCH"))
+ ((string-match (cobol--on-phrase "OVERFLOW") str)
+ '("CALL" "STRING" "UNSTRING"))
+ ((string-match (cobol--on-phrase "EXCEPTION") str)
+ '("ACCEPT" "CALL" "DISPLAY"))
+ ((string-match (cobol--on-phrase "ESCAPE") str)
+ '("ACCEPT")) ; MF/ACUCOBOL extension
+ ((string-match (cobol--on-phrase "SIZE\\s-+ERROR") str)
+ '("ADD" "COMPUTE" "DIVIDE" "MULTIPLY" "SUBTRACT"))
+ ((string-match (cobol--phrase-with-not "INVALID\\s-+KEY") str)
+ '("DELETE" "READ" "REWRITE" "START"))
+ (t
+ (error "Invalid phrase"))))
+
+(defun cobol--scope-terminator-statement (scope-terminator)
+ "Return the statement contained in SCOPE-TERMINATOR."
+ (cobol--match-with-leading-whitespace "END-\\(\\w+\\)" scope-terminator)
+ (match-string 1 scope-terminator))
+
+(defun cobol--first-word (str)
+ "Return the first word in STR."
+ (cobol--match-with-leading-whitespace "\\(\\w+\\)" str)
+ (match-string 1 str))
+
+(defun cobol--go-to-open-statement (statements)
+ "Go to the last open (unterminated) statement in STATEMENTS."
+ (let* ((statements-re (regexp-opt statements t))
+ (valid-statement-re (cobol--with-opt-whitespace-line statements-re))
+ (valid-scope-terminator-re cobol--scope-terminator-re)
+ found)
+ (while (not found)
+ (forward-line -1)
+ (cond ((looking-at valid-statement-re)
+ ;; Check the scope-terminator is not on the same line.
+ (let ((scope-terminator
+ (concat "END-" (cobol--first-word (thing-at-point 'line)))))
+ (unless (string-match scope-terminator (thing-at-point 'line))
+ (setf found t))))
+
+ ;; Skip past terminated statements
+ ((looking-at valid-scope-terminator-re)
+ (let ((terminated-statement
+ (cobol--scope-terminator-statement (thing-at-point 'line))))
+ (cobol--go-to-open-statement (list terminated-statement))))
+
+ ;; If no statement is found, stop at beginning of buffer.
+ ((bobp)
+ (setf found t))))))
+
+(defun cobol--indent-of-open-statement (statements)
+ "Return the indent of the last open statement in STATEMENTS."
+ (save-excursion
+ (cobol--go-to-open-statement statements)
+ (cobol--current-indentation)))
+
+(defun cobol--indent-of-containing-statement-or-phrase (str)
+ "Return the indentation of containing statement/phrase in STR."
+ (let ((phrase (upcase (cobol--first-word str))))
+ (cond ((or (string-equal phrase "IF")
+ (string-equal phrase "EVALUATE")
+ (string-equal phrase "PERFORM"))
+ (cobol--indent-from-previous))
+
+ ((string-equal phrase "ELSE")
+ (cobol--indent-of-open-statement '("IF")))
+
+ (t
+ (cobol--indent (cobol--indent-of-open-statement
+ (cobol--statements-with-phrase str)))))))
+
+(defun cobol--get-current-division ()
+ "Return the division containing point as a symbol."
+ (cobol--search-back
+ #'(lambda ()
+ (cond ((looking-at cobol--division-re)
+ (string-match cobol--division-re (thing-at-point 'line))
+ (let ((division (downcase (match-string 1 (thing-at-point 'line)))))
+ (cons t (intern division))))
+
+ ((or (looking-at cobol--end-marker-re)
+ (bobp))
+ (cons t 'identification))))))
+
+(defun cobol--no-instances-of-after-in-division (instance-re after-re division)
+ "Actual implementation of `cobol--no-instances-of'."
+ (and (eq division (cobol--get-current-division))
+ (cobol--search-back
+ #'(lambda ()
+ (cond ((looking-at after-re)
+ (cons t t))
+ ((or (looking-at instance-re)
+ (bobp))
+ (cons t nil)))))))
+
+(defmacro cobol--no-instances-of (re after re2 in division)
+ "Return non-nil if there are no instances of things matched by RE
+between point and the previous instance of RE2.
+Return nil if point is not in DIVISION or if nothing is found.
+Arguments must be in the form 'RE after RE2 in DIVISION' where
+`after' and `in' stand for themselves."
+ (cl-assert (and (eq after 'after)
+ (eq in 'in))
+ nil
+ "Clauses should be in the form 're AFTER re-2 IN division'.")
+ `(cobol--no-instances-of-after-in-division ,re ,re2 ,division))
+
+(defun cobol--in-file-control-p ()
+ "Return whether point is in the FILE-CONTROL paragraph."
+ (cobol--no-instances-of cobol--procedure-re
+ after (cobol--with-opt-whitespace-line "FILE-CONTROL.")
+ in 'environment))
+
+(defun cobol--no-statements-after (re)
+ "Return whether there are any statements between point and the previous
+instance of RE."
+ (cobol--no-instances-of cobol--verb-re
+ after re
+ in 'procedure))
+
+(defun cobol--in-proc-div-param-list-p ()
+ "Return whether point is in the procedure division header parameter list."
+ (cobol--no-statements-after cobol--procedure-division-re))
+
+(defun cobol--in-if-eval-when-or-perform-cond-p ()
+ "Return whether point is in the condition of an IF, EVALUATE or WHEN or in
+the clauses of a non-procedural PERFORM."
+ (cobol--no-statements-after (cobol--with-opt-whitespace-line
+ cobol--phrases-with-double-indent-after)))
+
+(defun cobol--indent-of-last-statement ()
+ "Return the indent of the last statement."
+ (cobol--search-back-for-indent cobol--verb-re))
+
+(defun cobol--indent-of-clauses ()
+ "Return the indentation for a clause at point."
+ (let ((current-division (cobol--get-current-division)))
+ (cond ((eq current-division 'identification)
+ (cobol--indent-from-previous))
+
+ ((eq current-division 'environment)
+ (if (cobol--in-file-control-p)
+ ;; Indent clauses of SELECT.
+ (cobol--indent (cobol--indent-of-last-statement))
+ (cobol--indent-from-previous)))
+
+ ((eq current-division 'data)
+ (- cobol-declaration-clause-indent (cobol--code-start)))
+
+ ((eq current-division 'procedure)
+ (cond ((cobol--in-proc-div-param-list-p)
+ ;; Indent procedure division parameter list twice.
+ (cobol--indent (cobol--search-back-for-indent cobol--procedure-division-re)
+ 2))
+ ((cobol--in-if-eval-when-or-perform-cond-p)
+ ;; Indent after IF/EVALUATE/WHEN/non-procedural PEROFRM twice.
+ (cobol--indent (cobol--search-back-for-indent
+ cobol--phrases-with-double-indent-after
+ :with-whitespace t)
+ 2))
+ ;; Indent once after any other statement.
+ (t
+ (cobol--indent (cobol--indent-of-last-statement))))))))
+
+(defun cobol--looking-at-comment-line ()
+ "Return whether we are looking at a comment line (using `looking-at')."
+ (or (looking-at cobol--free-form-comment-line-re)
+ (when (cobol--fixed-format-p)
+ (looking-at cobol--fixed-form-comment-re))))
+
+(defun cobol--find-indent-of-line ()
+ "Return what the indent of the current line should be."
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at cobol--scope-terminator-re)
+ (let ((matching-statement
+ (cobol--scope-terminator-statement (thing-at-point 'line))))
+ (cobol--indent-of-open-statement (list matching-statement))))
+
+ ((looking-at cobol--procedure-re)
+ (cobol--indent-of-last-div-or-section))
+
+ ((looking-at cobol--end-marker-re)
+ (cobol--match-line-with-leading-whitespace
+ (concat "END" cobol--identifier-re))
+ (let ((group (match-string 1 (thing-at-point 'line))))
+ (cobol--indent-of-end-marker-match group)))
+
+ ((looking-at cobol--division-re)
+ (cobol--indent-of-last-div))
+
+ ((looking-at cobol--generic-declaration-re)
+ (cobol--indent-of-declaration (thing-at-point 'line)))
+
+ ((looking-at cobol--containing-statement-or-phrase-re)
+ (cobol--indent-of-containing-statement-or-phrase
+ (thing-at-point 'line)))
+
+ ((or (cobol--looking-at-comment-line)
+ (looking-at cobol--verb-re)
+ (looking-at cobol--blank-line-re))
+ (cobol--indent-from-previous))
+
+ (t
+ (cobol--indent-of-clauses)))))
+
+(defun cobol--indent-point-to-col (col)
+ "Indent point to COL."
+ ;; FIXME: Use indent-line-to?
+ (cond ((< (current-column) col)
+ (indent-to col))
+ ((> (current-column) col)
+ (delete-char (- col (current-column))))))
+
+(defun cobol--set-line-indent (indent)
+ "Set the indent of the current line to INDENT."
+ (save-excursion
+ (let ((line-length (- (line-end-position) (line-beginning-position)))
+ (end-of-indent (+ (cobol--code-start) indent)))
+ ;; Following lines derived from source of `back-to-indentation'.
+ (move-to-column (cobol--code-start))
+ (if (>= line-length (cobol--code-start) (current-column))
+ (progn
+ (skip-syntax-forward " " (line-end-position))
+ (backward-prefix-chars))
+ (indent-to (cobol--code-start)))
+
+ (cobol--indent-point-to-col end-of-indent))))
+
+(defun cobol--indent-point ()
+ "Indent point to the next multiple of `cobol-tab-width' (relative to the
+start of area A, if fixed-format)."
+ (cobol--indent-point-to-col
+ (+ (current-column) (- cobol-tab-width
+ (% (if (cobol--fixed-format-p)
+ (1+ (current-column))
+ (current-column))
+ cobol-tab-width)))))
+
+(defun cobol-indent-line ()
+ "Indent current line as COBOL code."
+ (interactive "*")
+ (let ((indent (cobol--find-indent-of-line)))
+ (if (not (eq indent (cobol--current-indentation)))
+ (progn
+ (cobol--set-line-indent indent)
+ ;; If in leading whitespace/sequence area, move to first char of code.
+ (when (< (point) (+ (line-beginning-position) (cobol--code-start) indent))
+ (skip-syntax-forward " " (line-end-position))
+ (backward-prefix-chars)))
+ ;; Move to first non-whitespace char
+ (skip-syntax-forward " " (line-end-position))
+ (backward-prefix-chars)
+ ;; SuperBOL/OCamlPro: the following loop was commented to prevent
+ ;; inserting spaces at point
+ ;; Indent stuff at point if not the first word.
+; (when (< (cobol--current-indentation) (- (current-column) (cobol--code-start)))
+; (cobol--indent-point))
+ )))
+
+(defvar cobol-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap back-to-indentation] #'cobol-back-to-indentation)
+ ;;(define-key map (kbd "RET") #'newline-and-indent)
+ map))
+
+(easy-menu-define cobol-mode-menu cobol-mode-map "Menu used for `cobol-mode'."
+ '("COBOL"
+ ("Insert" :filter cobol-skeleton--menu)
+ ;; FIXME: This menu should likely grow a few more entries.
+ ))
+
+(defvar cobol-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?- "w" st)
+ (modify-syntax-entry ?_ "w" st)
+ (modify-syntax-entry ?* ". 1" st)
+ (modify-syntax-entry ?> "w 2" st)
+ (modify-syntax-entry ?\\ "." st)
+ (modify-syntax-entry ?' "\"" st)
+ (modify-syntax-entry ?\" "\"" st)
+ (modify-syntax-entry ?\n ">" st)
+ st))
+
+(defvar ac-ignore-case)
+
+;;;###autoload
+(define-derived-mode cobol-mode prog-mode "COBOL"
+ "COBOL mode is a major mode for handling COBOL files."
+
+ (set (make-local-variable 'font-lock-defaults) cobol-font-lock-defaults)
+
+ (when cobol-tab-width
+ (set (make-local-variable 'tab-width) cobol-tab-width))
+
+ (set (make-local-variable 'indent-tabs-mode) nil)
+
+ (set (make-local-variable 'comment-start-skip)
+ "\\(^.\\{6\\}\\*\\|\\*>\\)\\s-* *")
+ (set (make-local-variable 'comment-start) "*>")
+ (set (make-local-variable 'comment-end) "")
+
+ (set (make-local-variable 'syntax-propertize-function)
+ #'cobol--syntax-propertize-function)
+
+ (set (make-local-variable 'column-number-mode) t)
+
+ (set (make-local-variable 'indent-line-function) #'cobol-indent-line)
+
+ ;; Auto complete mode
+ (set (make-local-variable 'ac-ignore-case) t)
+ )
+
+(provide 'cobol-mode)
+
+;;; cobol-mode.el ends here
diff --git a/import/gnucobol b/import/gnucobol
new file mode 160000
index 000000000..c0d64addf
--- /dev/null
+++ b/import/gnucobol
@@ -0,0 +1 @@
+Subproject commit c0d64addfd83baff21f089e0ab7c92609e291442
diff --git a/import/merlin b/import/merlin
new file mode 160000
index 000000000..56590ff8e
--- /dev/null
+++ b/import/merlin
@@ -0,0 +1 @@
+Subproject commit 56590ff8e477bbd74fb81c55884009b2f19543b3
diff --git a/opam/cobol_ast.opam b/opam/cobol_ast.opam
new file mode 100644
index 000000000..0dcc4abfb
--- /dev/null
+++ b/opam/cobol_ast.opam
@@ -0,0 +1,54 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_ast"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_deriving" {>= "5.2.1"}
+ "cobol_common" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_common.opam b/opam/cobol_common.opam
new file mode 100644
index 000000000..a2476e820
--- /dev/null
+++ b/opam/cobol_common.opam
@@ -0,0 +1,54 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_common"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "pretty" {= version}
+ "ppx_deriving" {>= "5.2.1"}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_config.opam b/opam/cobol_config.opam
new file mode 100644
index 000000000..64bb9980c
--- /dev/null
+++ b/opam/cobol_config.opam
@@ -0,0 +1,56 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_config"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "pretty" {= version}
+ "ppx_deriving" {>= "5.2.1"}
+ "menhir" {>= "1.2"}
+ "cobol_common" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_data.opam b/opam/cobol_data.opam
new file mode 100644
index 000000000..cb98e7ab2
--- /dev/null
+++ b/opam/cobol_data.opam
@@ -0,0 +1,55 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_data"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_deriving" {>= "5.2.1"}
+ "cobol_parser" {= version}
+ "cobol_ast" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_indent.opam b/opam/cobol_indent.opam
new file mode 100644
index 000000000..b8789b7d7
--- /dev/null
+++ b/opam/cobol_indent.opam
@@ -0,0 +1,55 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_indent"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "fmt" {>= "0.9"}
+ "cobol_preproc" {= version}
+ "cobol_common" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_lsp.opam b/opam/cobol_lsp.opam
new file mode 100644
index 000000000..56a4a5453
--- /dev/null
+++ b/opam/cobol_lsp.opam
@@ -0,0 +1,62 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_lsp"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "toml" {>= "7.1.0" & < "8.0.0"}
+ "pretty" {= version}
+ "lsp" {>= "1.15" & < "1.16"}
+ "jsonrpc" {>= "1.15"}
+ "cobol_typeck" {= version}
+ "cobol_parser" {= version}
+ "cobol_indent" {= version}
+ "cobol_data" {= version}
+ "cobol_config" {= version}
+ "cobol_common" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_parser.opam b/opam/cobol_parser.opam
new file mode 100644
index 000000000..a6f748be4
--- /dev/null
+++ b/opam/cobol_parser.opam
@@ -0,0 +1,59 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_parser"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_deriving" {>= "5.2.1"}
+ "menhir" {>= "1.2"}
+ "ez_file" {>= "0.3"}
+ "ebcdic_lib" {= version}
+ "cobol_preproc" {= version}
+ "cobol_common" {= version}
+ "cobol_ast" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_preproc.opam b/opam/cobol_preproc.opam
new file mode 100644
index 000000000..fad10063b
--- /dev/null
+++ b/opam/cobol_preproc.opam
@@ -0,0 +1,56 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_preproc"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_deriving" {>= "5.2.1"}
+ "menhir" {>= "1.2"}
+ "cobol_config" {= version}
+ "cobol_common" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/cobol_typeck.opam b/opam/cobol_typeck.opam
new file mode 100644
index 000000000..901670f05
--- /dev/null
+++ b/opam/cobol_typeck.opam
@@ -0,0 +1,57 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "cobol_typeck"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_deriving" {>= "5.2.1"}
+ "cobol_parser" {= version}
+ "cobol_data" {= version}
+ "cobol_common" {= version}
+ "cobol_ast" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/ebcdic_lib.opam b/opam/ebcdic_lib.opam
new file mode 100644
index 000000000..46f66adcb
--- /dev/null
+++ b/opam/ebcdic_lib.opam
@@ -0,0 +1,52 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "ebcdic_lib"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/ppx_cobcflags.opam b/opam/ppx_cobcflags.opam
new file mode 100644
index 000000000..b98a8f32e
--- /dev/null
+++ b/opam/ppx_cobcflags.opam
@@ -0,0 +1,53 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "ppx_cobcflags"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ppxlib" {>= "0.15"}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/pretty.opam b/opam/pretty.opam
new file mode 100644
index 000000000..50028cafd
--- /dev/null
+++ b/opam/pretty.opam
@@ -0,0 +1,54 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "pretty"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "fmt" {>= "0.9"}
+ "ez_file" {>= "0.3"}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/superbol-free.opam b/opam/superbol-free.opam
new file mode 100644
index 000000000..d4d4ef53e
--- /dev/null
+++ b/opam/superbol-free.opam
@@ -0,0 +1,53 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "superbol-free"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "superbol_free_lib" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/opam/superbol_free_lib.opam b/opam/superbol_free_lib.opam
new file mode 100644
index 000000000..1867f9c79
--- /dev/null
+++ b/opam/superbol_free_lib.opam
@@ -0,0 +1,60 @@
+# This file was generated by `drom` from `drom.toml`.
+# Do not modify, or add to the `skip` field of `drom.toml`.
+opam-version: "2.0"
+name: "superbol_free_lib"
+version: "0.1.0"
+license: "MIT"
+synopsis: "The superbol-vscode-platform project"
+description: """\
+This is the description
+of the superbol-vscode-platform OCaml project
+"""
+authors: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+maintainer: [
+ "Fabrice Le Fessant "
+ "Emilien Lemaire "
+]
+homepage: "https://ocamlpro.github.io/superbol-vscode-platform"
+doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx"
+bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues"
+dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git"
+tags: "org:ocamlpro"
+build: [
+ ["dune" "subst"] {dev}
+ ["sh" "-c" "./scripts/before.sh build '%{name}%'"]
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+ ["sh" "-c" "./scripts/after.sh build '%{name}%'"]
+]
+install: [
+ ["sh" "-c" "./scripts/before.sh install '%{name}%'"]
+]
+depends: [
+ "ocaml" {>= "4.13.0"}
+ "dune" {>= "2.7.0"}
+ "ez_file" {>= "0.3"}
+ "ez_cmdliner" {>= "0.3.0" & < "1.0.0"}
+ "cobol_typeck" {= version}
+ "cobol_parser" {= version}
+ "cobol_lsp" {= version}
+ "cobol_indent" {= version}
+ "cobol_common" {= version}
+ "cobol_ast" {= version}
+ "ppx_inline_test" {with-test}
+ "ppx_expect" {with-test}
+ "odoc" {with-doc}
+ "ocamlformat" {with-test}
+]
+# Content of `opam-trailer` field:
\ No newline at end of file
diff --git a/scripts/before-sphinx.sh b/scripts/before-sphinx.sh
new file mode 100755
index 000000000..5b2851e13
--- /dev/null
+++ b/scripts/before-sphinx.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+./_build/default/src/lsp/superbol-free/main.exe rst > sphinx/commands.rst
diff --git a/sphinx/about.rst b/sphinx/about.rst
index c46364747..a169add7b 100644
--- a/sphinx/about.rst
+++ b/sphinx/about.rst
@@ -1,12 +1,14 @@
About
=====
-This is the description
-of the superbol-vscode-platform OCaml project
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
Authors
-------
+* Nicolas Berthier
+* David Declerck
* Fabrice Le Fessant
* Emilien Lemaire
diff --git a/sphinx/commands.rst b/sphinx/commands.rst
new file mode 100644
index 000000000..f5eba2dc0
--- /dev/null
+++ b/sphinx/commands.rst
@@ -0,0 +1,204 @@
+
+Sub-commands and Arguments
+==========================
+Common arguments to all sub-commands:
+
+
+* :code:`-q` or :code:`--quiet` Set verbosity level to 0
+
+* :code:`-v` or :code:`--verbose` Increase verbosity level
+
+Overview of sub-commands::
+
+ indent file
+ Indentation
+
+ indent range
+ Indentation range
+
+ lsp
+ run LSP server
+
+ pp
+ Preprocess a list of COBOL files, generating a preprocessed file with extension .i for each of them
+
+ texi2rst
+ build .texi documentation from gnucobol-docs
+
+
+main.exe indent file
+~~~~~~~~~~~~~~~~~~~~~~
+
+Indentation
+
+
+
+**DESCRIPTION**
+
+
+
+
+**USAGE**
+::
+
+ main.exe indent file FILES [OPTIONS]
+
+Where options are:
+
+
+* :code:`FILES` Cobol files to indent
+
+* :code:`-I DIRECTORY` Add DIRECTORY to library search path
+
+* :code:`--conf CONF_FILE` Set the configuration file to be used
+
+* :code:`--dialect DIALECT` or :code:`--std DIALECT` Set the dialect to bu used (overriden by `--conf` if used)
+
+* :code:`--free` Shorthand for `--source-format FREE`
+
+* :code:`--indent_config FILE` User defined configuration of indentation
+
+* :code:`--recovery BOOL` Enable/disable parser recovery after syntax errors (default: true)
+
+* :code:`--silence STRING` Silence specific messages
+
+* :code:`--source-format SOURCE_FORMAT` Set the format of source code; allowed values are: { FIXED (the default), FREE}
+Overrides `format` from configuration file if present.
+
+* :code:`--strict` Use the strict configuration
+
+
+main.exe indent range
+~~~~~~~~~~~~~~~~~~~~~~~
+
+Indentation range
+
+
+
+**DESCRIPTION**
+
+
+
+
+**USAGE**
+::
+
+ main.exe indent range FILE RANGE_START RANGE_END [OPTIONS]
+
+Where options are:
+
+
+* :code:`FILE` file to check the indentation
+
+* :code:`RANGE_START` start line of range
+
+* :code:`RANGE_END` end line of range
+
+* :code:`-I DIRECTORY` Add DIRECTORY to library search path
+
+* :code:`--conf CONF_FILE` Set the configuration file to be used
+
+* :code:`--dialect DIALECT` or :code:`--std DIALECT` Set the dialect to bu used (overriden by `--conf` if used)
+
+* :code:`--free` Shorthand for `--source-format FREE`
+
+* :code:`--indent_config FILE` User defined offset table file
+
+* :code:`--recovery BOOL` Enable/disable parser recovery after syntax errors (default: true)
+
+* :code:`--silence STRING` Silence specific messages
+
+* :code:`--source-format SOURCE_FORMAT` Set the format of source code; allowed values are: { FIXED (the default), FREE}
+Overrides `format` from configuration file if present.
+
+* :code:`--strict` Use the strict configuration
+
+
+main.exe lsp
+~~~~~~~~~~~~~~
+
+run LSP server
+
+
+
+**DESCRIPTION**
+
+
+Start a COBOL LSP server
+
+**USAGE**
+::
+
+ main.exe lsp [OPTIONS]
+
+Where options are:
+
+
+
+main.exe pp
+~~~~~~~~~~~~~
+
+Preprocess a list of COBOL files, generating a preprocessed file with extension .i for each of them
+
+
+
+**DESCRIPTION**
+
+
+
+
+**USAGE**
+::
+
+ main.exe pp FILE [OPTIONS]
+
+Where options are:
+
+
+* :code:`FILE` Cobol file to preprocess
+
+* :code:`-I DIRECTORY` Add DIRECTORY to library search path
+
+* :code:`--cobc` Activate cobc specific features
+
+* :code:`--conf CONF_FILE` Set the configuration file to be used
+
+* :code:`--dialect DIALECT` or :code:`--std DIALECT` Set the dialect to bu used (overriden by `--conf` if used)
+
+* :code:`--free` Shorthand for `--source-format FREE`
+
+* :code:`--output FILE` or :code:`-o FILE` Output File (use '-' for stdout)
+
+* :code:`--recovery BOOL` Enable/disable parser recovery after syntax errors (default: true)
+
+* :code:`--silence STRING` Silence specific messages
+
+* :code:`--source-format SOURCE_FORMAT` Set the format of source code; allowed values are: { FIXED (the default), FREE}
+Overrides `format` from configuration file if present.
+
+* :code:`--strict` Use the strict configuration
+
+
+main.exe texi2rst
+~~~~~~~~~~~~~~~~~~~
+
+build .texi documentation from gnucobol-docs
+
+
+
+**DESCRIPTION**
+
+
+Build .texi documentation from gnucobol-docs.
+
+**USAGE**
+::
+
+ main.exe texi2rst FILE [OPTIONS]
+
+Where options are:
+
+
+* :code:`FILE` .texi file
+
+* :code:`-o DIR` Target directory for RST generation
diff --git a/sphinx/conf.py b/sphinx/conf.py
index c4cb173c3..d09a2e675 100644
--- a/sphinx/conf.py
+++ b/sphinx/conf.py
@@ -52,7 +52,7 @@
# General information about the project.
project = 'superbol-vscode-platform'
copyright = 'OCamlPro SAS'
-author = 'Fabrice Le Fessant '
+author = 'Fabrice Le Fessant & Emilien Lemaire '
# The version info for the project you're documenting, acts as replacement for
# |version| and |release|, also used in various other places throughout the
@@ -220,4 +220,4 @@
# entry point for setup
def setup(app):
- app.add_css_file('css/fixes.css')
+ app.add_stylesheet('css/fixes.css')
diff --git a/sphinx/conf.py.drom-tpl b/sphinx/conf.py.drom-tpl
new file mode 100644
index 000000000..0d6be8589
--- /dev/null
+++ b/sphinx/conf.py.drom-tpl
@@ -0,0 +1,223 @@
+#!/usr/bin/env python3
+# -*- coding: utf-8 -*-
+#
+# superbol documentation build configuration file, created by
+# sphinx-quickstart.
+#
+# This file is execfile()d with the current directory set to its
+# containing dir.
+#
+# Note that not all possible configuration values are present in this
+# autogenerated file.
+#
+# All configuration values have a default; values that are commented out
+# serve to show the default.
+
+# If extensions (or modules to document with autodoc) are in another directory,
+# add these directories to sys.path here. If the directory is relative to the
+# documentation root, use os.path.abspath to make it absolute, like shown here.
+#
+# sys.path.insert(0, os.path.abspath('.'))
+
+import os
+import sys
+import datetime
+import subprocess
+from os import environ
+sys.path.insert(0, os.path.abspath('.') + '/_extensions')
+
+# -- General configuration ------------------------------------------------
+
+# If your documentation needs a minimal Sphinx version, state it here.
+#
+# needs_sphinx = '1.0'
+
+# Add any Sphinx extension module names here, as strings. They can be
+# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
+# ones.
+#extensions = ['sphinx.ext.extlinks']
+
+# Add any paths that contain templates here, relative to this directory.
+templates_path = ['_templates']
+
+# The suffix(es) of source filenames.
+# You can specify multiple suffix as a list of string:
+#
+source_suffix = ['.rst', '.md']
+# source_suffix = '.rst'
+
+# The master toctree document.
+master_doc = 'index'
+
+# General information about the project.
+project = 'superbol'
+copyright = 'OCamlPro SAS'
+author = 'Nicolas Berthier & David Declerck & Fabrice Le Fessant & Emilien Lemaire '
+
+# The version info for the project you're documenting, acts as replacement for
+# |version| and |release|, also used in various other places throughout the
+# built documents.
+#
+# The short X.Y version.
+
+git = subprocess.check_output("git describe --always", shell=True).decode("utf-8")
+branch= subprocess.check_output("git rev-parse --abbrev-ref HEAD", shell=True).decode("utf-8")
+version = branch + " (" + git + ")"
+# version = os.environ.get('CI_COMMIT_REF_NAME', 'v1.0')
+# The full version, including alpha/beta/rc tags.
+release = version + datetime.datetime.now().strftime(" (%Y/%m/%d %H:%M)")
+# The language for content autogenerated by Sphinx. Refer to documentation
+# for a list of supported languages.
+#
+# This is also used if you do content translation via gettext catalogs.
+# Usually you set "language" from the command line for these cases.
+language = None
+
+# List of patterns, relative to source directory, that match files and
+# directories to ignore when looking for source files.
+# This patterns also effect to html_static_path and html_extra_path
+exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store', 'doc_gen']
+
+# The name of the Pygments (syntax highlighting) style to use.
+pygments_style = 'lovelace'
+
+# Deactivate syntax highlighting
+# - http://www.sphinx-doc.org/en/stable/markup/code.html#code-examples
+# - http://www.sphinx-doc.org/en/stable/config.html#confval-highlight_language
+highlight_language = 'ocaml'
+# TODO write a Pygments lexer for Michelson
+# cf. http://pygments.org/docs/lexerdevelopment/ and http://pygments.org/docs/lexers/
+
+
+# If true, `todo` and `todoList` produce output, else they produce nothing.
+todo_include_todos = False
+
+
+# -- Options for HTML output ----------------------------------------------
+
+# The theme to use for HTML and HTML Help pages. See the documentation for
+# a list of builtin themes.
+#
+html_theme = "sphinx_rtd_theme"
+
+# Theme options are theme-specific and customize the look and feel of a theme
+# further. For a list of options available for each theme, see the
+# documentation.
+#
+html_theme_options = {'logo_only': True}
+# html_logo = "logo.svg"
+# Add any paths that contain custom static files (such as style sheets) here,
+# relative to this directory. They are copied after the builtin static files,
+# so a file named "default.css" will overwrite the builtin "default.css".
+html_static_path = ['_static']
+
+# Custom sidebar templates, must be a dictionary that maps document names
+# to template names.
+#
+# This is required for the alabaster theme
+# refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars
+# html_sidebars = {
+# '**': [
+# 'relations.html', # needs 'show_related': True theme option to display
+# 'searchbox.html',
+# ]
+# }
+
+
+# -- Options for HTMLHelp output ------------------------------------------
+
+# Output file base name for HTML help builder.
+htmlhelp_basename = 'Liqdoc'
+
+
+# -- Options for LaTeX output ---------------------------------------------
+
+latex_elements = {
+ 'inputenc':'',
+ 'utf8extra': '',
+ 'preamble': r'''
+ \usepackage{fontspec}
+ \IfFontExistsTF{Lato}{\setsansfont{Lato}}{\setsansfont{Arial}}
+ \IfFontExistsTF{Linux Libertine O}{
+ \setromanfont[Scale=1.1]{Linux Libertine O}
+ }{\setromanfont{Times New Roman}}
+ \IfFontExistsTF{DejaVu Sans Mono}{
+ \setmonofont[Scale=MatchLowercase]{DejaVu Sans Mono}
+ }{\setmonofont[Scale=MatchLowercase]{Courier}}
+ ''',
+
+ # The paper size ('letterpaper' or 'a4paper').
+ #
+ # 'papersize': 'letterpaper',
+
+ # The font size ('10pt', '11pt' or '12pt').
+ #
+ # 'pointsize': '10pt',
+
+ # Additional stuff for the LaTeX preamble.
+ #
+ # 'preamble': '',
+
+ # Latex figure (float) alignment
+ #
+ # 'figure_align': 'htbp',
+}
+
+# Grouping the document tree into LaTeX files. List of tuples
+# (source start file, target name, title,
+# author, documentclass [howto, manual, or own class]).
+latex_documents = [
+ (master_doc, 'superbol.tex', 'superbol Documentation',
+ 'author', 'manual'),
+]
+
+
+# -- Options for manual page output ---------------------------------------
+
+# One entry per manual page. List of tuples
+# (source start file, name, description, authors, manual section).
+man_pages = [
+ (master_doc, 'superbol', 'superbol Documentation',
+ [author], 1)
+]
+
+
+# -- Options for Texinfo output -------------------------------------------
+
+# Grouping the document tree into Texinfo files. List of tuples
+# (source start file, target name, title, author,
+# dir menu entry, description, category)
+texinfo_documents = [
+ (master_doc, 'superbol', 'superbol Documentation',
+ author, 'superbol', 'One line description of project.',
+ 'Miscellaneous'),
+]
+
+# -- Ignore fragments in linkcheck
+
+linkcheck_anchors = False
+
+
+# -- Options for Epub output -------------------------------------------------
+
+# Bibliographic Dublin Core info.
+epub_title = project
+epub_author = author
+epub_publisher = author
+epub_copyright = copyright
+
+# The unique identifier of the text. This can be a ISBN number
+# or the project homepage.
+#
+# epub_identifier = ''
+
+# A unique identification for the text.
+#
+# epub_uid = ''
+
+# A list of files that should not be packed into the epub file.
+epub_exclude_files = ['search.html']
+
+# entry point for setup
+def setup(app):
+ app.add_css_file('css/fixes.css')
diff --git a/sphinx/debug.rst b/sphinx/debug.rst
new file mode 100644
index 000000000..28227acb5
--- /dev/null
+++ b/sphinx/debug.rst
@@ -0,0 +1,177 @@
+Superbol VSCode Debug
+=====================
+
+This extension is used debug and check coverage of your COBOL code. It must be used with :code:`Superbol VSCode Platform`
+to recognize the :code:`COBOL` files.
+
+Usage
+-----
+
+If you do not already have a configuration, go to the :code:`Run and Debug` pane (:code:`Ctrl + Shift + D`),
+
+Click on :code:`Show all automatic debug configurations` and select :code:`Add configuration...`
+and :code:`COBOL Debugger`.
+
+This will add the necessary configurations to your :code:`launch.json` file (or create it if needed).
+
+Once you have your debugging configuration (see :ref:`configuration`), you can launch debugging
+by pressing :code:`F5` while being in the COBOL file you wish to debug.
+
+TODO: screenshots.
+
+Extension settings
+------------------
+
+These settings are to be modified by going to :code:`File` > :code:`Preferences` > :code:`Settings`
+
+Then select the :code:`Extensions` submenu and select :code:`Superbol Debugger`.
+
+:code:`cobcpath` [1]_
+^^^^^^^^^^^^^^^^^^^^^
+
+This is the path to the :code:`cobc` executable, which will be used to build your application.
+
+Default is :code:`cobc`.
+
+:code:`gdbpath`
+^^^^^^^^^^^^^^^
+
+This is the path to the :code:`gdb` executable, which will be used to launch the debugger.
+
+Default is :code:`gdb`.
+
+:code:`target`
+^^^^^^^^^^^^^^
+
+This is the path to your source code, it is relative to the VSCode workspace (or it can
+be an absolute path). This will be overriden by the :code:`target` field in the debugging
+configurations if specified (cf. next section).
+
+Default is :code:`${file}`.
+
+:code:`cwd`
+^^^^^^^^^^^
+
+This is the root directory of your project. This will be overriden by the :code:`cwd` field in
+the debugging configurations if specified (cf. next section).
+
+Default is :code:`${workspaceRoot}`.
+
+:code:`display_variable_attributes`
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+Set this to :code:`true` if you want to display data storages and fields attributes (e.g. size of
+alphanumerics or digits and scale of numerics).
+
+Default is :code:`false`.
+
+.. _configuration:
+
+Debugging configurations
+------------------------
+
+These configurations are to be added in your :code:`.vscode/launch.json` file. There are two
+types of configurations: :code:`launch` and :code:`attach`.
+Attach can be :code:`local` or :code:`remote`.
+
+.. _launch:
+
+:code:`launch` Configuration
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+This configuration is used to launch the compiled program with the debugger. This configuration
+has the following defaults:
+
+.. code-block:: json
+
+ {
+ "name": "Superbol debugger",
+ "type": "gdb",
+ "request": "launch",
+ "target": "${file}",
+ "arguments": null,
+ "cwd": "${workspaceRoot}",
+ "gdbpath": "gdb",
+ "cobcpath": "cobc",
+ "cobcargs": [
+ "-free",
+ "-x"
+ ],
+ "group": [],
+ "env": null,
+ "coverage": true,
+ "verbose": false
+ }
+
+The minimal configuration is as follow (all missing elements are either using the extension
+settings value if they exists or the default value given just above):
+
+.. code-block:: json
+
+ {
+ "name": "Superbol debugger",
+ "type": "gdb",
+ "request": "launch",
+ }
+
+The items of the configuration have the following effects:
+
+* :code:`target`: changes the target to be executed with the debugger;
+* :code:`arguments`: the arguments that the debugger will pass to the target;
+* :code:`cwd`: the path to the project root;
+* :code:`gdbpath`: the path to the :code:`gdb` executable;
+* :code:`cobcpath`: the path to the :code:`cobc` executable [1]_;
+* :code:`cobcargs`: the arguments to pass to :code:`cobc` [1]_;
+* :code:`group`: other files in the compilation group (other than :code:`target`) [1]_;
+* :code:`env`: an object containing environment variables
+* :code:`coverage`: weither to show the coverage of the debugged file;
+* :code:`verbose`: show the debugger output in the :code:`Debug Console` view (for debugging only).
+
+:code:`attach` Configuration
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The default configuration is as follow:
+
+.. code-block:: json
+
+ {
+ "name": "Superbol debugger",
+ "type": "gdb",
+ "request": "launch",
+ "target": "${file}",
+ "arguments": null,
+ "cwd": "${workspaceRoot}",
+ "gdbpath": "gdb",
+ "cobcpath": "cobc",
+ "cobcargs": [
+ "-free",
+ "-x"
+ ],
+ "group": [],
+ "env": null,
+ "coverage": true,
+ "verbose": false,
+ "pid": null,
+ "remoteDebugger": null
+ }
+
+However this configuration will not work, as either :code:`pid` or :code:`remoteDebugger` must
+have a value. All other values have the same usage as in :ref:`launch`.
+
+* :code:`pid`: The id of the process to attach to in a local attach configuration;
+* :code:`remoteDebugger`: The address of the :code:`gdb` server to attach to, with format :code:`host:port`.
+
+Coverage
+--------
+
+If you are running the debugger with a :code:`launch` request and set :code:`coverage` to :code:`true`,
+then once the debugger has stopped running, you will see the coverage status of every line in the
+:code:`PROCEDURE DIVISION`.
+
+A red line signifies that the line is never runned.
+
+A green line signifies that the line is runned.
+
+----
+
+.. [1] These options are to be removed to use the :code:`Superbol VSCode Platform` build tasks.
diff --git a/sphinx/emacs.rst b/sphinx/emacs.rst
new file mode 100644
index 000000000..e4c52f965
--- /dev/null
+++ b/sphinx/emacs.rst
@@ -0,0 +1,48 @@
+Emacs modes
+===========
+
+Standard file :code:`cobol-mode.el`
+-----------------------------------
+
+We provide our own fork of :code:`cobol-mode.el` from ELPA, with a fix
+on the indentation function preventing insertion of spaces at point.
+
+Installation
+~~~~~~~~~~~~
+
+Copy the file :code:`cobol-mode.el` to your :code:`$HOME/.emacs.d/`
+directory, and add the following lines to your :code:`$HOME/.emacs` file::
+
+ (autoload 'cobol-mode "cobol-mode")
+ (setq cobol-tab-width 3)
+ (setq auto-mode-alist
+ (append
+ '(("\\.cob\\'" . cobol-mode)
+ ("\\.cbl\\'" . cobol-mode)
+ ("\\.cpy\\'" . cobol-mode))
+ auto-mode-alist))
+ (setq cobol-source-format 'free)
+
+This configuration will set tabulations to be 3 spaces and free source
+format. If you want to change the source format, you will need to
+change this option using :code:`M-x customize`, save and then restart emacs.
+
+Features
+~~~~~~~~
+
+The :code:`cobol-mode.el` provides a following features:
+
+* colorization
+* indentation
+* comments
+* rulers
+* a COBOL menu with an item "Insert" with a few constructions
+
+Customization
+~~~~~~~~~~~~~
+
+* cobol-skeleton-alist (check the `cobol--def-skeleton` function)
+
+We advise to also use the :code:`auto-complete` mode also. This mode
+will propose completions while typing keywords (use TAB or RET to
+complete).
diff --git a/sphinx/index.rst b/sphinx/index.rst
index d9ac5dd76..5e0fd679d 100644
--- a/sphinx/index.rst
+++ b/sphinx/index.rst
@@ -13,9 +13,6 @@ Welcome to superbol-vscode-platform
Home
about
install
- settings
- features
- tasks
API doc
license
diff --git a/sphinx/install-vscode.rst b/sphinx/install-vscode.rst
new file mode 100644
index 000000000..546ab4808
--- /dev/null
+++ b/sphinx/install-vscode.rst
@@ -0,0 +1,38 @@
+Install VSCode extensions
+=========================
+
+From marketplace
+----------------
+
+TODO
+
+From :code:`.vsix` files
+------------------------
+
+You can build the vsix files from source. For :code:`superbol-vscode-platform`, run the following
+commands:
+
+.. code-block:: shell
+
+ yarn install #if not already done
+ drom build
+ make compile
+ yarn package
+
+For :code:`superbol-vscode-debug`, run the follwing command:
+
+.. code-block:: shell
+
+ yarn compile
+ vsce package
+
+With those commands you should have respectively :code:`superbol-vscode-platform.vsix` and
+:code:`superbol-vscode-debug.vsix` in the project root directory.
+
+To install them open VSCode and go the the :code:`Extensions` view.
+
+Click on the :code:`...` at the top right of the left pane and select :code:`Install from VSIX ...`.
+
+Select the :code:`superbol-vscode-debug.vsix` file first to install it.
+
+Finally select the :code:`superbol-vscode-platform.vsix` file to install it.
diff --git a/sphinx/install.rst b/sphinx/install.rst
index 027ceae17..69a8100e1 100644
--- a/sphinx/install.rst
+++ b/sphinx/install.rst
@@ -1,5 +1,42 @@
How to install
==============
-Please check `README.md `_ for
-installation guidelines.
+Install with :code:`opam`
+-------------------------
+
+If :code:`superbol-vscode-platform` is available in your opam repository, you can just call::
+
+ opam install superbol-vscode-platform
+
+Build and install with :code:`dune`
+-----------------------------------
+
+Checkout the sources of :code:`superbol-vscode-platform` in a directory.
+
+You need a switch with at least version :code:`4.13.0` of OCaml,
+you can for example create it with::
+
+ opam switch create 4.13.0
+
+Then, you need to install all the dependencies::
+
+ opam install --deps-only .
+
+Finally, you can build the package and install it::
+
+ eval $(opam env)
+ dune build
+ dune install
+
+Note that a :code:`Makefile` is provided, it contains the following
+targets:
+
+* :code:`build`: build the code
+* :code:`install`: install the generated files
+* :code:`build-deps`: install opam dependencies
+* :code:`sphinx`: build sphinx documentation (from the :code:`sphinx/` directory)
+* :code:`dev-deps`: build development dependencies, in particular
+ :code:`ocamlformat`, :code:`odoc` and :code:`merlin`
+* :code:`doc`: build documentation with :code:`odoc`
+* :code:`fmt`: format the code using :code:`ocamlformat`
+* :code:`test`: run tests
diff --git a/sphinx/lsp.rst b/sphinx/lsp.rst
new file mode 100644
index 000000000..038aff71f
--- /dev/null
+++ b/sphinx/lsp.rst
@@ -0,0 +1,146 @@
+LSP Server
+==========
+
+*Superbol* provides an LSP server for COBOL. Every dialect supported by superbol is supported by the LSP server.
+
+The server operates on the notion of *projects*, that bundle COBOL source files within a *root directory*, along with a configuration.
+
+Project layout
+--------------
+
+A project layout associates a configuration given in a file named :file:`superbol.toml` that is located at the root of the project, with a set of files that contain COBOL source code. A typical structure for a project may look as follows:
+
+.. code-block:: text
+
+ project
+ ├── superbol.toml
+ ├── src
+ │ └── prog1.cob
+ │ └── prog2.cob
+ │ └── ...
+ └── COPY
+ └── copy1.cpy
+ └── copy2.cpy
+ └── ...
+
+When a user opens any file that contains COBOL source code, the LSP server looks for the closest parent directory :file:`dir` that directly contains a configuration file :file:`superbol.toml`, and sets :file:`dir` as the root project directory for that file. If no configuration file is found, the project's root is defined as the directory that directly contains the opened file.
+
+.. note::
+ Note that files from distinct projects may be edited all at once via the same LSP server.
+
+
+Project configuration
+---------------------
+
+The :file:`superbol.toml` at the root of a project is a `TOML`_ file that defines the following configuration fields for the project:
+
+* :code:`dialect`: Sets the dialect for your project. Possible values are:
+
+ * :code:`"default"` (default if not provided)
+ * :code:`"COBOL85"`
+ * :code:`"GnuCOBOL"`
+ * :code:`"MicroFocus"` or :code:`"MF"`
+ * :code:`"ACU"`
+ * :code:`"GCOS"`
+ * :code:`"IBM"`
+
+* :code:`strict`: Whether to use the strict configuration for the dialect (default is :code:`false`)
+
+* :code:`source-format`: Select a specific COBOL source format. Possible values are:
+
+ * :code:`"Auto"` (default)
+ * :code:`"Free"`
+ * :code:`"Fixed"`
+ * :code:`"Variable"`
+ * :code:`"XOpen"`
+ * :code:`"xCard"`
+ * :code:`"CRT"`
+ * :code:`"Terminal"`
+ * :code:`"COBOLX"`
+
+* :code:`copybook`: This array is to be filled with all the directories where copybooks are located. It only contains the current working directory by default. Each element of the array must have a :code:`dir` field. This field may contain the name of a directory that is either:
+ 1. relative to the project root; or
+ 2. relative to the directory that contains the COBOL source file that defines the compilation group (when the associated Boolean field :code:`file-relative` holds).
+
+Every value given as a string for a configuration field is case insensitive, except when it describes a file or directory name.
+
+
+Example configuration
+^^^^^^^^^^^^^^^^^^^^^
+
+Consider the following project layout:
+
+.. code-block:: text
+
+ project
+ ├── superbol.toml
+ ├── GLOBAL_COPYBOOKS
+ │ └── global.cpy
+ └── src
+ ├── prog1
+ │ ├── LOCAL_COPYBOOKS
+ │ │ └── local.cpy
+ │ └── prog1.cob
+ └── prog2
+ ├── LOCAL_COPYBOOKS
+ │ └── local.cpy
+ └── prog2.cob
+
+
+Then you can provide the following configuration file:
+
+.. code-block:: toml
+ :caption: :file:`superbol.toml`
+
+ dialect = "GCOS"
+ strict = false
+ source-format = "COBOLX"
+
+ [[copybook]]
+ dir = "GLOBAL_COPYBOOKS"
+
+ [[copybook]]
+ dir = "LOCAL_COPYBOOKS"
+ file-relative = true
+
+All COBOL code in this project will be considered in GCOS dialect and written in COBOLX source format.
+
+In addition, the copybook :file:`global.cpy` can be used by any source file from this project.
+Furthermore, a :code:`COPY "local.cpy"` in :file:`prog1.cob` will include the copybook :file:`src/prog1/LOCAL_COPYBOOKS/local.copy` (and respectively for :file:`prog2.cob` and :file:`src/prog2/LOCAL_COPYBOOKS/local.copy`).
+
+Server capabilities
+-------------------
+
+This is a list of all the capabilities the server has, to see how they are used in VSCode, you
+can check the :code:`Superbol` extension documentation `here `_.
+
+Go to definition
+^^^^^^^^^^^^^^^^
+
+The server handles the :code:`textDocument/definition` request, and can find definition of any
+data item in your code.
+
+Find references
+^^^^^^^^^^^^^^^
+
+The server can list all the references to a data item in your code with the :code:`textDocument/references`
+request
+
+Code formatting
+^^^^^^^^^^^^^^^
+
+The server provides a formatter both for the full file or for a selection range. This formatter handles
+the :code:`FIXED` and :code:`FREE` format.
+
+Hover
+^^^^^
+
+The server provides a way to peek into copybooks via the :code:`textDocument/hover` request (more
+hovering features to come)
+
+Semantic tokens
+^^^^^^^^^^^^^^^
+
+The server can provide semantic tokens data via the :code:`textDocument/semanticTokens/full` request.
+
+.. _TOML: https://toml.io/
diff --git a/sphinx/platform.rst b/sphinx/platform.rst
new file mode 100644
index 000000000..61a91de81
--- /dev/null
+++ b/sphinx/platform.rst
@@ -0,0 +1,107 @@
+Superbol VSCode Platform
+========================
+
+This VSCode extension is used to interface VSCode with the Superbol LSP Server and provides building
+tasks for your COBOL projects.
+
+The extension can be used as a standalone, but is required for the `Superbol VSCode Extension` to
+work.
+
+Tasks
+-----
+We provide a task definition to build your COBOL files.
+The task is defined as follow:
+
+.. code-block:: json
+
+ {
+ "type": "superbol",
+ "copybooks": [],
+ "sourceFormat": "",
+ "dialect": "",
+ "extensions": [],
+ "forDebugging": false,
+ "problemMatcher": [],
+ "label": "superbol: Build file",
+ "group": {
+ "kind": "build",
+ "isDefault": true
+ }
+ }
+
+You can fill the fields with the following values:
+
+* :code:`copybooks`: an array of string, each string must point a to a directory with copybooks
+ inside
+* :code:`sourceFormat`: a string for the COBOL source format to be used by the compiler
+* :code:`dialect`: the dialect to be used by the compiler
+* :code:`extensions`: file extensions to resolve COPY (without the leading :code:`.`)
+* :code:`forDebugging`: if true then the compiler is :code:`cobcd`, otherwise :code:`cobc`.
+
+To trigger the building task just push :code:`Ctrl + Shift + B`.
+
+Settings
+--------
+
+The settings for the extension are to be modified by going to :code:`File` > :code:`Preferences` >
+:code:`Settings`.
+
+Then select the :code:`Extension` submenu and select :code:`Superbol COBOL`.
+
+:code:`Path`
+^^^^^^^^^^^^
+
+This is the path to the :code:`superbol` executable.
+
+Superbol extension features
+---------------------------
+
+Go to definition
+^^^^^^^^^^^^^^^^
+
+You can navigate to the defintion of any variable in your code. Push :code:`F12` on a variable name to go
+to it's defintion. This works on:
+* every variable in the :code:`PROCEDURE DIVISION`,
+* every variable that is on a :code:`RENAME` clause,
+* every variable that is used by a :code:`REDEFINES` clause
+
+Go to references
+^^^^^^^^^^^^^^^^
+
+You can have a list of references of every variables in your code. Push :code:`Shift + F12` on a variable
+name to find all the places it is referenced.
+
+Semantic highlight
+^^^^^^^^^^^^^^^^^^
+
+The extension understands your code on a semantic level, giving you better highlighting to make
+reading your code easier and focus on the important information of the source code.
+
+Peek copy
+^^^^^^^^^
+
+Place your cursor on :code:`COPY` statement and a pop up with the content of the copied file will
+appear, giving you all the information you need to understand the code at a glance.
+
+Indentation
+^^^^^^^^^^^
+
+You can indent your code for a better understanding of the control flow at a glance. Simply push
+:code:`Ctrl + Shift + I` and all the file is indented.
+
+You can also just select a part of your code and push the same shortcut just to indent the selection.
+
+Keyboard shortcuts
+^^^^^^^^^^^^^^^^^^
+
+========================================= ===============================================================================================================
+Shortcut Action
+========================================= ===============================================================================================================
+:code:`F12` Go to the defintion of the item under cursor
+:code:`Shift + F12` | List all references of the item under cursor.
+ If there is only one other reference then navigate directly to it
+:code:`Ctrl + Shift + I` (no selection) Format the whole file
+:code:`Ctrl + Shift + I` (with selection) Format the selection
+:code:`Mouse hover` If on a :code:`COPY` statement peek the content of the copied file.
+========================================= ===============================================================================================================
+
diff --git a/src/lsp/cobol_ast/README.md b/src/lsp/cobol_ast/README.md
new file mode 100644
index 000000000..e1336f717
--- /dev/null
+++ b/src/lsp/cobol_ast/README.md
@@ -0,0 +1,40 @@
+# Cobol_ast package
+
+This package contains the abstract versions of the AST, to be specialized in other packages.
+
+For API documentation, please see [index.mld].
+
+## Toplevel module
+
+* cobol_ast.ml
+
+## AST Definition
+
+* ast.ml: includes
+
+ * simple_statements.ml
+ * branching_statements.ml
+ * data_descr.ml
+ * misc_descr.ml
+ * terms.ml
+ * numericals.ml
+ * operands.ml
+
+* raw.ml : defines divisions over AST
+
+## Helpers and Visitors
+
+* traveral.ml
+* helpers.ml
+* raw_visitor.ml: main visitor entry point
+ * raw_compilation_group_visitor.ml: visitor on compilation groups
+ * raw_data_division_visitor.ml
+ * raw_data_sections_visitor.ml
+ * raw_misc_sections_visitor.ml
+ * raw_proc_division_visitor.ml
+ * raw_statements_visitor.ml
+* operands_visitor.ml
+* terms_visitor.ml
+
+* abstract.ml: module types with abstract types
+* abstract_visitor.ml: classes of visitors with abstract types
diff --git a/src/lsp/cobol_ast/abstract.ml b/src/lsp/cobol_ast/abstract.ml
new file mode 100644
index 000000000..bda19ab06
--- /dev/null
+++ b/src/lsp/cobol_ast/abstract.ml
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module type MISC_SECTIONS = sig
+ (* IDENTIFICATION_DIVISION *)
+ type informational_paragraphs [@@deriving show]
+ type options_paragraph [@@deriving show]
+ type environment_division [@@deriving show]
+end
+
+module type PICTURE = sig
+ type picture [@@deriving show]
+end
+
+module type DATA_SECTIONS = sig
+ type working_storage_section [@@deriving show]
+ type linkage_section [@@deriving show]
+ type file_section [@@deriving show]
+ type communication_section [@@deriving show]
+ type local_storage_section [@@deriving show]
+ type report_section [@@deriving show]
+ type screen_section [@@deriving show]
+end
+
+module type DATA_DIVISION = sig
+ (* NOTE: could become PROG_DIVISIONS if relevant *)
+ type data_division [@@deriving show]
+end
+
+module type STATEMENTS = sig
+ type statement [@@deriving show]
+ type statements [@@deriving show]
+end
+
+module type PROC_DIVISION = sig
+ type procedure_division [@@deriving show]
+end
+
+module type COMPILATION_GROUP = sig
+ type compilation_group [@@deriving show]
+end
diff --git a/src/lsp/cobol_ast/abstract_visitor.ml b/src/lsp/cobol_ast/abstract_visitor.ml
new file mode 100644
index 000000000..508f113eb
--- /dev/null
+++ b/src/lsp/cobol_ast/abstract_visitor.ml
@@ -0,0 +1,91 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Generic visitors for selected AST abstractions *)
+
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Visitor
+
+module For_misc_sections (Misc_sections: Abstract.MISC_SECTIONS) = struct
+ open Misc_sections
+ class virtual ['a] folder = object
+ method fold_informational_paragraphs: (informational_paragraphs, 'a) fold = default
+ method fold_options_paragraph: (options_paragraph, 'a) fold = default
+ method fold_environment_division: (environment_division, 'a) fold = default
+ method virtual continue_with_informational_paragraphs: informational_paragraphs -> 'a -> 'a
+ method virtual continue_with_options_paragraph: options_paragraph -> 'a -> 'a
+ method virtual continue_with_environment_division: environment_division -> 'a -> 'a
+ end
+end
+
+module For_picture (Picture: Abstract.PICTURE) = struct
+ open Picture
+ class virtual ['a] folder = object
+ method fold_picture: (picture, 'a) fold = default
+ method virtual continue_with_picture: picture -> 'a -> 'a
+ end
+end
+
+module For_data_sections (Data_sections: Abstract.DATA_SECTIONS) = struct
+ open Data_sections
+ class virtual ['a] folder = object
+ method fold_working_storage_section: (working_storage_section, 'a) fold = default
+ method fold_linkage_section : (linkage_section , 'a) fold = default
+ method fold_file_section : (file_section , 'a) fold = default
+ method fold_communication_section : (communication_section , 'a) fold = default
+ method fold_local_storage_section : (local_storage_section , 'a) fold = default
+ method fold_report_section : (report_section , 'a) fold = default
+ method fold_screen_section : (screen_section , 'a) fold = default
+ method virtual continue_with_working_storage_section: working_storage_section -> 'a -> 'a
+ method virtual continue_with_linkage_section : linkage_section -> 'a -> 'a
+ method virtual continue_with_file_section : file_section -> 'a -> 'a
+ method virtual continue_with_communication_section : communication_section -> 'a -> 'a
+ method virtual continue_with_local_storage_section : local_storage_section -> 'a -> 'a
+ method virtual continue_with_report_section : report_section -> 'a -> 'a
+ method virtual continue_with_screen_section : screen_section -> 'a -> 'a
+ end
+end
+
+module For_data_division (Data_division: Abstract.DATA_DIVISION) = struct
+ open Data_division
+ class virtual ['a] folder = object
+ method fold_data_division: (data_division, 'a) fold = default
+ method virtual continue_with_data_division: data_division -> 'a -> 'a
+ end
+end
+
+module For_statements (Statements: Abstract.STATEMENTS) = struct
+ open Statements
+ class virtual ['a] folder = object
+ method fold_statement': (statement with_loc, 'a) fold = default
+ method fold_statements': (statements with_loc, 'a) fold = default
+ method virtual continue_with_statement': statement with_loc -> 'a -> 'a
+ method virtual continue_with_statements': statements with_loc -> 'a -> 'a
+ end
+end
+
+module For_proc_division (Proc_division: Abstract.PROC_DIVISION) = struct
+ open Proc_division
+ class virtual ['a] folder = object
+ method fold_procedure_division: (procedure_division, 'a) fold = default
+ method virtual continue_with_procedure_division: procedure_division -> 'a -> 'a
+ end
+end
+
+module For_compilation_group (Compilation_group: Abstract.COMPILATION_GROUP) = struct
+ open Compilation_group
+ class virtual ['a] folder = object
+ method fold_compilation_group: (compilation_group, 'a) fold = default
+ (* method virtual continue_with_compilation_group : compilation_group -> 'a -> 'a *)
+ end
+end
diff --git a/src/lsp/cobol_ast/ast.ml b/src/lsp/cobol_ast/ast.ml
new file mode 100644
index 000000000..684009dff
--- /dev/null
+++ b/src/lsp/cobol_ast/ast.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+include Terms
+include Operands
+include Simple_statements
+include Branching_statements
+include Data_descr
+include Misc_descr
diff --git a/src/lsp/cobol_ast/branching_statements.ml b/src/lsp/cobol_ast/branching_statements.ml
new file mode 100644
index 000000000..5a635cfc9
--- /dev/null
+++ b/src/lsp/cobol_ast/branching_statements.ml
@@ -0,0 +1,458 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Potentially branching statements *)
+
+open Terms
+open Operands
+open Simple_statements
+
+
+(* GOTO DEPENDING *)
+type goto_depending_stmt =
+ {
+ goto_depending_targets: qualname list; (* procedures *)
+ goto_depending_on: ident;
+ }
+[@@deriving show, ord]
+
+
+(* Error/exception handlers *)
+type handler =
+ statements
+[@@deriving show, ord]
+
+and dual_handler =
+ {
+ dual_handler_pos: handler; (** positive case *)
+ dual_handler_neg: handler; (** negative case *)
+ }
+[@@deriving show, ord]
+
+
+(* EVAL *)
+and evaluate_stmt =
+ {
+ eval_subjects: selection_subject list;
+ eval_branches: evaluate_branch list;
+ eval_otherwise: statements;
+ }
+[@@deriving show, ord]
+
+and evaluate_branch =
+ {
+ eval_selection: selection_object list list;
+ eval_actions: statements;
+ }
+[@@deriving show, ord]
+
+
+(* PERFORM *)
+and perform_stmt =
+ {
+ perform_target: perform_target;
+ perform_mode: perform_mode option;
+ }
+[@@deriving show, ord]
+
+and perform_target =
+ | PerformOutOfLine of qualname procedure_range
+ | PerformInline of statements
+[@@deriving show, ord]
+
+and perform_mode =
+ | PerformNTimes of ident_or_intlit
+ | PerformUntil of
+ {
+ with_test: stage option;
+ until: condition;
+ }
+ | PerformVarying of
+ {
+ with_test: stage option;
+ varying: varying_phrase with_loc;
+ after: varying_phrase with_loc list;
+ }
+[@@deriving show, ord]
+
+and varying_phrase =
+ {
+ varying_ident: ident;
+ varying_from: ident_or_numlit;
+ varying_by: ident_or_numlit option;
+ varying_until: condition;
+ }
+[@@deriving show, ord]
+
+
+(* SEARCH *)
+and search_stmt =
+ {
+ search_item: qualname;
+ search_at_end: handler;
+ search_spec: search_spec;
+ }
+[@@deriving show, ord]
+
+and search_spec =
+ | SearchSerial of
+ {
+ varying: ident option;
+ when_clauses: search_when_clause with_loc list;
+ }
+ | SearchAll of
+ {
+ conditions: search_condition list;
+ action: branch;
+ }
+[@@deriving show, ord]
+
+and search_when_clause =
+ {
+ search_when_cond: condition;
+ search_when_stmts: branch;
+ }
+[@@deriving show, ord]
+
+
+(* IF *)
+and if_stmt =
+ {
+ condition: condition;
+ then_branch: branch;
+ else_branch: branch option;
+ }
+[@@deriving show, ord]
+
+
+(* ACCEPT *)
+and accept_stmt =
+ | AcceptGeneric of ident with_loc
+ | AcceptFromDevice of
+ {
+ item: ident with_loc;
+ device_item: name with_loc;
+ }
+ | AcceptTemporal of
+ {
+ item: ident with_loc;
+ date_time: date_time;
+ }
+ | AcceptMsgCount of name with_loc
+ | AcceptAtScreen of
+ {
+ item: name with_loc;
+ position: position option;
+ on_exception: dual_handler;
+ }
+ | AcceptFromEnv of (* MF *)
+ {
+ item: ident with_loc;
+ env_item: ident_or_nonnum with_loc;
+ on_exception: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(*
+DISPLAY id/lit+ UPON...? WITH...? END_DISP
+DISPLAY id AT...? ON EXCEPT?
+*)
+
+and display_stmt =
+ | DisplayDefault of ident_or_literal
+ | DisplayDevice of
+ {
+ displayed_items: ident_or_literal list; (* non-empty *)
+ upon: display_target with_loc option;
+ advancing: bool;
+ }
+ | DisplayScreen of
+ {
+ screen_item: name with_loc;
+ position: position option;
+ on_exception: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+and display_target =
+ | DisplayUponName of name with_loc
+ | DisplayUponDeviceViaMnemonic of display_device_mnemonic with_loc
+
+and display_device_mnemonic =
+ | DisplayDeviceEnvName
+ | DisplayDeviceEnvValue
+ | DisplayDeviceArgNumber
+ | DisplayDeviceCommandLine
+
+
+(* ADD & SUBTRACT *)
+and basic_arithmetic_stmt =
+ {
+ basic_arith_operands: basic_arithmetic_operands;
+ basic_arith_on_size_error: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* COMPUTE *)
+and compute_stmt =
+ {
+ compute_targets: rounded_idents;
+ compute_expr: expression;
+ compute_on_size_error: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* DELETE *)
+and delete_stmt =
+ {
+ delete_targets: name with_loc;
+ delete_retry: retry_clause option;
+ delete_on_invalid_key: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* DIVIDE *)
+and divide_stmt =
+ {
+ divide_operands: divide_operands;
+ divide_on_size_error: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* MULTIPLY *)
+and multiply_stmt =
+ {
+ multiply_operands: multiply_operands;
+ multiply_on_size_error: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* RECEIVE *)
+and receive_stmt =
+ {
+ receive_name: name with_loc; (* CD *)
+ receive_kind: mcs_awaiting_item;
+ receive_into: ident;
+ receive_on_no_data: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* RETURN *)
+and return_stmt =
+ {
+ return_file: name with_loc;
+ return_into: ident with_loc option;
+ return_at_end: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* REWRITE *)
+and rewrite_stmt =
+ {
+ rewrite_to: write_target;
+ rewrite_from: ident_or_literal option;
+ rewrite_retry: retry_clause option;
+ rewrite_lock: bool option;
+ rewrite_invalid_key_handler: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* START *)
+and start_stmt =
+ {
+ start_file: name with_loc;
+ start_position: start_position option;
+ start_on_invalid_key: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* STRING *)
+and string_stmt =
+ {
+ string_sources: string_source list;
+ string_target: ident;
+ string_pointer: ident option;
+ string_on_overflow: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* UNSTRING *)
+and unstring_stmt =
+ {
+ unstring_source: ident;
+ unstring_delimiters: unstring_delimiter list;
+ unstring_targets: unstring_target list;
+ unstring_pointer: ident option;
+ unstring_tallying: ident option;
+ unstring_on_overflow: dual_handler;
+ }
+[@@deriving show, ord]
+
+
+(* WRITE *)
+and write_stmt =
+ {
+ write_to: write_target;
+ write_from: ident_or_literal option;
+ write_advancing: advancing_phrase option;
+ write_retry: retry_clause option;
+ write_lock: bool option;
+ write_error_handler: (write_error * dual_handler) option;
+ }
+[@@deriving show, ord]
+
+and write_error =
+ | WriteAtEndOfPage
+ | WriteInvalidKey
+[@@deriving show, ord]
+
+
+
+(*
+CALL id/lit USING...? RETURNING...? ON OVERFLOW (on-overflow - archaic)
+CALL id/lit USING...? RETURNING...? ON EXCEPT (on-exception)
+
+CALL (id/lit AS)? NESTED/id USING...? RETURNING...? (program-prototype)
+*)
+
+(* CALL *)
+and call_stmt =
+ {
+ call_prefix: call_prefix;
+ call_using: call_using_clause with_loc list;
+ call_returning: ident with_loc option;
+ call_error_handler: call_error_handler option;
+ }
+[@@deriving show, ord]
+
+and call_prefix =
+ | CallGeneral of ident_or_strlit
+ | CallProto of
+ {
+ called: ident_or_strlit option;
+ prototype: call_proto;
+ }
+[@@deriving show, ord]
+
+and call_proto =
+ | CallProtoIdent of ident
+ | CallProtoNested
+[@@deriving show, ord]
+
+and call_error_handler =
+ | CallOnOverflow of handler
+ | CallOnException of dual_handler
+[@@deriving show, ord]
+
+
+(* READ *)
+and read_stmt =
+ {
+ read_file: name with_loc;
+ read_direction: read_direction option;
+ read_into: ident option;
+ read_lock_behavior: read_lock_behavior option;
+ read_lock: bool option;
+ read_key: qualname option;
+ read_error_handler: (read_error * dual_handler) option;
+ }
+[@@deriving show, ord]
+
+and read_error =
+ | ReadAtEnd
+ | ReadInvalidKey
+[@@deriving show, ord]
+
+
+
+and statement =
+ (* TODO: split composed high-level (that depend on statement), and basic
+ statements *)
+ (* TODO: term-like unification (long-term) *)
+ | Accept of accept_stmt
+ | Add of basic_arithmetic_stmt
+ | Allocate of allocate_stmt
+ | Alter of alter_stmt
+ | Call of call_stmt
+ | Cancel of ident_or_strlit list (* non-empty *)
+ | Close of close_stmt
+ | Compute of compute_stmt
+ | Continue
+ | Delete of delete_stmt
+ | Disable of mcs_command_operands
+ | Display of display_stmt
+ | Divide of divide_stmt
+ | Enable of mcs_command_operands
+ | Enter of enter_stmt
+ | Evaluate of evaluate_stmt
+ | Exit of exit_stmt
+ | Free of name with_loc list
+ | Generate of name with_loc
+ | GoTo of qualname
+ | GoToDepending of goto_depending_stmt
+ | GoBack of raising option
+ | If of if_stmt
+ | Initialize of initialize_stmt
+ | Initiate of name with_loc list
+ | Inspect of inspect_stmt
+ | Invoke of invoke_stmt
+ | LoneGoTo (* COB85, obsolete *)
+ | Merge of merge_stmt
+ | Move of move_stmt
+ | Multiply of multiply_stmt
+ | Open of open_stmt
+ | Perform of perform_stmt
+ | Purge of name with_loc
+ | Raise of raise_operand
+ | Read of read_stmt
+ | Receive of receive_stmt
+ | Release of release_stmt
+ | Resume of qualname
+ | ResumeNextStatement
+ | Return of return_stmt
+ | Rewrite of rewrite_stmt
+ | Search of search_stmt
+ | Send of send_stmt
+ | Set of set_stmt
+ | Sort of sort_stmt
+ | Start of start_stmt
+ | Stop of stop_stmt
+ | String of string_stmt
+ | Subtract of basic_arithmetic_stmt
+ | Suppress
+ | Terminate of terminate_stmt
+ | Transform of transform_stmt
+ | Unlock of unlock_stmt
+ | Unstring of unstring_stmt
+ | Validate of ident list
+ | Write of write_stmt
+[@@deriving show, ord]
+
+and statements = statement with_loc list [@@deriving show, ord]
+
+and branch =
+ | Statements of statements
+ | NextSentence
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_ast/cobol_ast.ml b/src/lsp/cobol_ast/cobol_ast.ml
new file mode 100644
index 000000000..be858d119
--- /dev/null
+++ b/src/lsp/cobol_ast/cobol_ast.ml
@@ -0,0 +1,31 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module Traversal = Traversal
+module Helpers = Helpers
+
+include Ast
+
+module Terms_visitor = Terms_visitor
+module Operands_visitor = Operands_visitor
+
+module Abstract = Abstract
+module Abstract_visitor = Abstract_visitor
+
+module Raw = Raw
+module Raw_visitor = Raw_visitor
+(* module Raw_misc_sections_visitor = Raw_misc_sections_visitor *)
+(* module Raw_data_sections_visitor = Raw_data_sections_visitor *)
+(* module Raw_data_division_visitor = Raw_data_division_visitor *)
+(* module Raw_proc_division_visitor = Raw_proc_division_visitor *)
+(* module Raw_compilation_group_visitor = Raw_compilation_group_visitor *)
diff --git a/src/lsp/cobol_ast/data_descr.ml b/src/lsp/cobol_ast/data_descr.ml
new file mode 100644
index 000000000..a688028e2
--- /dev/null
+++ b/src/lsp/cobol_ast/data_descr.ml
@@ -0,0 +1,463 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Terms
+
+(* ----------------------------- DATA DIVISION ----------------------------- *)
+type format_clause =
+ | Bit
+ | Character
+ | Numeric
+[@@deriving show, ord]
+
+
+type file_block_contents =
+ | FileBlockContainsCharacters
+ | FileBlockContainsRecords
+[@@deriving show, ord]
+
+
+type record_clause =
+ | FixedLength of integer
+ | VariableLength of
+ {
+ min_length: integer option;
+ max_length: integer option;
+ depending: qualname with_loc option;
+ }
+ | FixedOrVariableLength of
+ {
+ min_length: integer;
+ max_length: integer;
+ }
+[@@deriving show, ord]
+
+type label_clause =
+ | LabelStandard
+ | LabelOmitted
+[@@deriving show, ord]
+
+type file_data_clause =
+ name with_loc list
+[@@deriving show, ord]
+
+type file_linage_clause = (* file descr only *)
+ {
+ file_linage_lines: qualname_or_intlit;
+ file_linage_with_footing_at: qualname_or_intlit option;
+ file_linage_lines_at_top: qualname_or_intlit option;
+ file_linage_lines_at_bottom: qualname_or_intlit option;
+ }
+[@@deriving show, ord]
+
+type data_level = int
+[@@deriving show, ord]
+
+type rename_item =
+ {
+ rename_level: data_level with_loc;
+ rename_to: name with_loc;
+ rename_renamed: qualname;
+ rename_through: qualname option;
+ }
+[@@deriving show, ord]
+
+
+type condition_name_item =
+ {
+ condition_name_level: data_level with_loc; (* is always 88 *)
+ condition_name: name with_loc;
+ condition_name_values: condition_name_value list;
+ condition_name_alphabet: name with_loc option;
+ condition_name_when_false: literal option;
+ }
+[@@deriving show, ord]
+
+and condition_name_value =
+ {
+ condition_name_value: literal;
+ condition_name_through: literal option;
+ }
+[@@deriving show, ord]
+
+
+type data_name =
+ | DataName of name with_loc
+ | DataFiller
+[@@deriving show, ord]
+
+(* Format seen on IBM: PICTURE ... SIZE ... LOCALE ... *)
+type locale_phrase =
+ {
+ locale_name: name with_loc option;
+ locale_size: integer;
+ }
+[@@deriving show, ord]
+
+type sign_clause =
+ {
+ sign_position: sign_position;
+ sign_separate_character: bool;
+ }
+[@@deriving show, ord]
+
+and sign_position = LeadingSign | TrailingSign
+
+type report_screen_usage_clause =
+ | Display
+ | National
+[@@deriving show, ord]
+
+type external_clause =
+ strlit option
+[@@deriving show, ord]
+
+type group_usage_clause =
+ | GroupUsageBit
+ | GroupUsageNational
+[@@deriving show, ord]
+
+type data_occurs_clause =
+ | OccursFixed of
+ {
+ times: integer;
+ key_is: sort_spec list;
+ indexed_by: name with_loc list;
+ }
+ | OccursDepending of
+ {
+ from: integer;
+ to_: integer;
+ depending: qualname with_loc;
+ key_is: sort_spec list;
+ indexed_by: name with_loc list;
+ }
+ | OccursDynamic of
+ {
+ capacity_in: name with_loc option;
+ from: integer option;
+ to_: integer option;
+ initialized: bool;
+ key_is: sort_spec list;
+ indexed_by: name with_loc list;
+ }
+[@@deriving show, ord]
+
+and sort_spec =
+ {
+ sort_key_direction: sort_direction;
+ sort_key_names: qualname list;
+ }
+[@@deriving show, ord]
+
+and sort_direction =
+ | SortAscending
+ | SortDescending
+[@@deriving show, ord]
+
+type data_varying =
+ {
+ data_varying: name with_loc;
+ data_varying_from: expression option;
+ data_varying_by: expression option;
+ }
+[@@deriving show, ord]
+
+type select_when_clause =
+ | SelectWhen of name with_loc
+ | SelectWhenOther
+[@@deriving show, ord]
+
+type synchronized_clause =
+ | SynchronizedLeft
+ | SynchronizedRight
+ | SynchronizedDefault
+[@@deriving show, ord]
+
+
+type property_clause =
+ {
+ property_with_no: property_kind option;
+ property_is_final: bool;
+ }
+[@@deriving show, ord]
+
+and property_kind =
+ | PropertyGet
+ | PropertySet
+[@@deriving show, ord]
+
+
+type usage_clause =
+ | Binary
+ | BinaryChar of signedness option (* +COB2002 *)
+ | BinaryShort of signedness option (* +COB2002 *)
+ | BinaryLong of signedness option (* +COB2002 *)
+ | BinaryDouble of signedness option (* +COB2002 *)
+ | Bit (* +COB2002 *)
+ | Display
+ | FloatBinary32 of endianness_mode option (* +COB2002 *)
+ | FloatBinary64 of endianness_mode option (* +COB2002 *)
+ | FloatBinary128 of endianness_mode option (* +COB2002 *)
+ | FloatDecimal16 of encoding_endianness (* +COB2002 *)
+ | FloatDecimal34 of encoding_endianness (* +COB2002 *)
+ | FloatExtended (* +COB2002 *)
+ | FloatLong (* +COB2002 *)
+ | FloatShort (* +COB2002 *)
+ | Index
+ | National (* +COB2002 *)
+ | ObjectReference of object_reference_kind option (* +COB2002 *)
+ | PackedDecimal
+ | Pointer of name with_loc option (* +COB2002 *)
+ | FunctionPointer of name with_loc (* +COB2002 *)
+ | ProgramPointer of name with_loc option (* +COB2002 *)
+ | UsagePending of [`Comp0 | `Comp1 | `Comp5 | `Comp6 | `CompX |
+ `CompN | `Comp9 | `Comp10 | `Comp15 ]
+[@@deriving show, ord]
+
+and signedness =
+ | Signed
+ | Unsigned
+[@@deriving show]
+
+and endianness_mode =
+ | HighOrderLeft
+ | HighOrderRight
+[@@deriving show]
+
+and encoding_mode =
+ | BinaryEncoding
+ | DecimalEncoding
+[@@deriving show]
+
+and encoding_endianness =
+ {
+ encoding_mode: encoding_mode option;
+ encoding_endianness: endianness_mode option;
+ }
+[@@deriving show]
+
+and object_reference_kind =
+ | ActiveClass of
+ {
+ factory_of: bool;
+ }
+ | Name of
+ {
+ class_or_interface_name: name with_loc;
+ factory_of: bool;
+ only: bool;
+ }
+[@@deriving show]
+
+type validation_clause =
+ | Class of class_clause
+ | Default of ident_or_literal option
+ | Destination of ident list (* non-empty *)
+ | InvalidWhen of condition list (* non-empty *)
+ | PresentWhen of condition
+ | Varying of data_varying list
+ | ValidateStatus of
+ {
+ is_: ident_or_literal;
+ when_: validate_when;
+ on: validation_stage list;
+ for_: ident list; (* non-empty *)
+ }
+[@@deriving show, ord]
+
+and class_clause =
+ | Alphabetic
+ | AlphabeticLower
+ | AlphabeticUpper
+ | Boolean
+ | Numeric
+ | ClassOrAlphabet of name with_loc
+[@@deriving show]
+
+and validate_when =
+ | ValidateWhenError
+ | ValidateWhenNoError
+[@@deriving show]
+
+and validation_stage =
+ | ValidationStageFormat
+ | ValidationStageContent
+ | ValidationStageRelation
+[@@deriving show]
+
+type data_value_clause =
+ | ValueData of literal
+ | ValueTable of table_data_value list
+[@@deriving show]
+
+and table_data_value =
+ {
+ table_data_values: literal list; (* non-empty *)
+ table_data_from: subscript list; (* non-empty *)
+ table_data_to: subscript list;
+ }
+[@@deriving show]
+
+type report_data_name_or_final =
+ | ReportDataName of qualident
+ | ReportFinal
+[@@deriving show, ord]
+
+type report_type_clause =
+ | Detail
+ | ReportHeading
+ | ReportFooting
+ | PageHeading
+ | PageFooting
+ | ControlHeading of (report_data_name_or_final * bool) option
+ | ControlFooting of report_data_name_or_final option
+[@@deriving show, ord]
+
+type next_group_clause =
+ | ReportNextAbsolute of integer
+ | ReportNextRelative of integer
+ | ReportNextNextPage of bool
+[@@deriving show, ord]
+
+type column_position =
+ | ColumnAbsolute of integer
+ | ColumnRelative of integer
+[@@deriving show, ord]
+
+type alignment =
+ | AlignLeft
+ | AlignRight
+ | AlignCenter
+[@@deriving show, ord]
+
+type line_position =
+ | LineAbsolute of integer * bool
+ | LineRelative of integer
+ | LineOnNextPage
+[@@deriving show, ord]
+
+type sum_phrase =
+ {
+ sum_operands: expression list; (* non-empty *)
+ sum_upon_items: name with_loc list;
+ }
+[@@deriving show, ord]
+
+type polarity =
+ | Plus
+ | Minus
+[@@deriving show, ord]
+
+type blank_clause =
+ | Line
+ | Screen
+[@@deriving show, ord]
+
+type erase_clause =
+ | EndOfLine
+ | EndOfScreen
+[@@deriving show, ord]
+
+type screen_attribute_clause =
+ | Bell
+ | Blink
+ | Highlight
+ | Lowlight
+ | ReverseVideo
+ | Underline
+ | ForegroundColor of ident_or_intlit
+ | BackgroundColor of ident_or_intlit
+[@@deriving show, ord]
+
+type screen_line_column_clause =
+ | Absolute of ident_or_intlit
+ | Relative of polarity * ident_or_intlit
+[@@deriving show, ord]
+
+type source_destination_clause =
+ | From of ident_or_literal
+ | To of ident
+ | Using of ident
+ | Value of literal
+[@@deriving show, ord]
+
+type value_of_clause =
+ {
+ value_of_valued: name with_loc;
+ value_of_value: qualname_or_literal;
+ }
+[@@deriving show, ord]
+
+type report_clause =
+ | Global
+ | Code of ident
+ | Control of
+ {
+ final: bool;
+ controls: name with_loc list;
+ }
+ | PageLimit of
+ {
+ lines: integer option;
+ columns: integer option;
+ heading: integer option;
+ first_detail: integer option;
+ last_control_heading: integer option;
+ last_detail: integer option;
+ footing: integer option;
+ }
+[@@deriving show, ord]
+
+
+type constant_item =
+ {
+ constant_level: data_level with_loc; (* is a constant *) (* TODO: check \in {"1", "01"} *)
+ constant_name: data_name with_loc option; (* ident only (NB:refine the type???) *)
+ constant_global: bool;
+ constant_value: constant_value with_loc;
+ }
+[@@deriving show, ord]
+
+and constant_value =
+ | ConstExpr of expression (* or plain ident *)
+ | ConstByteLength of name with_loc
+ | ConstLength of name with_loc
+ | ConstFrom of name with_loc (* compilation variable *)
+[@@deriving show, ord]
+
+
+(* --- COMMUNICATION SECTION --- *)
+
+type comm_clause =
+ | CommSymbolic of comm_channel * name with_loc
+ | CommDestinationCount of name with_loc (* OUTPUT only *)
+ | CommDestinationTable of integer * name with_loc list (* OUTPUT only *)
+ | CommMessageCount of name with_loc (* INPUT [@@deriving show]*)
+ | CommMessageDate of name with_loc (* INPUT [@@deriving show]type I-O *)
+ | CommMessageTime of name with_loc (* INPUT type I-O [@@deriving show]*)
+ | CommTextLength of name with_loc (* INPUT, OUTPUT [@@deriving show]type I-O *)
+ | CommStatusKey of name with_loc (* INPUT,[@@deriving show] OUTPUT type I-O *)
+ | CommEndKey of name with_loc (* INPUT type I-O *)
+ | CommErrorKey of name with_loc (* OUTPUT only *)
+[@@deriving show, ord]
+
+and comm_channel =
+ | CommQueue (* INPUT only *)
+ | CommSubQueue1 (* INPUT only *)
+ | CommSubQueue2 (* INPUT only *)
+ | CommSubQueue3 (* INPUT only *)
+ | CommSource (* INPUT only *)
+ | CommTerminal (* I-O only *)
+ | CommDestination (* OUTPUT only *)
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_ast/dune b/src/lsp/cobol_ast/dune
new file mode 100644
index 000000000..05db5b229
--- /dev/null
+++ b/src/lsp/cobol_ast/dune
@@ -0,0 +1,26 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_ast)
+ (public_name cobol_ast)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries ppx_deriving cobol_common )
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show ppx_deriving.ord))
+
+ )
+
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_ast))
+
+; use field 'dune-trailer' to add more stuff here
+
diff --git a/src/lsp/cobol_ast/helpers.ml b/src/lsp/cobol_ast/helpers.ml
new file mode 100644
index 000000000..9f62bd5a9
--- /dev/null
+++ b/src/lsp/cobol_ast/helpers.ml
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.INFIX
+
+module type TAGS = sig
+ val loc: Terms.srcloc
+end
+
+module Make (Tags: TAGS) = struct
+ open Terms
+
+ module Term = struct
+ let name x : qualname = Name (x &@ Tags.loc)
+ let qualident x : qualident =
+ { ident_name = name x; ident_subscripts = []; ident_refmod = None }
+ let ident x : ident_or_literal = QualIdent (qualident x)
+ let strlit l : ident_or_literal = Alphanum l
+ end
+
+ module Cond = struct
+ open Term
+ let ident x : condition = Expr (Atom (ident x))
+ end
+
+end
diff --git a/src/lsp/cobol_ast/index.mld b/src/lsp/cobol_ast/index.mld
new file mode 100644
index 000000000..3840058dc
--- /dev/null
+++ b/src/lsp/cobol_ast/index.mld
@@ -0,0 +1,9 @@
+{1 Library cobol_ast}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+This library contains the abstract version of the AST, to be specialized in other packages.
+
+The entry point of this library is the module: {!Cobol_ast}.
+
diff --git a/src/lsp/cobol_ast/misc_descr.ml b/src/lsp/cobol_ast/misc_descr.ml
new file mode 100644
index 000000000..fe96bb00d
--- /dev/null
+++ b/src/lsp/cobol_ast/misc_descr.ml
@@ -0,0 +1,412 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Terms
+open Operands
+
+(* -------------------- IDENTIFICATION DIVISION (EXTRA) -------------------- *)
+
+type informational_paragraphs =
+ {
+ author: string with_loc option;
+ installation: string with_loc option;
+ date_written: string with_loc option;
+ date_compiled: string with_loc option;
+ security: string with_loc option;
+ }
+[@@deriving show, ord]
+
+(* ------------------------- ENVIRONMENT DIVISION -------------------------- *)
+type environment_division =
+ {
+ env_configuration: configuration_section option;
+ env_input_output: input_output_section option;
+ }
+[@@deriving show, ord]
+
+(* ------------- ENVIRONMENT DIVISION / CONFIGURATION SECTION -------------- *)
+and configuration_section =
+ {
+ source_computer_paragraph: source_computer_paragraph option;
+ object_computer_paragraph: object_computer_paragraph option;
+ special_names_paragraph: special_names_paragraph option;
+ repository_paragraph: repository_paragraph option; (* +COB2002 *)
+ }
+[@@deriving show]
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)
+and source_computer_paragraph =
+ source_computer option
+[@@deriving show]
+
+and source_computer =
+ {
+ source_computer_name: name with_loc;
+ source_computer_with_debugging_mode: bool;
+ }
+[@@deriving show]
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / OBJECT-COMPUTER PARAGRAPH *)
+and object_computer_paragraph =
+ object_computer option
+[@@deriving show]
+
+and object_computer =
+ {
+ object_computer_name: name with_loc;
+ object_computer_clauses: object_computer_clause with_loc list;
+ }
+[@@deriving show]
+
+and object_computer_clause =
+ | ComputerMemorySize of (* ~COB85, -COB2002 *)
+ integer * memory_size_unit
+ | ComputerCharClassification of (* +COB2002 *)
+ {
+ alphanumeric: locale option; (* at least one must be set *)
+ national: locale option
+ }
+ | ComputerProgCollatingSeq of alphabet_specification (* COB85 != COB2002 *)
+ | ComputerSegmentLimit of integer (* -COB2002 *)
+[@@deriving show]
+
+and memory_size_unit =
+ | MemoryWords
+ | MemoryCharacters
+ | MemoryModules
+[@@deriving show]
+
+and locale =
+ | CharClassificationName of name with_loc
+ | CharClassificationLocale
+ | CharClassificationSystemDefault
+ | CharClassificationUserDefault
+[@@deriving show]
+
+and alphabet_specification = (* At least one is required *)
+ {
+ alphanumeric: name with_loc option;
+ national: name with_loc option;
+ }
+[@@deriving show]
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SPECIAL-NAMES PARAGRAPH *)
+and special_names_paragraph =
+ special_names_clause with_loc list
+[@@deriving show]
+
+and special_names_clause =
+ | AlphabetName of (* Multiple allowed *)
+ {
+ alphabet_name: name with_loc;
+ category: alphanumeric_or_national;
+ characters: character_set;
+ }
+ | ClassName of (* Multiple allowed *)
+ {
+ class_name: name with_loc;
+ category: alphanumeric_or_national;
+ characters: character_range list;
+ source_charset: name with_loc option;
+ }
+ | CRTStatus of name with_loc (* +COB2002 *)
+ | CurrencySign of (* Multiple in COB2002 *)
+ {
+ sign: strlit;
+ picture_symbol: strlit option;
+ }
+ | Cursor of name with_loc (* +COB2002 *)
+ | DecimalPointIsComma
+ | DynLenStruct of (* +COB2002 *) (* Multiple allowed *)
+ {
+ name: name with_loc;
+ kind: dyn_len_struct_kind;
+ }
+ | SpecialNameLocale of (* +COB2002 *) (* Multiple allowed *)
+ {
+ locale_name: name with_loc;
+ external_name: name_or_string;
+ }
+ | MnemonicName of (* Multiple allowed *)
+ {
+ implementor_name: name with_loc;
+ mnemonic_name: name with_loc option;
+ status: status_switch option;
+ }
+ | SymbolicChars of (* Multiple allowed *)
+ {
+ category: alphanumeric_or_national;
+ characters: (name with_loc list * integer list) list; (* same lengths *)
+ source_charset: name with_loc option;
+ }
+ | OrderTable of (* +COB2002 *)
+ {
+ ordering_name: name with_loc;
+ cultural_ordering: strlit;
+ }
+[@@deriving show]
+
+and alphanumeric_or_national =
+ | Alphanumeric
+ | National
+[@@deriving show]
+
+and character_range =
+ | SingleCharacter of strlit_or_intlit
+ | CharacterRange of range_items
+[@@deriving show]
+
+and characters_range =
+ | CharactersRange of character_range
+ | CharactersList of strlit_or_intlit list (* non-trivial *)
+[@@deriving show]
+
+and range_items =
+ {
+ start_item: strlit_or_intlit;
+ end_item: strlit_or_intlit;
+ }
+[@@deriving show]
+
+and character_set =
+ | CharSetLocale of name with_loc option (* +COB2002 *)
+ | CharSetNative (* +COB2002 *)
+ | CharSetStandard_1 (* Alphanum only *)
+ | CharSetStandard_2 (* Alphanum only *)
+ | CharSetUCS_4 (* +COB2002 *) (* National only *)
+ | CharSetUTF_8 (* +COB2002 *) (* National only *)
+ | CharSetUTF_16 (* +COB2002 *) (* National only *)
+ | CharSetCharacters of characters_range list (* non-empty *)
+[@@deriving show]
+
+and dyn_len_struct_kind =
+ | DynLenPrefixed of { signed: bool; short: bool }
+ | DynLenDelimited
+ | DynLenPhysical of name with_loc
+[@@deriving show]
+
+and status_switch =
+ | StatusSwitchOn of name with_loc
+ | StatusSwitchOff of name with_loc
+ | StatusSwitch of { on_: name with_loc; off: name with_loc }
+[@@deriving show]
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / REPOSITORY PARAGRAPH *)
+and repository_paragraph =
+ specifier list
+[@@deriving show]
+
+and specifier = (* TODO: inline records *)
+ | ClassSpecifier of
+ {
+ name: name with_loc;
+ external_name: strlit option;
+ expands: expands option;
+ }
+ | InterfaceSpecifier of
+ {
+ name: name with_loc;
+ external_name: strlit option;
+ expands: expands option;
+ }
+ | UserFunctionSpecifier of
+ {
+ name: name with_loc;
+ external_name: strlit option;
+ }
+ | IntrinsicFunctionSpecifier of
+ name with_loc list (* non-empty *)
+ | IntrinsicFunctionAllSpecifier
+ | ProgramSpecifier of
+ {
+ name: name with_loc;
+ external_name: strlit option;
+ }
+ | PropertySpecifier of
+ {
+ name: name with_loc;
+ external_name: strlit option;
+ }
+[@@deriving show]
+
+and expands =
+ {
+ expands_name: name with_loc;
+ expands_using: name with_loc list; (* non-empty *)
+ }
+[@@deriving show]
+
+
+(* -------------- ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION -------------- *)
+and input_output_section =
+ {
+ file_control_paragraph: file_control_paragraph option; (* COB85: mandatory *)
+ io_control_paragraph: io_control_paragraph option;
+ }
+[@@deriving show]
+
+(* - ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION / FILE-CONTROL PARAGRAPH -- *)
+and file_control_paragraph =
+ select list
+[@@deriving show]
+
+and select =
+ {
+ select_optional: bool;
+ select_name: name with_loc;
+ select_clauses: select_clause with_loc list;
+ }
+[@@deriving show]
+
+and select_clause =
+ | SelectAssign of
+ {
+ to_: name_or_alphanum list;
+ using: name with_loc option;
+ }
+ | SelectAccessMode of access_mode
+ | SelectAlternateRecordKey of
+ {
+ key: qualname;
+ source: name with_loc list;
+ with_duplicates: bool;
+ }
+ (* | SelectCollatingSequence of collating_sequence_clause *)
+ | SelectCollatingSequenceOfFile of
+ alphabet_specification (* +COB2002 *) (* Multiple *)
+ | SelectCollatingSequenceOfKey of (* +COB2002 *) (* Multiple *)
+ {
+ keys: name with_loc list;
+ alphabet: name with_loc;
+ }
+ | SelectStatus of qualname
+ | SelectLockMode of (* +COB2002 *)
+ {
+ mode: lock_mode;
+ with_lock: with_lock;
+ }
+ | SelectOrganization of organization
+ | SelectPaddingCharacter of qualname_or_alphanum (* -COB2002 *)
+ | SelectRecordDelimiter of record_delimiter
+ | SelectRecordKey of
+ {
+ key: qualname;
+ source: name with_loc list;
+ }
+ | SelectRelativeKey of name with_loc
+ | SelectReserve of integer
+ | SelectSharing of sharing_mode (* +COB2002 *)
+[@@deriving show]
+
+and access_mode =
+ | AccessModeDynamic
+ | AccessModeRandom
+ | AccessModeSequential
+[@@deriving show]
+
+and lock_mode =
+ | LockManual
+ | LockAutomatic
+[@@deriving show]
+
+and with_lock =
+ | WithLockNone
+ | WithLock of { multiple: bool }
+[@@deriving show]
+
+and organization =
+ | OrganizationIndexed
+ | OrganizationRelative
+ | OrganizationSequential
+[@@deriving show]
+
+and record_delimiter =
+ | Standard_1
+[@@deriving show]
+
+(* -- ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION / I-O-CONTROL PARAGRAPH -- *)
+and io_control_paragraph =
+ io_control_entry option
+[@@deriving show]
+
+and io_control_entry =
+ {
+ io_control_rerun_clauses: rerun_clause with_loc list; (* -COB2002 *)
+ io_control_same_area_clauses: same_area_clause with_loc list;
+ io_control_multiple_file_clauses: multiple_file_clause with_loc list; (* -COB2002 *)
+ }
+[@@deriving show]
+
+and rerun_clause =
+ {
+ rerun_on: name with_loc option;
+ rerun_every: rerun_frequency;
+ }
+[@@deriving show]
+
+and rerun_frequency =
+ | RerunEndOf of name with_loc
+ | RerunRecords of integer * name with_loc
+ | RerunClockUnits of integer
+ | RerunCond of name with_loc
+[@@deriving show]
+
+and same_area_clause =
+ {
+ same_area_source: area_source;
+ same_area_file_name: name with_loc;
+ same_area_file_names: name with_loc list; (* non-empty *)
+ }
+[@@deriving show]
+
+and area_source =
+ | AreaSourceFile
+ | AreaSourceRecord
+ | AreaSourceSortMerge
+[@@deriving show]
+
+and multiple_file_clause =
+ file_portion list
+[@@deriving show]
+
+and file_portion =
+ {
+ file_portion_name: name with_loc;
+ file_portion_position: integer option;
+ }
+[@@deriving show]
+
+type options_paragraph =
+ options_clause with_loc list
+[@@deriving show, ord]
+
+and options_clause =
+ | Arithmetic of arithmetic_mode
+ | DefaultRoundedMode of rounding_mode
+ | EntryConvention of entry_convention
+ | FloatBinaryDefault of Data_descr.endianness_mode
+ | FloatDecimalDefault of Data_descr.encoding_endianness (* 1+ *)
+ | IntermediateRounding of rounding_mode (* not all are valid (TODO:
+ restriction with type param) *)
+[@@deriving show]
+
+and arithmetic_mode =
+ | Native
+ | Standard (* ~COB2002 *)
+ | StandardBinary
+ | StandardDecimal
+[@@deriving show]
+
+(* Other conventions may be defined by the implementor *)
+and entry_convention =
+ | COBOL
+[@@deriving show]
diff --git a/src/lsp/cobol_ast/numericals.ml b/src/lsp/cobol_ast/numericals.ml
new file mode 100644
index 000000000..819cd03f5
--- /dev/null
+++ b/src/lsp/cobol_ast/numericals.ml
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+type integer = string [@@deriving ord]
+
+type fixed =
+ {
+ fixed_integer: string; (** Integer part *)
+ fixed_fractional: string; (** Fractional part *)
+ } [@@deriving ord]
+
+type floating =
+ {
+ float_significand: fixed;
+ float_exponent: string; (* 0 <= . <= 9999 in ISO/IEC 2014 *)
+ } [@@deriving ord]
+
+type boolean =
+ {
+ bool_base: [`Bool | `Hex];
+ bool_value: string;
+ } [@@deriving ord]
+
+(* --- *)
+
+let pp_integer = Pretty.string
+
+let fixed_of_strings i d =
+ {
+ fixed_integer = i;
+ fixed_fractional = d;
+ }
+
+let pp_fixed ppf { fixed_integer; fixed_fractional } =
+ Pretty.print ppf "%s.%s" fixed_integer fixed_fractional
+
+let floating_of_strings i d e =
+ {
+ float_significand = fixed_of_strings i d;
+ float_exponent = e;
+ }
+
+let pp_floating ppf { float_significand = s; float_exponent = e } =
+ Pretty.print ppf "%aE%s" pp_fixed s e
+
+(* --- *)
+
+let boolean_of_string ?(base: [`Bool | `Hex] = `Bool) s =
+ {
+ bool_base = base;
+ bool_value = s;
+ }
diff --git a/src/lsp/cobol_ast/operands.ml b/src/lsp/cobol_ast/operands.ml
new file mode 100644
index 000000000..492182f83
--- /dev/null
+++ b/src/lsp/cobol_ast/operands.ml
@@ -0,0 +1,395 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Terms
+
+(* ACCEPT, DISPLAY *)
+type position =
+ | LinePosition of ident_or_intlit
+ | ColumnPosition of ident_or_intlit
+ | LineColumnPosition of ident_or_intlit * ident_or_intlit
+[@@deriving show, ord]
+
+(* CALL, INVOKE *)
+
+type call_using_clause =
+ {
+ call_using_by: call_using_by option;
+ call_using_expr: expression option;(* [@compare
+ fun a b -> Option.compare compare_expression a b] *) (** OMITTED if [None] *)
+ }
+[@@deriving show, ord]
+
+and call_using_by =
+ | CallUsingByReference
+ | CallUsingByContent
+ | CallUsingByValue
+[@@deriving show, ord]
+
+
+(* DELETE, OPEN, REWRITE, WRITE, READ (through on_lock_or_retry) *)
+type retry_clause =
+ | RetryNTimes of expression (* arith *)
+ | RetryForNSeconds of expression (* arith *)
+ | RetryForever
+[@@deriving show, ord]
+
+
+(* ENABLE, DISABLE *)
+(* MCS: Message Control System *)
+
+type mcs_command_operands =
+ {
+ mcs_command_kind: mcs_kind;
+ mcs_command_target: name with_loc;
+ mcs_command_key: ident_or_alphanum option;
+ }
+[@@deriving show, ord]
+
+and mcs_kind =
+ | MCSInput
+ | MCSOutput
+ | MCSInputOutput
+[@@deriving show, ord]
+
+
+(* SEND, WRITE, PERFORM *)
+type stage =
+ | After
+ | Before
+[@@deriving show, ord]
+
+(* REWRITE, WRITE *)
+type write_target =
+ | WriteTargetName of qualname
+ | WriteTargetFile of name with_loc
+[@@deriving show ,ord]
+
+(*
+ACCEPT id END_ACC (device or screen)
+ACCEPT id FROM DATE/DAY... END_ACC (temporal)
+ACCEPT id MESSAGE? COUNT END_ACC (message count?)
+ACCEPT id AT ... ON EXCEPT ... END_ACC (screen)
+*)
+
+(* ACCEPT *)
+type date_time =
+ | Date of bool
+ | Day of bool
+ | DayOfWeek
+ | Time
+[@@deriving show, ord]
+
+
+(* ADD, SUBTRACT *)
+type basic_arithmetic_operands =
+ | ArithSimple of
+ {
+ sources: ident_or_numlit list;
+ targets: rounded_idents;
+ }
+ | ArithGiving of
+ {
+ sources: ident_or_numlit list;
+ to_or_from_item: ident_or_numlit;
+ targets: rounded_idents;
+ }
+ | ArithCorresponding of
+ {
+ source: qualname;
+ target: rounded_ident;
+ }
+[@@deriving show, ord]
+
+
+
+(*
+DIVIDE id/lit INTO id_rounded+ ON_SIZE...? END_DIV
+
+DIVIDE id/lit INTO id/lit GIVING... ON_SIZE...? END_DIV
+DIVIDE id/lit INTO id/lit GIVING... REMAINDER... ON_SIZE...? END_DIV
+
+DIVIDE id/lit BY id/lit GIVING... ON_SIZE...? END_DIV
+DIVIDE id/lit BY id/lit GIVING... REMAINDER... ON_SIZE...? END_DIV
+*)
+
+(* DIVIDE *)
+type divide_operands =
+ | DivideInto of
+ {
+ divisor: ident_or_numlit;
+ dividends: rounded_idents; (* non-empty *)
+ }
+ | DivideGiving of
+ {
+ divisor: ident_or_numlit;
+ dividend: ident_or_numlit;
+ giving: rounded_idents;
+ into: bool; (* "INTO" if true, "by" otherwise *)
+ remainder: ident option;
+ }
+[@@deriving show, ord]
+
+
+(* EVALUATE *)
+type selection_subject =
+ | Subject of condition
+ | SubjectConst of bool
+[@@deriving show, ord]
+
+type selection_object =
+ | SelCond of condition (* ident / literal / expression *)
+ | SelRange of
+ {
+ negated: bool;
+ start: expression;
+ stop: expression;
+ alphabet: name with_loc option;
+ }
+ | SelRelation of
+ {
+ relation: relop;
+ expr: expression;
+ }
+ | SelClassCond of
+ {
+ negated: bool;
+ class_specifier: class_;
+ }
+ | SelSignCond of
+ {
+ negated: bool;
+ sign_specifier: signz;
+ }
+ | SelOmitted of
+ {
+ negated: bool;
+ }
+ | SelConst of bool
+ | SelAny
+[@@deriving show, ord]
+
+
+(* MULTIPLY *)
+type multiply_operands =
+ | MultiplyBy of
+ {
+ multiplier: ident_or_numlit;
+ multiplicand: rounded_idents;
+ }
+ | MultiplyGiving of
+ {
+ multiplier: ident_or_numlit;
+ multiplicand: ident_or_numlit;
+ targets: rounded_idents;
+ }
+[@@deriving show, ord]
+
+
+(* OPEN *)
+type open_mode =
+ | OpenInput
+ | OpenOutput
+ | OpenInputOutput
+ | OpenExtend
+[@@deriving show, ord]
+
+type sharing_mode =
+ | SharingAllOther
+ | SharingNoOther
+ | SharingReadOnly
+[@@deriving show, ord]
+
+type file_option =
+ | FileOptReversed
+ | FileOptWithNoRewind
+[@@deriving show, ord]
+
+
+(* RAISE *)
+type raise_operand =
+ | RaiseIdent of ident
+ | RaiseException of name with_loc
+[@@deriving show, ord]
+
+
+(* EXIT & GO BACK *)
+type raising =
+ | RaisingIdent of ident (* CHECKME: Can ident be a subscript?*)
+ | RaisingException of name with_loc
+ | RaisingLastException
+[@@deriving show, ord]
+
+
+(* READ *)
+type read_direction =
+ | ReadNext
+ | ReadPrevious
+[@@deriving show, ord]
+
+type read_lock_behavior =
+ | ReadAdvancingOnLock
+ | ReadIgnoringLock
+ | ReadRetry of retry_clause
+[@@deriving show, ord]
+
+
+(* RECEIVE *)
+type mcs_awaiting_item =
+ | MCSMessage
+ | MCSSegment
+[@@deriving show, ord]
+
+
+(* SEARCH *)
+type search_condition =
+ | IsEqual of
+ {
+ data_item: qualident;
+ condition: expression;
+ }
+ | Cond of qualident
+[@@deriving show, ord]
+
+
+(* SEND, WRITE *)
+type advancing_phrase =
+ | AdvancingLines of
+ {
+ stage: stage;
+ lines: ident_or_intlit;
+ ambiguous: bool;
+ }
+ | AdvancingPage of
+ {
+ stage: stage;
+ }
+[@@deriving show, ord]
+
+
+(* SET *)
+type set_attribute_switch =
+ {
+ set_attribute: screen_attribute;
+ set_attribute_switch_value: on_off;
+ }
+[@@deriving show, ord]
+
+and screen_attribute =
+ | ScreenBell
+ | ScreenBlink
+ | ScreenHighlight
+ | ScreenLowlight
+ | ScreenReverseVideo
+ | ScreenUnderline
+[@@deriving show, ord]
+
+and set_ambiguous_method =
+ | SetMethodUp
+ | SetMethodDown
+ | SetMethodTo
+[@@deriving show, ord]
+
+and on_off =
+ | On
+ | Off
+[@@deriving show, ord]
+
+and locale_category =
+ | LcAll
+ | LcCollate
+ | LcCtype
+ | LcMessages
+ | LcMonetary
+ | LcNumeric
+ | LcTime
+[@@deriving show, ord]
+
+and set_save_locale =
+ | SetSaveLocaleLcAll
+ | SetSaveLocaleUserDefault
+[@@deriving show, ord]
+
+and set_locale_target =
+ | SetLocaleTarget of locale_category
+ | SetLocaleTargetUserDefault
+[@@deriving show, ord]
+
+and set_locale_source =
+ | SetLocaleSource of ident
+ | SetLocaleSourceUserDefault
+ | SetLocaleSourceSystemDefault
+[@@deriving show, ord]
+
+and float_content =
+ | FarthestFromZero of bool
+ | NearestToZero of bool
+ | FloatInfinity
+ | FloatNotANumber
+ | FloatNotANumberSignaling
+[@@deriving show, ord]
+
+
+(* START *)
+type start_position =
+ | StartPositionFirst
+ | StartPositionLast
+ | StartPositionKey of
+ {
+ operator: relop;
+ name: qualname;
+ length: expression option;
+ }
+ (* any relop except IS NOT EQUAL TO or IS NOT = *)
+[@@deriving show, ord]
+
+
+(* STRING *)
+type string_source =
+ {
+ string_source: ident_or_nonnum;
+ string_delimiter: string_delimiter option;
+ }
+[@@deriving show, ord]
+
+and string_delimiter =
+ | StringDelimiter of ident_or_nonnum
+ | StringDelimiterSize
+[@@deriving show, ord]
+
+
+(* UNSTRING *)
+type unstring_delimiter =
+ {
+ unstring_delimiter: ident_or_strlit;
+ unstring_delimiter_by_all: bool;
+ }
+[@@deriving show, ord]
+
+type unstring_target =
+ {
+ unstring_target: ident;
+ unstring_target_delimiter: ident option;
+ unstring_target_count: ident option;
+ }
+[@@deriving show, ord]
+
+
+(* --- generics --- *)
+
+type 'a procedure_range =
+ {
+ procedure_start: 'a;
+ procedure_end: 'a option;
+ }
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_ast/operands_visitor.ml b/src/lsp/cobol_ast/operands_visitor.ml
new file mode 100644
index 000000000..02fa4a717
--- /dev/null
+++ b/src/lsp/cobol_ast/operands_visitor.ml
@@ -0,0 +1,264 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+open Ast
+
+let todo x = Cobol_common.Visitor.todo __FILE__ __MODULE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ __MODULE__ x
+
+(* --- *)
+
+class ['a] folder = object
+ inherit ['a] Terms_visitor.folder
+ method fold_basic_arithmetic_operands: (basic_arithmetic_operands , 'a) fold = default
+ method fold_call_using_clause : (call_using_clause , 'a) fold = default
+ method fold_call_using_clause' : (call_using_clause with_loc, 'a) fold = default
+ method fold_call_using_by : (call_using_by , 'a) fold = default
+ method fold_date_time : (date_time , 'a) fold = default
+ method fold_divide_operands : (divide_operands , 'a) fold = default
+ method fold_file_option : (file_option , 'a) fold = default
+ method fold_multiply_operands : (multiply_operands , 'a) fold = default
+ method fold_open_mode : (open_mode , 'a) fold = default
+ method fold_position : (position , 'a) fold = default
+ method fold_raising : (raising , 'a) fold = default
+ method fold_read_direction : (read_direction , 'a) fold = default
+ method fold_read_lock_behavior : (read_lock_behavior , 'a) fold = default
+ method fold_retry_clause : (retry_clause , 'a) fold = default
+ method fold_search_condition : (search_condition , 'a) fold = default
+ method fold_sharing_mode : (sharing_mode , 'a) fold = default
+ method fold_stage : (stage , 'a) fold = default
+ method fold_advancing_phrase : (advancing_phrase , 'a) fold = default
+ method fold_write_target : (write_target , 'a) fold = default
+ method fold_procedure_range: 'x. ('x procedure_range, 'a) fold = default
+ (* SET *)
+ method fold_set_attribute_switch : (set_attribute_switch , 'a) fold = default
+ method fold_screen_attribute : (screen_attribute , 'a) fold = default
+ method fold_set_ambiguous_method : (set_ambiguous_method , 'a) fold = default
+ method fold_on_off : (on_off , 'a) fold = default
+ method fold_locale_category : (locale_category , 'a) fold = default
+ method fold_set_save_locale : (set_save_locale , 'a) fold = default
+ method fold_set_locale_target : (set_locale_target , 'a) fold = default
+ method fold_set_locale_source : (set_locale_source , 'a) fold = default
+ method fold_start_position : (start_position , 'a) fold = default
+ method fold_float_content : (float_content , 'a) fold = default
+
+end
+
+let fold_basic_arithmetic_operands (v: _ #folder) =
+ handle v#fold_basic_arithmetic_operands
+ ~continue:begin fun o x -> match o with
+ | ArithSimple { sources; targets } -> x
+ >> fold_list ~fold:fold_ident_or_numlit v sources
+ >> fold_rounded_idents v targets
+ | ArithGiving { sources; to_or_from_item; targets } -> x
+ >> fold_list ~fold:fold_ident_or_numlit v sources
+ >> fold_ident_or_numlit v to_or_from_item
+ >> fold_rounded_idents v targets
+ | ArithCorresponding { source; target } -> x
+ >> fold_qualname v source
+ >> fold_rounded_ident v target
+ end
+
+let fold_call_using_by (v: _ #folder) =
+ leaf v#fold_call_using_by
+
+let fold_call_using_clause (v: _ #folder) =
+ handle v#fold_call_using_clause
+ ~continue:begin fun { call_using_by; call_using_expr } x -> x
+ >> fold_option ~fold:fold_call_using_by v call_using_by
+ >> fold_option ~fold:fold_expr v call_using_expr
+ end
+
+let fold_call_using_clause' (v: _ #folder) =
+ handle' v#fold_call_using_clause' v ~fold:fold_call_using_clause
+
+let fold_date_time (v: _ #folder) =
+ leaf v#fold_date_time (* NB: only `bool` children: consider as a leaf *)
+
+let fold_divide_operands (v: _ #folder) =
+ handle v#fold_divide_operands
+ ~continue:begin fun o x -> match o with
+ | DivideInto { divisor; dividends } -> x
+ >> fold_ident_or_numlit v divisor
+ >> fold_rounded_idents v dividends
+ | DivideGiving { divisor; dividend; giving; into; remainder } -> x
+ >> fold_ident_or_numlit v divisor
+ >> fold_ident_or_numlit v dividend
+ >> fold_rounded_idents v giving
+ >> fold_bool v into
+ >> fold_option ~fold:fold_ident v remainder
+ end
+
+let fold_file_option (v: _ #folder) =
+ leaf v#fold_file_option
+
+let fold_multiply_operands (v: _ #folder) =
+ handle v#fold_multiply_operands
+ ~continue:begin fun o x -> match o with
+ | MultiplyBy { multiplier; multiplicand } -> x
+ >> fold_ident_or_numlit v multiplier
+ >> fold_rounded_idents v multiplicand
+ | MultiplyGiving { multiplier; multiplicand; targets } -> x
+ >> fold_ident_or_numlit v multiplier
+ >> fold_ident_or_numlit v multiplicand
+ >> fold_rounded_idents v targets
+ end
+
+let fold_open_mode (v: _ #folder) =
+ leaf v#fold_open_mode
+
+let fold_position (v: _ #folder) =
+ handle v#fold_position
+ ~continue:begin fun p x -> match p with
+ | LinePosition i
+ | ColumnPosition i -> x
+ >> fold_ident_or_intlit v i
+ | LineColumnPosition (i, j) -> x
+ >> fold_ident_or_intlit v i
+ >> fold_ident_or_intlit v j
+ end
+
+let fold_raising (v: _ #folder) =
+ handle v#fold_raising
+ ~continue:begin function
+ | RaisingIdent i -> fold_ident v i
+ | RaisingException n -> fold_name' v n
+ | RaisingLastException -> Fun.id
+ end
+
+let fold_read_direction (v: _ #folder) =
+ leaf v#fold_read_direction
+
+let fold_retry_clause (v: _ #folder) =
+ handle v#fold_retry_clause
+ ~continue:begin function
+ | RetryNTimes e
+ | RetryForNSeconds e -> fold_expr v e
+ | RetryForever -> Fun.id
+ end
+
+let fold_read_lock_behavior (v: _ #folder) =
+ handle v#fold_read_lock_behavior
+ ~continue:begin function
+ | ReadAdvancingOnLock
+ | ReadIgnoringLock -> Fun.id
+ | ReadRetry retry_clause -> fold_retry_clause v retry_clause
+ end
+
+let fold_search_condition (v: _ #folder) =
+ handle v#fold_search_condition
+ ~continue:begin fun cond x -> match cond with
+ | IsEqual { data_item; condition } -> x
+ >> fold_qualident v data_item
+ >> fold_expression v condition
+ | Cond ql -> x
+ >> fold_qualident v ql
+ end
+
+let fold_sharing_mode (v: _ #folder) =
+ leaf v#fold_sharing_mode
+
+let fold_stage (v: _ #folder) =
+ leaf v#fold_stage
+
+let fold_advancing_phrase (v: _ #folder) =
+ handle v#fold_advancing_phrase
+ ~continue:begin fun phrase x -> match phrase with
+ | AdvancingLines { stage; lines; ambiguous } -> x
+ >> fold_stage v stage
+ >> fold_ident_or_intlit v lines
+ >> fold_bool v ambiguous
+ | AdvancingPage { stage } -> x
+ >> fold_stage v stage
+ end
+
+let fold_start_position (v: _#folder) =
+ handle v#fold_start_position
+ ~continue:begin fun pos x -> match pos with
+ | StartPositionFirst
+ | StartPositionLast -> x
+ | StartPositionKey { operator; name; length } -> x
+ >> fold_relop v operator
+ >> fold_qualname v name
+ >> fold_option ~fold:fold_expression v length
+ end
+
+let fold_write_target (v: _ #folder) =
+ handle v#fold_write_target
+ ~continue:begin function
+ | WriteTargetName qn -> fold_qualname v qn
+ | WriteTargetFile name' -> fold_name' v name'
+ end
+
+
+(* --- *)
+
+let fold_procedure_range (v: _ #folder) ~fold =
+ handle v#fold_procedure_range
+ ~continue:begin fun { procedure_start; procedure_end } x -> x
+ >> fold v procedure_start
+ >> fold_option ~fold v procedure_end
+ end
+
+(* SET *)
+
+let fold_screen_attribute (v: _ #folder) =
+ leaf v#fold_screen_attribute
+
+let fold_set_ambiguous_method (v: _ #folder) =
+ leaf v#fold_set_ambiguous_method
+
+let fold_on_off (v: _ #folder) =
+ leaf v#fold_on_off
+
+let fold_locale_category (v: _ #folder) =
+ leaf v#fold_locale_category
+
+let fold_set_save_locale (v: _ #folder) =
+ leaf v#fold_set_save_locale
+
+let fold_set_attribute_switch (v: _ #folder) =
+ handle v#fold_set_attribute_switch
+ ~continue:begin fun { set_attribute; set_attribute_switch_value } x -> x
+ >> fold_screen_attribute v set_attribute
+ >> fold_on_off v set_attribute_switch_value
+ end
+
+let fold_set_locale_target (v: _ #folder) =
+ handle v#fold_set_locale_target
+ ~continue:begin function
+ | SetLocaleTarget locale_category ->
+ fold_locale_category v locale_category
+ | SetLocaleTargetUserDefault -> Fun.id
+ end
+
+let fold_set_locale_source (v: _ #folder) =
+ handle v#fold_set_locale_source
+ ~continue:begin function
+ | SetLocaleSource id -> fold_ident v id
+ | SetLocaleSourceUserDefault
+ | SetLocaleSourceSystemDefault -> Fun.id
+ end
+
+let fold_float_content (v: _ #folder) =
+ handle v#fold_float_content
+ ~continue:begin function
+ | FarthestFromZero b
+ | NearestToZero b -> fold_bool v b
+ | FloatInfinity
+ | FloatNotANumber
+ | FloatNotANumberSignaling -> Fun.id
+ end
diff --git a/src/lsp/cobol_ast/package.toml b/src/lsp/cobol_ast/package.toml
new file mode 100644
index 000000000..c7b3dd71c
--- /dev/null
+++ b/src/lsp/cobol_ast/package.toml
@@ -0,0 +1,75 @@
+
+# name of package
+name = "cobol_ast"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+# generators = [ "ocamllex", "menhir" ]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+preprocess = "pps ppx_deriving.show ppx_deriving.ord"
+
+# files to skip while updating at package level
+skip = ["index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+cobol_common = "version"
+ppx_deriving = ">=5.2.1"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+# ...
diff --git a/src/lsp/cobol_ast/raw.ml b/src/lsp/cobol_ast/raw.ml
new file mode 100644
index 000000000..a2ac6a2a3
--- /dev/null
+++ b/src/lsp/cobol_ast/raw.ml
@@ -0,0 +1,510 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Ast
+
+module Misc_sections = struct
+ type informational_paragraphs = Ast.informational_paragraphs [@@deriving show]
+ type options_paragraph = Ast.options_paragraph [@@deriving show]
+ type environment_division = Ast.environment_division [@@deriving show]
+end
+
+module Data_sections (Picture: Abstract.PICTURE) = struct
+ include Picture
+
+ type picture_clause =
+ {
+ picture: Picture.picture;
+ picture_locale: locale_phrase option;
+ picture_depending: qualname with_loc option;
+ }
+ [@@deriving show]
+
+ (* TODO (can be delayed): Unify some of the types (probably like for terms) *)
+
+ type data_clause =
+ | DataAligned (* +COB2002 *)
+ | DataAnyLength (* +COB2002 *)
+ | DataBased (* +COB2002 *)
+ | DataBlankWhenZero
+ | DataConstantRecord (* +COB2002 *)
+ | DataOccurs of data_occurs_clause
+ | DataType of name with_loc (* +COB2002 *)
+ | DataValue of data_value_clause
+ | DataDynamicLength of (* +COB2002 *)
+ {
+ dynamic_length_structure_name: name with_loc option;
+ limit_is: integer option;
+ }
+ | DataExternal of external_clause
+ | DataGlobal
+ | DataGroupUsage of group_usage_clause (* +COB2002 *)
+ | DataJustified
+ | DataPicture of picture_clause with_loc
+ | DataProperty of property_clause with_loc (* +COB2002 *)
+ | DataRedefines of name with_loc
+ | DataSameAs of name with_loc (* +COB2002 *)
+ | DataSelectWhen of select_when_clause (* +COB2002 *)
+ | DataSign of sign_clause
+ | DataSynchronized of synchronized_clause
+ | DataTypedef of (* +COB2002 *)
+ {
+ strong: bool;
+ }
+ | DataUsage of usage_clause
+ | DataValidation of validation_clause (* +COB2002 *)
+ [@@deriving show]
+
+ type report_group_clause =
+ | ReportType of report_type_clause
+ | ReportNextGroup of next_group_clause
+ | ReportLine of line_position list
+ | ReportPicture of picture_clause with_loc
+ | ReportUsage of report_screen_usage_clause
+ | ReportSign of sign_clause
+ | ReportJustified
+ | ReportColumn of
+ {
+ alignment: alignment;
+ position: column_position list; (* non-empty *)
+ }
+ | ReportBlankWhenZero
+ | ReportSource of
+ {
+ source: expression list; (* non-empty *)
+ rounding: rounding;
+ }
+ | ReportSum of
+ {
+ sum_of: sum_phrase list; (* non-empty *)
+ reset_on: report_data_name_or_final option;
+ rounding: rounding;
+ }
+ | ReportValue of literal
+ | ReportPresentWhen of condition (* +COB2002 *)
+ | ReportGroupIndicate
+ | ReportOccurs of (* +COB2002 *)
+ {
+ from: integer;
+ to_: integer option;
+ depending: qualname with_loc option;
+ step: integer option;
+ }
+ | ReportVarying of data_varying list (* +COB2002 *)
+ [@@deriving show]
+
+ type screen_clause =
+ | ScreenAuto
+ | ScreenBlank of blank_clause
+ | ScreenBlankWhenZero
+ | ScreenErase of erase_clause
+ | ScreenFull
+ | ScreenGlobal
+ | ScreenJustified
+ | ScreenPicture of picture_clause with_loc
+ | ScreenUsage of report_screen_usage_clause
+ | ScreenRequired
+ | ScreenAttribute of screen_attribute_clause with_loc list (* non-empty *)
+ | ScreenColumn of screen_line_column_clause
+ | ScreenLine of screen_line_column_clause
+ | ScreenOccurs of integer
+ | ScreenSecure
+ | ScreenSign of sign_clause
+ | ScreenSourceDestination of source_destination_clause with_loc list (* non-empty *)
+ [@@deriving show]
+
+ type data_item =
+ {
+ data_level: data_level with_loc;
+ data_name: data_name with_loc option;
+ data_clauses: data_clause with_loc list;
+ }
+ [@@deriving show]
+
+ type screen_item =
+ {
+ screen_level: int;
+ screen_data_name: data_name with_loc option;
+ screen_clauses: screen_clause with_loc list;
+ }
+ [@@deriving show]
+
+ type report_group_item =
+ {
+ report_level: int;
+ report_data_name: data_name with_loc option;
+ report_group_clauses: report_group_clause with_loc list;
+ }
+ [@@deriving show]
+
+ type data_ = [`data]
+ type constant_ = [`const]
+ type rename_ = [`rename]
+ type condition_name_ = [`condition_name]
+ type screen_ = [`screen]
+ type report_group_ = [`report_group]
+ type _ item_descr =
+ | Constant: constant_item -> [>constant_] item_descr
+ | Data: data_item -> [>data_] item_descr
+ | Renames: rename_item -> [>rename_] item_descr
+ | CondName: condition_name_item -> [>condition_name_] item_descr
+ | Screen: screen_item -> [>screen_] item_descr
+ | ReportGroup: report_group_item -> [>report_group_] item_descr
+
+ let pp_item_descr (type k) : k item_descr Pretty.printer = fun ppf -> function
+ | Constant c -> pp_constant_item ppf c
+ | Data d -> pp_data_item ppf d
+ | Renames r -> pp_rename_item ppf r
+ | CondName c -> pp_condition_name_item ppf c
+ | Screen s -> pp_screen_item ppf s
+ | ReportGroup r -> pp_report_group_item ppf r
+
+ type data_item_descr = data_ item_descr
+ and constant_item_descr = constant_ item_descr
+ and working_item_descr = [constant_|data_|
+ rename_|condition_name_] item_descr
+ and report_item_descr = [constant_|report_group_] item_descr
+ and screen_item_descr = [constant_|screen_] item_descr
+ and any_item_descr = [constant_|data_|rename_|condition_name_|
+ report_group_|screen_] item_descr
+ let pp_data_item_descr = pp_item_descr
+ let pp_constant_item_descr = pp_item_descr
+ let pp_working_item_descr = pp_item_descr
+ let pp_report_item_descr = pp_item_descr
+ let pp_screen_item_descr = pp_item_descr
+ let pp_any_item_descr = pp_item_descr
+
+ type working_storage_item_descr = working_item_descr [@@deriving show]
+ type linkage_item_descr = working_item_descr [@@deriving show]
+ type file_item_descr = working_item_descr [@@deriving show]
+ type communication_item_descr = working_item_descr [@@deriving show]
+ type local_storage_item_descr = working_item_descr [@@deriving show]
+
+ type file_descr =
+ {
+ file_name: name with_loc;
+ file_clauses: file_clauses;
+ file_items: file_item_descr with_loc list;
+ }
+ [@@deriving show]
+
+ and file_clauses =
+ | FileFD of file_fd_clause with_loc list
+ | FileSD of file_sd_clause with_loc list
+ [@@deriving show]
+
+ and file_fd_clause =
+ | FileExternal of external_clause
+ | FileGlobal
+ | FileFormat of format_clause
+ | FileBlockContains of
+ {
+ from: integer;
+ to_: integer option;
+ characters_or_records: file_block_contents;
+ }
+ | FileRecord of record_clause
+ | FileLabel of label_clause
+ | FileValueOf of value_of_clause list
+ | FileData of file_data_clause
+ | FileLinage of file_linage_clause
+ | FileCodeSet of alphabet_specification
+ | FileReport of name with_loc list
+ [@@deriving show]
+
+ and file_sd_clause =
+ | FileSDRecord of record_clause
+ | FileSDData of file_data_clause
+ | FileSDGlobal
+ [@@deriving show]
+
+
+ type communication_descr =
+ {
+ comm_name: name with_loc;
+ comm_clauses: comm_clause with_loc list;
+ comm_items: communication_item_descr with_loc list;
+ comm_direction: comm_direction;
+ }
+ [@@deriving show]
+
+ and comm_direction =
+ | CommInput of { initial: bool; items: data_name with_loc list }
+ | CommOutput
+ | CommIO of { initial: bool; items: name with_loc list }
+ [@@deriving show]
+
+
+ type report_descr =
+ {
+ report_name: name with_loc;
+ report_clauses: report_clause with_loc list;
+ report_items: report_item_descr with_loc list;
+ }
+ [@@deriving show]
+
+
+ (* Actual sections *)
+
+ type file_section = file_descr with_loc list [@@deriving show]
+ type working_storage_section = working_storage_item_descr with_loc list [@@deriving show]
+ type linkage_section = linkage_item_descr with_loc list [@@deriving show]
+ type communication_section = communication_descr with_loc list [@@deriving show]
+ type local_storage_section = local_storage_item_descr with_loc list [@@deriving show]
+ type report_section = report_descr with_loc list [@@deriving show]
+ type screen_section = screen_item_descr with_loc list [@@deriving show]
+
+end
+
+module Data_division (Data_sections: Abstract.DATA_SECTIONS) = struct
+ include Data_sections
+
+ type data_division =
+ {
+ file_section: file_section option;
+ working_storage_section: working_storage_section option;
+ linkage_section: linkage_section option;
+ communication_section: communication_section option;
+ local_storage_section: local_storage_section option;
+ report_section: report_section option;
+ screen_section: screen_section option;
+ }
+ [@@deriving show]
+
+end
+
+module Statements = struct
+ type statement = Ast.statement [@@deriving show]
+ type statements = Ast.statements [@@deriving show]
+end
+
+module Proc_division (Statements: Abstract.STATEMENTS) = struct
+ include Statements
+
+ type procedure_division =
+ {
+ procedure_using_clauses: using_clause with_loc list;
+ procedure_returning: ident with_loc option;
+ procedure_raising_phrases: raising_phrase with_loc list;
+ procedure_declaratives: declarative with_loc list;
+ procedure_paragraphs: paragraph with_loc list;
+ }
+ [@@deriving show]
+
+ and using_clause =
+ | UsingByReference of using_by_reference list
+ | UsingByValue of name with_loc list
+ [@@deriving show]
+
+ and using_by_reference =
+ {
+ using_by_reference: name with_loc;
+ using_by_reference_optional: bool;
+ }
+ [@@deriving show]
+
+ and raising_phrase =
+ {
+ raising: name with_loc;
+ raising_factory: bool;
+ }
+ [@@deriving show]
+
+ and declarative =
+ {
+ declarative_name: name with_loc;
+ declarative_segment: integer option;
+ declarative_use: declarative_use option;
+ declarative_sentences: statements with_loc list;
+ }
+ [@@deriving show]
+
+ and declarative_use =
+ | UseAfterFileException of
+ {
+ global: bool;
+ trigger: use_file_exception_on;
+ }
+ | UseBeforeReporting of
+ {
+ global: bool;
+ report_group: ident;
+ }
+ | UseForDebugging of use_for_debugging_target list
+ | UseAfterIOException of use_after_exception list
+ | UseAfterExceptionObject of name with_loc
+ [@@deriving show]
+
+ and use_for_debugging_target =
+ | UseForDebuggingProcedure of
+ {
+ all: bool;
+ procedure: qualname;
+ }
+ | UseForDebuggingAllProcedures
+ [@@deriving show]
+
+ and use_file_exception_on =
+ | UseFileExceptionOnNames of name with_loc list
+ | UseFileExceptionOnOpenMode of open_mode
+ [@@deriving show]
+
+ and use_after_exception =
+ {
+ use_after_exception: name with_loc;
+ use_after_exception_on_files: name with_loc list;
+ }
+ [@@deriving show]
+
+ and paragraph =
+ {
+ paragraph_name: name with_loc option;
+ paragraph_is_section: bool;
+ paragraph_segment: integer option;
+ paragraph_sentences: statements with_loc list;
+ }
+ [@@deriving show]
+
+end
+
+module Compilation_group
+ (Misc_sections: Abstract.MISC_SECTIONS)
+ (Data_division: Abstract.DATA_DIVISION)
+ (Proc_division: Abstract.PROC_DIVISION) =
+struct
+
+ include Misc_sections
+ include Data_division
+ include Proc_division
+
+ type program_unit =
+ {
+ program_name: name with_loc;
+ program_as: strlit option;
+ program_level: program_level;
+ program_options: options_paragraph option;
+ program_env: environment_division with_loc option;
+ program_data: data_division with_loc option;
+ program_proc: procedure_division with_loc option;
+ program_end_name: name with_loc option;
+ }
+ [@@deriving show]
+
+ and program_level =
+ | ProgramDefinition of
+ { (* Note: more general than before (allows nested prototypes): *)
+ kind: program_kind option;
+ has_identification_division: bool;
+ informational_paragraphs: informational_paragraphs; (* ~COB85, -COB2002 *)
+ nested_programs: program_unit with_loc list;
+ }
+ | ProgramPrototype
+ [@@deriving show]
+
+ and program_kind =
+ | Common
+ | Initial
+ | Recursive
+ [@@deriving show]
+
+ type function_unit =
+ {
+ function_name: name with_loc;
+ function_as: strlit option;
+ function_is_proto: bool;
+ function_options: options_paragraph option;
+ function_env: environment_division with_loc option;
+ function_data: data_division with_loc option;
+ function_proc: procedure_division option;
+ function_end_name: name with_loc;
+ }
+ [@@deriving show]
+
+ type method_definition =
+ {
+ method_name: name with_loc;
+ method_kind: method_kind;
+ method_override: bool;
+ method_final: bool;
+ method_options: options_paragraph option;
+ method_env: environment_division with_loc option;
+ method_data: data_division with_loc option;
+ method_proc: procedure_division option;
+ method_end_name: name with_loc;
+ }
+ [@@deriving show]
+
+ and method_kind =
+ | NamedMethod of { as_: strlit option }
+ | PropertyMethod of { kind: property_kind }
+
+ type factory_definition = (* Note: could be merged with instance_definition *)
+ {
+ factory_implements: name with_loc list;
+ factory_options: options_paragraph option;
+ factory_env: environment_division with_loc option;
+ factory_data: data_division with_loc option;
+ factory_methods: method_definition with_loc list option;
+ }
+ [@@deriving show]
+
+ type instance_definition =
+ {
+ instance_implements: name with_loc list;
+ instance_options: options_paragraph option;
+ instance_env: environment_division with_loc option;
+ instance_data: data_division with_loc option;
+ instance_methods: method_definition with_loc list option;
+ }
+ [@@deriving show]
+
+ type class_definition =
+ {
+ class_name: name with_loc;
+ class_as: strlit option;
+ class_final: bool;
+ class_inherits: name with_loc list;
+ class_usings: name with_loc list;
+ class_options: options_paragraph option;
+ class_env: environment_division with_loc option;
+ class_factory: factory_definition option;
+ class_instance: instance_definition option;
+ class_end_name: name with_loc;
+ }
+ [@@deriving show]
+
+ type interface_definition =
+ {
+ interface_name: name with_loc;
+ interface_as: strlit option;
+ interface_inherits: name with_loc list;
+ interface_usings: name with_loc list;
+ interface_options: options_paragraph option;
+ interface_env: environment_division with_loc option;
+ interface_methods: method_definition with_loc list option;
+ interface_end_name: name with_loc;
+ }
+ [@@deriving show]
+
+ type compilation_unit =
+ | Program of program_unit
+ | Function of function_unit
+ | ClassDefinition of class_definition
+ | InterfaceDefinition of interface_definition
+ [@@deriving show]
+
+ type compilation_group =
+ compilation_unit with_loc list
+ [@@deriving show]
+
+end
diff --git a/src/lsp/cobol_ast/raw_compilation_group_visitor.ml b/src/lsp/cobol_ast/raw_compilation_group_visitor.ml
new file mode 100644
index 000000000..a19774055
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_compilation_group_visitor.ml
@@ -0,0 +1,213 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Srcloc.INFIX
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make
+ (Misc_sections: Abstract.MISC_SECTIONS)
+ (Data_division: Abstract.DATA_DIVISION)
+ (Proc_division: Abstract.PROC_DIVISION) =
+struct
+
+ module Compilation_group =
+ Raw.Compilation_group (Misc_sections) (Data_division) (Proc_division)
+
+ module Compilation_group_visitor =
+ Abstract_visitor.For_compilation_group (Compilation_group)
+ module Misc_sections_visitor =
+ Abstract_visitor.For_misc_sections (Misc_sections)
+ module Data_division_visitor =
+ Abstract_visitor.For_data_division (Data_division)
+ module Proc_division_visitor =
+ Abstract_visitor.For_proc_division (Proc_division)
+
+ open Compilation_group
+
+ class virtual ['a] folder = object
+ inherit ['a] Terms_visitor.folder
+ inherit ['a] Misc_sections_visitor.folder
+ inherit ['a] Data_division_visitor.folder
+ method fold_data_division' : (data_division with_loc , 'a) fold = default
+ inherit ['a] Proc_division_visitor.folder
+ method fold_procedure_division' : (procedure_division with_loc , 'a) fold = default
+ inherit ['a] Compilation_group_visitor.folder
+ method fold_program_unit : (program_unit , 'a) fold = default
+ method fold_program_unit' : (program_unit with_loc , 'a) fold = default
+ method fold_function_unit : (function_unit , 'a) fold = default
+ method fold_function_unit' : (function_unit with_loc , 'a) fold = default
+ method fold_method_definition : (method_definition , 'a) fold = default
+ method fold_factory_definition : (factory_definition , 'a) fold = default
+ method fold_instance_definition : (instance_definition , 'a) fold = default
+ method fold_class_definition' : (class_definition with_loc , 'a) fold = default
+ method fold_interface_definition' : (interface_definition with_loc, 'a) fold = default
+ method fold_compilation_unit' : (compilation_unit with_loc , 'a) fold = default
+ (* Additonal methods: *)
+ method fold_method_kind : (method_kind , 'a) fold = default
+ end
+
+ let todo x = todo __MODULE__ x
+ let partial x = partial __MODULE__ x
+
+ let fold_options_paragraph_opt (v: _ #folder) =
+ fold_option ~fold:(fun v -> v#continue_with_options_paragraph) v
+
+ let fold_environment_division' (v: _ #folder) =
+ fold' ~fold:(fun v -> v#continue_with_environment_division) v
+
+ let fold_environment_division'_opt (v: _ #folder) =
+ fold_option ~fold:fold_environment_division' v
+
+ let fold_data_division' (v: _ #folder) =
+ handle' v#fold_data_division' v ~fold:(fun v -> v#continue_with_data_division)
+
+ let fold_data_division'_opt (v: _ #folder) =
+ fold_option ~fold:fold_data_division' v
+
+ let fold_procedure_division' (v: _ #folder) =
+ handle' v#fold_procedure_division' v
+ ~fold:(fun v -> v#continue_with_procedure_division)
+
+ let fold_procedure_division_opt (v: _ #folder) =
+ fold_option ~fold:(fun v -> v#continue_with_procedure_division) v
+
+ let fold_procedure_division'_opt (v: _ #folder) =
+ fold_option ~fold:fold_procedure_division' v
+
+ let rec fold_program_unit (v: _ #folder) =
+ handle v#fold_program_unit
+ ~continue:begin fun { program_name; program_as; program_level;
+ program_options; program_env; program_data;
+ program_proc; program_end_name } x -> x
+ >> fold_name' v program_name
+ >> fold_strlit_opt v program_as
+ >> fold_options_paragraph_opt v program_options
+ >> fold_environment_division'_opt v program_env
+ >> fold_data_division'_opt v program_data
+ >> (fun x -> match program_level with
+ | ProgramPrototype -> x
+ | ProgramDefinition { kind;
+ has_identification_division;
+ informational_paragraphs = infos;
+ nested_programs } -> ignore kind; x
+ >> fold_bool v has_identification_division
+ >> v#continue_with_informational_paragraphs infos
+ >> fold_with_loc_list v nested_programs ~fold:fold_program_unit)
+ >> fold_procedure_division'_opt v program_proc
+ >> fold_name'_opt v program_end_name (* XXX: useful? *)
+ end
+
+ let fold_program_unit' (v: _#folder) =
+ handle' v#fold_program_unit' ~fold:fold_program_unit v
+
+ let fold_function_unit (v: _#folder) =
+ handle v#fold_function_unit
+ ~continue:begin fun { function_name; function_as; function_is_proto;
+ function_options; function_env; function_data;
+ function_proc; function_end_name } x -> x
+ >> fold_name' v function_name
+ >> fold_strlit_opt v function_as
+ >> fold_bool v function_is_proto (* XXX: useful? *)
+ >> fold_options_paragraph_opt v function_options
+ >> fold_environment_division'_opt v function_env
+ >> fold_data_division'_opt v function_data
+ >> fold_procedure_division_opt v function_proc
+ >> fold_name' v function_end_name (* XXX: useful? *)
+ end
+
+ let fold_function_unit' (v: _#folder) =
+ handle' v#fold_function_unit' ~fold:fold_function_unit v
+
+ let fold_method_kind (v: _#folder) =
+ handle v#fold_method_kind
+ ~continue:begin function
+ | NamedMethod { as_ } -> fold_strlit_opt v as_
+ | PropertyMethod { kind } -> fold_property_kind v kind
+ end
+
+ let fold_method_definition (v: _#folder) =
+ handle v#fold_method_definition
+ ~continue:begin fun { method_name; method_kind;
+ method_override; method_final;
+ method_options; method_env; method_data;
+ method_proc; method_end_name } x -> x
+ >> fold_name' v method_name
+ >> fold_method_kind v method_kind
+ >> fold_bool v method_override
+ >> fold_bool v method_final
+ >> fold_options_paragraph_opt v method_options
+ >> fold_environment_division'_opt v method_env
+ >> fold_data_division'_opt v method_data
+ >> fold_procedure_division_opt v method_proc
+ >> fold_name' v method_end_name (* XXX: useful? *)
+ end
+
+ let fold_factory_definition (v: _#folder) =
+ handle v#fold_factory_definition
+ ~continue:begin fun { factory_implements; factory_options; factory_env;
+ factory_data; factory_methods } x -> x
+ >> fold_name'_list v factory_implements
+ >> fold_options_paragraph_opt v factory_options
+ >> fold_environment_division'_opt v factory_env
+ >> fold_data_division'_opt v factory_data
+ >> fold_option v factory_methods
+ ~fold:(fold_with_loc_list ~fold:fold_method_definition)
+ end
+
+ let fold_instance_definition (v: _#folder) =
+ handle v#fold_instance_definition
+ ~continue:begin fun { instance_implements; instance_options; instance_env;
+ instance_data; instance_methods } x ->
+ ignore instance_env;
+ partial __LINE__ "fold_instance_definition" ();
+ x
+ >> fold_name'_list v instance_implements
+ >> fold_options_paragraph_opt v instance_options
+ >> fold_data_division'_opt v instance_data
+ >> fold_option v instance_methods
+ ~fold:(fold_with_loc_list ~fold:fold_method_definition)
+ end
+
+ let fold_class_definition' (v: _#folder) =
+ handle v#fold_class_definition'
+ ~continue:(todo __LINE__ "fold_class_definition")
+
+ let fold_interface_definition' (v: _#folder) =
+ handle v#fold_interface_definition'
+ ~continue:(todo __LINE__ "fold_interface_definition")
+
+ let fold_compilation_unit' (v: _#folder) =
+ handle v#fold_compilation_unit'
+ ~continue:begin fun { payload; loc } -> match payload with
+ | Program d -> fold_program_unit' v (d &@ loc)
+ | Function d -> fold_function_unit' v (d &@ loc)
+ | ClassDefinition d -> fold_class_definition' v (d &@ loc)
+ | InterfaceDefinition d -> fold_interface_definition' v (d &@ loc)
+ end
+
+ let fold_compilation_group (v: _#folder) =
+ handle v#fold_compilation_group
+ ~continue:(fold_list ~fold:fold_compilation_unit' v)
+
+ (* let fold_compilation_group' (v: _#folder) = *)
+ (* handle' v#fold_compilation_group' ~fold:fold_compilation_group v *)
+
+end
diff --git a/src/lsp/cobol_ast/raw_data_division_visitor.ml b/src/lsp/cobol_ast/raw_data_division_visitor.ml
new file mode 100644
index 000000000..fb1b5d85c
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_data_division_visitor.ml
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make
+ (Data_sections: Abstract.DATA_SECTIONS) =
+struct
+
+ module Data_division =
+ Raw.Data_division (Data_sections)
+
+ module Data_sections_visitor =
+ Abstract_visitor.For_data_sections (Data_sections)
+ module Data_division_visitor =
+ Abstract_visitor.For_data_division (Data_division)
+
+ class virtual ['a] folder = object
+ inherit ['a] Terms_visitor.folder
+ inherit ['a] Data_sections_visitor.folder
+ inherit ['a] Data_division_visitor.folder
+ end
+
+ let fold_data_division (v: _#folder) =
+ handle v#fold_data_division
+ ~continue:begin fun { file_section; working_storage_section;
+ linkage_section; communication_section;
+ local_storage_section; report_section;
+ screen_section } x -> x
+ >> fold_option v file_section
+ ~fold:(fun v -> v#continue_with_file_section)
+ >> fold_option v working_storage_section
+ ~fold:(fun v -> v#continue_with_working_storage_section)
+ >> fold_option v linkage_section
+ ~fold:(fun v -> v#continue_with_linkage_section)
+ >> fold_option v communication_section
+ ~fold:(fun v -> v#continue_with_communication_section)
+ >> fold_option v local_storage_section
+ ~fold:(fun v -> v#continue_with_local_storage_section)
+ >> fold_option v report_section
+ ~fold:(fun v -> v#continue_with_report_section)
+ >> fold_option v screen_section
+ ~fold:(fun v -> v#continue_with_screen_section)
+ end
+
+end
diff --git a/src/lsp/cobol_ast/raw_data_sections_visitor.ml b/src/lsp/cobol_ast/raw_data_sections_visitor.ml
new file mode 100644
index 000000000..7cf1c7241
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_data_sections_visitor.ml
@@ -0,0 +1,441 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Srcloc.INFIX
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make
+ (Picture: Abstract.PICTURE) =
+struct
+
+ module Data_sections =
+ Raw.Data_sections (Picture)
+
+ module Picture_visitor =
+ Abstract_visitor.For_picture (Picture)
+ module Data_sections_visitor =
+ Abstract_visitor.For_data_sections (Data_sections)
+
+ open Data_descr
+ open Data_sections
+
+ class virtual ['a] folder = object
+ inherit ['a] Terms_visitor.folder
+ inherit ['a] Picture_visitor.folder
+ inherit ['a] Data_sections_visitor.folder
+ method fold_data_level : (data_level , 'a) fold = default
+ method fold_data_level' : (data_level with_loc , 'a) fold = default
+ method fold_data_name : (data_name , 'a) fold = default
+ method fold_data_name' : (data_name with_loc , 'a) fold = default
+ method fold_locale_phrase : (locale_phrase , 'a) fold = default
+ method fold_constant_value : (constant_value , 'a) fold = default
+ method fold_constant_value' : (constant_value with_loc , 'a) fold = default
+ method fold_constant_item : (constant_item , 'a) fold = default
+ method fold_constant_item' : (constant_item with_loc , 'a) fold = default
+ method fold_rename_item : (rename_item , 'a) fold = default
+ method fold_rename_item' : (rename_item with_loc , 'a) fold = default
+ method fold_condition_name_value: (condition_name_value , 'a) fold = default
+ method fold_condition_name_item : (condition_name_item , 'a) fold = default
+ method fold_condition_name_item': (condition_name_item with_loc, 'a) fold = default
+ method fold_picture_clause : (picture_clause , 'a) fold = default
+ method fold_picture_clause' : (picture_clause with_loc , 'a) fold = default
+ method fold_data_clause : (data_clause , 'a) fold = default
+ method fold_data_clause' : (data_clause with_loc , 'a) fold = default
+ method fold_data_item : (data_item , 'a) fold = default
+ method fold_data_item' : (data_item with_loc , 'a) fold = default
+ method fold_comm_channel : (comm_channel , 'a) fold = default
+ method fold_comm_clause : (comm_clause , 'a) fold = default
+ method fold_comm_clause' : (comm_clause with_loc , 'a) fold = default
+ method fold_comm_direction : (comm_direction , 'a) fold = default
+ method fold_communication_descr : (communication_descr , 'a) fold = default
+ method fold_communication_descr': (communication_descr with_loc, 'a) fold = default
+ method fold_report_group_clause : (report_group_clause , 'a) fold = default
+ method fold_report_group_clause': (report_group_clause with_loc, 'a) fold = default
+ method fold_report_group_item : (report_group_item , 'a) fold = default
+ method fold_report_group_item' : (report_group_item with_loc , 'a) fold = default
+ method fold_report_clause : (report_clause , 'a) fold = default
+ method fold_report_clause' : (report_clause with_loc , 'a) fold = default
+ method fold_report_descr : (report_descr , 'a) fold = default
+ method fold_report_descr' : (report_descr with_loc , 'a) fold = default
+ method fold_screen_clause : (screen_clause , 'a) fold = default
+ method fold_screen_clause' : (screen_clause with_loc , 'a) fold = default
+ method fold_screen_item : (screen_item , 'a) fold = default
+ method fold_screen_item' : (screen_item with_loc , 'a) fold = default
+ method fold_data_occurs_clause : (data_occurs_clause , 'a) fold = default
+ method fold_sort_spec : (sort_spec , 'a) fold = default
+ method fold_sort_direction : (sort_direction , 'a) fold = default
+ end
+
+ let todo x = todo __MODULE__ x
+ and partial x = partial __MODULE__ x
+
+ let fold_data_level (v: _ #folder) =
+ leaf v#fold_data_level
+
+ let fold_data_level' (v: _ #folder) =
+ handle' v#fold_data_level' ~fold:fold_data_level v
+
+ let fold_data_name (v: _ #folder) =
+ handle v#fold_data_name
+ ~continue:(function DataName n -> fold_name' v n | DataFiller -> Fun.id)
+
+ let fold_data_name' (v: _ #folder) =
+ handle v#fold_data_name'
+ ~continue:(fold' ~fold:fold_data_name v)
+
+ let fold_data_name'_opt (v: _ #folder) =
+ fold_option ~fold:fold_data_name' v
+
+ let fold_locale_phrase (v: _ #folder) =
+ handle v#fold_locale_phrase
+ ~continue:begin fun { locale_name; locale_size } x -> x
+ >> fold_name'_opt v locale_name
+ >> fold_integer v locale_size
+ end
+
+ let fold_locale_phrase_opt (v: _ #folder) =
+ fold_option ~fold:fold_locale_phrase v
+
+ let fold_constant_value (v: _ #folder) =
+ handle v#fold_constant_value
+ ~continue:begin function
+ | ConstExpr e -> fold_expr v e
+ | ConstByteLength n | ConstLength n | ConstFrom n -> fold_name' v n
+ end
+
+ let fold_constant_value' (v: _ #folder) =
+ handle' v#fold_constant_value' ~fold:fold_constant_value v
+
+ let fold_constant_item (v: _ #folder) =
+ handle v#fold_constant_item
+ ~continue:begin fun { constant_level; constant_name;
+ constant_global; constant_value } x -> x
+ >> fold_data_level' v constant_level
+ >> fold_data_name'_opt v constant_name
+ >> fold_bool v constant_global
+ >> fold_constant_value' v constant_value
+ end
+
+ let fold_constant_item' (v: _ #folder) =
+ handle' v#fold_constant_item' ~fold:fold_constant_item v
+
+ let fold_rename_item (v: _ #folder) =
+ handle v#fold_rename_item
+ ~continue:begin fun { rename_level; rename_to;
+ rename_renamed; rename_through } x -> x
+ >> fold_data_level' v rename_level
+ >> fold_name' v rename_to
+ >> fold_qualname v rename_renamed
+ >> fold_qualname_opt v rename_through
+ end
+
+ let fold_rename_item' (v: _ #folder) =
+ handle' v#fold_rename_item' ~fold:fold_rename_item v
+
+ let fold_condition_name_value (v: _ #folder) =
+ handle v#fold_condition_name_value
+ ~continue:begin fun { condition_name_value; condition_name_through } x -> x
+ >> fold_literal v condition_name_value
+ >> fold_literal_opt v condition_name_through
+ end
+
+ let fold_condition_name_item (v: _ #folder) =
+ handle v#fold_condition_name_item
+ ~continue:begin fun { condition_name_level; (*is always 88*)
+ condition_name; condition_name_values;
+ condition_name_alphabet;
+ condition_name_when_false } x -> x
+ >> fold_data_level' v condition_name_level (*or ignore*)
+ >> fold_name' v condition_name
+ >> fold_list ~fold:fold_condition_name_value v condition_name_values
+ >> fold_name'_opt v condition_name_alphabet
+ >> fold_literal_opt v condition_name_when_false
+ end
+
+ let fold_condition_name_item' (v: _ #folder) =
+ handle' v#fold_condition_name_item' ~fold:fold_condition_name_item v
+
+ let fold_picture_clause (v: _ #folder) =
+ handle v#fold_picture_clause
+ ~continue:begin fun { picture; picture_locale; picture_depending } x -> x
+ >> v#continue_with_picture picture
+ >> fold_locale_phrase_opt v picture_locale
+ >> fold_qualname'_opt v picture_depending
+ end
+
+ let fold_picture_clause' (v: _ #folder) =
+ handle' v#fold_picture_clause' ~fold:fold_picture_clause v
+
+ let fold_sort_direction (v: _ #folder) = leaf v#fold_sort_direction
+
+ let fold_sort_spec (v: _ #folder) =
+ handle v#fold_sort_spec
+ ~continue:begin fun { sort_key_direction; sort_key_names } x -> x
+ >> fold_sort_direction v sort_key_direction
+ >> fold_list ~fold:fold_qualname v sort_key_names
+ end
+
+ let fold_data_occurs_clause (v: _ #folder) =
+ handle v#fold_data_occurs_clause
+ ~continue:begin fun c x -> match c with
+ | OccursFixed { times; key_is; indexed_by } -> x
+ >> fold_integer v times
+ >> fold_list ~fold:fold_sort_spec v key_is
+ >> fold_name'_list v indexed_by
+ | OccursDepending { from; to_; depending;
+ key_is; indexed_by } -> x
+ >> fold_integer v from
+ >> fold_integer v to_
+ >> fold_qualname' v depending
+ >> fold_list ~fold:fold_sort_spec v key_is
+ >> fold_name'_list v indexed_by
+ | OccursDynamic { capacity_in; from; to_;
+ initialized; key_is; indexed_by } -> x
+ >> fold_name'_opt v capacity_in
+ >> fold_integer_opt v from
+ >> fold_integer_opt v to_
+ >> fold_bool v initialized
+ >> fold_list ~fold:fold_sort_spec v key_is
+ >> fold_name'_list v indexed_by
+ end
+
+ let fold_data_clause (v: _ #folder) =
+ handle v#fold_data_clause
+ ~continue:begin function
+ | DataAligned
+ | DataAnyLength
+ | DataBased
+ | DataBlankWhenZero
+ | DataConstantRecord
+ | DataGlobal
+ | DataJustified -> Fun.id
+ | DataOccurs c -> fold_data_occurs_clause v c
+ | _ -> partial __LINE__ "fold_data_clause"
+ end
+
+ let fold_data_clause' (v: _ #folder) =
+ handle' v#fold_data_clause' ~fold:fold_data_clause v
+
+ let fold_data_clauses (v: _ #folder) =
+ fold_list ~fold:fold_data_clause' v
+
+ let fold_data_item (v: _ #folder) =
+ handle v#fold_data_item
+ ~continue:begin fun { data_level; data_name; data_clauses } x -> x
+ >> fold_data_level' v data_level
+ >> fold_data_name'_opt v data_name
+ >> fold_data_clauses v data_clauses
+ end
+
+ let fold_data_item' (v: _ #folder) =
+ handle' v#fold_data_item' ~fold:fold_data_item v
+
+ let fold_working_item_descr (v: _ #folder) : working_item_descr -> _ = function
+ | Constant c -> fold_constant_item v c
+ | Renames r -> fold_rename_item v r
+ | CondName c -> fold_condition_name_item v c
+ | Data e -> fold_data_item v e
+
+ let fold_working_item_descr' (v: _ #folder)
+ : working_item_descr with_loc -> _ = fun d -> match ~&d with
+ | Constant c -> fold_constant_item' v (c &@<- d)
+ | Renames r -> fold_rename_item' v (r &@<- d)
+ | CondName c -> fold_condition_name_item' v (c &@<- d)
+ | Data e -> fold_data_item' v (e &@<- d)
+
+ let fold_working_storage_item_descr = fold_working_item_descr
+ let fold_working_storage_item_descr' = fold_working_item_descr'
+ let fold_working_storage_section (v: _ #folder) =
+ handle v#fold_working_storage_section
+ ~continue:(fold_list ~fold:fold_working_storage_item_descr' v)
+
+ let fold_linkage_item_descr = fold_working_item_descr
+ let fold_linkage_item_descr' = fold_working_item_descr'
+ let fold_linkage_section (v: _ #folder) =
+ handle v#fold_linkage_section
+ ~continue:(fold_list ~fold:fold_linkage_item_descr' v)
+
+ let fold_file_item_descr = fold_working_item_descr
+ let fold_file_item_descr' = fold_working_item_descr'
+ let fold_file_section (v: _ #folder) =
+ handle v#fold_file_section
+ ~continue:(todo __LINE__ "fold_file_section")
+
+ let fold_comm_channel (v: _ #folder) =
+ leaf v#fold_comm_channel
+
+ let fold_comm_clause (v: _ #folder) =
+ handle v#fold_comm_clause
+ ~continue:begin fun c x -> match c with
+ | CommSymbolic (c, n) -> x
+ >> fold_comm_channel v c
+ >> fold_name' v n
+ | CommDestinationTable (i, nl) -> x
+ >> fold_integer v i
+ >> fold_name'_list v nl
+ | CommDestinationCount n
+ | CommMessageCount n
+ | CommMessageDate n
+ | CommMessageTime n
+ | CommTextLength n
+ | CommStatusKey n
+ | CommEndKey n
+ | CommErrorKey n -> x
+ >> fold_name' v n
+ end
+
+ let fold_comm_clause' (v: _ #folder) =
+ handle' v#fold_comm_clause' ~fold:fold_comm_clause v
+
+ let fold_comm_direction (v: _ #folder) =
+ handle v#fold_comm_direction
+ ~continue:begin fun d x -> match d with
+ | CommOutput -> x
+ | CommInput { initial; items } -> x
+ >> fold_bool v initial
+ >> fold_list ~fold:fold_data_name' v items
+ | CommIO { initial; items } -> x
+ >> fold_bool v initial
+ >> fold_name'_list v items
+ end
+
+ let fold_communication_item_descr = fold_working_item_descr
+ let fold_communication_item_descr' = fold_working_item_descr'
+ let fold_communication_descr (v: _ #folder) =
+ handle v#fold_communication_descr
+ ~continue:begin fun { comm_name; comm_clauses;
+ comm_items; comm_direction } x -> x
+ >> fold_name' v comm_name
+ >> fold_list ~fold:fold_comm_clause' v comm_clauses
+ >> fold_list ~fold:fold_communication_item_descr' v comm_items
+ >> fold_comm_direction v comm_direction
+ end
+
+ let fold_communication_descr' (v: _ #folder) =
+ handle' v#fold_communication_descr' ~fold:fold_communication_descr v
+
+ let fold_communication_section (v: _ #folder) =
+ handle v#fold_communication_section
+ ~continue:(fold_list ~fold:fold_communication_descr' v)
+
+ let fold_local_storage_item_descr = fold_working_item_descr
+ let fold_local_storage_item_descr' = fold_working_item_descr'
+ let fold_local_storage_section (v: _ #folder) =
+ handle v#fold_local_storage_section
+ ~continue:(fold_list ~fold:fold_local_storage_item_descr' v)
+
+ let fold_report_group_clause (v: _ #folder) =
+ handle v#fold_report_group_clause
+ ~continue:(todo __LINE__ "fold_report_group_clause")
+
+ let fold_report_group_clause' (v: _ #folder) =
+ handle' v#fold_report_group_clause' ~fold:fold_report_group_clause v
+
+ let fold_report_group_item (v: _ #folder) =
+ handle v#fold_report_group_item
+ ~continue:begin fun { report_level; report_data_name;
+ report_group_clauses } x -> x
+ >> fold_int v report_level
+ >> fold_data_name'_opt v report_data_name
+ >> fold_list ~fold:fold_report_group_clause' v report_group_clauses
+ end
+
+ let fold_report_group_item' (v: _ #folder) =
+ handle' v#fold_report_group_item' ~fold:fold_report_group_item v
+
+ let fold_report_item_descr (v: _ #folder) : report_item_descr -> _ = function
+ | Constant c -> fold_constant_item v c
+ | ReportGroup r -> fold_report_group_item v r
+
+ let fold_report_item_descr' (v: _ #folder)
+ : report_item_descr with_loc -> _ = fun d -> match ~&d with
+ | Constant c -> fold_constant_item' v (c &@<- d)
+ | ReportGroup r -> fold_report_group_item' v (r &@<- d)
+
+ let fold_report_clause (v: _ #folder) =
+ handle v#fold_report_clause
+ ~continue:begin fun r x -> match r with
+ | Global -> x
+ | Code i -> fold_ident v i x
+ | Control { final; controls } -> x
+ >> fold_bool v final
+ >> fold_name'_list v controls
+ | PageLimit { lines; columns; heading; first_detail;
+ last_control_heading; last_detail; footing } -> x
+ >> fold_integer_opt v lines
+ >> fold_integer_opt v columns
+ >> fold_integer_opt v heading
+ >> fold_integer_opt v first_detail
+ >> fold_integer_opt v last_control_heading
+ >> fold_integer_opt v last_detail
+ >> fold_integer_opt v footing
+ end
+
+ let fold_report_clause' (v: _ #folder) =
+ handle' v#fold_report_clause' ~fold:fold_report_clause v
+
+ let fold_report_descr (v: _ #folder) =
+ handle v#fold_report_descr
+ ~continue:begin fun { report_name; report_clauses; report_items } x -> x
+ >> fold_name' v report_name
+ >> fold_list ~fold:fold_report_clause' v report_clauses
+ >> fold_list ~fold:fold_report_item_descr' v report_items
+ end
+
+ let fold_report_descr' (v: _ #folder) =
+ handle' v#fold_report_descr' ~fold:fold_report_descr v
+
+ let fold_report_section (v: _ #folder) =
+ handle v#fold_report_section
+ ~continue:(fold_list ~fold:fold_report_descr' v)
+
+ let fold_screen_clause (v: _ #folder) =
+ handle v#fold_screen_clause
+ ~continue:(todo __LINE__ "fold_screen_clause")
+
+ let fold_screen_clause' (v: _ #folder) =
+ handle' v#fold_screen_clause' ~fold:fold_screen_clause v
+
+ let fold_screen_item (v: _ #folder) =
+ handle v#fold_screen_item
+ ~continue:begin fun { screen_level; screen_data_name; screen_clauses } x -> x
+ >> fold_int v screen_level
+ >> fold_data_name'_opt v screen_data_name
+ >> fold_list ~fold:fold_screen_clause' v screen_clauses
+ end
+
+ let fold_screen_item' (v: _ #folder) =
+ handle' v#fold_screen_item' ~fold:fold_screen_item v
+
+ let fold_screen_item_descr (v: _ #folder) : screen_item_descr -> _ = function
+ | Constant c -> fold_constant_item v c
+ | Screen s -> fold_screen_item v s
+
+ let fold_screen_item_descr' (v: _ #folder)
+ : screen_item_descr with_loc -> _ = fun d -> match ~&d with
+ | Constant c -> fold_constant_item' v (c &@<- d)
+ | Screen s -> fold_screen_item' v (s &@<- d)
+
+ let fold_screen_section (v: _ #folder) =
+ handle v#fold_screen_section
+ ~continue:(fold_list ~fold:fold_screen_item_descr' v)
+
+end
diff --git a/src/lsp/cobol_ast/raw_misc_sections_visitor.ml b/src/lsp/cobol_ast/raw_misc_sections_visitor.ml
new file mode 100644
index 000000000..983164801
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_misc_sections_visitor.ml
@@ -0,0 +1,236 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make = struct
+
+ module Misc_sections_visitor =
+ Abstract_visitor.For_misc_sections (Raw.Misc_sections)
+
+ open Misc_descr
+
+ class virtual ['a] folder = object
+ inherit ['a] Terms_visitor.folder
+ inherit ['a] Misc_sections_visitor.folder
+ method fold_options_clause: (options_clause, 'a) fold = default
+ method fold_configuration_section: (configuration_section, 'a) fold = default
+ method fold_special_names_paragraph: (special_names_paragraph, 'a) fold = default
+ method fold_special_names_clause: (special_names_clause, 'a) fold = default
+ method fold_special_names_clause': (special_names_clause with_loc, 'a) fold = default
+ method fold_repository_paragraph: (repository_paragraph, 'a) fold = default
+ method fold_specifier: (specifier, 'a) fold = default
+ method fold_expands: (expands, 'a) fold = default
+ method fold_select: (select, 'a) fold = default
+ method fold_select_clause: (select_clause, 'a) fold = default
+ method fold_file_control_paragraph: (file_control_paragraph, 'a) fold = default
+ method fold_io_control_paragraph: (io_control_paragraph, 'a) fold = default
+ method fold_io_control_entry: (io_control_entry, 'a) fold = default
+ method fold_rerun_clause: (rerun_clause, 'a) fold = default
+ method fold_rerun_frequency: (rerun_frequency, 'a) fold = default
+ method fold_same_area_clause: (same_area_clause, 'a) fold = default
+ method fold_area_source: (area_source, 'a) fold = default
+ method fold_multiple_file_clause: (multiple_file_clause, 'a) fold = default
+ method fold_file_portion: (file_portion, 'a) fold = default
+ method fold_input_output_section: (input_output_section, 'a) fold = default
+ method fold_alphabet_specification: (alphabet_specification, 'a) fold = default
+ end
+
+ let todo x = todo __MODULE__ x
+ and partial x = partial __MODULE__ x
+
+ let fold_options_clause (v: _ #folder) =
+ handle v#fold_options_clause
+ ~continue:(todo __LINE__ "fold_options_clause")
+
+ let fold_select_clause (v: _ #folder) =
+ handle v#fold_select_clause
+ ~continue:(todo __LINE__ "fold_select_clause")
+
+ let fold_select (v: _ #folder) =
+ handle v#fold_select
+ ~continue:begin fun { select_optional; select_name; select_clauses } x -> x
+ >> fold_bool v select_optional
+ >> fold_name' v select_name
+ >> fold_with_loc_list ~fold:fold_select_clause v select_clauses
+ end
+
+ let fold_file_control_paragraph (v: _ #folder) =
+ handle v#fold_file_control_paragraph
+ ~continue:(fold_list ~fold:fold_select v)
+
+ let fold_rerun_frequency (v: _ #folder) =
+ handle v#fold_rerun_frequency
+ ~continue:begin function
+ | RerunEndOf n | RerunCond n -> fold_name' v n
+ | RerunRecords (i, n) -> fun x -> x >> fold_integer v i >> fold_name' v n
+ | RerunClockUnits i -> fold_integer v i
+ end
+
+ let fold_rerun_clause (v: _ #folder) =
+ handle v#fold_rerun_clause
+ ~continue:begin fun { rerun_on; rerun_every } x -> x
+ >> fold_name'_opt v rerun_on
+ >> fold_rerun_frequency v rerun_every
+ end
+
+ let fold_area_source (v: _ #folder) =
+ leaf v#fold_area_source
+
+ let fold_same_area_clause (v: _ #folder) =
+ handle v#fold_same_area_clause
+ ~continue:begin fun { same_area_source;
+ same_area_file_name;
+ same_area_file_names } x -> x
+ >> fold_area_source v same_area_source
+ >> fold_name' v same_area_file_name
+ >> fold_name'_list v same_area_file_names
+ end
+
+ let fold_file_portion (v: _ #folder) =
+ handle v#fold_file_portion
+ ~continue:begin fun { file_portion_name; file_portion_position } x -> x
+ >> fold_name' v file_portion_name
+ >> fold_integer_opt v file_portion_position
+ end
+
+ let fold_multiple_file_clause (v: _ #folder) =
+ handle v#fold_multiple_file_clause
+ ~continue:(fold_list ~fold:fold_file_portion v)
+
+ let fold_io_control_entry (v: _ #folder) =
+ handle v#fold_io_control_entry
+ ~continue:begin fun { io_control_rerun_clauses;
+ io_control_same_area_clauses;
+ io_control_multiple_file_clauses } x -> x
+ >> fold_with_loc_list v io_control_rerun_clauses
+ ~fold:fold_rerun_clause
+ >> fold_with_loc_list v io_control_same_area_clauses
+ ~fold:fold_same_area_clause
+ >> fold_with_loc_list v io_control_multiple_file_clauses
+ ~fold:fold_multiple_file_clause
+ end
+
+ let fold_io_control_paragraph (v: _ #folder) =
+ handle v#fold_io_control_paragraph
+ ~continue:(fold_option ~fold:fold_io_control_entry v)
+
+ let fold_input_output_section (v: _ #folder) =
+ handle v#fold_input_output_section
+ ~continue:begin fun { file_control_paragraph; io_control_paragraph } x -> x
+ >> fold_option v file_control_paragraph
+ ~fold:fold_file_control_paragraph
+ >> fold_option v io_control_paragraph
+ ~fold:fold_io_control_paragraph
+ end
+
+ (* --- *)
+
+ let fold_informational_paragraphs (v: _ #folder) =
+ handle v#fold_informational_paragraphs
+ ~continue:begin fun { author; installation; date_written;
+ date_compiled; security } x -> x
+ >> fold_string'_opt v author
+ >> fold_string'_opt v installation
+ >> fold_string'_opt v date_written
+ >> fold_string'_opt v date_compiled
+ >> fold_string'_opt v security
+ end
+
+ let fold_options_paragraph (v: _ #folder) =
+ handle v#fold_options_paragraph
+ ~continue:(fold_with_loc_list ~fold:fold_options_clause v)
+
+ let fold_expands (v: _ #folder) =
+ handle v#fold_expands
+ ~continue:begin fun { expands_name; expands_using } x -> x
+ >> fold_name' v expands_name
+ >> fold_name'_list v expands_using
+ end
+
+ let fold_specifier (v: _ #folder) =
+ handle v#fold_specifier
+ ~continue:begin fun s x -> match s with
+ | ClassSpecifier { name; external_name; expands }
+ | InterfaceSpecifier { name; external_name; expands } -> x
+ >> fold_name' v name
+ >> fold_strlit_opt v external_name
+ >> fold_option ~fold:fold_expands v expands
+ | UserFunctionSpecifier { name; external_name }
+ | ProgramSpecifier { name; external_name }
+ | PropertySpecifier { name; external_name } -> x
+ >> fold_name' v name
+ >> fold_strlit_opt v external_name
+ | IntrinsicFunctionSpecifier names -> x
+ >> fold_name'_list v names
+ | IntrinsicFunctionAllSpecifier ->
+ x
+ end
+
+ let fold_repository_paragraph (v: _ #folder) =
+ handle v#fold_repository_paragraph
+ ~continue:(fold_list ~fold:fold_specifier v)
+
+ let fold_special_names_clause (v: _ #folder) =
+ handle v#fold_special_names_clause
+ ~continue:begin fun c x -> match c with
+ | DecimalPointIsComma -> x
+ | CurrencySign { sign; picture_symbol } -> x
+ >> fold_strlit v sign
+ >> fold_strlit_opt v picture_symbol
+ | _ -> partial __LINE__ "fold_special_names_clause" x
+ end
+
+ let fold_special_names_clause' (v: _ #folder) =
+ handle' v#fold_special_names_clause' ~fold:fold_special_names_clause v
+
+ let fold_special_names_paragraph (v: _ #folder) =
+ handle v#fold_special_names_paragraph
+ ~continue:(fold_list ~fold:fold_special_names_clause' v)
+
+ let fold_configuration_section (v: _ #folder) =
+ handle v#fold_configuration_section
+ ~continue:begin fun { source_computer_paragraph;
+ object_computer_paragraph;
+ special_names_paragraph;
+ repository_paragraph } x ->
+ ignore source_computer_paragraph;
+ ignore object_computer_paragraph;
+ ignore special_names_paragraph;
+ x
+ >> partial __LINE__ "fold_configuration_section"
+ >> fold_option ~fold:fold_repository_paragraph v repository_paragraph
+ end
+
+ let fold_environment_division (v: _ #folder) =
+ handle v#fold_environment_division
+ ~continue:begin fun { env_configuration; env_input_output } x -> x
+ >> fold_option ~fold:fold_configuration_section v env_configuration
+ >> fold_option ~fold:fold_input_output_section v env_input_output
+ end
+
+ let fold_alphabet_specification (v: _ #folder) =
+ handle v#fold_alphabet_specification
+ ~continue:begin fun { alphanumeric; national } x -> x
+ >> fold_option ~fold:fold_name' v alphanumeric
+ >> fold_option ~fold:fold_name' v national
+ end
+end
diff --git a/src/lsp/cobol_ast/raw_proc_division_visitor.ml b/src/lsp/cobol_ast/raw_proc_division_visitor.ml
new file mode 100644
index 000000000..50314b951
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_proc_division_visitor.ml
@@ -0,0 +1,167 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+open Operands_visitor
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make
+ (Statements: Abstract.STATEMENTS) =
+struct
+
+ module Proc_division =
+ Raw.Proc_division (Statements)
+
+ module Statements_visitor =
+ Abstract_visitor.For_statements (Statements)
+ module Proc_division_visitor =
+ Abstract_visitor.For_proc_division (Proc_division)
+
+ open Proc_division
+
+ class virtual ['a] folder = object
+ inherit ['a] Operands_visitor.folder (* inherits Terms_visitor.folder *)
+ inherit ['a] Statements_visitor.folder
+ inherit ['a] Proc_division_visitor.folder
+ method fold_declarative : (declarative , 'a) fold = default
+ method fold_declarative' : (declarative with_loc , 'a) fold = default
+ method fold_paragraph : (paragraph , 'a) fold = default
+ method fold_paragraph' : (paragraph with_loc , 'a) fold = default
+ method fold_using_clause : (using_clause , 'a) fold = default
+ method fold_using_clause' : (using_clause with_loc , 'a) fold = default
+ method fold_using_by_reference : (using_by_reference , 'a) fold = default
+ method fold_declarative_use : (declarative_use , 'a) fold = default
+ method fold_use_after_exception : (use_after_exception , 'a) fold = default
+ method fold_use_for_debugging_target: (use_for_debugging_target, 'a) fold = default
+ method fold_raising_phrase : (raising_phrase , 'a) fold = default
+ method fold_raising_phrase' : (raising_phrase with_loc , 'a) fold = default
+ end
+
+ let todo x = todo __MODULE__ x
+ and partial x = partial __MODULE__ x
+
+ let fold_use_exception_on (v: _ #folder) = function
+ | UseFileExceptionOnNames n -> fold_name'_list v n
+ | UseFileExceptionOnOpenMode m -> fold_open_mode v m
+
+ let fold_use_for_debugging_target (v: _ #folder) =
+ handle v#fold_use_for_debugging_target
+ ~continue:begin fun t x -> match t with
+ | UseForDebuggingProcedure { all; procedure } -> x
+ >> fold_bool v all
+ >> fold_qualname v procedure
+ | UseForDebuggingAllProcedures -> x
+ end
+
+ let fold_use_after_exception (v: _ #folder) =
+ handle v#fold_use_after_exception
+ ~continue:begin fun { use_after_exception;
+ use_after_exception_on_files } x -> x
+ >> fold_name' v use_after_exception
+ >> fold_name'_list v use_after_exception_on_files
+ end
+
+ let fold_declarative_use (v: _ #folder) =
+ handle v#fold_declarative_use
+ ~continue:begin fun u x -> match u with
+ | UseAfterFileException { global; trigger } -> x
+ >> fold_bool v global
+ >> fold_use_exception_on v trigger
+ | UseBeforeReporting { global; report_group } -> x
+ >> fold_bool v global
+ >> fold_ident v report_group
+ | UseForDebugging l -> x
+ >> fold_list ~fold:fold_use_for_debugging_target v l
+ | UseAfterIOException l -> x
+ >> fold_list ~fold:fold_use_after_exception v l
+ | UseAfterExceptionObject n -> x
+ >> fold_name' v n
+ end
+
+ let fold_declarative (v: _ #folder) =
+ handle v#fold_declarative
+ ~continue:begin fun { declarative_name; declarative_segment;
+ declarative_use; declarative_sentences } x -> x
+ >> fold_name' v declarative_name
+ >> fold_integer_opt v declarative_segment
+ >> fold_option ~fold:fold_declarative_use v declarative_use
+ >> fold_list ~fold:(fun v -> v#continue_with_statements') v declarative_sentences
+ end
+
+ let fold_declarative' (v: _ #folder) =
+ handle' v#fold_declarative' ~fold:fold_declarative v
+
+ let fold_paragraph (v: _ #folder) =
+ handle v#fold_paragraph
+ ~continue:begin fun { paragraph_name; paragraph_is_section;
+ paragraph_segment; paragraph_sentences } x ->
+ ignore paragraph_is_section; x
+ >> fold_name'_opt v paragraph_name
+ >> fold_integer_opt v paragraph_segment
+ >> fold_list ~fold:(fun v -> v#continue_with_statements') v paragraph_sentences
+ end
+
+ let fold_paragraph' (v: _ #folder) =
+ handle' v#fold_paragraph' ~fold:fold_paragraph v
+
+ let fold_using_by_reference (v: _ #folder) =
+ handle v#fold_using_by_reference
+ ~continue:begin fun { using_by_reference;
+ using_by_reference_optional } x -> x
+ >> fold_name' v using_by_reference
+ >> fold_bool v using_by_reference_optional
+ end
+
+ let fold_using_clause (v: _ #folder) =
+ handle v#fold_using_clause
+ ~continue:begin function
+ | UsingByReference l -> fold_list ~fold:fold_using_by_reference v l
+ | UsingByValue l -> fold_name'_list v l
+ end
+
+ let fold_using_clause' (v: _ #folder) =
+ handle' v#fold_using_clause' ~fold:fold_using_clause v
+
+ let fold_raising_phrase (v: _ #folder) =
+ handle v#fold_raising_phrase
+ ~continue:begin fun { raising; raising_factory } x -> x
+ >> fold_name' v raising
+ >> fold_bool v raising_factory
+ end
+
+ let fold_raising_phrase' (v: _ #folder) =
+ handle' v#fold_raising_phrase' ~fold:fold_raising_phrase v
+
+ let fold_procedure_division (v: _ #folder) =
+ handle v#fold_procedure_division
+ ~continue:begin fun { procedure_using_clauses; procedure_returning;
+ procedure_raising_phrases; procedure_declaratives;
+ procedure_paragraphs } x -> x
+ >> fold_list ~fold:fold_using_clause' v procedure_using_clauses
+ >> fold_ident'_opt v procedure_returning
+ >> fold_list ~fold:fold_raising_phrase' v procedure_raising_phrases
+ >> fold_list ~fold:fold_declarative' v procedure_declaratives
+ >> fold_list ~fold:fold_paragraph' v procedure_paragraphs
+ end
+
+ let fold_procedure_division' (v: _ #folder) =
+ handle' v#fold_procedure_division' ~fold:fold_procedure_division v
+
+end
diff --git a/src/lsp/cobol_ast/raw_statements_visitor.ml b/src/lsp/cobol_ast/raw_statements_visitor.ml
new file mode 100644
index 000000000..534d4f7b9
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_statements_visitor.ml
@@ -0,0 +1,956 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.INFIX
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Terms_visitor
+open Operands_visitor
+
+let todo x = Cobol_common.Visitor.todo __FILE__ x
+let partial x = Cobol_common.Visitor.partial __FILE__ x
+
+(* --- *)
+
+module Make = struct
+
+ module Statements_visitor =
+ Abstract_visitor.For_statements (Raw.Statements)
+
+ open Terms
+ open Operands
+ open Simple_statements
+ open Branching_statements
+
+ class virtual ['a] folder = object
+ inherit ['a] Operands_visitor.folder (* inherits Terms_visitor.folder *)
+ inherit ['a] Statements_visitor.folder
+
+ (* Statement-specific operands; shared ones should be in
+ Operands_visitor. *)
+ method fold_perform_mode : (perform_mode , 'a) fold = default
+ method fold_varying_phrase : (varying_phrase , 'a) fold = default
+ method fold_varying_phrase' : (varying_phrase with_loc , 'a) fold = default
+ method fold_allocate_kind : (allocate_kind , 'a) fold = default
+ method fold_alter_operands' : (alter_operands with_loc , 'a) fold = default
+ method fold_call_prefix : (call_prefix , 'a) fold = default
+ method fold_call_proto : (call_proto , 'a) fold = default
+ method fold_close_format : (close_format , 'a) fold = default
+ method fold_close_phrase : (close_phrase , 'a) fold = default
+ (* method fold_display_target' : (display_target with_loc , 'a) fold = default *)
+ method fold_init_data_category : (init_data_category , 'a) fold = default
+ method fold_init_replacing : (init_replacing , 'a) fold = default
+ method fold_named_file_option : (named_file_option , 'a) fold = default
+ (*for inspect*)
+ method fold_inspect_spec : (inspect_spec , 'a) fold = default
+ method fold_tallying : (tallying , 'a) fold = default
+ method fold_tallying_clause' : (tallying_clause with_loc, 'a) fold = default
+ method fold_tallying_spec : (tallying_spec , 'a) fold = default
+ method fold_replacing : (replacing , 'a) fold = default
+ method fold_replacing_clause : (replacing_clause , 'a) fold = default
+ method fold_replacing_range_spec: (replacing_range_spec , 'a) fold = default
+ method fold_converting : (converting , 'a) fold = default
+ method fold_inspect_where : (inspect_where , 'a) fold = default
+ method fold_merge_or_sort_target: (merge_or_sort_target , 'a) fold = default
+ method fold_open_phrase : (open_phrase , 'a) fold = default
+ method fold_read_error : (read_error , 'a) fold = default
+ method fold_stop_run : (stop_run , 'a) fold = default
+ method fold_stop_kind : (stop_kind , 'a) fold = default
+ method fold_string_source : (string_source , 'a) fold = default
+ method fold_string_delimiter : (string_delimiter , 'a) fold = default
+ method fold_evaluate_branch : (evaluate_branch , 'a) fold = default
+ method fold_selection_subject : (selection_subject , 'a) fold = default
+ method fold_selection_object : (selection_object , 'a) fold = default
+ method fold_set_switch_spec : (set_switch_spec , 'a) fold = default
+ method fold_set_condition_spec : (set_condition_spec , 'a) fold = default
+ method fold_unstring_delimiter : (unstring_delimiter , 'a) fold = default
+ method fold_unstring_target : (unstring_target , 'a) fold = default
+ method fold_write_error : (write_error , 'a) fold = default
+
+ (* high-level structures and branches *)
+ method fold_handler' : (handler with_loc , 'a) fold = default
+ method fold_dual_handler : (dual_handler , 'a) fold = default
+ method fold_perform_target : (perform_target , 'a) fold = default
+ method fold_call_error_handler : (call_error_handler , 'a) fold = default
+ method fold_search_when_clause' : (search_when_clause with_loc, 'a) fold = default
+ method fold_search_spec : (search_spec , 'a) fold = default
+ method fold_read_error_handler : (read_error * dual_handler , 'a) fold = default
+ method fold_write_error_handler : (write_error * dual_handler , 'a) fold = default
+
+ (* Individial statements with locations *)
+ method fold_accept' : (accept_stmt with_loc , 'a) fold = default
+ method fold_allocate' : (allocate_stmt with_loc , 'a) fold = default
+ method fold_alter' : (alter_stmt with_loc , 'a) fold = default
+ method fold_add' : (basic_arithmetic_stmt with_loc, 'a) fold = default
+ method fold_call' : (call_stmt with_loc , 'a) fold = default
+ method fold_cancel' : (ident_or_strlit list with_loc , 'a) fold = default
+ method fold_close' : (close_stmt with_loc , 'a) fold = default
+ method fold_compute' : (compute_stmt with_loc , 'a) fold = default
+ method fold_delete' : (delete_stmt with_loc , 'a) fold = default
+ method fold_display' : (display_stmt with_loc , 'a) fold = default
+ method fold_divide' : (divide_stmt with_loc , 'a) fold = default
+ method fold_exit' : (exit_stmt with_loc , 'a) fold = default
+ method fold_evaluate' : (evaluate_stmt with_loc , 'a) fold = default
+ method fold_free' : (name with_loc list with_loc , 'a) fold = default
+ method fold_generate' : (name with_loc with_loc , 'a) fold = default
+ method fold_goback' : (raising option with_loc , 'a) fold = default
+ method fold_goto' : (qualname with_loc , 'a) fold = default
+ method fold_goto_depending': (goto_depending_stmt with_loc , 'a) fold = default
+ method fold_if' : (if_stmt with_loc , 'a) fold = default
+ method fold_initialize' : (initialize_stmt with_loc , 'a) fold = default
+ method fold_initiate' : (name with_loc list with_loc , 'a) fold = default
+ method fold_inspect' : (inspect_stmt with_loc , 'a) fold = default
+ method fold_invoke' : (invoke_stmt with_loc , 'a) fold = default
+ method fold_move' : (move_stmt with_loc , 'a) fold = default
+ method fold_multiply' : (multiply_stmt with_loc , 'a) fold = default
+ method fold_open' : (open_stmt with_loc , 'a) fold = default
+ method fold_perform' : (perform_stmt with_loc , 'a) fold = default
+ method fold_raise' : (raise_operand with_loc , 'a) fold = default
+ method fold_read' : (read_stmt with_loc , 'a) fold = default
+ method fold_release' : (release_stmt with_loc , 'a) fold = default
+ method fold_resume' : (qualname with_loc , 'a) fold = default
+ method fold_return' : (return_stmt with_loc , 'a) fold = default
+ method fold_rewrite' : (rewrite_stmt with_loc , 'a) fold = default
+ method fold_search' : (search_stmt with_loc , 'a) fold = default
+ method fold_set' : (set_stmt with_loc , 'a) fold = default
+ method fold_start' : (start_stmt with_loc , 'a) fold = default
+ method fold_stop' : (stop_stmt with_loc , 'a) fold = default
+ method fold_string_stmt' : (string_stmt with_loc , 'a) fold = default
+ method fold_subtract' : (basic_arithmetic_stmt with_loc, 'a) fold = default
+ method fold_terminate' : (terminate_stmt with_loc , 'a) fold = default
+ method fold_transform' : (transform_stmt with_loc , 'a) fold = default
+ method fold_unlock' : (unlock_stmt with_loc , 'a) fold = default
+ method fold_unstring' : (unstring_stmt with_loc , 'a) fold = default
+ method fold_validate' : (ident list with_loc , 'a) fold = default
+ method fold_write' : (write_stmt with_loc , 'a) fold = default
+ end
+
+ let todo x = todo __MODULE__ x
+ and partial x = partial __MODULE__ x
+
+
+ let fold_varying_phrase (v: _ #folder) =
+ handle v#fold_varying_phrase
+ ~continue:begin fun { varying_ident; varying_from;
+ varying_by; varying_until } x -> x
+ >> fold_ident v varying_ident
+ >> fold_ident_or_numlit v varying_from
+ >> fold_option ~fold:fold_ident_or_numlit v varying_by
+ >> fold_condition v varying_until
+ end
+
+ let fold_varying_phrase' (v: _ #folder) =
+ handle' v#fold_varying_phrase' ~fold:fold_varying_phrase v
+
+ let fold_perform_mode (v: _ #folder) =
+ handle v#fold_perform_mode
+ ~continue:begin fun m x -> match m with
+ | PerformNTimes i -> x
+ >> fold_ident_or_intlit v i
+ | PerformUntil { with_test; until } -> x
+ >> fold_option ~fold:fold_stage v with_test
+ >> fold_condition v until
+ | PerformVarying { with_test; varying; after } -> x
+ >> fold_option ~fold:fold_stage v with_test
+ >> fold_varying_phrase' v varying
+ >> fold_list ~fold:fold_varying_phrase' v after
+ end
+
+ let fold_allocate_kind (v: _ #folder) =
+ handle v#fold_allocate_kind
+ ~continue:begin function
+ | AllocateCharacters e -> fold_expression v e
+ | AllocateDataItem n -> fold_name' v n
+ end
+
+ let fold_alter_operands' (v: _ #folder) =
+ handle' v#fold_alter_operands' v
+ ~fold:begin fun v { alter_source; alter_target } x -> x
+ >> fold_qualname v alter_source
+ >> fold_qualname v alter_target
+ end
+
+ let fold_call_proto (v: _ #folder) =
+ handle v#fold_call_proto
+ ~continue:begin function
+ | CallProtoIdent i -> fold_ident v i
+ | CallProtoNested -> Fun.id
+ end
+
+ let fold_call_prefix (v: _ #folder) =
+ handle v#fold_call_prefix
+ ~continue:begin fun p x -> match p with
+ | CallGeneral i -> x
+ >> fold_ident_or_strlit v i
+ | CallProto { called; prototype } -> x
+ >> fold_option ~fold:fold_ident_or_strlit v called
+ >> fold_call_proto v prototype
+ end
+
+ let fold_close_format (v: _ #folder) =
+ handle v#fold_close_format
+ ~continue:begin function
+ | CloseUnitReel b -> fold_bool v b
+ | CloseWithLock
+ | CloseWithNoRewind -> Fun.id
+ end
+
+ let fold_close_phrase (v: _ #folder) =
+ handle v#fold_close_phrase
+ ~continue:begin fun { close_item; close_format} x -> x
+ >> fold_name' v close_item
+ >> fold_option ~fold:fold_close_format v close_format
+ end
+
+ let fold_init_data_category (v: _ #folder) =
+ leaf v#fold_init_data_category
+
+ let fold_init_category (v: _ #folder) = function
+ | InitAll -> Fun.id
+ | InitCategory c -> fold_init_data_category v c
+
+ let fold_init_replacing (v: _ #folder) =
+ handle v#fold_init_replacing
+ ~continue:begin fun { init_replacing_category;
+ init_replacing_replacement_item } x -> x
+ >> fold_init_data_category v init_replacing_category
+ >> fold_ident_or_literal v init_replacing_replacement_item
+ end
+
+ let fold_inspect_where (v: _ #folder) =
+ handle v#fold_inspect_where
+ ~continue:begin fun (_, reference) ->
+ fold_ident_or_nonnum v reference
+ end
+
+ let fold_tallying_spec (v: _ #folder) =
+ handle v#fold_tallying_spec
+ ~continue:begin fun { tallying_item; tallying_where } x -> x
+ >> fold_ident_or_nonnum v tallying_item
+ >> fold_list ~fold:fold_inspect_where v tallying_where
+ end
+
+ let fold_tallying_clause' (v: _ #folder) =
+ handle' v#fold_tallying_clause' v
+ ~fold:begin fun v clause x -> match clause with
+ | TallyingCharacters wheres -> x
+ >> fold_list ~fold:fold_inspect_where v wheres
+ | TallyingRange (_, spec) -> x
+ >> fold_list ~fold:fold_tallying_spec v spec
+ end
+
+ let fold_tallying (v: _ #folder) =
+ handle v#fold_tallying
+ ~continue:begin fun { tallying_target; tallying_clauses } x -> x
+ >> fold_qualident v tallying_target
+ >> fold_list ~fold:fold_tallying_clause' v tallying_clauses
+ end
+
+ let fold_replacing_range_spec (v: _ #folder) =
+ handle v#fold_replacing_range_spec
+ ~continue:begin fun { replacing_item;
+ replacing_by;
+ replacing_where} x -> x
+ >> fold_ident_or_nonnum v replacing_item
+ >> fold_ident_or_nonnum v replacing_by
+ >> fold_list ~fold:fold_inspect_where v replacing_where
+ end
+
+ let fold_replacing_clause (v: _ #folder) =
+ handle v#fold_replacing_clause
+ ~continue:begin fun clause x -> match clause with
+ | ReplacingCharacters { replacement; where } -> x
+ >> fold_ident_or_nonnum v replacement
+ >> fold_list ~fold:fold_inspect_where v where
+ | ReplacingRange (_, specs) -> x
+ >> fold_list ~fold:fold_replacing_range_spec v specs
+ end
+
+ let fold_replacing (v:_ #folder) =
+ handle' v#fold_replacing v ~fold:fold_replacing_clause
+
+ let fold_converting (v: _ #folder) =
+ handle v#fold_converting
+ ~continue:begin fun { converting_from;
+ converting_to;
+ converting_where} x -> x
+ >> fold_ident_or_nonnum v converting_from
+ >> fold_ident_or_nonnum v converting_to
+ >> fold_list ~fold:fold_inspect_where v converting_where
+ end
+
+ let fold_inspect_spec (v: _ #folder) =
+ handle v#fold_inspect_spec
+ ~continue:begin fun spec x -> match spec with
+ | InspectTallying tl -> x
+ >> fold_list ~fold:fold_tallying v tl
+ | InspectReplacing rl -> x
+ >> fold_list ~fold:fold_replacing v rl
+ | InspectBoth (tl, rl) -> x
+ >> fold_list ~fold:fold_tallying v tl
+ >> fold_list ~fold:fold_replacing v rl
+ | InspectConverting converting -> x
+ >> fold_converting v converting
+ end
+
+ let fold_merge_or_sort_target (v : _ #folder) =
+ handle v#fold_merge_or_sort_target
+ ~continue:begin function
+ | OutputProcedure name_procedure_range ->
+ fold_procedure_range ~fold:fold_name' v name_procedure_range
+ | Giving names ->
+ fold_list ~fold:fold_name' v names
+ end
+
+ (*for open*)
+ let fold_named_file_option (v: _ #folder) =
+ handle v#fold_named_file_option
+ ~continue:begin fun { named_file_name;
+ named_file_option} x -> x
+ >> fold_name' v named_file_name
+ >> fold_option ~fold:fold_file_option v named_file_option
+ end
+
+ let fold_open_phrase (v: _ #folder) =
+ handle v#fold_open_phrase
+ ~continue:begin fun { open_mode; open_sharing;
+ open_retry; open_files } x -> x
+ >> fold_open_mode v open_mode
+ >> fold_option ~fold:fold_sharing_mode v open_sharing
+ >> fold_option ~fold:fold_retry_clause v open_retry
+ >> fold_list ~fold:fold_named_file_option v open_files
+ end
+
+ let fold_read_error (v: _ #folder) =
+ leaf v#fold_read_error
+
+ let fold_set_switch_spec (v: _ #folder) =
+ handle v#fold_set_switch_spec
+ ~continue:begin fun { set_switch_targets;
+ set_switch_value } x -> x
+ >> fold_list ~fold:fold_ident v set_switch_targets
+ >> fold_on_off v set_switch_value
+ end
+
+ let fold_set_condition_spec (v: _ #folder) =
+ handle v#fold_set_condition_spec
+ ~continue:begin fun { set_condition_targets;
+ set_condition_value } x -> x
+ >> fold_list ~fold:fold_ident v set_condition_targets
+ >> fold_bool v set_condition_value
+ end
+
+ let fold_stop_kind (v: _ #folder) =
+ leaf v#fold_stop_kind
+
+ let fold_stop_run (v: _ #folder) =
+ handle v#fold_stop_run
+ ~continue:begin fun { stop_kind; stop_status } x -> x
+ >> fold_stop_kind v stop_kind
+ >> fold_ident_or_literal v stop_status
+ end
+
+ let fold_string_delimiter (v: _ #folder) =
+ handle v#fold_string_delimiter
+ ~continue:begin function
+ | StringDelimiter ident_or_nonnum ->
+ fold_ident_or_nonnum v ident_or_nonnum
+ | StringDelimiterSize -> Fun.id
+ end
+
+ let fold_string_source (v: _ #folder) =
+ handle v#fold_string_source
+ ~continue:begin fun {string_source; string_delimiter} x -> x
+ >> fold_ident_or_nonnum v string_source
+ >> fold_option ~fold:fold_string_delimiter v string_delimiter
+ end
+
+ let fold_unstring_delimiter (v: _ #folder) =
+ handle v#fold_unstring_delimiter
+ ~continue:begin fun { unstring_delimiter;
+ unstring_delimiter_by_all } x -> x
+ >> fold_ident_or_strlit v unstring_delimiter
+ >> fold_bool v unstring_delimiter_by_all
+ end
+
+ let fold_unstring_target (v: _ #folder) =
+ handle v#fold_unstring_target
+ ~continue:begin fun { unstring_target;
+ unstring_target_delimiter;
+ unstring_target_count} x -> x
+ >> fold_ident v unstring_target
+ >> fold_option ~fold:fold_ident v unstring_target_delimiter
+ >> fold_option ~fold:fold_ident v unstring_target_count
+ end
+
+ let fold_write_error (v: _ #folder) =
+ leaf v#fold_write_error
+
+
+ (* Statements that do not need recursion (not high-level control structure,
+ and no inline handler) *)
+
+ let fold_allocate' (v: _ #folder) =
+ handle' v#fold_allocate' v
+ ~fold:begin fun v { allocate_kind;
+ allocate_initialized;
+ allocate_returning } x -> x
+ >> fold_allocate_kind v allocate_kind
+ >> fold_bool v allocate_initialized
+ >> fold_ident'_opt v allocate_returning
+ end
+
+ let fold_alter' (v: _ #folder) =
+ handle' v#fold_alter' v ~fold:(fold_list ~fold:fold_alter_operands')
+
+ let fold_cancel' (v: _ #folder) =
+ handle' v#fold_cancel' v ~fold:(fold_list ~fold:fold_ident_or_strlit)
+
+ let fold_close' (v: _ #folder) =
+ handle' v#fold_close' v ~fold:(fold_list ~fold:fold_close_phrase)
+
+ let fold_exit' (v: _ #folder) =
+ handle' v#fold_exit' v
+ ~fold:begin fun v -> function
+ | ExitSimple
+ | ExitParagraph
+ | ExitSection -> Fun.id
+ | ExitPerform b -> fold_bool v b
+ | ExitProgram r
+ | ExitMethod r
+ | ExitFunction r -> fold_option ~fold:fold_raising v r
+ end
+
+ let fold_free' (v: _ #folder) =
+ handle' v#fold_free' v ~fold:(fold_list ~fold:fold_name')
+
+ let fold_generate' (v: _ #folder) =
+ handle' v#fold_generate' v ~fold:fold_name'
+
+ let fold_goback' (v: _ #folder) =
+ handle' v#fold_goback' v ~fold:(fold_option ~fold:fold_raising)
+
+ let fold_goto' (v: _ #folder) =
+ handle' v#fold_goto' ~fold:fold_qualname v
+
+ let fold_goto_depending' (v: _ #folder) =
+ handle' v#fold_goto_depending' v
+ ~fold:begin fun v { goto_depending_targets; goto_depending_on } x -> x
+ >> fold_list ~fold:fold_qualname v goto_depending_targets
+ >> fold_ident v goto_depending_on
+ end
+
+ let fold_initialize' (v: _ #folder) =
+ handle' v#fold_initialize' v
+ ~fold:begin fun v { init_items; init_filler; init_category;
+ init_replacings; init_to_default } x -> x
+ >> fold_list ~fold:fold_ident v init_items
+ >> fold_bool v init_filler
+ >> fold_option ~fold:fold_init_category v init_category
+ >> fold_list ~fold:fold_init_replacing v init_replacings
+ >> fold_bool v init_to_default
+ end
+
+ let fold_initiate' (v: _ #folder) =
+ handle' v#fold_initiate' v ~fold:(fold_list ~fold:fold_name')
+
+ let fold_inspect' (v: _ #folder) =
+ handle' v#fold_inspect' v
+ ~fold:begin fun v { inspect_item; inspect_spec } x -> x
+ >> fold_ident v inspect_item
+ >> fold_inspect_spec v inspect_spec
+ end
+
+ let fold_invoke' (v: _ #folder) =
+ handle' v#fold_invoke' v
+ ~fold:begin fun v { invoke_target; invoke_method;
+ invoke_using; invoke_returning} x -> x
+ >> fold_ident v invoke_target
+ >> fold_ident_or_strlit v invoke_method
+ >> fold_list ~fold:fold_call_using_clause' v invoke_using
+ >> fold_ident'_opt v invoke_returning
+ end
+
+ let fold_move' (v: _ #folder) =
+ handle' v#fold_move' v
+ ~fold:begin fun v m x -> match m with
+ | MoveSimple { from; to_ } -> x
+ >> fold_ident_or_literal v from
+ >> fold_list ~fold:fold_ident v to_
+ | MoveCorresponding { from; to_ } -> x
+ >> fold_ident v from
+ >> fold_list ~fold:fold_ident v to_
+ end
+
+ let fold_open' (v: _ #folder) =
+ handle' v#fold_open' v ~fold:(fold_list ~fold:fold_open_phrase)
+
+ let fold_raise' (v: _ #folder) =
+ handle' v#fold_raise' v
+ ~fold:begin fun v -> function
+ | RaiseIdent id -> fold_ident v id
+ | RaiseException name -> fold_name' v name
+ end
+
+ let fold_release' (v: _ #folder) =
+ handle' v#fold_release' v
+ ~fold:begin fun v {release_item; release_from} x -> x
+ >> fold_name' v release_item
+ >> fold_option ~fold:fold_ident_or_literal v release_from
+ end
+
+ let fold_resume' (v: _ #folder) =
+ handle' v#fold_resume' v ~fold:(fold_qualname)
+
+ let fold_set' (v: _ #folder) =
+ handle' v#fold_set' v
+ ~fold:begin fun v stmt x -> match stmt with
+ | SetAmbiguous { targets; set_method; value} -> x
+ >> fold_list ~fold:fold_ident v targets
+ >> fold_set_ambiguous_method v set_method
+ >> fold_expression v value
+ | SetSwitch specs -> x
+ >> fold_list ~fold:fold_set_switch_spec v specs
+ | SetCondition specs -> x
+ >> fold_list ~fold:fold_set_condition_spec v specs
+ | SetAttribute { name; attribute_switches } -> x
+ >> fold_name' v name
+ >> fold_list ~fold:fold_set_attribute_switch v attribute_switches
+ | SetSaveLocale { target; locale } -> x
+ >> fold_ident v target
+ >> fold_set_save_locale v locale
+ | SetLocale { target; source } -> x
+ >> fold_set_locale_target v target
+ >> fold_set_locale_source v source
+ | SetSavedException -> x
+ | SetFloatContent { targets; content; sign } -> x
+ >> fold_list ~fold:fold_ident v targets
+ >> fold_float_content v content
+ >> fold_option ~fold:fold_sign v sign
+ end
+
+ let fold_terminate' (v: _ #folder) =
+ handle' v#fold_terminate' v
+ ~fold:(fold_list ~fold:fold_name')
+
+ let fold_transform' (v: _ #folder) =
+ handle' v#fold_transform' v
+ ~fold:begin fun v { transform_ident; transform_from; transform_to } x -> x
+ >> fold_ident' v transform_ident
+ >> fold' ~fold:fold_ident_or_nonnum v transform_from
+ >> fold' ~fold:fold_ident_or_nonnum v transform_to
+ end
+
+ let fold_unlock' (v: _ #folder) =
+ handle' v#fold_unlock' v
+ ~fold:begin fun v { unlock_file; unlock_record } x -> x
+ >> fold_name' v unlock_file
+ >> fold_bool v unlock_record
+ end
+
+ let fold_validate' (v: _ #folder) =
+ handle' v#fold_validate' v ~fold:(fold_list ~fold:fold_ident)
+
+ let fold_stop' (v: _ #folder) =
+ handle' v#fold_stop' v
+ ~fold:begin fun v -> function
+ | StopRun o -> fold_option ~fold:fold_stop_run v o
+ | StopLiteral l -> fold_literal v l
+ end
+
+ let fold_selection_subject (v: _ #folder) =
+ handle v#fold_selection_subject
+ ~continue:begin function
+ | Subject c -> fold_condition v c
+ | SubjectConst b -> fold_bool v b
+ end
+
+ let fold_selection_object (v: _ #folder) =
+ handle v#fold_selection_object
+ ~continue:begin fun selection_object x ->
+ match selection_object with
+ | SelCond c -> x
+ >> fold_condition v c
+ | SelRange { negated; start; stop; alphabet} -> x
+ >> fold_bool v negated
+ >> fold_expression v start
+ >> fold_expression v stop
+ >> fold_option ~fold:fold_name' v alphabet
+ | SelRelation { relation; expr } -> x
+ >> fold_relop v relation
+ >> fold_expression v expr
+ | SelClassCond { negated; class_specifier } -> x
+ >> fold_bool v negated
+ >> fold_class v class_specifier
+ | SelSignCond { negated; sign_specifier } -> x
+ >> fold_bool v negated
+ >> fold_signz v sign_specifier
+ | SelOmitted { negated } -> x
+ >> fold_bool v negated
+ | SelConst b -> x
+ >> fold_bool v b
+ | SelAny -> x
+ end
+
+ (* Statements with high-level control structure and/or (inline) handlers *)
+ let rec fold_statement' (v: _ #folder) =
+ handle v#fold_statement'
+ ~continue:begin fun { payload; loc } -> match payload with
+ | Accept s -> fold_accept' v (s &@ loc)
+ | Allocate s -> fold_allocate' v (s &@ loc)
+ | Add s -> fold_add' v (s &@ loc)
+ | Alter s -> fold_alter' v (s &@ loc)
+ | Call s -> fold_call' v (s &@ loc)
+ | Cancel s -> fold_cancel' v (s &@ loc)
+ | Close s -> fold_close' v (s &@ loc)
+ | Compute s -> fold_compute' v (s &@ loc)
+ | Delete s -> fold_delete' v (s &@ loc)
+ | Display s -> fold_display' v (s &@ loc)
+ | Divide s -> fold_divide' v (s &@ loc)
+ | Evaluate s -> fold_evaluate' v (s &@ loc)
+ | Exit s -> fold_exit' v (s &@ loc)
+ | Free s -> fold_free' v (s &@ loc)
+ | Generate s -> fold_generate' v (s &@ loc)
+ | GoBack s -> fold_goback' v (s &@ loc)
+ | GoTo s -> fold_goto' v (s &@ loc)
+ | GoToDepending s -> fold_goto_depending' v (s &@ loc)
+ | If s -> fold_if' v (s &@ loc)
+ | Initialize s -> fold_initialize' v (s &@ loc)
+ | Initiate s -> fold_initiate' v (s &@ loc)
+ | Inspect s -> fold_inspect' v (s &@ loc)
+ | Invoke s -> fold_invoke' v (s &@ loc)
+ | Move s -> fold_move' v (s &@ loc)
+ | Multiply s -> fold_multiply' v (s &@ loc)
+ | Open s -> fold_open' v (s &@ loc)
+ | Perform s -> fold_perform' v (s &@ loc)
+ | Raise s -> fold_raise' v (s &@ loc)
+ | Read s -> fold_read' v (s &@ loc)
+ | Release s -> fold_release' v (s &@ loc)
+ | Resume s -> fold_resume' v (s &@ loc)
+ | Return s -> fold_return' v (s &@ loc)
+ | Rewrite s -> fold_rewrite' v (s &@ loc)
+ | Search s -> fold_search' v (s &@ loc)
+ | Set s -> fold_set' v (s &@ loc)
+ | Start s -> fold_start' v (s &@ loc)
+ | Stop s -> fold_stop' v (s &@ loc)
+ | String s -> fold_string_stmt' v (s &@ loc)
+ | Subtract s -> fold_subtract' v (s &@ loc)
+ | Terminate s -> fold_terminate' v (s &@ loc)
+ | Transform s -> fold_transform' v (s &@ loc)
+ | Unlock s -> fold_unlock' v (s &@ loc)
+ | Unstring s -> fold_unstring' v (s &@ loc)
+ | Validate s -> fold_validate' v (s &@ loc)
+ | Write s -> fold_write' v (s &@ loc)
+ | ResumeNextStatement
+ | Continue
+ | LoneGoTo
+ | Suppress -> Fun.id
+ | _ -> partial __LINE__ "fold_statement"
+ (* | Disable of mcs_command_operands *)
+ (* | Enable of mcs_command_operands *)
+ (* | Enter of enter_stmt *)
+ (* | Merge of merge_stmt *)
+ (* | Purge of name with_loc *)
+ (* | Receive of receive_stmt *)
+ (* | Send of send_stmt *)
+ (* | Sort of sort_stmt *)
+ end
+
+ and fold_statements (v: _ #folder) =
+ (* handle v#fold_statements ~continue: *)(fold_list ~fold:fold_statement' v)
+
+ and fold_statements' (v: _ #folder) =
+ handle' v#fold_statements' ~fold:fold_statements v
+
+ and fold_handler v = fold_statements v
+ and fold_dual_handler (v: _ #folder) { dual_handler_pos;
+ dual_handler_neg } x = x
+ >> fold_handler v dual_handler_pos
+ >> fold_handler v dual_handler_neg
+
+ and fold_branch (v: _ #folder) : branch -> 'a -> 'a = function
+ | Statements stmts -> fold_statements v stmts
+ | NextSentence -> Fun.id
+
+ and fold_basic_arith_stmt (v: _ #folder) : basic_arithmetic_stmt -> 'a -> 'a =
+ fun { basic_arith_operands; basic_arith_on_size_error } x -> x
+ >> fold_basic_arithmetic_operands v basic_arith_operands
+ >> fold_dual_handler v basic_arith_on_size_error
+
+ and fold_accept' (v: _ #folder) : accept_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_accept' v
+ ~fold:begin fun v stmt x -> match stmt with
+ | AcceptGeneric id -> x
+ >> fold_ident' v id
+ | AcceptFromDevice { item; device_item } -> x
+ >> fold_ident' v item
+ >> fold_name' v device_item
+ | AcceptTemporal { item; date_time } -> x
+ >> fold_ident' v item
+ >> fold_date_time v date_time
+ | AcceptMsgCount name' -> x
+ >> fold_name' v name'
+ | AcceptAtScreen { item; position; on_exception } -> x
+ >> fold_name' v item
+ >> fold_option ~fold:fold_position v position
+ >> fold_dual_handler v on_exception
+ | AcceptFromEnv { item; env_item; on_exception } -> x
+ >> fold_ident' v item
+ >> fold' ~fold:fold_ident_or_nonnum v env_item
+ >> fold_dual_handler v on_exception
+ end
+
+ and fold_add' (v: _ #folder) : basic_arithmetic_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_add' v ~fold:fold_basic_arith_stmt
+
+ and fold_call' (v: _ #folder) : call_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_call' v
+ ~fold:begin fun v { call_prefix; call_using; call_returning;
+ call_error_handler } x -> x
+ >> fold_call_prefix v call_prefix
+ >> fold_list ~fold:fold_call_using_clause' v call_using
+ >> fold_ident'_opt v call_returning
+ >> fold_option ~fold:fold_call_error_handler v call_error_handler
+ end
+
+ and fold_call_error_handler (v: _ #folder) =
+ handle v#fold_call_error_handler
+ ~continue:begin function
+ | CallOnOverflow h -> fold_handler v h
+ | CallOnException h -> fold_dual_handler v h
+ end
+
+ and fold_compute' (v: _ #folder) : compute_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_compute' v
+ ~fold:begin fun v { compute_targets; compute_expr;
+ compute_on_size_error } x -> x
+ >> fold_rounded_idents v compute_targets
+ >> fold_expr v compute_expr
+ >> fold_dual_handler v compute_on_size_error
+ end
+
+ and fold_delete' (v: _ #folder) : delete_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_delete' v
+ ~fold:begin fun v { delete_targets; delete_retry;
+ delete_on_invalid_key } x -> x
+ >> fold_name' v delete_targets
+ >> fold_option ~fold:fold_retry_clause v delete_retry
+ >> fold_dual_handler v delete_on_invalid_key
+ end
+
+ and fold_display' (v: _ #folder) : display_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_display' v
+ ~fold:begin fun v d x -> match d with
+ | DisplayDefault i -> x
+ >> fold_ident_or_literal v i
+ | DisplayDevice { displayed_items; upon; advancing } -> x
+ >> fold_list ~fold:fold_ident_or_literal v displayed_items
+ >> fold_option ~fold:fold_display_target' v upon
+ >> fold_bool v advancing
+ | DisplayScreen { screen_item; position; on_exception } -> x
+ >> fold_name' v screen_item
+ >> fold_option ~fold:fold_position v position
+ >> fold_dual_handler v on_exception
+ end
+
+ and fold_display_target' (v: _ #folder) : display_target with_loc -> 'a -> 'a =
+ (* handle' v#fold_display_target' *)fold' v
+ ~fold:begin fun v -> function
+ | DisplayUponName n -> fold_name' v n
+ | DisplayUponDeviceViaMnemonic _ -> Fun.id
+ end
+
+ and fold_divide' (v: _ #folder) : divide_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_divide' v
+ ~fold:begin fun v { divide_operands; divide_on_size_error } x -> x
+ >> fold_divide_operands v divide_operands
+ >> fold_dual_handler v divide_on_size_error
+ end
+
+ and fold_evaluate' (v: _ #folder) : evaluate_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_evaluate' v
+ ~fold:begin fun v { eval_subjects; eval_branches; eval_otherwise } x -> x
+ >> fold_list ~fold:fold_selection_subject v eval_subjects
+ >> fold_list ~fold:fold_evaluate_branch v eval_branches
+ >> fold_statements v eval_otherwise
+ end
+
+ and fold_evaluate_branch (v: _#folder) =
+ handle v#fold_evaluate_branch
+ ~continue:begin fun { eval_selection; eval_actions } x -> x
+ >> fold_list v eval_selection
+ ~fold:(fold_list ~fold:fold_selection_object)
+ >> fold_statements v eval_actions
+ end
+
+ and fold_if' (v: _ #folder) : if_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_if' v
+ ~fold:begin fun v { condition; then_branch; else_branch } x -> x
+ >> fold_condition v condition
+ >> fold_branch v then_branch
+ >> fold_option ~fold:fold_branch v else_branch
+ end
+
+ and fold_multiply' (v: _ #folder) : multiply_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_multiply' v
+ ~fold:begin fun v { multiply_operands; multiply_on_size_error } x -> x
+ >> fold_multiply_operands v multiply_operands
+ >> fold_dual_handler v multiply_on_size_error
+ end
+
+ and fold_perform' (v: _ #folder) : perform_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_perform' v
+ ~fold:begin fun v { perform_target; perform_mode } x -> x
+ >> fold_perform_target v perform_target
+ >> fold_option ~fold:fold_perform_mode v perform_mode
+ end
+
+ and fold_perform_target (v: _ #folder) =
+ handle v#fold_perform_target
+ ~continue:begin function
+ | PerformOutOfLine proc_range ->
+ fold_procedure_range ~fold:fold_qualname v proc_range
+ | PerformInline stmts ->
+ fold_statements v stmts
+ end
+
+ and fold_read_error_handler (v: _ #folder) =
+ handle v#fold_read_error_handler
+ ~continue:begin fun (read_error, dual_handler) x -> x
+ >> fold_read_error v read_error
+ >> fold_dual_handler v dual_handler
+ end
+
+ and fold_read' (v: _#folder) =
+ handle' v#fold_read' v
+ ~fold:begin fun v { read_file; read_direction;
+ read_into; read_lock_behavior;
+ read_lock; read_key;
+ read_error_handler } x -> x
+ >> fold_name' v read_file
+ >> fold_option ~fold:fold_read_direction v read_direction
+ >> fold_option ~fold:fold_ident v read_into
+ >> fold_option ~fold:fold_read_lock_behavior v read_lock_behavior
+ >> fold_option ~fold:fold_bool v read_lock
+ >> fold_option ~fold:fold_qualname v read_key
+ >> fold_option ~fold:fold_read_error_handler v read_error_handler
+ end
+
+ and fold_return' (v: _ #folder) =
+ handle' v#fold_return' v
+ ~fold:begin fun v {return_file; return_into; return_at_end} x -> x
+ >> fold_name' v return_file
+ >> fold_ident'_opt v return_into
+ >> fold_dual_handler v return_at_end
+ end
+
+ and fold_rewrite' (v: _ #folder) =
+ handle' v#fold_rewrite' v
+ ~fold:begin fun v { rewrite_to; rewrite_from;
+ rewrite_retry; rewrite_lock;
+ rewrite_invalid_key_handler } x -> x
+ >> fold_write_target v rewrite_to
+ >> fold_option ~fold:fold_ident_or_literal v rewrite_from
+ >> fold_option ~fold:fold_retry_clause v rewrite_retry
+ >> fold_option ~fold:fold_bool v rewrite_lock
+ >> fold_dual_handler v rewrite_invalid_key_handler
+ end
+
+ and fold_search_when_clause' (v: _#folder) =
+ handle' v#fold_search_when_clause' v
+ ~fold:begin fun v {search_when_cond; search_when_stmts} x -> x
+ >> fold_condition v search_when_cond
+ >> fold_branch v search_when_stmts
+ end
+
+ and fold_search_spec (v: _ #folder) =
+ handle v#fold_search_spec
+ ~continue:begin fun s x -> match s with
+ | SearchSerial { varying; when_clauses } -> x
+ >> fold_option ~fold:fold_ident v varying
+ >> fold_list ~fold:fold_search_when_clause' v when_clauses
+ | SearchAll { conditions; action } -> x
+ >> fold_list ~fold:fold_search_condition v conditions
+ >> fold_branch v action
+ end
+
+ and fold_search' (v: _ #folder) =
+ handle' v#fold_search' v
+ ~fold:begin fun v { search_item; search_spec;
+ search_at_end} x -> x
+ >> fold_qualname v search_item
+ >> fold_handler v search_at_end
+ >> fold_search_spec v search_spec
+ end
+
+ and fold_start' (v: _ #folder) =
+ handle' v#fold_start' v
+ ~fold:begin fun v { start_file; start_position;
+ start_on_invalid_key } x -> x
+ >> fold_name' v start_file
+ >> fold_option ~fold:fold_start_position v start_position
+ >> fold_dual_handler v start_on_invalid_key
+ end
+
+ and fold_string_stmt' (v: _ #folder) =
+ handle' v#fold_string_stmt' v
+ ~fold:begin fun v { string_sources;
+ string_target;
+ string_pointer;
+ string_on_overflow} x -> x
+ >> fold_list ~fold:fold_string_source v string_sources
+ >> fold_ident v string_target
+ >> fold_option ~fold:fold_ident v string_pointer
+ >> fold_dual_handler v string_on_overflow
+ end
+
+ and fold_subtract' (v: _ #folder) : basic_arithmetic_stmt with_loc -> 'a -> 'a =
+ handle' v#fold_subtract' v ~fold:fold_basic_arith_stmt
+
+ and fold_unstring' (v: _ #folder) =
+ handle' v#fold_unstring' v
+ ~fold:begin fun v { unstring_source;
+ unstring_delimiters;
+ unstring_targets;
+ unstring_pointer;
+ unstring_tallying;
+ unstring_on_overflow} x -> x
+ >> fold_ident v unstring_source
+ >> fold_list ~fold:fold_unstring_delimiter v unstring_delimiters
+ >> fold_list ~fold:fold_unstring_target v unstring_targets
+ >> fold_option ~fold:fold_ident v unstring_pointer
+ >> fold_option ~fold:fold_ident v unstring_tallying
+ >> fold_dual_handler v unstring_on_overflow
+ end
+
+ and fold_write_error_handler (v: _ #folder) =
+ handle v#fold_write_error_handler
+ ~continue:begin fun (write_error, dual_handler) x -> x
+ >> fold_write_error v write_error
+ >> fold_dual_handler v dual_handler
+ end
+
+ and fold_write' (v: _ #folder) =
+ handle' v#fold_write' v
+ ~fold:begin fun v { write_to; write_from;
+ write_advancing; write_retry;
+ write_lock; write_error_handler } x -> x
+ >> fold_write_target v write_to
+ >> fold_option ~fold:fold_ident_or_literal v write_from
+ >> fold_option ~fold:fold_advancing_phrase v write_advancing
+ >> fold_option ~fold:fold_retry_clause v write_retry
+ >> fold_option ~fold:fold_bool v write_lock
+ >> fold_option ~fold:fold_write_error_handler v write_error_handler
+ end
+
+end
diff --git a/src/lsp/cobol_ast/raw_visitor.ml b/src/lsp/cobol_ast/raw_visitor.ml
new file mode 100644
index 000000000..8e088f1ba
--- /dev/null
+++ b/src/lsp/cobol_ast/raw_visitor.ml
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module Make_for_misc_sections = Raw_misc_sections_visitor.Make
+module Make_for_data_sections = Raw_data_sections_visitor.Make
+module Make_for_data_division = Raw_data_division_visitor.Make
+module Make_for_statements = Raw_statements_visitor.Make
+module Make_for_proc_division = Raw_proc_division_visitor.Make
+module Make_for_compilation_group = Raw_compilation_group_visitor.Make
diff --git a/src/lsp/cobol_ast/simple_statements.ml b/src/lsp/cobol_ast/simple_statements.ml
new file mode 100644
index 000000000..f465d2570
--- /dev/null
+++ b/src/lsp/cobol_ast/simple_statements.ml
@@ -0,0 +1,453 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Non-branching statements *)
+
+open Terms
+open Operands
+
+
+(*
+ALLOCATE exp CHARACTERS INIT? (RET id)?
+ALLOCATE id INIT? (RET id)?
+*)
+
+(* ALLOCATE *)
+type allocate_stmt =
+ {
+ allocate_kind: allocate_kind;
+ allocate_initialized: bool;
+ allocate_returning: ident with_loc option;
+ }
+[@@deriving show, ord]
+
+and allocate_kind =
+ | AllocateCharacters of expression (*arith exp that evaluates to int (may be rounded)*)
+ | AllocateDataItem of name with_loc
+[@@deriving show, ord]
+
+
+(*
+ALTER id TO PROCEED? id
+*)
+
+(* ALTER *)
+type alter_stmt =
+ alter_operands with_loc list
+[@@deriving show, ord]
+
+and alter_operands =
+ {
+ alter_source: qualname;
+ alter_target: qualname;
+ }
+[@@deriving show, ord]
+
+
+(* CLOSE *)
+type close_stmt = close_phrase list [@@deriving show, ord]
+and close_phrase =
+ {
+ close_item: name with_loc;
+ close_format: close_format option;
+ }
+[@@deriving show, ord]
+
+and close_format =
+ | CloseUnitReel of bool (* for removal *)
+ | CloseWithLock
+ | CloseWithNoRewind
+[@@deriving show, ord]
+
+
+(* ENTER *)
+type enter_stmt =
+ {
+ enter_language: name with_loc;
+ enter_routine: name with_loc option;
+ }
+[@@deriving show, ord]
+
+
+(* EXIT *)
+type exit_stmt =
+ | ExitSimple
+ | ExitProgram of raising option
+ | ExitMethod of raising option
+ | ExitFunction of raising option
+ | ExitPerform of bool
+ | ExitParagraph
+ | ExitSection
+[@@deriving show, ord]
+
+
+(* INITIALIZE *)
+type initialize_stmt =
+ {
+ init_items: ident list;
+ init_filler: bool;
+ init_category: init_category option;
+ init_replacings: init_replacing list;
+ init_to_default: bool;
+ }
+[@@deriving show, ord]
+
+and init_category =
+ | InitAll
+ | InitCategory of init_data_category
+[@@deriving show, ord]
+
+and init_replacing =
+ {
+ init_replacing_category: init_data_category;
+ init_replacing_replacement_item: ident_or_literal;
+ }
+[@@deriving show, ord]
+
+and init_data_category =
+ | InitCategoryAlphabetic
+ | InitCategoryAlphanumeric
+ | InitCategoryAlphanumericEdited
+ | InitCategoryBoolean
+ | InitCategoryDataPointer
+ | InitCategoryFunctionPointer
+ | InitCategoryNational
+ | InitCategoryNationalEdited
+ | InitCategoryNumeric
+ | InitCategoryNumericEdited
+ | InitCategoryObjectReference
+ | InitCategoryProgramPointer
+[@@deriving show, ord]
+
+
+(* INVOKE *)
+type invoke_stmt =
+ {
+ invoke_target: ident;
+ invoke_method: ident_or_strlit;
+ invoke_using: call_using_clause with_loc list;
+ invoke_returning: ident with_loc option;
+ (* error_htypeler: error_htypeler; (* seen on IBM Cobol *) *)
+ }
+[@@deriving show, ord]
+
+
+(* INSPECT *)
+type inspect_stmt =
+ {
+ inspect_item: ident;
+ inspect_spec: inspect_spec;
+ }
+[@@deriving show, ord]
+
+and inspect_spec =
+ | InspectTallying of tallying list
+ | InspectReplacing of replacing list
+ | InspectBoth of tallying list * replacing list
+ | InspectConverting of converting
+[@@deriving show, ord]
+
+and tallying =
+ {
+ tallying_target: qualident;
+ tallying_clauses: tallying_clause with_loc list;
+ }
+[@@deriving show, ord]
+
+and tallying_clause =
+ | TallyingCharacters of inspect_where list
+ | TallyingRange of tallying_range * tallying_spec list
+[@@deriving show, ord]
+
+and tallying_range =
+ | TallyAll
+ | TallyLeading
+[@@deriving show, ord]
+
+and tallying_spec =
+ {
+ tallying_item: ident_or_nonnum;
+ tallying_where: inspect_where list;
+ }
+[@@deriving show, ord]
+
+and replacing = replacing_clause with_loc
+[@@deriving show ,ord]
+
+and replacing_clause =
+ | ReplacingCharacters of
+ {
+ replacement: ident_or_nonnum;
+ where: inspect_where list;
+ }
+ | ReplacingRange of replacing_range * replacing_range_spec list
+[@@deriving show, ord]
+
+and replacing_range =
+ | ReplaceAll
+ | ReplaceLeading
+ | ReplaceFirst
+[@@deriving show, ord]
+
+and replacing_range_spec =
+ {
+ replacing_item: ident_or_nonnum;
+ replacing_by: ident_or_nonnum;
+ replacing_where: inspect_where list;
+ }
+[@@deriving show, ord]
+
+and converting =
+ {
+ converting_from: ident_or_nonnum;
+ converting_to: ident_or_nonnum;
+ converting_where: inspect_where list;
+ }
+[@@deriving show, ord]
+
+and inspect_where = inspect_direction * inspect_reference
+[@@deriving show, ord]
+
+and inspect_direction =
+ | InspectAfter
+ | InspectBefore
+[@@deriving show, ord]
+
+and inspect_reference = ident_or_nonnum
+[@@deriving show, ord]
+
+
+(* MERGE *)
+type merge_stmt =
+ {
+ merge_file: name with_loc;
+ merge_keys: Data_descr.sort_spec list;
+ merge_collating: Misc_descr.alphabet_specification option;
+ merge_using: name with_loc list;
+ merge_target: merge_or_sort_target;
+ }
+[@@deriving show, ord]
+
+and merge_or_sort_target =
+ | OutputProcedure of name with_loc procedure_range
+ | Giving of name with_loc list
+[@@deriving show, ord]
+
+
+(* MOVE *)
+type move_stmt = (* TODO: maybe split in two distinct statements *)
+ | MoveSimple of
+ {
+ from: ident_or_literal;
+ to_: ident list;
+ }
+ | MoveCorresponding of
+ {
+ from: ident;
+ to_: ident list;
+ }
+[@@deriving show, ord]
+
+
+(* OPEN *)
+type open_stmt = open_phrase list [@@deriving show, ord]
+and open_phrase =
+ {
+ open_mode: open_mode;
+ open_sharing: sharing_mode option;
+ open_retry: retry_clause option;
+ open_files: named_file_option list;
+ }
+[@@deriving show, ord]
+
+and named_file_option =
+ {
+ named_file_name: name with_loc;
+ named_file_option: file_option option;
+ }
+[@@deriving show, ord]
+
+
+(* RELEASE *)
+type release_stmt =
+ {
+ release_item: name with_loc;
+ release_from: ident_or_literal option;
+ }
+[@@deriving show, ord]
+
+
+(* SEND *)
+type send_stmt =
+ {
+ send_name: name with_loc;
+ send_operands: send_operands;
+ }
+[@@deriving show, ord]
+
+and send_operands =
+ | SendSimple of
+ {
+ from: ident;
+ }
+ | SendWith of
+ {
+ from: ident option;
+ ending_indicator: message_ending_indicator;
+ advancing: advancing_phrase option;
+ replace: bool;
+ }
+[@@deriving show, ord]
+
+and message_ending_indicator =
+ | EndingIndicator of ident
+ | EndingIndicatorESI
+ | EndingIndicatorEMI
+ | EndingIndicatorEGI
+[@@deriving show, ord]
+
+
+(* SET *)
+
+ (*
+ SET ADDR/id... UPBY/DOWNBY/TO id/exp/int
+
+ SET (id... TO ON/OFF)...
+ SET (id... TO TRUE/FALSE)...
+
+ SET id ATTRIBUTE
+ SET id TO LOCALE
+
+ SET LOCALE
+ SET LAST EXCEPTION
+ SET CONTENT
+ *)
+type set_stmt =
+ | SetAmbiguous of
+ {
+ targets: ident list;
+ set_method: set_ambiguous_method;
+ value: expression;
+ }
+ | SetSwitch of
+ set_switch_spec list
+ | SetCondition of
+ set_condition_spec list
+ | SetAttribute of
+ {
+ name: name with_loc;
+ attribute_switches: set_attribute_switch list;
+ }
+ | SetSaveLocale of
+ {
+ target: ident;
+ locale: set_save_locale;
+ }
+ | SetLocale of
+ {
+ target: set_locale_target;
+ source: set_locale_source;
+ }
+ | SetSavedException
+ | SetFloatContent of
+ {
+ targets: ident list;
+ content: float_content;
+ sign: sign option;
+ }
+[@@deriving show, ord]
+
+and set_switch_spec =
+ {
+ set_switch_targets: ident list;
+ set_switch_value: on_off;
+ }
+[@@deriving show, ord]
+
+and set_condition_spec =
+ {
+ set_condition_targets: ident list;
+ set_condition_value: bool;
+ }
+[@@deriving show, ord]
+
+
+
+(* SORT *)
+type sort_stmt =
+ | SortFile of
+ {
+ file: qualident;
+ keys: Data_descr.sort_spec list; (* Not empty *)
+ duplicate_in_order: bool;
+ collating: Misc_descr.alphabet_specification option;
+ source: sort_source;
+ target: merge_or_sort_target;
+ }
+ | SortTable of
+ {
+ table: qualident;
+ keys: Data_descr.sort_spec list; (* Can be empty *)
+ duplicate_in_order: bool;
+ collating: Misc_descr.alphabet_specification option;
+ }
+[@@deriving show, ord]
+
+and sort_source = (* SORT only *)
+ | SortInputProcedure of name with_loc procedure_range
+ | SortUsing of name with_loc list
+[@@deriving show, ord]
+
+
+(* STOP *)
+type stop_stmt =
+ | StopRun of stop_run option
+ | StopLiteral of literal
+[@@deriving show, ord]
+
+and stop_run =
+ {
+ stop_kind: stop_kind;
+ stop_status: ident_or_literal;
+ }
+[@@deriving show, ord]
+
+and stop_kind =
+ | StopRunError
+ | StopRunNormal
+[@@deriving show, ord]
+
+
+type terminate_stmt =
+ name with_loc list
+[@@deriving show, ord]
+
+
+(* TRANSFORM *)
+
+type transform_stmt =
+ {
+ transform_ident: ident with_loc;
+ transform_from: ident_or_nonnum with_loc;
+ transform_to: ident_or_nonnum with_loc;
+ }
+[@@deriving show, ord]
+
+
+(* UNLOCK *)
+type unlock_stmt =
+ {
+ unlock_file: name with_loc;
+ unlock_record: bool;
+ }
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_ast/terms.ml b/src/lsp/cobol_ast/terms.ml
new file mode 100644
index 000000000..89e43c984
--- /dev/null
+++ b/src/lsp/cobol_ast/terms.ml
@@ -0,0 +1,849 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+include Numericals
+
+type lexloc = Cobol_common.Srcloc.lexloc
+type srcloc = Cobol_common.Srcloc.srcloc
+
+type 'a with_loc = 'a Cobol_common.Srcloc.with_loc =
+ { payload: 'a; loc: srcloc [@compare fun _ _ -> 0]; }
+ [@@deriving ord]
+let pp_with_loc = Cobol_common.Srcloc.pp_with_loc
+
+type name = string
+[@@deriving ord]
+let pp_name = Pretty.string
+
+let pp_name' ppf { payload; _ } = pp_name ppf payload
+
+(** {2 Term attributes} *)
+
+(* Polymorphic GADT parameter types are a neat solution to share type and tag
+ names. This is what we use to unify the type of all/most terms in the
+ syntax.
+
+ For now this appears to break `deriving.show` (ppx), but that limitation
+ should not prevent us from using neat typing features and obtain ASTs that
+ are easier to work with.
+*)
+type alnum_ = [ `AlphaNum ]
+type bool_ = [ `Bool ]
+type fixed_ = [ `Fixed ]
+type float_ = [ `Float ]
+type ident_ = [ `Ident ]
+type int_ = [ `Int ]
+type name_ = [ `Name ]
+type national_ = [ `National ]
+type 'a qual_ = [ `Qual of 'a ]
+type qualname_ = [name_|name qual_]
+type num_ = [int_|fixed_|float_]
+type nonnum_ = [alnum_|national_|bool_]
+type strlit_ = [alnum_|national_]
+type lit_ = [nonnum_|bool_|num_]
+
+
+(* Attributes for distinguishing expressions *)
+type simple_ = [ `Simple ]
+type complex_ = [ `Complex ]
+
+(* Attributes for distinguishing sign conditions *)
+type strict_ = [ `Strict ]
+type loose_ = [ `Loose ]
+
+(** Now comes the type of all/most terms *)
+type _ term =
+ | Alphanum: string -> [>alnum_] term
+ | Boolean: boolean -> [>bool_] term
+ | Fixed: fixed -> [>fixed_] term
+ | Floating: floating -> [>float_] term
+ | Integer: integer -> [>int_] term
+ | National: string -> [>national_] term
+
+ | NumFig: int_ figurative -> [>int_] term
+ | Fig: [nonnum_|strlit_] figurative -> [>strlit_] term
+
+ | Name: name with_loc -> [>name_] term
+ | Qual: name with_loc * qualname_ term -> [>name qual_] term
+
+ | Address: address -> [>ident_] term
+ | Counter: counter -> [>ident_] term
+ | InlineCall: inline_call -> [>ident_] term
+ | InlineInvoke: inline_invocation -> [>ident_] term
+ | ObjectView: object_view -> [>ident_] term
+ | ObjectRef: object_ref -> [>ident_] term (* Includes predefined address (NULL) *)
+ | QualIdent: qualident -> [>ident_] term (* Includes subscripts and ref-mod *)
+
+ | StrConcat: strlit_ term * strlit_ term -> [>strlit_] term
+ | Concat: nonnum_ term * nonnum_ term -> [>nonnum_] term
+
+and _ figurative =
+ | Zero: [strlit_] figurative (* ALPHA/NAT *)
+ | Quote: [>strlit_] figurative (* ALPHA/NAT *)
+ | LowValue: [>strlit_] figurative (* ALPHA/NAT *)
+ | HighValue: [>strlit_] figurative (* ALPHA/NAT *)
+ | All: nonnumlit -> [ [>simple_] cond (* exp (bool), ident (bool, cond, switch) *)
+ | Relation: expression * relop * expression -> [>simple_] cond (* general, bool, pointer *)
+ | ClassCond: expression * class_ -> [>simple_] cond (* exp = ident *)
+ | SignCond: expression * signz -> [>simple_] cond (* exp = arith exp *)
+ | Omitted: expression -> [>simple_] cond (* exp = ident *)
+ | Not: _ cond -> [>complex_] cond
+ | Logop: _ cond * logop * _ cond -> [>complex_] cond (* TODO: move logop left *)
+
+and condition = [simple_|complex_] cond
+and simple_condition = simple_ cond
+
+and logop =
+ | LAnd
+ | LOr
+
+and relop =
+ | Gt
+ | Lt
+ | Eq
+ | Ne
+ | Ge
+ | Le
+
+and class_ =
+ | AlphabetOrClass of name with_loc
+ | Alphabetic
+ | AlphabeticLower
+ | AlphabeticUpper
+ | ClassBoolean
+ | FarthestFromZero
+ | FloatInfinity
+ | FloatNotANumber
+ | FloatNotANumberQuiet
+ | FloatNotANumberSignaling
+ | InArithmeticRange
+ | NearestToZero
+ | ClassNumeric
+
+
+and inline_call = (* in ancient terms: funident *)
+ {
+ call_fun: name with_loc;
+ call_args: effective_arg list;
+ call_refmod: refmod option;
+ }
+
+and effective_arg = (* TODO: could be an [expression option] *)
+ | ArgExpr of expression (* Regroup identifiers, literals and arithmetic expressions *)
+ | ArgOmitted
+
+and qualident =
+ {
+ ident_name: qualname;
+ ident_subscripts: subscript list;
+ ident_refmod: refmod option;
+ }
+
+and subscript =
+ | SubSAll
+ | SubSExpr of expression
+ | SubSIdx of name with_loc * sign * integer
+
+and _ sign_cond =
+ | SgnPositive: [ int
+ (*manual compare for term*)
+ let compare_struct first lazy_cmp =
+ if first <> 0
+ then first
+ else Lazy.force lazy_cmp
+ let compare_with_loc_name =
+ compare_with_loc compare_name
+
+ let rec compare_term: type a. a term compare_fun =
+ fun x y -> match x , y with
+ | Alphanum a, Alphanum b ->
+ String.compare a b
+ | Alphanum _, Fig HighValue ->
+ -1
+ | Alphanum _, Fig _ -> 1
+ | Boolean a, Boolean b ->
+ Stdlib.compare a b
+ | Integer a, Integer b ->
+ String.compare a b
+ | Integer _, Fig Zero
+ | Integer _, NumFig Zero ->
+ 1
+ | National a, National b ->
+ String.compare a b
+ | National _, Fig HighValue ->
+ -1
+ | National _, Fig _ ->
+ 1
+ | NumFig Zero, Integer _ ->
+ -1
+ | NumFig Zero, NumFig Zero ->
+ 0
+ | Fig Zero, Integer _ ->
+ -1
+ | Fig _, Fig _ ->
+ 0 (* TODO: `compare_fig` *)
+ | Name a, Name b ->
+ compare_with_loc_name a b
+ | Qual (a, c), Qual (b, d) ->
+ let first = compare_with_loc_name a b in
+ if first <> 0
+ then first
+ else compare_term c d
+ | Address a, Address b ->
+ compare_address a b
+ | Counter a, Counter b ->
+ compare_counter a b
+ | InlineCall a, InlineCall b ->
+ compare_inline_call a b
+ | InlineInvoke a, InlineInvoke b ->
+ compare_inline_invoke a b
+ | ObjectView a, ObjectView b ->
+ compare_object_view a b
+ | ObjectRef a, ObjectRef b ->
+ compare_object_ref a b
+ | QualIdent a, QualIdent b ->
+ compare_qualident a b
+ | StrConcat (a, c), StrConcat (b, d) ->
+ compare_struct (compare_term a b) @@ lazy (compare_term c d)
+ | Concat(a,c), Concat(b,d) ->
+ compare_struct (compare_term a b) @@ lazy (compare_term c d)
+ | a , b ->
+ Stdlib.compare a b
+ and compare_expression x y = match x, y with
+ | Atom a ,Atom b ->
+ compare_term a b
+ | Unop(a, c), Unop(b, d) ->
+ compare_struct (Stdlib.compare a b) @@ lazy (compare_expression c d)
+ | Binop(a, c ,e), Binop(b, d, f) ->
+ compare_struct (Stdlib.compare c d) @@
+ lazy (compare_struct (compare_expression a b) @@
+ lazy (compare_expression e f))
+ (* take the arbitrari order Binop > Unop > Atom *)
+ | Atom _, _ ->
+ -1
+ | _, Atom _->
+ 1
+ | Unop _, _ ->
+ -1
+ | _, Unop _ ->
+ 1
+ and compare_cond a b = match a, b with
+ | Expr x, Expr y ->
+ compare_expression x y
+ | Relation (x1, r1, y1), Relation (x2, r2, y2) ->
+ compare_struct (compare_expression x1 x2) @@
+ lazy (compare_struct (compare r1 r2) @@ lazy (compare_expression y1 y2))
+ | ClassCond (x1, c1), ClassCond (x2, c2) ->
+ compare_struct (compare_expression x1 x2) @@ lazy (compare_class_ c1 c2)
+ | SignCond (x1, s1), SignCond(x2, s2) ->
+ compare_struct (compare_expression x1 x2) @@ lazy (compare_signz s1 s2)
+ | a, b ->
+ Stdlib.compare a b
+ and compare_relop =
+ Stdlib.compare
+ and compare_class_ a b = match a, b with
+ | AlphabetOrClass n1, AlphabetOrClass n2 ->
+ compare_with_loc_name n1 n2
+ | a, b ->
+ Stdlib.compare a b
+ and compare_qualident
+ { ident_name = a; ident_subscripts = c; ident_refmod = e }
+ { ident_name = b; ident_subscripts = d; ident_refmod = f } =
+ compare_struct (compare_term a b) @@
+ lazy (compare_struct (List.compare compare_subcript c d) @@
+ lazy (Option.compare compare_refmod e f))
+ and compare_subcript x y = match x,y with
+ | SubSExpr a ,SubSExpr b ->
+ compare_expression a b
+ | SubSIdx(n1, s1, i1),
+ SubSIdx(n2, s2, i2) ->
+ compare_struct (compare_with_loc_name n1 n2) @@
+ lazy (compare_struct (compare_sign s1 s2) @@ lazy (compare i1 i2))
+ | a, b ->
+ Stdlib.compare a b
+ and compare_refmod
+ { leftmost = a; length_opt = c }
+ { leftmost = b; length_opt = d } =
+ compare_struct (compare_expression a b) @@
+ lazy (Option.compare compare_expression c d)
+ and compare_sign : strict_ sign_cond compare_fun = compare
+ and compare_signz : loose_ sign_cond compare_fun = compare
+ and compare_object_ref x y = match x, y with
+ | Super a, Super b ->
+ Option.compare compare_with_loc_name a b
+ | a, b ->
+ Stdlib.compare a b
+ and compare_object_view
+ { object_view_ident = a; object_view_spec = c }
+ { object_view_ident = b; object_view_spec = d } =
+ compare_struct (compare_ident a b) @@ lazy (compare_object_view_spec c d)
+ and compare_object_view_spec x y = match x, y with
+ | ObjViewAmbiguous a , ObjViewAmbiguous b
+ | ObjViewFactory a, ObjViewFactory b
+ | ObjViewOnly a, ObjViewOnly b
+ | ObjViewFactoryOnly a, ObjViewFactoryOnly b ->
+ compare_with_loc_name a b
+ | a, b ->
+ compare a b
+ and compare_inline_invoke
+ { invoke_class = a; invoke_meth = c; invoke_args = e }
+ { invoke_class = b; invoke_meth = d; invoke_args = f } =
+ compare_struct (compare_term a b) @@
+ lazy (compare_struct (compare_term c d) @@
+ lazy (List.compare compare_effective_arg e f))
+ and compare_inline_call
+ { call_fun = a; call_args = c; call_refmod = r1 }
+ { call_fun = b; call_args = d; call_refmod = r2 } =
+ compare_struct (compare_with_loc_name a b) @@
+ lazy (compare_struct (List.compare compare_effective_arg c d) @@
+ lazy (Option.compare compare_refmod r1 r2))
+ and compare_effective_arg x y = match x, y with
+ | ArgExpr a, ArgExpr b ->
+ compare_expression a b
+ | ArgExpr _, ArgOmitted ->
+ 1
+ | ArgOmitted, ArgOmitted ->
+ 0
+ | ArgOmitted, ArgExpr _ ->
+ -1
+ and compare_address x y = match x, y with
+ | DataAddress a, DataAddress b ->
+ compare_term a b
+ | ProgAddress a, ProgAddress b ->
+ compare_term a b
+ | a, b ->
+ compare a b
+ and compare_counter
+ { counter_kind = a; counter_name = c }
+ { counter_kind = b; counter_name = d } =
+ compare_struct (Stdlib.compare a b) @@
+ lazy (Option.compare (compare_with_loc_name) c d)
+
+ and compare_ident: ident compare_fun = fun a b -> compare_term a b
+
+ let compare_qualname: qualname compare_fun = compare_term
+ let compare_literal: literal compare_fun = compare_term
+ let compare_ident_or_numlit: ident_or_numlit compare_fun = compare_term
+ let compare_ident_or_alphanum: ident_or_alphanum compare_fun = compare_term
+ let compare_ident_or_intlit: ident_or_intlit compare_fun = compare_term
+ let compare_ident_or_literal: ident_or_literal compare_fun = compare_term
+ let compare_ident_or_nonnum: ident_or_nonnum compare_fun = compare_term
+ let compare_ident_or_strlit: ident_or_strlit compare_fun = compare_term
+ let compare_name_or_alphanum: name_or_alphanum compare_fun = compare_term
+ let compare_name_or_string: name_or_string compare_fun = compare_term
+ let compare_qualname_or_alphanum: qualname_or_alphanum compare_fun = compare_term
+ let compare_qualname_or_intlit: qualname_or_intlit compare_fun = compare_term
+ let compare_qualname_or_literal: qualname_or_literal compare_fun = compare_term
+ let compare_strlit: strlit compare_fun = compare_term
+ let compare_strlit_or_intlit: strlit_or_intlit compare_fun = compare_term
+
+ let compare_condition = compare_cond
+end
+include COMPARE
+
+(** [major_qualifier qualname] returns [Name name] when [qualname] is
+ [Qual (..., Qual (_, Name name)) | Name name]*)
+let rec major_qualifier_of_qualname qualname =
+ match (qualname: qualname) with
+ | Qual (_, qn) ->
+ major_qualifier_of_qualname qn
+ | Name n -> n
+
+(** [qualifier_of_qualname qualname] returns [name] when [qualname] is [Name name] or
+ [Qual (name, _)] *)
+let qualifier_of_qualname: qualname -> name with_loc = function
+ | Qual (name, _) -> name
+ | Name name -> name
+
+(** [list_of_qualname qualname] returns the list [nameN; ...; name1] when qualname is [Qual(name1, ... (Name nameN))],
+ (note that the major qualifier is first and the minor is last). *)
+let list_of_qualname qualname =
+ let rec aux acc = function
+ | Qual(n, qn) -> aux (n::acc) qn
+ | Name n -> n::acc
+ in
+ aux [] qualname
+
+
+
+(** {2 Manual prettty-printing for terms} *)
+module FMT = struct
+
+ open Fmt
+
+ let pp_boolean: boolean Pretty.printer = fun ppf -> function
+ (* | { bool_width = 0; _ } -> *)
+ (* string ppf "zero-length-boolean" *)
+ | { bool_value; _ } ->
+ string ppf bool_value
+
+ let rec pp_term: type k. k term Pretty.printer = fun ppf -> function
+ | Alphanum s -> fmt "@[%S:@ alphanum@]" ppf s
+ | Boolean b -> fmt "@[%a:@ boolean@]" ppf pp_boolean b
+ | Fixed f -> pp_fixed ppf f
+ | Floating f -> pp_floating ppf f
+ | Integer i -> pp_integer ppf i
+ | National s -> fmt "@[%S:@ national@]" ppf s
+ | NumFig f -> pp_figurative ppf f
+ | Fig f -> pp_figurative ppf f
+
+ | Name n -> pp_name' ppf n
+ | Qual (n, q) -> fmt "%a@ IN@ %a" ppf pp_name' n pp_term q
+
+ | Address i -> pp_address ppf i
+ | Counter c -> pp_counter ppf c
+ | InlineCall i -> pp_inline_call ppf i
+ | InlineInvoke i -> pp_inline_invocation ppf i
+ | ObjectView o -> pp_object_view ppf o
+ | ObjectRef o -> pp_object_ref ppf o
+ | QualIdent i -> pp_qualident ppf i
+
+ | StrConcat (a, b) -> fmt "%a@ &@ %a" ppf pp_term a pp_term b
+ | Concat (a, b) -> fmt "%a@ &@ %a" ppf pp_term a pp_term b
+
+ and pp_figurative: type k. k figurative Pretty.printer = fun ppf -> function
+ | Zero -> string ppf "ZERO"
+ | Space -> string ppf "SPACE"
+ | Quote -> string ppf "QUOTE"
+ | LowValue -> fmt "LOW@ VALUE" ppf
+ | HighValue -> fmt "HIGH@ VALUE" ppf
+ | All l -> fmt "ALL@ OF@ %a" ppf pp_term l
+
+ and pp_subscript ppf : subscript -> unit = function
+ | SubSAll -> string ppf "ALL"
+ | SubSExpr e -> pp_expression ppf e
+ | SubSIdx (n, s, i) -> fmt "%a@ %a@ %a" ppf pp_name' n pp_sign s pp_integer i
+
+ and pp_refmod ppf { leftmost; length_opt } =
+ fmt "@[<1>(%a:%a)@]" ppf
+ pp_expression leftmost
+ (option pp_expression) length_opt
+
+ and pp_qualident ppf { ident_name = n; ident_refmod; ident_subscripts } =
+ pp_qualname ppf n;
+ if ident_subscripts <> []
+ then fmt "@[<1>(%a)@]" ppf (list pp_subscript) ident_subscripts;
+ option pp_refmod ppf ident_refmod
+
+ and pp_qualname ppf = pp_term ppf
+
+ and pp_address ppf = function
+ | DataAddress i -> fmt "ADDRESS@ OF@ %a" ppf pp_ident i
+ | ProgAddress i -> fmt "ADDRESS@ OF@ PROGRAM@ %a" ppf pp_term i
+
+ and pp_inline_call ppf { call_fun; call_args; call_refmod } =
+ fmt "FUNCTION@ %a@ @[<1>(%a)%a@]" ppf pp_name' call_fun
+ (list ~sep:nop pp_effective_arg) call_args
+ (option (fun ppf -> fmt "@ %a" ppf pp_refmod)) call_refmod
+
+ and pp_inline_invocation ppf { invoke_class; invoke_meth; invoke_args } =
+ fmt "%a::%a@ @[<1>(%a)@]" ppf pp_ident invoke_class pp_literal invoke_meth
+ (list ~sep:nop pp_effective_arg) invoke_args
+
+ and pp_effective_arg ppf = function
+ | ArgOmitted -> string ppf "OMITTED"
+ | ArgExpr e -> pp_expression ppf e
+
+ and pp_object_view ppf { object_view_ident; object_view_spec } =
+ fmt "%a@ AS@ " ppf pp_ident object_view_ident;
+ match object_view_spec with
+ | ObjViewAmbiguous n -> pp_name' ppf n
+ | ObjViewOnly n -> fmt "%a@ ONLY" ppf pp_name' n
+ | ObjViewFactory n -> fmt "FACTORY@ OF@ %a" ppf pp_name' n
+ | ObjViewFactoryOnly n -> fmt "FACTORY@ OF@ %a@ ONLY" ppf pp_name' n
+ | ObjViewUniversal -> string ppf "UNIVERSAL"
+
+ and pp_object_ref ppf = function
+ | ExceptionObject -> string ppf "EXCEPTION-OBJECT"
+ | Null -> string ppf "NULL"
+ | Self -> string ppf "SELF"
+ | Super None -> string ppf "SUPER"
+ | Super (Some n) -> fmt "%a@ OF@ SUPER" ppf pp_name' n
+
+ and pp_counter ppf { counter_kind; counter_name } =
+ let k = match counter_kind with
+ | LineageCounter -> "LINAGE-COUNTER"
+ | PageCounter -> "PAGE-COUNTER"
+ | LineCounter -> "LINE-COUNTER"
+ in
+ string ppf k;
+ Option.iter (fmt "@ OF@ %a" ppf pp_name') counter_name
+
+ and pp_expression ppf = function
+ | Atom a ->
+ pp_term ppf a
+ | Unop (o, e) ->
+ fmt "@[<1>(%s@ %a)@]" ppf ([%derive.show: unop] o) pp_expression e
+ | Binop (a, o, b) ->
+ fmt "@[<1>(%a@ %s@ %a)@]" ppf
+ pp_expression a ([%derive.show: binop] o) pp_expression b
+
+ and show_unop = function
+ | UPlus -> "+"
+ | UMinus -> "-"
+ | UNot -> "B-NOT"
+ and pp_unop ppf o = string ppf (show_unop o)
+
+ and show_binop = function
+ | BPlus -> "+"
+ | BMinus -> "-"
+ | BMul -> "*"
+ | BDiv -> "/"
+ | BPow -> "**"
+ | BAnd -> "B-AND"
+ | BOr -> "B-OR"
+ | BXor -> "B-XOR"
+ and pp_binop ppf o = string ppf (show_binop o)
+
+ and pp_cond
+ : type k. ?pos:_ -> k cond Pretty.printer = fun ?(pos = true) ppf -> function
+ | Expr e ->
+ fmt "%a%a" ppf not_ pos pp_expression e
+ | Relation (a, o, b) ->
+ fmt "@[<1>%a(%a@ %s@ %a)@]" ppf
+ not_ pos pp_expression a ([%derive.show: relop] o) pp_expression b
+ | ClassCond (e, c) ->
+ fmt "%a@ %a%a" ppf pp_expression e not_ pos pp_class_ c
+ | SignCond (e, s) ->
+ fmt "%a@ %a%a" ppf pp_expression e not_ pos pp_sign s
+ | Omitted e ->
+ fmt "%a@ %aOMITTED" ppf pp_expression e not_ pos
+ | Not c ->
+ pp_cond ~pos:(not pos) ppf c
+ | Logop (a, o, b) ->
+ fmt "@[<1>%a(%a@ %a@ %a)@]" ppf
+ not_ pos (pp_cond ~pos:true) a pp_logop o (pp_cond ~pos:true) b
+ and pp_condition ppf = pp_cond ppf
+ and not_ ppf = function false -> fmt "NOT@ " ppf | true -> ()
+
+ and show_relop = function
+ | Gt -> ">"
+ | Lt -> "<"
+ | Eq -> "="
+ | Ne -> "<>"
+ | Ge -> ">="
+ | Le -> "<="
+ and pp_relop ppf o = string ppf (show_relop o)
+
+ and show_class_ = function
+ | AlphabetOrClass n -> str "%a" pp_name' n
+ | Alphabetic -> "ALPHABETIC"
+ | AlphabeticLower -> "ALPHABETIC-LOWER"
+ | AlphabeticUpper -> "ALPHABETIC-UPPER"
+ | ClassBoolean -> "BOOLEAN"
+ | FarthestFromZero -> "FARTHEST-FROM-ZERO"
+ | FloatInfinity -> "FLOAT-INFINITY"
+ | FloatNotANumber -> "FLOAT-NOT-A-NUMBER"
+ | FloatNotANumberQuiet -> "FLOAT-NOT-A-NUMBER-QUIET"
+ | FloatNotANumberSignaling -> "FLOAT-NOT-A-NUMBER-SIGNALING"
+ | InArithmeticRange -> "IN-ARITHMETIC-RANGE"
+ | NearestToZero -> "NEAREST-TO-ZERO"
+ | ClassNumeric -> "NUMERIC"
+ and pp_class_ ppf c = string ppf (show_class_ c)
+
+ and pp_sign: type k. k sign_cond Pretty.printer = fun ppf -> function
+ | SgnPositive -> string ppf "POSITIVE"
+ | SgnNegative -> string ppf "NEGATIVE"
+ | SgnZero -> string ppf "ZERO"
+ and pp_signz ppf = pp_sign ppf
+
+ and pp_logop ppf = function
+ | LAnd -> string ppf "AND"
+ | LOr -> string ppf "OR"
+
+ and pp_literal: literal Pretty.printer = fun ppf -> pp_term ppf
+ and pp_ident: ident Pretty.printer = fun ppf -> pp_term ppf
+
+ (** Pretty-printing for named unions of term types (some are yet to be
+ renamed) *)
+
+ let pp_ident_or_alphanum: ident_or_alphanum Pretty.printer = pp_term
+ let pp_ident_or_intlit: ident_or_intlit Pretty.printer = pp_term
+ let pp_ident_or_literal: ident_or_literal Pretty.printer = pp_term
+ let pp_ident_or_nonnum: ident_or_nonnum Pretty.printer = pp_term
+ let pp_ident_or_numlit: ident_or_numlit Pretty.printer = pp_term
+ let pp_ident_or_strlit: ident_or_strlit Pretty.printer = pp_term
+ let pp_strlit: strlit Pretty.printer = pp_term
+ let pp_name_or_string: name_or_string Pretty.printer = pp_term
+ let pp_name_or_alphanum: name_or_alphanum Pretty.printer = pp_term
+ let pp_strlit_or_intlit: strlit_or_intlit Pretty.printer = pp_term
+ let pp_qualname_or_literal: qualname_or_literal Pretty.printer = pp_term
+ let pp_qualname_or_intlit: qualname_or_intlit Pretty.printer = pp_term
+ let pp_qualname_or_alphanum: qualname_or_alphanum Pretty.printer = pp_term
+
+end
+include FMT
+
+module UPCAST = struct
+ (** Exlicit term upcasting utilities, that should all reduce to identity. *)
+
+ let ident_with_alphanum: ident -> ident_or_alphanum = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let ident_with_nonnum: ident -> ident_or_nonnum = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let ident_with_numeric: ident -> ident_or_numlit = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let ident_with_string: ident -> ident_or_strlit = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let ident_with_literal: ident -> ident_or_literal = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let ident_with_integer: ident -> ident_or_intlit = function
+ | QualIdent _ as v -> v
+ | InlineCall _ as v -> v
+ | InlineInvoke _ as v -> v
+ | ObjectView _ as v -> v
+ | ObjectRef _ as v -> v
+ | Address _ as v -> v
+ | Counter _ as v -> v
+
+ let string_with_name: strlit -> name_or_string = function
+ | Alphanum _ as v -> v
+ | National _ as v -> v
+ | Fig _ as v -> v
+ | StrConcat _ as v -> v
+
+ let string_with_ident: strlit -> ident_or_strlit = function
+ | Alphanum _ as v -> v
+ | National _ as v -> v
+ | Fig _ as v -> v
+ | StrConcat _ as v -> v
+
+ let numeric_with_ident: numlit -> ident_or_numlit = function
+ | Integer _ as v -> v
+ | Fixed _ as v -> v
+ | Floating _ as v -> v
+ | NumFig _ as v -> v
+
+ let nonnum_with_ident: nonnumlit -> ident_or_nonnum = function
+ | Alphanum _ as v -> v
+ | National _ as v -> v
+ | Boolean _ as v -> v
+ | Fig _ as v -> v
+ | StrConcat _ as v -> v
+ | Concat _ as v -> v
+
+ let literal_with_ident: literal -> ident_or_literal = function
+ | Alphanum _ as v -> v
+ | National _ as v -> v
+ | Boolean _ as v -> v
+ | Integer _ as v -> v
+ | Fixed _ as v -> v
+ | Floating _ as v -> v
+ | NumFig _ as v -> v
+ | Fig _ as v -> v
+ | StrConcat _ as v -> v
+ | Concat _ as v -> v
+
+ let literal_with_qualdatname: literal -> qualname_or_literal = function
+ | Alphanum _ as v -> v
+ | National _ as v -> v
+ | Boolean _ as v -> v
+ | Integer _ as v -> v
+ | Fixed _ as v -> v
+ | Floating _ as v -> v
+ | NumFig _ as v -> v
+ | Fig _ as v -> v
+ | StrConcat _ as v -> v
+ | Concat _ as v -> v
+
+ let qualname_with_alphanum: qualname -> qualname_or_alphanum = function
+ | Name _ as v -> v
+ | Qual _ as v -> v
+
+ let qualname_with_literal: qualname -> qualname_or_literal = function
+ | Name _ as v -> v
+ | Qual _ as v -> v
+
+ let qualname_with_integer: qualname -> qualname_or_intlit = function
+ | Name _ as v -> v
+ | Qual _ as v -> v
+
+ let simple_cond: simple_condition -> condition = function
+ | Expr _ as c -> c
+ | Relation _ as c -> c
+ | ClassCond _ as c -> c
+ | SignCond _ as c -> c
+ | Omitted _ as c -> c
+end
+
+type rounded_ident =
+ {
+ rounded_ident: ident;
+ rounded_rounding: rounding;
+ }
+[@@deriving show, ord]
+
+and rounding =
+ | RoundingNotAny
+ | RoundingDefault
+ | RoundingMode of rounding_mode
+[@@deriving show, ord]
+
+and rounding_mode =
+ | AwayFromZero
+ | NearestAwayFromZero
+ | NearestEven
+ | NearestTowardZero
+ | TowardGreater
+ | TowardLesser
+ | Truncation
+ | Prohibited
+[@@deriving show, ord]
+
+and rounded_idents = rounded_ident list
+[@@deriving ord]
diff --git a/src/lsp/cobol_ast/terms_visitor.ml b/src/lsp/cobol_ast/terms_visitor.ml
new file mode 100644
index 000000000..1c20618c3
--- /dev/null
+++ b/src/lsp/cobol_ast/terms_visitor.ml
@@ -0,0 +1,435 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Visitor
+open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *)
+open Ast
+
+(* --- *)
+
+class ['a] folder = object
+ inherit ['a] Cobol_common.Visitor.Fold.folder
+ method fold_name: (name, 'a) fold = default
+ method fold_name': (name with_loc, 'a) fold = default
+ method fold_ident: (ident, 'a) fold = default
+ method fold_qualname: (qualname, 'a) fold = default
+ method fold_qualident: (qualident, 'a) fold = default
+ method fold_address: (address, 'a) fold = default
+ method fold_counter: (counter, 'a) fold = default
+ method fold_counter_kind: (counter_kind, 'a) fold = default
+ method fold_inline_call: (inline_call, 'a) fold = default
+ method fold_inline_invocation: (inline_invocation, 'a) fold = default
+ method fold_effective_arg: (effective_arg, 'a) fold = default
+ method fold_object_view: (object_view, 'a) fold = default
+ method fold_object_view_spec: (object_view_spec, 'a) fold = default
+ method fold_object_ref: (object_ref, 'a) fold = default
+ method fold_subscript: (subscript, 'a) fold = default
+ method fold_refmod: (refmod, 'a) fold = default
+ method fold_sign: (sign, 'a) fold = default
+ method fold_signz: (signz, 'a) fold = default
+ method fold_boolean: (boolean, 'a) fold = default
+ method fold_alphanum: (alphanum, 'a) fold = default
+ method fold_national: (national, 'a) fold = default
+ (* method fold_strlit_figurative: (strlit_ figurative, 'a) fold = default *)
+ (* method fold_intlit: (int_ term, 'a) fold = default *)
+ method fold_int_figurative: (int_ figurative, 'a) fold = default
+ method fold_any_figurative: 'k. ('k figurative, 'a) fold = default
+ (* method fold_figurative: 'k. ('k figurative, 'a) fold = default *)
+ (* method fold_numlit: (numlit, 'a) fold = default *)
+ (* method fold_strlit: (strlit, 'a) fold = default *)
+ (* method fold_literal: (literal, 'a) fold = default *)
+ (* method fold_ident_or_alphanum: (ident_or_alphanum, 'a) fold = default *)
+ (* method fold_ident_or_literal: (ident_or_literal, 'a) fold = default *)
+ method fold_floating: (floating, 'a) fold = default
+ method fold_fixed: (fixed, 'a) fold = default
+ method fold_integer: (integer, 'a) fold = default
+ method fold_binop: (binop, 'a) fold = default
+ method fold_unop: (unop, 'a) fold = default
+ method fold_expr: (expression, 'a) fold = default
+ method fold_class: (class_, 'a) fold = default
+ method fold_cond: 'k. ('k cond, 'a) fold = default
+ method fold_simple_cond: (simple_condition, 'a) fold = default
+ method fold_logop: (logop, 'a) fold = default
+ method fold_relop: (relop, 'a) fold = default
+ method fold_rounding_mode: (rounding_mode, 'a) fold = default
+ method fold_rounding: (rounding, 'a) fold = default
+ method fold_rounded_ident: (rounded_ident, 'a) fold = default
+ (* method fold_constant_value: (constant_value, 'a) fold = default *)
+ (* method fold_constant: (constant, 'a) fold = default *)
+ (* method fold_constant': (constant with_loc, 'a) fold = default *)
+ method fold_property_kind: (property_kind, 'a) fold = default
+
+end
+
+let fold_name (v: _ #folder) = leaf v#fold_name
+let fold_name_opt (v: _ #folder) = fold_option ~fold:fold_name v
+let fold_name_list (v: _ #folder) = fold_list ~fold:fold_name v
+let fold_name' (v: _ #folder) =
+ handle' v#fold_name' v ~fold:fold_name
+
+let fold_name'_opt (v: _ #folder) = fold_option ~fold:fold_name' v
+let fold_name'_list (v: _ #folder) = fold_list ~fold:fold_name' v
+
+let fold_binop (v: _ #folder) = leaf v#fold_binop
+let fold_unop (v: _ #folder) = leaf v#fold_unop
+let fold_logop (v: _ #folder) = leaf v#fold_logop
+let fold_relop (v: _ #folder) = leaf v#fold_relop
+let fold_sign (v: _ #folder) = leaf v#fold_sign
+let fold_signz (v: _ #folder) = leaf v#fold_signz
+let fold_counter_kind (v: _ #folder) = leaf v#fold_counter_kind
+
+let fold_fixed (v: _ #folder) = leaf v#fold_fixed
+let fold_floating (v: _ #folder) = leaf v#fold_floating
+let fold_integer (v: _ #folder) = leaf v#fold_integer
+let fold_integer_opt (v: _ #folder) = fold_option ~fold:fold_integer v
+
+let fold_boolean (v: _ #folder) = leaf v#fold_boolean
+
+let fold_alphanum (v: _ #folder) =
+ handle v#fold_alphanum ~continue:(fun (Alphanum s) -> fold_string v s)
+
+let fold_national (v: _ #folder) =
+ handle v#fold_national ~continue:(fun (National s) -> fold_string v s)
+
+let fold_counter (v: _ #folder) =
+ handle v#fold_counter
+ ~continue:begin fun { counter_kind; counter_name } x -> x
+ >> fold_counter_kind v counter_kind
+ >> fold_name'_opt v counter_name
+ end
+
+let fold_object_ref (v: _ #folder) =
+ handle v#fold_object_ref
+ ~continue:begin function
+ | ExceptionObject | Null | Self -> Fun.id
+ | Super s -> fold_name'_opt v s
+ end
+
+let rec fold_literal (v: _ #folder) : literal -> 'a -> 'a = function
+ | Boolean b -> fold_boolean v b
+ | Fixed _
+ | Floating _
+ | Integer _ as n -> fold_numlit v n
+ | National _ as n -> fold_national v n
+ | NumFig f -> fold_int_figurative v f
+ | Fig f -> fold_any_figurative v f
+ | Alphanum _
+ | StrConcat _ as s -> fold_strlit v s
+ | Concat _ as s -> fold_nonnumlit v s
+
+and fold_intlit (v: _ #folder) : int_ term -> 'a -> 'a = function
+ | Integer i -> fold_integer v i
+ | NumFig f -> fold_int_figurative v f
+
+and fold_numlit (v: _ #folder) : numlit -> 'a -> 'a = function
+ | Fixed f -> fold_fixed v f
+ | Floating f -> fold_floating v f
+ | Integer _
+ | NumFig _ as i -> fold_intlit v i
+
+and fold_nonnumlit (v: _ #folder) : nonnumlit -> 'a -> 'a = function
+ | Alphanum _ as a -> fold_alphanum v a
+ | Boolean b -> fold_boolean v b
+ | National _ as n -> fold_national v n
+ | Fig f -> fold_any_figurative v f
+ | StrConcat _ as s -> fold_strlit v s
+ | Concat _ as n -> fold_nonnumlit v n
+
+and fold_int_figurative (v: _ #folder) =
+ leaf v#fold_int_figurative
+
+and fold_any_figurative (v: _ #folder) =
+ handle v#fold_any_figurative
+ ~continue:begin function
+ | Zero | Space | Quote | LowValue | HighValue -> Fun.id
+ | All n -> fold_nonnumlit v n
+ end
+
+and fold_strlit (v: _ #folder) : strlit -> 'a -> 'a = function
+ | Alphanum _ as a -> fold_alphanum v a
+ | National _ as n -> fold_national v n
+ | Fig f -> fold_any_figurative v f
+ | StrConcat (s, s') -> fun x -> x >> fold_strlit v s >> fold_strlit v s'
+
+and fold_ident (v: _ #folder) =
+ handle v#fold_ident
+ ~continue:begin function
+ | Address ai -> fold_address v ai
+ | Counter c -> fold_counter v c
+ | InlineCall fi -> fold_inline_call v fi
+ | InlineInvoke ii -> fold_inline_invocation v ii
+ | ObjectView ov -> fold_object_view v ov
+ | ObjectRef po -> fold_object_ref v po
+ | QualIdent qi -> fold_qualident v qi
+ end
+
+and fold_qualident (v: _ #folder) =
+ handle v#fold_qualident
+ ~continue:begin fun { ident_name; ident_subscripts; ident_refmod } x -> x
+ >> fold_qualname v ident_name
+ >> fold_list ~fold:fold_subscript v ident_subscripts
+ >> fold_option ~fold:fold_refmod v ident_refmod
+ end
+
+and fold_qualname (v: _ #folder) =
+ handle v#fold_qualname
+ ~continue:begin function
+ | Name n -> fold_name' v n
+ | Qual (n, qn) -> fun x -> x >> fold_name' v n >> fold_qualname v qn
+ end
+
+and fold_subscript (v: _ #folder) =
+ handle v#fold_subscript
+ ~continue:begin function
+ | SubSAll ->
+ Fun.id
+ | SubSExpr e ->
+ fold_expr v e
+ | SubSIdx (n, s, l) ->
+ fun x -> x >> fold_name' v n >> fold_sign v s >> fold_integer v l
+ end
+
+and fold_refmod (v: _ #folder) =
+ handle v#fold_refmod
+ ~continue:begin fun { leftmost; length_opt } x -> x
+ >> fold_expr v leftmost
+ >> fold_option ~fold:fold_expr v length_opt
+ end
+
+and fold_address (v: _ #folder) =
+ handle v#fold_address
+ ~continue:begin function
+ | DataAddress i -> fold_ident v i
+ | ProgAddress i -> fold_ident_or_literal v i
+ end
+
+and fold_inline_call (v: _ #folder) =
+ handle v#fold_inline_call
+ ~continue:begin fun { call_fun; call_args; call_refmod } x -> x
+ >> fold_name' v call_fun
+ >> fold_list ~fold:fold_effective_arg v call_args
+ >> fold_option ~fold:fold_refmod v call_refmod
+ end
+
+and fold_inline_invocation (v: _ #folder) =
+ handle v#fold_inline_invocation
+ ~continue:begin fun { invoke_class; invoke_meth; invoke_args } x -> x
+ >> fold_ident v invoke_class
+ >> fold_literal v invoke_meth
+ >> fold_list ~fold:fold_effective_arg v invoke_args
+ end
+
+and fold_effective_arg (v: _ #folder) =
+ handle v#fold_effective_arg
+ ~continue:begin function
+ | ArgExpr e -> fold_expr v e
+ | ArgOmitted -> Fun.id
+ end
+
+and fold_object_view (v: _ #folder) =
+ handle v#fold_object_view
+ ~continue:begin fun { object_view_ident; object_view_spec } x -> x
+ >> fold_ident v object_view_ident
+ >> fold_object_view_spec v object_view_spec
+ end
+
+and fold_object_view_spec (v: _ #folder) =
+ handle v#fold_object_view_spec
+ ~continue:begin function
+ | ObjViewAmbiguous n
+ | ObjViewFactory n
+ | ObjViewOnly n
+ | ObjViewFactoryOnly n -> fold_name' v n
+ | ObjViewUniversal -> Fun.id
+ end
+
+and fold_expr (v: _ #folder) =
+ handle v#fold_expr
+ ~continue:begin fun e x -> match e with
+ | Atom a -> x >> fold_ident_or_literal v a
+ | Unop (o, e) -> x
+ >> fold_unop v o
+ >> fold_expr v e
+ | Binop (e, o, e') -> x
+ >> fold_expr v e
+ >> fold_binop v o
+ >> fold_expr v e'
+ end
+
+and fold_ident_or_literal (v: _ #folder) : ident_or_literal -> 'a -> 'a = function
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+ | Alphanum _
+ | Boolean _
+ | Fixed _
+ | Floating _
+ | Integer _
+ | National _
+ | NumFig _
+ | Fig _
+ | StrConcat _
+ | Concat _ as l -> fold_literal v l
+
+let fold_class (v: _ #folder) =
+ handle v#fold_class
+ ~continue:begin function
+ | AlphabetOrClass n -> fold_name' v n
+ | Alphabetic
+ | AlphabeticLower
+ | AlphabeticUpper
+ | ClassBoolean
+ | FarthestFromZero
+ | FloatInfinity
+ | FloatNotANumber
+ | FloatNotANumberQuiet
+ | FloatNotANumberSignaling
+ | InArithmeticRange
+ | NearestToZero
+ | ClassNumeric -> Fun.id
+ end
+
+let rec fold_cond: type k. _ #folder -> k cond -> _ = fun v ->
+ handle v#fold_cond
+ ~continue:begin fun (c: k cond) x -> match c with
+ | Expr _ | Omitted _ | Relation _ | ClassCond _ | SignCond _ as c -> x
+ >> fold_simple_cond v c
+ | Not c -> x
+ >> fold_cond v c
+ | Logop (c, l, d) -> x
+ >> fold_cond v c
+ >> fold_logop v l
+ >> fold_cond v d
+ end
+
+and fold_simple_cond (v: _ #folder) =
+ handle v#fold_simple_cond
+ ~continue:begin fun c x -> match c with
+ | Expr e | Omitted e -> x
+ >> fold_expr v e
+ | Relation (e, r, f) -> x
+ >> fold_expr v e
+ >> fold_relop v r
+ >> fold_expr v f
+ | ClassCond (e, c) -> x
+ >> fold_expr v e
+ >> fold_class v c
+ | SignCond (e, s) -> x
+ >> fold_expr v e
+ >> fold_signz v s
+ end
+
+let fold_expression = fold_expr (* alias *)
+let fold_condition = fold_cond (* alias *)
+
+let fold_ident_or_alphanum (v: _ #folder) : ident_or_alphanum -> 'a -> 'a = function
+ | Alphanum _ as a -> fold_alphanum v a
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+
+let fold_ident_or_intlit (v: _ #folder) : ident_or_intlit -> 'a -> 'a = function
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+ | Integer _ | NumFig _ as i -> fold_intlit v i
+
+let fold_ident_or_numlit (v: _ #folder) : ident_or_numlit -> 'a -> 'a = function
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+ | Fixed _ | Floating _
+ | Integer _ | NumFig _ as i -> fold_numlit v i
+
+let fold_ident_or_nonnum (v: _ #folder) : ident_or_nonnum -> 'a -> 'a = function
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+ | Alphanum _
+ | Boolean _
+ | National _
+ | Concat _
+ | StrConcat _
+ | Fig _ as f -> fold_literal v f
+
+let fold_ident_or_strlit (v: _ #folder) : ident_or_strlit -> 'a -> 'a = function
+ | Address _
+ | Counter _
+ | InlineCall _
+ | InlineInvoke _
+ | ObjectView _
+ | ObjectRef _
+ | QualIdent _ as i -> fold_ident v i
+ | Alphanum _
+ | National _
+ | Fig _
+ | StrConcat _ as s -> fold_strlit v s
+
+let fold_qualname_or_alphanum (v: _ #folder) : qualname_or_alphanum -> _ = function
+ | Name _ | Qual _ as qn -> fold_qualname v qn
+ | Alphanum _ as a -> fold_alphanum v a
+
+let fold_qualname_or_intlit (v: _ #folder) : qualname_or_intlit -> _ = function
+ | Name _ | Qual _ as qn -> fold_qualname v qn
+ | Integer _ | NumFig _ as i -> fold_intlit v i
+
+let fold_qualname' (v: _ #folder) = fold' ~fold:fold_qualname v
+let fold_qualname_opt (v: _ #folder) = fold_option ~fold:fold_qualname v
+let fold_qualname'_opt (v: _ #folder) = fold_option ~fold:fold_qualname' v
+let fold_strlit_opt (v: _ #folder) = fold_option ~fold:fold_strlit v
+let fold_literal_opt (v: _ #folder) = fold_option ~fold:fold_literal v
+let fold_ident' (v: _ #folder) = fold' ~fold:fold_ident v
+let fold_ident'_opt (v: _ #folder) = fold_option ~fold:fold_ident' v
+
+let fold_rounding_mode (v: _ #folder) =
+ leaf v#fold_rounding_mode
+
+let fold_rounding (v: _ #folder) =
+ handle v#fold_rounding
+ ~continue:begin function
+ | RoundingMode m -> fold_rounding_mode v m
+ | RoundingNotAny | RoundingDefault -> Fun.id
+ end
+
+let fold_rounded_ident (v: _ #folder) =
+ handle v#fold_rounded_ident
+ ~continue: begin fun { rounded_ident; rounded_rounding } x -> x
+ >> fold_ident v rounded_ident
+ >> fold_rounding v rounded_rounding
+ end
+
+let fold_rounded_idents (v: _ #folder) =
+ fold_list ~fold:fold_rounded_ident v
+
+let fold_property_kind (v: _ #folder) =
+ leaf v#fold_property_kind
diff --git a/src/lsp/cobol_ast/traversal.ml b/src/lsp/cobol_ast/traversal.ml
new file mode 100644
index 000000000..eb653ad80
--- /dev/null
+++ b/src/lsp/cobol_ast/traversal.ml
@@ -0,0 +1,896 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(* NB: broken, but possibly obsolete. *)
+
+(*
+open Cobol_common.Srcloc.INFIX
+open Cobol_common.Basics
+open Ast
+
+(** This module implements the functors let module types to make mapfolder from one
+ implementation of {!Cobol_ptree.Make} to another. *)
+
+module Make_data_sections_traversal
+ (Data_sec_in: DATA_SECTIONS_AST)
+ (Data_sec_out: DATA_SECTIONS_AST)
+ (Default_map: sig
+ val picture: Data_sec_in.Pic_repr.picture -> Data_sec_out.Pic_repr.picture
+ end) =
+struct
+ (** This functor makes a mapfolder from {!In} to {!Out}, using {!Annot_map} to map the different
+ representations from {!In} to {!Out}. *)
+ open Data_sec_in
+ open Data_sec_out
+
+ (** This type is used to specify the types of the mapfold functions, ['a] is the type of
+ the accumulator, ['b] is the type of the AST node that is given as input and
+ ['c] is the type of the AST node that is given as output. *)
+ type ('a, 'b, 'c) fm_fun = 'a fm_funs -> 'a -> 'b -> 'c * 'a
+
+ (** This type is used to specify functions where the returns ast type does not change from the
+ one that was given as input *)
+ and ('a, 'b) fm_id_fun = ('a, 'b, 'b) fm_fun
+
+ (** This record type is used to implement the mapfolder functions. *)
+ and 'a fm_funs = {
+ environment_division: ('a, environment_division with_loc, environment_division with_loc) fm_fun;
+ configuration_section: ('a, configuration_section) fm_id_fun;
+ input_output_section: ('a, input_output_section) fm_id_fun;
+ special_names_paragraph: ('a, special_names_paragraph) fm_id_fun;
+ currency_sign: ('a, currency_sign with_loc) fm_id_fun;
+ decimal_point: ('a, decimal_point with_loc) fm_id_fun;
+ condition_name_entry: ('a, condition_name_entry with_loc) fm_id_fun;
+ rename_entry: ('a, rename_entry with_loc) fm_id_fun;
+ qualname: ('a, qualname) fm_id_fun;
+ data_name: ('a, entry_name option with_loc) fm_id_fun;
+ level: ('a, integer) fm_id_fun;
+ redefines_clause: ('a, redefines_clause with_loc) fm_id_fun;
+ picture_clause: ('a, Data_sec_in.picture_clause with_loc, Data_sec_out.picture_clause with_loc) fm_fun;
+ data_description_clause: ('a, Data_sec_in.data_description_clause with_loc, Data_sec_out.data_description_clause with_loc) fm_fun;
+ screen_description_clause: ('a, Data_sec_in.screen_description_clause with_loc, Data_sec_out.screen_description_clause with_loc) fm_fun;
+ report_group_description_clause: ('a, Data_sec_in.report_group_description_clause with_loc, Data_sec_out.report_group_description_clause with_loc) fm_fun;
+ data_description_entry: ('a, Data_sec_in.data_description_entry with_loc, Data_sec_out.data_description_entry with_loc) fm_fun;
+ report_group_description_entry: ('a, Data_sec_in.report_group_description_entry, Data_sec_out.report_group_description_entry) fm_fun;
+ screen_description_entry: ('a, Data_sec_in.screen_description_entry, Data_sec_out.screen_description_entry) fm_fun;
+ constant_or_data_description_entry: ('a, Data_sec_in.constant_or_data_description_entry with_loc, Data_sec_out.constant_or_data_description_entry with_loc) fm_fun;
+ file_description_entry: ('a, Data_sec_in.file_description_entry, Data_sec_out.file_description_entry) fm_fun;
+ sort_merge_description_entry: ('a, Data_sec_in.sort_merge_description_entry, Data_sec_out.sort_merge_description_entry) fm_fun;
+ input_communication_entry: ('a, Data_sec_in.input_communication_entry, Data_sec_out.input_communication_entry) fm_fun;
+ io_communication_entry: ('a, Data_sec_in.io_communication_entry, Data_sec_out.io_communication_entry) fm_fun;
+ output_communication_entry: ('a, Data_sec_in.output_communication_entry, Data_sec_out.output_communication_entry) fm_fun;
+ communication_description_entry: ('a, Data_sec_in.communication_description_entry with_loc, Data_sec_out.communication_description_entry with_loc) fm_fun;
+ constant_or_report_group_description_entry: ('a, Data_sec_in.constant_or_report_group_description_entry with_loc, Data_sec_out.constant_or_report_group_description_entry with_loc) fm_fun;
+ report_description_entry: ('a, Data_sec_in.report_description_entry with_loc, Data_sec_out.report_description_entry with_loc) fm_fun;
+ constant_or_screen_description_entry: ('a, Data_sec_in.constant_or_screen_description_entry with_loc, Data_sec_out.constant_or_screen_description_entry with_loc) fm_fun;
+ file_or_sort_merge_description_entry: ('a, Data_sec_in.file_or_sort_merge_description_entry with_loc, Data_sec_out.file_or_sort_merge_description_entry with_loc) fm_fun;
+ }
+
+ let fm_environment_division funs acc v =
+ funs.environment_division funs acc v
+
+ let fm_configuration_section funs acc v =
+ funs.configuration_section funs acc v
+
+ let fm_input_output_section funs acc v =
+ funs.input_output_section funs acc v
+
+ let fm_special_names_paragraph funs acc v =
+ funs.special_names_paragraph funs acc v
+
+ let fm_currency_sign funs acc v =
+ funs.currency_sign funs acc v
+
+ let fm_decimal_point funs acc v =
+ funs.decimal_point funs acc v
+
+ let fm_condition_name_entry funs acc v =
+ funs.condition_name_entry funs acc v
+
+ let fm_rename_entry funs acc v =
+ funs.rename_entry funs acc v
+
+ let fm_qualname funs acc v =
+ funs.qualname funs acc v
+
+ let fm_data_name funs acc v =
+ funs.data_name funs acc v
+
+ let fm_level funs acc v =
+ funs.level funs acc v
+
+ let fm_redefines_clause funs acc v =
+ funs.redefines_clause funs acc v
+
+ let fm_picture_clause funs acc v =
+ funs.picture_clause funs acc v
+
+ let fm_data_description_clause funs acc v =
+ funs.data_description_clause funs acc v
+
+ let fm_screen_description_clause funs acc v =
+ funs.screen_description_clause funs acc v
+
+ let fm_report_group_description_clause funs acc v =
+ funs.report_group_description_clause funs acc v
+
+ let fm_data_description_entry funs acc v =
+ funs.data_description_entry funs acc v
+
+ let fm_report_group_description_entry funs acc v =
+ funs.report_group_description_entry funs acc v
+
+ let fm_screen_description_entry funs acc v =
+ funs.screen_description_entry funs acc v
+
+ let fm_constant_or_data_description_entry funs acc v =
+ funs.constant_or_data_description_entry funs acc v
+
+ let fm_file_description_entry funs acc v =
+ funs.file_description_entry funs acc v
+
+ let fm_sort_merge_description_entry funs acc v =
+ funs.sort_merge_description_entry funs acc v
+
+ let fm_input_communication_entry funs acc v =
+ funs.input_communication_entry funs acc v
+
+ let fm_io_communication_entry funs acc v =
+ funs.io_communication_entry funs acc v
+
+ let fm_output_communication_entry funs acc v =
+ funs.output_communication_entry funs acc v
+
+ let fm_communication_description_entry funs acc v =
+ funs.communication_description_entry funs acc v
+
+ let fm_constant_or_report_group_description_entry funs acc v =
+ funs.constant_or_report_group_description_entry funs acc v
+
+ let fm_report_description_entry funs acc v =
+ funs.report_description_entry funs acc v
+
+ let fm_constant_or_screen_description_entry funs acc v =
+ funs.constant_or_screen_description_entry funs acc v
+
+ let fm_file_or_sort_merge_description_entry funs acc v =
+ funs.file_or_sort_merge_description_entry funs acc v
+
+ let nop _ x y =
+ y, x
+
+ let environment_division funs acc (ed: environment_division with_loc) =
+ let configuration_section, acc =
+ (~&ed.configuration_section, acc) >>= fm_configuration_section funs
+ in
+ let input_output_section, acc =
+ (~&ed.input_output_section, acc) >>= fm_input_output_section funs
+ in
+ {
+ configuration_section;
+ input_output_section;
+ } &@<- ed, acc
+
+ let configuration_section funs acc (cs: configuration_section) =
+ let special_names_paragraph, acc =
+ (cs.special_names_paragraph, acc) >>= fm_special_names_paragraph funs
+ in
+ {cs with
+ special_names_paragraph;
+ }, acc
+
+ let input_output_section = nop
+
+ let special_names_paragraph funs acc (snp: special_names_paragraph) =
+ LIST.foldmap (snp, acc) ~f:(fun acc (sncl_loc) ->
+ match ~&sncl_loc with
+ | CurrencySign cs ->
+ let cs, acc = fm_currency_sign funs acc (cs &@<- sncl_loc) in
+ (CurrencySign ~&cs &@<- cs), acc
+ | DecimalPoint dp ->
+ let dp, acc = fm_decimal_point funs acc (dp &@<- sncl_loc) in
+ (DecimalPoint ~&dp &@<- dp), acc
+ | _ ->
+ sncl_loc, acc)
+
+ let qualname = nop
+
+ let data_name = nop
+
+ let level = nop
+
+ let decimal_point = nop
+
+ let currency_sign = nop
+
+ let condition_name_entry = nop
+
+ let rename_entry funs acc re_loc =
+ let re = ~&re_loc in
+ let renamed_item, acc = fm_qualname funs acc (re.renamed_item) in
+ let through_opt, acc = (re.through_opt, acc) >>= fm_qualname funs in
+ {re with
+ renamed_item;
+ through_opt
+ } &@<- re_loc, acc
+
+ let redefines_clause = nop
+
+ let picture_clause _funs acc (pc: Data_sec_in.picture_clause with_loc) =
+ let picture = Default_map.picture (~&pc).picture in
+ {
+ picture;
+ locale_opt = ~&pc.locale_opt;
+ } &@<- pc, acc
+
+ let data_description_clause funs acc ddc =
+ match ~&ddc with
+ | Data_sec_in.Aligned ->
+ Aligned &@<- ddc, acc
+ | AnyLength ->
+ AnyLength &@<- ddc, acc
+ | Based ->
+ Based &@<- ddc, acc
+ | BlankWhenZero ->
+ (BlankWhenZero: data_description_clause) &@<- ddc, acc
+ | ConstantRecord ->
+ ConstantRecord &@<- ddc, acc
+ | DataOccurs do_ ->
+ DataOccurs do_ &@<- ddc, acc
+ | DataType dt ->
+ DataType dt &@<- ddc, acc
+ | DataValue dv ->
+ DataValue dv &@<- ddc, acc
+ | DynamicLength dl ->
+ DynamicLength dl &@<- ddc, acc
+ | External e ->
+ External e &@<- ddc, acc
+ | Global ->
+ (Global: data_description_clause) &@<- ddc, acc
+ | GroupUsage gu ->
+ GroupUsage gu &@<- ddc, acc
+ | Justified ->
+ (Justified: data_description_clause) &@<- ddc, acc
+ | Picture p ->
+ let picture_clause, acc = fm_picture_clause funs acc (p &@<- ddc) in
+ (Picture ~&picture_clause: data_description_clause) &@<- picture_clause, acc
+ | Property p ->
+ Property p &@<- ddc, acc
+ | Redefines r ->
+ let redefines_clause, acc = fm_redefines_clause funs acc (r &@<- ddc) in
+ Redefines ~&redefines_clause &@<- ddc, acc
+ | SameAs sa ->
+ SameAs sa &@<- ddc, acc
+ | SelectWhen sw ->
+ SelectWhen sw &@<- ddc, acc
+ | Sign s ->
+ (Sign s: data_description_clause) &@<- ddc, acc
+ | Synchronized s ->
+ Synchronized s &@<- ddc, acc
+ | Typedef t ->
+ Typedef t &@<- ddc, acc
+ | Usage u ->
+ Usage u &@<- ddc, acc
+ | Validation v ->
+ Validation v &@<- ddc, acc
+
+ let report_group_description_clause funs acc rgde =
+ match ~&rgde with
+ | Data_sec_in.ReportType rt ->
+ ReportType rt &@<- rgde, acc
+ | NextGroup ng ->
+ NextGroup ng &@<- rgde, acc
+ | ReportLine rl ->
+ ReportLine rl &@<- rgde, acc
+ | Picture p ->
+ let picture_clause, acc = fm_picture_clause funs acc (p &@<- rgde) in
+ (Picture ~&picture_clause: report_group_description_clause) &@<- rgde, acc
+ | ReportScreenUsage rsu ->
+ (ReportScreenUsage rsu: report_group_description_clause) &@<- rgde, acc
+ | Sign s ->
+ (Sign s: report_group_description_clause) &@<- rgde, acc
+ | Justified ->
+ (Justified: report_group_description_clause) &@<- rgde, acc
+ | ReportColumn rc ->
+ ReportColumn rc &@<- rgde, acc
+ | BlankWhenZero ->
+ (BlankWhenZero: report_group_description_clause) &@<- rgde, acc
+ | Source s ->
+ Source s &@<- rgde, acc
+ | Sum s ->
+ Sum s &@<- rgde, acc
+ | ReportValue rv ->
+ ReportValue rv &@<- rgde, acc
+ | PresentWhen pw ->
+ PresentWhen pw &@<- rgde, acc
+ | GroupIndicate ->
+ GroupIndicate &@<- rgde, acc
+ | ReportOccurs ro ->
+ ReportOccurs ro &@<- rgde, acc
+ | Varying v ->
+ Varying v &@<- rgde, acc
+
+ let screen_description_clause funs acc sdc =
+ match ~&sdc with
+ | Data_sec_in.Auto ->
+ Auto &@<- sdc, acc
+ | Blank b ->
+ Blank b &@<- sdc, acc
+ | BlankWhenZero ->
+ BlankWhenZero &@<- sdc, acc
+ | Erase e ->
+ Erase e &@<- sdc, acc
+ | Full ->
+ (Full: screen_description_clause) &@<- sdc, acc
+ | Global ->
+ Global &@<- sdc, acc
+ | Justified ->
+ Justified &@<- sdc, acc
+ | Picture p ->
+ let picture_clause, acc = fm_picture_clause funs acc (p &@<- sdc) in
+ Picture ~&picture_clause &@<- sdc, acc
+ | ReportScreenUsage rsu ->
+ ReportScreenUsage rsu &@<- sdc, acc
+ | Required ->
+ Required &@<- sdc, acc
+ | ScreenAttribute ra ->
+ ScreenAttribute ra &@<- sdc, acc
+ | ScreenColumn rc ->
+ ScreenColumn rc &@<- sdc, acc
+ | ScreenLine sl ->
+ ScreenLine sl &@<- sdc, acc
+ | ScreenOccurs so ->
+ ScreenOccurs so &@<- sdc, acc
+ | Secure ->
+ Secure &@<- sdc, acc
+ | Sign s ->
+ Sign s &@<- sdc, acc
+ | SourceDestination sd ->
+ SourceDestination sd &@<- sdc, acc
+
+ let data_description_entry funs acc (dde: Data_sec_in.data_description_entry with_loc) =
+ let level, acc = fm_level funs acc ~&dde.level in
+ let data_name, acc = fm_data_name funs acc ~&dde.data_name in
+ let data_description_clauses, acc =
+ LIST.foldmap (~&dde.data_description_clauses, acc) ~f:(fm_data_description_clause funs)
+ in
+ {
+ level;
+ data_name;
+ data_description_clauses;
+ } &@<- dde, acc
+
+ let report_group_description_entry funs acc (rgde: Data_sec_in.report_group_description_entry) =
+ let report_group_description_clauses, acc =
+ LIST.foldmap (rgde.report_group_description_clauses, acc)
+ ~f:(fm_report_group_description_clause funs)
+ in
+ {
+ level = rgde.level;
+ data_name = rgde.data_name;
+ report_group_description_clauses
+ }, acc
+
+ let screen_description_entry funs acc (sde: Data_sec_in.screen_description_entry) =
+ let screen_description_clauses, acc =
+ LIST.foldmap (sde.screen_description_clauses, acc)
+ ~f:(fm_screen_description_clause funs)
+ in
+ {
+ level = sde.level;
+ data_name = sde.data_name;
+ screen_description_clauses;
+ }, acc
+
+ let constant_or_data_description_entry funs acc cdde =
+ match ~&cdde with
+ | (Data_sec_in.Constant ce: Data_sec_in.constant_or_data_description_entry) ->
+ (Constant ce: constant_or_data_description_entry) &@<- cdde, acc
+ | Data dde ->
+ let dde, acc = fm_data_description_entry funs acc (dde &@<- cdde) in
+ (Data ~&dde: constant_or_data_description_entry) &@<- cdde, acc
+ | Renames re ->
+ let re, acc = fm_rename_entry funs acc (re &@<- cdde) in
+ (Renames ~&re: constant_or_data_description_entry) &@<- cdde, acc
+ | CondName cde ->
+ let cde, acc = fm_condition_name_entry funs acc (cde &@<- cdde) in
+ (CondName ~&cde: constant_or_data_description_entry) &@<- cdde, acc
+
+ let file_description_entry funs acc (fde: Data_sec_in.file_description_entry) =
+ let constant_or_data_descriptions, acc =
+ LIST.foldmap (fde.constant_or_data_descriptions, acc)
+ ~f:(fm_constant_or_data_description_entry funs)
+ in
+ {
+ file_name = fde.file_name;
+ file_descriptions = fde.file_descriptions;
+ constant_or_data_descriptions;
+ }, acc
+
+ let sort_merge_description_entry funs acc (smde: Data_sec_in.sort_merge_description_entry) =
+ let constant_or_data_descriptions, acc =
+ LIST.foldmap (smde.constant_or_data_descriptions, acc)
+ ~f:(fm_constant_or_data_description_entry funs)
+ in
+ {
+ file_name = smde.file_name;
+ sort_merge_file_descriptions = smde.sort_merge_file_descriptions;
+ constant_or_data_descriptions;
+ }, acc
+
+ let input_communication_entry funs acc (ice: Data_sec_in.input_communication_entry) =
+ let constant_or_data_descriptions, acc =
+ LIST.foldmap (ice.constant_or_data_descriptions, acc)
+ ~f:(fm_constant_or_data_description_entry funs)
+ in
+ ({
+ cd_name = ice.cd_name;
+ initial = ice.initial;
+ communication_descriptions = ice.communication_descriptions;
+ data_items = ice.data_items;
+ constant_or_data_descriptions;
+ }: input_communication_entry), acc
+
+ let io_communication_entry funs acc (ice: Data_sec_in.io_communication_entry) =
+ let constant_or_data_descriptions, acc =
+ LIST.foldmap (ice.constant_or_data_descriptions, acc)
+ ~f:(fm_constant_or_data_description_entry funs)
+ in
+ {
+ cd_name = ice.cd_name;
+ initial = ice.initial;
+ communication_descriptions = ice.communication_descriptions;
+ data_items = ice.data_items;
+ constant_or_data_descriptions;
+ }, acc
+
+ let output_communication_entry funs acc (oce: Data_sec_in.output_communication_entry) =
+ let constant_or_data_descriptions, acc =
+ LIST.foldmap (oce.constant_or_data_descriptions, acc)
+ ~f:(fm_constant_or_data_description_entry funs)
+ in
+ {
+ cd_name = oce.cd_name;
+ communication_descriptions = oce.communication_descriptions;
+ constant_or_data_descriptions;
+ }, acc
+
+ let communication_description_entry funs acc cde =
+ match ~&cde with
+ | Data_sec_in.(Input i) ->
+ let i, acc = fm_input_communication_entry funs acc i in
+ Input i &@<- cde, acc
+ | Output o ->
+ let o, acc = fm_output_communication_entry funs acc o in
+ Output o &@<- cde, acc
+ | IO io ->
+ let io, acc = fm_io_communication_entry funs acc io in
+ IO io &@<- cde, acc
+
+ let constant_or_report_group_description_entry funs acc crgde =
+ match ~&crgde with
+ | (Data_sec_in.Constant ce: Data_sec_in.constant_or_report_group_description_entry) ->
+ (Constant ce: constant_or_report_group_description_entry) &@<- crgde, acc
+ | ReportGroup rg ->
+ let rg, acc = fm_report_group_description_entry funs acc rg in
+ ReportGroup rg &@<- crgde, acc
+
+ let report_description_entry funs acc (rde: Data_sec_in.report_description_entry with_loc) =
+ let constant_or_report_group_descriptions, acc =
+ LIST.foldmap (~&rde.constant_or_report_group_descriptions, acc)
+ ~f:(fm_constant_or_report_group_description_entry funs)
+ in
+ {
+ report_name = ~&rde.report_name;
+ report_descriptions = ~&rde.report_descriptions;
+ constant_or_report_group_descriptions;
+ } &@<- rde, acc
+
+ let constant_or_screen_description_entry funs acc csde =
+ match ~&csde with
+ | Data_sec_in.(Constant ce) ->
+ Constant ce &@<- csde, acc
+ | Screen sde ->
+ let sde, acc = fm_screen_description_entry funs acc sde in
+ Screen sde &@<- csde, acc
+
+ let file_or_sort_merge_description_entry funs acc fsmde =
+ match ~&fsmde with
+ | Data_sec_in.(File fde) ->
+ let fde, acc = fm_file_description_entry funs acc fde in
+ File fde &@<- fsmde, acc
+ | SortMergeFile smf ->
+ let smf, acc = fm_sort_merge_description_entry funs acc smf in
+ SortMergeFile smf &@<- fsmde, acc
+ (** This record contains the functions with the default behaviour of the mapfolder (do nothing) except
+ for the picture where it applies the transformation provided by {!Annot_map.picture_repr}. *)
+ let fm_default: 'a fm_funs = {
+ environment_division;
+ configuration_section;
+ input_output_section;
+ special_names_paragraph;
+ currency_sign;
+ decimal_point;
+ condition_name_entry;
+ rename_entry;
+ qualname;
+ data_name;
+ level;
+ redefines_clause;
+ picture_clause;
+ data_description_clause;
+ screen_description_clause;
+ report_group_description_clause;
+ data_description_entry;
+ report_group_description_entry;
+ screen_description_entry;
+ constant_or_data_description_entry;
+ file_description_entry;
+ sort_merge_description_entry;
+ input_communication_entry;
+ io_communication_entry;
+ output_communication_entry;
+ communication_description_entry;
+ constant_or_report_group_description_entry;
+ report_description_entry;
+ constant_or_screen_description_entry;
+ file_or_sort_merge_description_entry;
+ }
+
+end
+
+module Make_data_div_traversal
+ (Data_div_in: DATA_DIVISION_AST)
+ (Data_div_out: DATA_DIVISION_AST)
+ (Default_map: sig
+ val file_section: Data_div_in.file_section -> Data_div_out.file_section
+ val working_storage_section: Data_div_in.working_storage_section -> Data_div_out.working_storage_section
+ val linkage_section: Data_div_in.linkage_section -> Data_div_out.linkage_section
+ val communication_section: Data_div_in.communication_section -> Data_div_out.communication_section
+ val local_storage_section: Data_div_in.local_storage_section -> Data_div_out.local_storage_section
+ val report_section: Data_div_in.report_section -> Data_div_out.report_section
+ val screen_section: Data_div_in.screen_section -> Data_div_out.screen_section
+ end)
+ =
+struct
+ (** This functor makes a mapfolder from {!In} to {!Out}, using {!Annot_map} to map the different
+ representations from {!In} to {!Out}. *)
+ module Data_div_in = Data_div_in
+ module Data_div_out = Data_div_out
+
+ open Data_div_in
+ open Data_div_out
+
+
+ (** This type is used to specify the types of the mapfold functions, ['a] is the type of
+ the accumulator, ['b] is the type of the AST node that is given as input and
+ ['c] is the type of the AST node that is given as output. *)
+ type ('a, 'b, 'c) fm_fun = 'a fm_funs -> 'a -> 'b -> 'c * 'a
+
+ (** This type is used to specify functions where the returns ast type does not change from the
+ one that was given as input *)
+ and ('a, 'b) fm_id_fun = ('a, 'b, 'b) fm_fun
+
+ (** This record type is used to implement the mapfolder functions. *)
+ and 'a fm_funs = {
+ data_division: ('a,Data_div_in.data_division with_loc, Data_div_out.data_division with_loc) fm_fun;
+ file_section: ('a, Data_div_in.file_section, Data_div_out.file_section) fm_fun;
+ working_storage_section: ('a, Data_div_in.working_storage_section, Data_div_out.working_storage_section) fm_fun;
+ linkage_section: ('a, Data_div_in.linkage_section, Data_div_out.linkage_section) fm_fun;
+ communication_section: ('a, Data_div_in.communication_section, Data_div_out.communication_section) fm_fun;
+ local_storage_section: ('a, Data_div_in.local_storage_section, Data_div_out.local_storage_section) fm_fun;
+ report_section: ('a, Data_div_in.report_section, Data_div_out.report_section) fm_fun;
+ screen_section: ('a, Data_div_in.screen_section, Data_div_out.screen_section) fm_fun;
+ }
+
+ let fm_data_division funs acc v =
+ funs.data_division funs acc v
+
+ let fm_file_section funs acc v =
+ funs.file_section funs acc v
+
+ let fm_working_storage_section funs acc v =
+ funs.working_storage_section funs acc v
+
+ let fm_linkage_section funs acc v =
+ funs.linkage_section funs acc v
+
+ let fm_communication_section funs acc v =
+ funs.communication_section funs acc v
+
+ let fm_local_storage_section funs acc v =
+ funs.local_storage_section funs acc v
+
+ let fm_report_section funs acc v =
+ funs.report_section funs acc v
+
+ let fm_screen_section funs acc v =
+ funs.screen_section funs acc v
+
+ let nop _ x y =
+ y, x
+
+ let qualname = nop
+
+ let data_name = nop
+
+ let level = nop
+
+ let file_section _funs acc fs =
+ Default_map.file_section fs, acc
+
+ let working_storage_section _funs acc wss =
+ Default_map.working_storage_section wss, acc
+
+ let linkage_section _funs acc ls =
+ Default_map.linkage_section ls, acc
+
+ let communication_section _funs acc cs =
+ Default_map.communication_section cs, acc
+
+ let local_storage_section _funs acc lss =
+ Default_map.local_storage_section lss, acc
+
+ let report_section _funs acc rs =
+ Default_map.report_section rs, acc
+
+ let screen_section _funs acc ss =
+ Default_map.screen_section ss, acc
+
+ let data_division funs acc (dd:Data_div_in.data_division with_loc) =
+ let file_section, acc =
+ (~&dd.file_section, acc) >>= fm_file_section funs
+ in
+ let working_storage_section, acc =
+ (~&dd.working_storage_section, acc) >>= fm_working_storage_section funs
+ in
+ let linkage_section, acc =
+ (~&dd.linkage_section, acc) >>= fm_linkage_section funs
+ in
+ let communication_section, acc =
+ (~&dd.communication_section, acc) >>= fm_communication_section funs
+ in
+ let local_storage_section, acc =
+ (~&dd.local_storage_section, acc) >>= fm_local_storage_section funs
+ in
+ let report_section, acc =
+ (~&dd.report_section, acc) >>= fm_report_section funs
+ in
+ let screen_section, acc =
+ (~&dd.screen_section, acc) >>= fm_screen_section funs
+ in
+ {
+ file_section;
+ working_storage_section;
+ linkage_section;
+ communication_section;
+ local_storage_section;
+ report_section;
+ screen_section;
+ } &@<- dd, acc
+
+ (** This record contains the functions with the default behaviour of the mapfolder (do nothing) except
+ for the picture where it applies the transformation provided by {!Annot_map.picture_repr}. *)
+ let fm_default: 'a fm_funs = {
+ data_division;
+ file_section;
+ working_storage_section;
+ linkage_section;
+ communication_section;
+ local_storage_section;
+ report_section;
+ screen_section;
+ }
+
+end
+
+module Make
+ (AstIn: Ast.S)
+ (AstOut: Ast.S)
+ (Default_map: sig
+ val picture: AstIn.Data_section.Pic_repr.picture -> AstOut.Data_section.Pic_repr.picture
+ val file_section: AstIn.Data_div.file_section -> AstOut.Data_div.file_section
+ val working_storage_section: AstIn.Data_div.working_storage_section -> AstOut.Data_div.working_storage_section
+ val linkage_section: AstIn.Data_div.linkage_section -> AstOut.Data_div.linkage_section
+ val communication_section: AstIn.Data_div.communication_section -> AstOut.Data_div.communication_section
+ val local_storage_section: AstIn.Data_div.local_storage_section -> AstOut.Data_div.local_storage_section
+ val report_section: AstIn.Data_div.report_section -> AstOut.Data_div.report_section
+ val screen_section: AstIn.Data_div.screen_section -> AstOut.Data_div.screen_section
+ end)
+ =
+struct
+ (** This functor makes a mapfolder from {!In} to {!Out}, using {!Annot_map} to map the different
+ representations from {!In} to {!Out}. *)
+ module Data_sec_traversal = Make_data_sections_traversal (AstIn.Data_section) (AstOut.Data_section) (struct
+ let picture = Default_map.picture end)
+ module Data_div_traversal = Make_data_div_traversal (AstIn.Data_div) (AstOut.Data_div) (struct
+ let file_section = Default_map.file_section
+ let working_storage_section = Default_map.working_storage_section
+ let linkage_section = Default_map.linkage_section
+ let communication_section = Default_map.communication_section
+ let local_storage_section = Default_map.local_storage_section
+ let report_section = Default_map.report_section
+ let screen_section = Default_map.screen_section
+ end)
+
+ open AstOut
+ (** This type is used to specify the types of the mapfold functions, ['a] is the type of
+ the accumulator, ['b] is the type of the AST node that is given as input and
+ ['c] is the type of the AST node that is given as output. *)
+ type ('a, 'b, 'c) fm_fun = 'a fm_funs -> 'a -> 'b -> 'c * 'a
+
+ (** This type is used to specify functions where the returns ast type does not change from the
+ one that was given as input *)
+ and ('a, 'b) fm_id_fun = ('a, 'b, 'b) fm_fun
+
+ (** This record type is used to implement the mapfolder functions. *)
+ and 'a fm_funs = {
+ compilation_group: ('a, AstIn.compilation_group, AstOut.compilation_group) fm_fun;
+ compilation_unit: ('a, AstIn.compilation_unit with_loc, AstOut.compilation_unit with_loc) fm_fun;
+ program_definition: ('a, AstIn.program_definition, AstOut.program_definition) fm_fun;
+ program_prototype: ('a, AstIn.program_prototype, AstOut.program_prototype) fm_fun;
+ function_definition: ('a, AstIn.function_definition, AstOut.function_definition) fm_fun;
+ function_prototype: ('a, AstIn.function_prototype, AstOut.function_prototype) fm_fun;
+ data_sec_traversal_funs: 'a Data_sec_traversal.fm_funs;
+ data_div_traversal_funs: 'a Data_div_traversal.fm_funs;
+ }
+
+ let fm_compilation_group funs acc cg =
+ funs.compilation_group funs acc cg
+
+ let fm_compilation_unit funs acc cu =
+ funs.compilation_unit funs acc cu
+
+ let fm_program_definition funs acc pd =
+ funs.program_definition funs acc pd
+
+ let fm_program_prototype funs acc pp =
+ funs.program_prototype funs acc pp
+
+ let fm_function_definition funs acc fd =
+ funs.function_definition funs acc fd
+
+ let fm_function_prototype funs acc fp =
+ funs.function_prototype funs acc fp
+
+ let nop _ x y =
+ y, x
+
+ let function_prototype funs acc (fp: AstIn.function_prototype) =
+ let environment_division, acc =
+ (fp.environment_division, acc)
+ >>= (Data_sec_traversal.fm_environment_division funs.data_sec_traversal_funs)
+ in
+ let data_division, acc =
+ (fp.data_division, acc)
+ >>= Data_div_traversal.fm_data_division funs.data_div_traversal_funs
+ in
+ {
+ function_prototype_id_paragraph = fp.function_prototype_id_paragraph;
+ options_paragraph = fp.options_paragraph;
+ environment_division;
+ data_division;
+ procedure_division = fp.procedure_division;
+ end_function = fp.end_function;
+ }, acc
+
+ let function_definition funs acc (fd: AstIn.function_definition) =
+ let environment_division, acc =
+ (fd.environment_division, acc)
+ >>= (Data_sec_traversal.fm_environment_division funs.data_sec_traversal_funs)
+ in
+ let data_division, acc =
+ (fd.data_division, acc)
+ >>= Data_div_traversal.fm_data_division funs.data_div_traversal_funs
+ in
+ {
+ function_id_paragraph = fd.function_id_paragraph;
+ options_paragraph = fd.options_paragraph;
+ environment_division;
+ data_division;
+ procedure_division = fd.procedure_division;
+ end_function = fd.end_function;
+ }, acc
+
+ let program_prototype funs acc (pp: AstIn.program_prototype) =
+ let environment_division, acc =
+ (pp.environment_division, acc)
+ >>= (Data_sec_traversal.fm_environment_division funs.data_sec_traversal_funs)
+ in
+ let data_division, acc =
+ (pp.data_division, acc)
+ >>= Data_div_traversal.fm_data_division funs.data_div_traversal_funs
+ in
+ {
+ program_prototype_id_paragraph = pp.program_prototype_id_paragraph;
+ options_paragraph = pp.options_paragraph;
+ environment_division;
+ data_division;
+ procedure_division = pp.procedure_division;
+ end_program = pp.end_program;
+ }, acc
+
+ let program_definition funs acc (pd: AstIn.program_definition) =
+ let environment_division, acc =
+ (pd.environment_division, acc)
+ >>= (Data_sec_traversal.fm_environment_division funs.data_sec_traversal_funs)
+ in
+ let data_division, acc =
+ (pd.data_division, acc)
+ >>= Data_div_traversal.fm_data_division funs.data_div_traversal_funs
+ in
+ let nested_programs, acc =
+ LIST.foldmap (pd.nested_programs, acc) ~f:(fun acc np_loc ->
+ let np, acc = fm_program_definition funs acc ~&np_loc in
+ np &@<- np_loc, acc)
+ in
+ {
+ has_identification_division = pd.has_identification_division;
+ program_id_paragraph = pd.program_id_paragraph;
+ informational_paragraphs = pd.informational_paragraphs;
+ options_paragraph = pd.options_paragraph;
+ environment_division;
+ data_division;
+ procedure_division = pd.procedure_division;
+ nested_programs;
+ end_program = pd.end_program;
+ }, acc
+
+ let compilation_unit funs acc cu =
+ match ~&cu with
+ | AstIn.ProgramDefinition (pd) ->
+ let pd, acc = fm_program_definition funs acc pd in
+ (ProgramDefinition pd) &@<- cu, acc
+ | ProgramPrototype (pp) ->
+ let pp, acc = fm_program_prototype funs acc pp in
+ (ProgramPrototype pp) &@<- cu, acc
+ | FunctionDefinition (fd) ->
+ let fd, acc = fm_function_definition funs acc fd in
+ (FunctionDefinition fd) &@<- cu, acc
+ | FunctionPrototype (fp) ->
+ let fp, acc = fm_function_prototype funs acc fp in
+ (FunctionPrototype fp) &@<- cu, acc
+ | _ -> failwith "Not implemented yet"
+
+ let compilation_group funs acc (cg: AstIn.compilation_group) =
+ LIST.foldmap (cg, acc) ~f:(fm_compilation_unit funs)
+
+ (** This record contains the functions with the default behaviour of the mapfolder (do nothing) except
+ for the picture where it applies the transformation provided by {!Annot_map.picture_repr}. *)
+ let fm_default: 'a fm_funs = {
+ compilation_group;
+ compilation_unit;
+ program_definition;
+ program_prototype;
+ function_definition;
+ function_prototype;
+ data_sec_traversal_funs = Data_sec_traversal.fm_default;
+ data_div_traversal_funs = Data_div_traversal.fm_default;
+ }
+
+
+end
+
+module Id_default_mapper = struct
+ let picture = Fun.id
+ let file_section = Fun.id
+ let working_storage_section = Fun.id
+ let linkage_section = Fun.id
+ let communication_section = Fun.id
+ let local_storage_section = Fun.id
+ let report_section = Fun.id
+ let screen_section = Fun.id
+end
+
+module MakeId (Ast: Ast.S) = Make (Ast) (Ast) (Id_default_mapper)
+*)
diff --git a/src/interop-js-stubs/version.mlt b/src/lsp/cobol_ast/version.mlt
similarity index 100%
rename from src/interop-js-stubs/version.mlt
rename to src/lsp/cobol_ast/version.mlt
diff --git a/src/lsp/cobol_common/README.md b/src/lsp/cobol_common/README.md
new file mode 100644
index 000000000..7d525e3f6
--- /dev/null
+++ b/src/lsp/cobol_common/README.md
@@ -0,0 +1,10 @@
+# Cobol_common package
+
+This package contains utility modules that are used in all other `superbol` libraries.
+The main modules found here are:
+* `Basics` which contains basic helper modules such as `StringMap`, `StringSet` and functions for pairs and lists
+* `Srcloc` which contains all functions to handle source locations
+* `Diagnostics` to handle the creation and printing of diagnostics
+* `Visitors` which contains all the basic defitions for our visitors
+
+For API documentation, please see [index.mld].
diff --git a/src/lsp/cobol_common/basics.ml b/src/lsp/cobol_common/basics.ml
new file mode 100644
index 000000000..2956fa5ce
--- /dev/null
+++ b/src/lsp/cobol_common/basics.ml
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open EzCompat (* for StringMap and Stringset *)
+
+(* CHECKE: Is it worth having this long name in addition to StrMap *)
+module StringMap = StringMap
+module StringSet = StringSet
+module Strings = StringSet (** alias of {!StringSet} *)
+module StrMap = StringMap (** alias of {!StringMap} *)
+module IntMap = Map.Make (Int)
+module CharSet = Set.Make (Char)
+
+module Pair = struct
+
+ let with_fst l r = (l, r)
+ let with_snd r l = (l, r)
+
+ let map_fst ~f (l, r) = (f l, r)
+ let map_snd ~f (l, r) = (l, f r)
+
+ (** [filter_fst (Some l, r) = Some (l, r) ] and [filter_fst (None, _) = None] *)
+ let if_fst (l, r) = Option.map (fun l -> l, r) l
+
+ (** [filter_snd (l, Some r) = Some (l, r)] and [filter_snd (_, None) = None] *)
+ let if_snd (l, r) = Option.map (fun r -> l, r) r
+
+ let filter = function
+ | Some l, Some r -> Some (l, r)
+ | _ -> None
+
+ let filter_map_fst ~f (l, r) = Option.map (fun l -> f l, r) l
+
+ let filter_snd_map_pair ~f (l, r) = Option.map (fun r -> f (l, r) ) r
+
+ let filter_map_snd ~f (l, r) = Option.map (fun r -> l, f r) r
+
+ let filter_map ~fl ~fr = function
+ | Some l, Some r -> Some (fl l, fr r)
+ | _ -> None
+
+ let swap (f, s) = (s, f)
+end
+
+(* Fabrice: we should upstream such functions in ocplib-stuff, within
+ the EzList module *)
+module LIST = struct
+ (** [split_at_first ~prefix ~where p list] splits [list] right after, right
+ before, or around the first element [e] that satisfies [p e].
+
+ [prefix] indicates whether or not to keep the prefix in revered order, and
+ [where] instructs where to split ([`Around] discards the element). *)
+ let split_at_first
+ ~(prefix: [`Same | `Rev])
+ ~(where: [`After | `Before | `Around])
+ p
+ =
+ let prefix = match prefix with
+ | `Same -> List.rev
+ | `Rev -> fun l -> l
+ in
+ let rec aux acc l = match l, where with
+ | [], _ -> Error ()
+ | x :: tl, _ when not (p x) -> aux (x :: acc) tl
+ | x :: tl, `After -> Ok (prefix (x :: acc), tl)
+ | x :: tl, `Before -> Ok (prefix acc, x :: tl)
+ | _ :: tl, `Around -> Ok (prefix acc, tl)
+ in
+ aux []
+
+ (** [take_while pred l] returns all the successive elements of [l] while [pred elt] is
+ is satisfied, [elt] being the first element of the remaining of the list. *)
+ let take_while pred list =
+ let rec aux acc l =
+ match l with
+ | hd::tl when pred hd ->
+ aux (hd::acc) tl
+ | _ ->
+ List.rev acc
+ in
+ aux [] list
+
+ (*TODO: Remove this and edit its occurences with List.fold_left_map *)
+ let foldmap ~f (l, acc) =
+ let l, acc = List.fold_left
+ (fun (l, acc) x -> let x, acc = f acc x in x::l, acc) ([], acc) l
+ in
+ List.rev l, acc
+
+
+ (** [fold_left_while pred f acc l] is (f (... (f acc l1) ...) ln) with [l1] [ln] the elements of
+ [l] for which [pred acc] is satisfied. *)
+ let rec fold_left_while pred f acc l =
+ match l with
+ | [] -> acc
+ | hd::tl when pred acc -> fold_left_while pred f (f acc hd) tl
+ | _ -> acc
+
+ (** [fold_left_whilei pred f acc l] is (f n (... (f 0 acc l0) ...) ln) with [l0] [ln] the elements of
+ [l] for which [pred acc] is satisfied. *)
+ let fold_left_whilei pred f acc l =
+ let rec aux idx pred f acc l =
+ match l with
+ | [] -> acc
+ | hd::tl when pred acc -> aux (idx + 1) pred f (f idx acc hd) tl
+ | _ -> acc
+ in
+ aux 0 pred f acc l
+end
+
+(** This operator maps a ['a option * 'b] to the function [f]. The function [f] must be of type
+ ['b -> 'a -> 'c * 'b]. [(x, acc) >>= f] returns [None, acc] if [x = None] or [(Some x', acc')]
+ if [x = Some y] with [x', acc' = f acc y]. *)
+let (>>=) (x, acc) f =
+ Option.fold ~none:(None, acc) ~some:(fun x -> let x, acc = f acc x in Some x, acc) x
+
+
+(*CHECKME: Is there an already defined operator for this? If not maybe we can keep these
+ * somewhere else, it might be useful in more than one places, or maybe it's too confusing. *)
+let (>>) f g = (fun x -> f x |> g)
diff --git a/src/lsp/cobol_common/behaviors.ml b/src/lsp/cobol_common/behaviors.ml
new file mode 100644
index 000000000..3a0329b97
--- /dev/null
+++ b/src/lsp/cobol_common/behaviors.ml
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Type tags, useful to name and determine component behaviors *)
+(* This may not really belong to `Cobol_common` as it's not specific to COBOL.
+ Still, only `Srcloc` really satisfies that property; we should probably end
+ up with an `Cobol_srcloc` library, and rename `Cobol_common` into something
+ like `Superbol_utils`. *)
+
+type amnesic = ForgetAll
+type eidetic = RememberAll
diff --git a/src/lsp/cobol_common/cobol_common.ml b/src/lsp/cobol_common/cobol_common.ml
new file mode 100644
index 000000000..b46148254
--- /dev/null
+++ b/src/lsp/cobol_common/cobol_common.ml
@@ -0,0 +1,143 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module Basics = Basics
+module Srcloc = Srcloc
+module Diagnostics = Diagnostics
+module Visitor = Visitor
+module Behaviors = Behaviors
+module Tokenizing = Tokenizing
+
+exception FatalError of string
+let fatal fmt = Pretty.string_to (fun s -> raise @@ FatalError s) fmt
+
+let status_ref = ref 0
+let exit ?(status= 0) () =
+ exit (max status !status_ref)
+
+(* Register a printer for some common exceptions. *)
+let () =
+ Printexc.register_printer begin function
+ | Failure m
+ | Sys_error m
+ | Stdlib.Arg.Bad m -> Some m
+ | _ -> None
+ end
+
+(* --- *)
+
+module Types = struct
+
+ (** Transitional (to be removed) *)
+ type 'a res = ('a * Diagnostics.Set.t, Diagnostics.Set.t) result
+
+ include Diagnostics.TYPES
+ include Srcloc.TYPES
+
+end
+include Types
+
+(* TODO: move the ['a result] type related functions somewhere else *)
+let join_all l =
+ List.fold_left
+ (fun res elt ->
+ match res, elt with
+ | Result.Error e, _ | _, Result.Error e -> Error e
+ | Ok res, Ok e -> Ok (e::res))
+ (Ok [])
+ l
+ |> Result.map List.rev
+
+let join_any l =
+ List.filter_map
+ (fun elt ->
+ match elt with
+ | Ok elt ->
+ Some elt
+ | Error _ ->
+ None)
+ l
+ |> List.rev
+
+let catch_diagnostics ?(ppf = Fmt.stderr) f x =
+ let module D = Diagnostics.InitStateful () in
+ match f (module D: Diagnostics.STATEFUL) x with
+ | Ok (v, diags) ->
+ Ok (v, Diagnostics.Set.union diags @@ D.inspect ~reset:true)
+ | Error diags ->
+ Error (Diagnostics.Set.union diags @@ D.inspect ~reset:true)
+ | exception Msgs.LocalizedError (s, loc, _) -> (* TODO: addenda *)
+ D.error ~loc "%t" s;
+ Error (D.inspect ~reset:true)
+ | exception Msgs.Error msg ->
+ D.error "%t" msg;
+ Error (D.inspect ~reset:true)
+ (* | exception (Failure msg | Sys_error msg) -> *)
+ (* D.error "%s" msg; *)
+ (* Error (D.inspect ~reset:true) *)
+ (* | exception Diagnostics.Fatal.Sink diags -> *)
+ (* Error (Diagnostics.Set.union diags @@ D.inspect ~reset:true) *)
+ | exception (FatalError _ as e) ->
+ Pretty.print ppf "%a%!" Diagnostics.Set.pp (D.inspect ~reset:false);
+ raise e
+
+let with_stateful_diagnostics ~f x =
+ let module D = Diagnostics.InitStateful () in
+ let result = f (module D: Diagnostics.STATEFUL) x in
+ { result; diags = D.inspect ~reset:true }
+
+(** [show_diagnostics ~ppf diagnostics] prints the given set of diagnostics
+ using the formatter [ppf] (that defaults to [stderr]), and sets an internal
+ status flags to register whether [diagnostics] includes an error. This flag
+ is used to determine the status code upon program termination. *)
+let show_diagnostics ?(ppf = Fmt.stderr) diags =
+ Pretty.print ppf "%a%!" Diagnostics.Set.pp diags;
+ if Diagnostics.Set.has_errors diags then status_ref := !status_ref lor 1
+
+let catch_n_show_diagnostics ~cont ?(ppf = Fmt.stderr) f x =
+ match catch_diagnostics ~ppf f x with
+ | Ok (_, diags) | Error diags as res ->
+ show_diagnostics ~ppf diags;
+ if Result.is_error res then status_ref := !status_ref lor 1;
+ cont res
+
+(* --- *)
+
+let do_one ~cont f ?epf a =
+ catch_n_show_diagnostics ?ppf:epf ~cont f a
+
+let do_unit f =
+ do_one begin fun diags a ->
+ f diags a;
+ Ok ((), Diagnostics.Set.none)
+ end ~cont:(fun _ -> ())
+
+let do_any f =
+ do_one begin fun diags a ->
+ Ok (f diags a, Diagnostics.Set.none)
+ end ~cont:(Result.fold ~ok:fst ~error:(fun _ -> Stdlib.exit 1))
+
+(* --- *)
+
+(* let tmp_files = ref [] *)
+(* let remove_temporary_files = ref true *)
+
+(* let add_temporary_file file = tmp_files := file :: !tmp_files *)
+(* let keep_temporary_files () = remove_temporary_files := false *)
+
+(* ;; *)
+
+(* at_exit begin fun () -> *)
+(* if !remove_temporary_files then *)
+(* List.iter (fun file -> Sys.remove file) !tmp_files *)
+(* end *)
diff --git a/src/lsp/cobol_common/cobol_common.mli b/src/lsp/cobol_common/cobol_common.mli
new file mode 100644
index 000000000..a3a84d3b7
--- /dev/null
+++ b/src/lsp/cobol_common/cobol_common.mli
@@ -0,0 +1,95 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module Basics = Basics
+module Srcloc = Srcloc
+module Diagnostics = Diagnostics
+module Visitor = Visitor
+module Behaviors = Behaviors
+module Tokenizing = Tokenizing
+
+exception FatalError of string
+val fatal: ('a, Format.formatter, unit, _) format4 -> 'a
+
+module Types: sig
+
+ (** Transitional (to be removed) *)
+ type 'a res = ('a * Diagnostics.Set.t, Diagnostics.Set.t) result
+
+ include module type of Diagnostics.TYPES
+ include module type of Srcloc.TYPES
+
+end
+include module type of Types
+ with type 'a res = 'a Types.res
+ and type 'a with_diags = 'a Types.with_diags
+ and type 'a with_loc = 'a Types.with_loc
+ and type lexloc = Types.lexloc
+ and type srcloc = Types.srcloc
+
+(** [join_all diags res_l] takes every value of a list of {!type:('a, 'e) result}
+ and return a {!type:('a, 'e) list result}. If all the elements in the parameter list
+ are [Ok _] then the result is [Ok _] otherwise [Error _] *)
+val join_all: ('a, 'e) result list -> ('a list, 'e) result
+
+(** [join_any diags res_l] takes a list of result and makes it a list, the elements of the given
+ list are added to the resulting list only if they are [Ok _]. *)
+val join_any: ('a, 'e) result list -> 'a list
+
+(** [catch_diagnostics ?ppf f x] enables [f] to fail abruptly with an exception
+ while operating on an imperative (state-full) diagnostics module.
+
+ It first creates a stateful diagnostics module [D] and calls [f D x] while
+ intercepting common system exceptions (only {!Sys_error} for now) and fatal
+ diagnostics. An {!Error} is returned in the latter case, or whenever [f]
+ terminates with an {!Error}.
+
+ At last, the diagnostics accumulated in [D] are printed using [ppf]
+ ([Format.err_formatter] by default) in case of a fatal error ({!fatal} is
+ called and {!FatalError} is not caught --- which it shouldn't); in this case
+ {!FatalError} is re-thrown afterwards. *)
+val catch_diagnostics
+ : ?ppf:Format.formatter
+ -> ((module Diagnostics.STATEFUL) -> 'c -> 'a res) -> 'c -> 'a res
+
+(** [with_stateful_diagnostics ~f x] applies [f] on a fresh stateful diagnostics
+ module [D] and [x], and returns the result combined with all diagnostics
+ accumulated using [D].
+
+ Any exception that may be raised and escape [f] is not caught, so it is the
+ responsibility of [f] to catch it. *)
+val with_stateful_diagnostics
+ : f:((module Diagnostics.STATEFUL) -> 'b -> 'a) -> 'b -> 'a with_diags
+
+val show_diagnostics
+ : ?ppf:Format.formatter
+ -> Diagnostics.Set.t -> unit
+
+
+(** Exit the program with a status that depends on diagnostics reported in
+ {!catch_n_show_diagnostics}. *)
+val exit: ?status:int -> unit -> _
+
+
+
+val do_unit
+ : ((module Diagnostics.STATEFUL) -> 'a -> unit)
+ -> ?epf:Format.formatter
+ -> 'a
+ -> unit
+
+val do_any
+ : ((module Diagnostics.STATEFUL) -> 'a -> 'b)
+ -> ?epf:Format.formatter
+ -> 'a
+ -> 'b
diff --git a/src/lsp/cobol_common/diagnostics.ml b/src/lsp/cobol_common/diagnostics.ml
new file mode 100644
index 000000000..50dc7f212
--- /dev/null
+++ b/src/lsp/cobol_common/diagnostics.ml
@@ -0,0 +1,269 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Srcloc
+
+module TYPES = struct
+ type severity = Diagnostics_sigs.severity =
+ | Hint (** hint *)
+ | Note (** general note *)
+ | Info (** informative message *)
+ | Warn (** warning *)
+ | Error (** unrecoverable error *)
+
+ type diagnostic =
+ {
+ severity: severity;
+ message: Pretty.delayed;
+ location: srcloc option;
+ stamp: int;
+ }
+
+ type diagnostics = diagnostic list (* reversed, abstract *)
+
+ type 'a in_result = ('a * diagnostic option, diagnostic option) result
+
+ type 'a with_diags =
+ {
+ result: 'a;
+ diags: diagnostics;
+ }
+end
+include TYPES
+type t = diagnostic
+
+let mk =
+ let current_stamp = ref 0 in
+ fun severity location message ->
+ let stamp = !current_stamp in
+ incr current_stamp;
+ { severity; message; location; stamp }
+
+let pp ppf { severity; message; location = loc; _ } =
+ let prefix, style = match severity with
+ | Hint -> "Hint", `Fg `Cyan
+ | Note -> "Note", `None
+ | Info -> "Info", `Fg `Green
+ | Warn -> "Warning", `Fg `Yellow
+ | Error -> "Error", `Fg `Red
+ in
+ Msgs.pp_msg ?loc ppf "%a" begin
+ Pretty.styles [`Bold; style] @@ fun ppf ->
+ Pretty.print ppf ">> %s: @[%t@]@\n" prefix
+ end message
+
+let is_error = function
+ | { severity = Error; _ } -> true
+ | _ -> false
+
+let pp_msg ppf diag = diag.message ppf
+let message diag = diag.message
+let severity diag = diag.severity
+let location diag = diag.location
+
+(* --- *)
+
+module One = struct
+ (** Reporting module where each function builds and returns a single
+ diagnostic. *)
+ let diag severity ?loc = Pretty.delayed_to (mk severity loc)
+ let hint ?loc fmt = diag Hint ?loc fmt
+ and note ?loc fmt = diag Note ?loc fmt
+ and info ?loc fmt = diag Info ?loc fmt
+ and warn ?loc fmt = diag Warn ?loc fmt
+ and error ?loc fmt = diag Error ?loc fmt
+ and blind = Fun.id
+end
+
+module Now = struct
+ (** Reporting module where each value is a procedure that prints a single
+ diagnostic on a given formatter. *)
+ let diag severity ppf ?loc fmt =
+ Pretty.delayed_to (fun message -> pp ppf (mk severity loc message)) (fmt^^"@.")
+ let hint ppf = diag Hint ppf
+ and note ppf = diag Note ppf
+ and info ppf = diag Info ppf
+ and warn ppf = diag Warn ppf
+ and error ppf = diag Error ppf
+ and blind = pp
+end
+
+module Cont = struct
+ (** Reporting module where each function gives diagnostics to a continuation
+ function. *)
+ let kdiag severity k ?loc =
+ Pretty.delayed_to (fun message -> k (mk severity loc message))
+ let khint s = kdiag Hint s
+ and knote s = kdiag Note s
+ and kinfo s = kdiag Info s
+ and kwarn s = kdiag Warn s
+ and kerror s = kdiag Error s
+ and kblind = ( @@ )
+end
+
+(* --- *)
+
+module Set = struct
+ (** Persistent sets of diagnostics *)
+
+ type t = diagnostics (* reversed *)
+
+ let sort diags =
+ List.sort (fun { stamp = s1; _ } { stamp = s2; _ } -> Int.compare s1 s2) diags
+
+ (* TODO: order via locs and/or a global timestamp? something more
+ intricate? *)
+ let pp ppf diags =
+ Pretty.list ~fopen:"@[" ~fclose:"@]@\n" ~fsep:"@\n" ~fempty:""
+ pp ppf (sort diags)
+ let none: t = []
+ let one d = [d]
+ let two d d' = [d; d']
+ let maybe = Option.fold ~some:one ~none
+ let cons = List.cons
+ let union = List.rev_append
+ let has_errors = List.exists is_error
+ let map f diags = List.map f (sort diags)
+ let fold f diags acc = List.fold_left (fun a d -> f d a) acc (sort diags)
+
+ let diag s = Cont.kdiag s one
+ let hint ?loc = Cont.khint one ?loc
+ let note ?loc = Cont.knote one ?loc
+ let info ?loc = Cont.kinfo one ?loc
+ let warn ?loc = Cont.kwarn one ?loc
+ let error ?loc = Cont.kerror one ?loc
+ let blind = Cont.kblind one
+
+ (** Sets of diagnostics with values that do not contain any closure or module,
+ and that can thus be marshalled/unmarshalled safely.
+
+ The ability to perform delayed formatting is lost when translating from
+ "regular" diagnostics into serializable ones, as the translation applies
+ the formatting as if into a string without any right-margin. *)
+ type serializable = serializable_diagnostic list
+ and serializable_diagnostic = {
+ sd_severity: severity;
+ sd_msg: string;
+ sd_loc: srcloc option;
+ }
+
+ let apply_delayed_formatting: t -> serializable =
+ map begin fun { severity; message; location; _ } ->
+ { sd_severity = severity;
+ sd_msg = Pretty.(to_string "%t@[%t@]" blast_margin) message;
+ sd_loc = location }
+ end
+ let of_serializable: serializable -> t =
+ List.map begin fun { sd_severity; sd_msg; sd_loc } ->
+ mk sd_severity sd_loc (Pretty.delayed "%s" sd_msg)
+ end
+end
+type diagnostics = Set.t
+
+(* --- *)
+
+module Acc = struct
+ (** Reporting module where each functions adds diagnostics into a given
+ set. *)
+ let diag severity (diags: diagnostics) ?loc =
+ Pretty.delayed_to (fun message -> Set.cons (mk severity loc message) diags)
+ let hint s = diag Hint s
+ and note s = diag Note s
+ and info s = diag Info s
+ and warn s = diag Warn s
+ and error s = diag Error s
+ and blind s d = Set.cons d s
+end
+
+include Acc
+include Cont
+
+(* --- *)
+
+let result ?(diags = Set.none) result = { result; diags }
+let with_diag r d = result ~diags:(Set.one d) r
+let with_diags r diags = result ~diags r
+let with_more_diags ~diags { result; diags = diags' } =
+ { result; diags = Set.union diags' diags }
+let simple_result r = result r
+let some_result ?diags r = result ?diags (Some r)
+let no_result ~diags = { result = None; diags }
+let map_result f { result; diags } = { result = f result; diags }
+
+let hint_result r = Cont.khint (with_diag r)
+let note_result r = Cont.knote (with_diag r)
+let info_result r = Cont.kinfo (with_diag r)
+let warn_result r = Cont.kwarn (with_diag r)
+let error_result r = Cont.kerror (with_diag r)
+
+(* --- *)
+
+(** Type of modules that encapsulate an internal, mutable, set of diagnostics.
+ See {!Cobol_common.catch_diagnostics} and
+ {!Cobol_common.catch_n_show_diagnostics} for typical usage. *)
+module type STATEFUL = Diagnostics_sigs.STATEFUL
+ with type blind := t -> unit
+ and type diagnostics := diagnostics
+ and type 'a with_diags := 'a with_diags
+
+module type STATEFUL0 = Diagnostics_sigs.STATEFUL0
+ with type blind := t -> unit
+ and type diagnostics := diagnostics
+ and type 'a with_diags := 'a with_diags
+
+(** Initializes a stateful diagnostics reporting module based on the given
+ history. *)
+module MakeStateful (H: sig val history: diagnostics end) = struct
+ let diags = ref H.history
+ let blind d = diags := d :: !diags
+ let add_all set = diags := List.rev_append set !diags
+ let inspect ~reset =
+ let res = !diags in
+ if reset then diags := [];
+ res
+ let diag severity ?loc =
+ Pretty.delayed_to (fun message -> blind (mk severity loc message))
+ let hint ?loc = diag Hint ?loc
+ and note ?loc = diag Note ?loc
+ and info ?loc = diag Info ?loc
+ and warn ?loc = diag Warn ?loc
+ and error ?loc = diag Error ?loc
+ let grab_diags { result; diags } = add_all diags; result
+end
+
+(** Initializes a stateful diagnostics reporting module based on an empty
+ history. *)
+module InitStateful () = MakeStateful (struct let history = Set.none end)
+
+(* --- *)
+
+module Fatal = struct
+ (** Fatal errors from which we cannot recover. *)
+ let localized_error = Msgs.localized_error
+ let error = Msgs.error
+ (* exception Sink of Set.t *)
+
+ (* (\** Fail with a set of diagnostics *\) *)
+ (* let sink s = raise @@ Sink s *)
+end
+
+let of_exn: exn -> diagnostic = function
+ | Msgs.LocalizedError (s, loc, _) -> (* TODO: addenda *)
+ One.error ~loc "%t" s
+ | Msgs.Error msg ->
+ One.error "%t" msg
+ | Failure msg
+ | Sys_error msg ->
+ One.error "%s" msg
+ | e ->
+ raise e
diff --git a/src/lsp/cobol_common/diagnostics.mli b/src/lsp/cobol_common/diagnostics.mli
new file mode 100644
index 000000000..cd1eac3f7
--- /dev/null
+++ b/src/lsp/cobol_common/diagnostics.mli
@@ -0,0 +1,148 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module TYPES: sig
+ type severity = Diagnostics_sigs.severity =
+ | Hint
+ | Note
+ | Info
+ | Warn
+ | Error
+
+ type diagnostic
+ type diagnostics
+
+ type 'a in_result = ('a * diagnostic option, diagnostic option) result
+
+ type 'a with_diags =
+ {
+ result: 'a;
+ diags: diagnostics;
+ }
+end
+include module type of TYPES
+ with type severity = TYPES.severity
+ and type diagnostic = TYPES.diagnostic
+ and type diagnostics = TYPES.diagnostics
+ and type 'a in_result = 'a TYPES.in_result
+ and type 'a with_diags = 'a TYPES.with_diags
+type t = diagnostic
+
+val pp: t Pretty.printer
+val pp_msg: t Pretty.printer
+
+val message: t -> Pretty.delayed
+val severity: t -> severity
+val location: t -> Srcloc.srcloc option
+
+(** {1 Set of diagnostics} *)
+
+module Set: sig
+ (** Persistent set of diagnostics *)
+ type t = diagnostics
+ val pp: t Pretty.printer
+ val none: t
+ val one: diagnostic -> t
+ val maybe: diagnostic option -> t
+ val two: diagnostic -> diagnostic -> t
+ val cons: diagnostic -> t -> t
+ val union: t -> t -> t
+ val has_errors: t -> bool
+ val map: (diagnostic -> 'a) -> t -> 'a list
+ val fold: (diagnostic -> 'a -> 'a) -> t -> 'a -> 'a
+
+ include Diagnostics_sigs.REPORT
+ with type 'a t := ?loc:Srcloc.srcloc -> ('a, t) Pretty.func
+ and type blind := diagnostic -> t
+
+ (** Sets of diagnostics with values that do not contain any closure or module,
+ and that can thus be marshalled/unmarshalled safely.
+
+ The ability to perform delayed formatting is lost when translating from
+ "regular" diagnostics into serializable ones, as the translation applies
+ the formatting as if into a string without any right-margin. *)
+ type serializable
+ val apply_delayed_formatting: t -> serializable
+ val of_serializable: serializable -> t
+end
+
+(** {1 Functional and imperative interfaces to diagnostics} *)
+
+module One: Diagnostics_sigs.REPORT
+ with type 'a t := ?loc:Srcloc.srcloc -> ('a, t) Pretty.func
+ and type blind := t -> t
+
+module Now: Diagnostics_sigs.REPORT
+ with type 'a t := Format.formatter -> ?loc:Srcloc.srcloc -> 'a Pretty.proc
+ and type blind := Format.formatter -> t -> unit
+
+module Acc: Diagnostics_sigs.REPORT
+ with type 'a t := (Set.t as 's) -> ?loc:Srcloc.srcloc -> ('a, 's) Pretty.func
+ and type blind := Set.t -> t -> Set.t
+
+module Cont: Diagnostics_sigs.KREPORT
+ with type ('a, 'b) t := (t -> 'b) -> ?loc:Srcloc.srcloc -> ('a, 'b) Pretty.func
+ and type 'b kblind := (t -> 'b) -> t -> 'b
+
+(** Allow direct access to persistent diagnostics reporting *)
+include module type of Acc
+include module type of Cont
+
+(* --- *)
+
+val result: ?diags:diagnostics -> 'a -> 'a with_diags
+val with_diag: 'a -> diagnostic -> 'a with_diags
+val with_diags: 'a -> diagnostics -> 'a with_diags
+val with_more_diags: diags:diagnostics -> 'a with_diags -> 'a with_diags
+val simple_result: 'a -> 'a with_diags
+val some_result: ?diags:diagnostics -> 'a -> 'a option with_diags
+val no_result: diags:diagnostics -> _ option with_diags
+val map_result: ('a -> 'b) -> 'a with_diags -> 'b with_diags
+
+val hint_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
+val note_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
+val info_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
+val warn_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
+val error_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
+
+(* --- *)
+
+module type STATEFUL = Diagnostics_sigs.STATEFUL
+ with type blind := t -> unit
+ and type diagnostics := diagnostics
+ and type 'a with_diags := 'a with_diags
+
+module type STATEFUL0 = Diagnostics_sigs.STATEFUL0
+ with type blind := t -> unit
+ and type diagnostics := diagnostics
+ and type 'a with_diags := 'a with_diags
+
+module MakeStateful:
+ functor (H: sig val history: diagnostics end) -> STATEFUL0
+
+module InitStateful:
+ functor () -> STATEFUL0
+
+(* --- *)
+
+module Fatal: Diagnostics_sigs.FATAL
+ with type ('a, 'b) with_location :=
+ ?addenda:Msgs.addenda
+ -> Srcloc.srcloc
+ -> ('a, Format.formatter, unit, 'b) format4 -> 'a
+ and type ('a, 'b) with_optional_location :=
+ ?loc:(Srcloc.srcloc)
+ -> ('a, Format.formatter, unit, 'b) format4 -> 'a
+ (* and type set := Set.t *)
+
+val of_exn: exn -> diagnostic
diff --git a/src/lsp/cobol_common/diagnostics_sigs.ml b/src/lsp/cobol_common/diagnostics_sigs.ml
new file mode 100644
index 000000000..b31faa4c1
--- /dev/null
+++ b/src/lsp/cobol_common/diagnostics_sigs.ml
@@ -0,0 +1,70 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Modules signatures dedicated to diagnostics.
+
+ Placed here to avoid duplications in ML & MLI *)
+
+type severity =
+ | Hint
+ | Note
+ | Info
+ | Warn
+ | Error
+
+module type REPORT = sig
+ type _ t and blind
+ val diag: severity -> _ t
+ val hint: _ t
+ val note: _ t
+ val info: _ t
+ val warn: _ t
+ val error: _ t
+ val blind: blind
+end
+
+module type KREPORT = sig
+ type (_, _) t and 'a kblind
+ val kdiag: severity -> _ t
+ val khint: _ t
+ val knote: _ t
+ val kinfo: _ t
+ val kwarn: _ t
+ val kerror: _ t
+ val kblind: 'a kblind
+end
+
+module type STATEFUL = sig
+ include REPORT
+ with type 'a t := ?loc:Srcloc.srcloc -> 'a Pretty.proc
+ type diagnostics
+ type _ with_diags
+ val add_all: diagnostics -> unit
+ val grab_diags: 'a with_diags -> 'a
+end
+
+module type STATEFUL0 = sig
+ include STATEFUL
+ val inspect: reset:bool -> diagnostics
+end
+
+module type FATAL = sig
+ type ('a, 'b) with_location
+ type ('a, 'b) with_optional_location
+ val localized_error: _ with_location [@@deprecated "Please try a proper \
+ recovery"]
+ val error: _ with_optional_location
+ (* type set *)
+ (* exception Sink of set *)
+ (* val sink: set -> _ *)
+end
diff --git a/src/lsp/cobol_common/dune b/src/lsp/cobol_common/dune
new file mode 100644
index 000000000..501f2f807
--- /dev/null
+++ b/src/lsp/cobol_common/dune
@@ -0,0 +1,26 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_common)
+ (public_name cobol_common)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries pretty ppx_deriving str)
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show ppx_deriving.ord))
+
+ )
+
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_common))
+
+; use field 'dune-trailer' to add more stuff here
+
diff --git a/src/lsp/cobol_common/index.mld b/src/lsp/cobol_common/index.mld
new file mode 100644
index 000000000..24baee349
--- /dev/null
+++ b/src/lsp/cobol_common/index.mld
@@ -0,0 +1,16 @@
+{1 Library cobol_common}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+This library contains utility modules that are used in all other {b Superbol} packages:
+{ul
+ {- {!Cobol_common.Basics} contains basic helper modules such as [StringMap], [StringSet] and
+ helper functions for pairs and lists.}
+ {- {!Cobol_common.Diagnostics} which contains all the logic to create and print diagnostics.}
+ {- {!Cobol_common.Srcloc} which contains all the logic to handle locations.}
+ {- {!Cobol_common.Visitors} which contains all the basic definitions for our visitors.}}
+
+
+The entry point of this library is the module: {!Cobol_common}.
+
diff --git a/src/lsp/cobol_common/msgs.ml b/src/lsp/cobol_common/msgs.ml
new file mode 100644
index 000000000..862dc060e
--- /dev/null
+++ b/src/lsp/cobol_common/msgs.ml
@@ -0,0 +1,52 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+type addenda = (Pretty.delayed * Srcloc.srcloc option) list
+exception LocalizedError of Pretty.delayed * Srcloc.srcloc * addenda
+exception Error of Pretty.delayed
+
+let localized_error ?(addenda = []) (loc: Srcloc.srcloc) =
+ Pretty.delayed_to (fun s -> raise @@ LocalizedError (s, loc, addenda))
+
+let error ?loc =
+ Pretty.delayed_to (fun s -> match loc with
+ | None -> raise @@ Error s
+ | Some loc -> raise @@ LocalizedError (s, loc, []))
+
+(* --- *)
+
+let pp_msg ?loc ppf fmt =
+ (* Source text right above message for now: *)
+ Pretty.print ppf ("%a"^^fmt) (Pretty.option Srcloc.pp_srcloc) loc
+
+(* --- *)
+
+let pp_kuncaught k exn fmt =
+ Pretty.string_to k ("Fatal error: uncaught exception %s:@\n"^^fmt) exn
+
+(* Register some printing functions, useful upon misuse of
+ `Cobol_common.catch_diagnostics` and co. *);;
+Stdlib.Printexc.register_printer begin
+ let uncaught exn fmt =
+ pp_kuncaught Option.some (__MODULE__^exn) @@ fmt ^^
+ "@\n(Dev hint: this is probably due to a missing call to \
+ Cobol_common.catch_diagnostics)@."
+ in
+ function
+ | LocalizedError (msg, loc, _) ->
+ uncaught "LocalizedError" "%a" (fun ppf -> pp_msg ~loc ppf "%t") msg
+ | Error msg ->
+ uncaught "Error" "%t" msg
+ | _ ->
+ None
+end
diff --git a/src/lsp/cobol_common/package.toml b/src/lsp/cobol_common/package.toml
new file mode 100644
index 000000000..5b379041d
--- /dev/null
+++ b/src/lsp/cobol_common/package.toml
@@ -0,0 +1,75 @@
+
+# name of package
+name = "cobol_common"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+generators = ["menhir"]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+preprocess = "pps ppx_deriving.show ppx_deriving.ord"
+
+# files to skip while updating at package level
+skip = ["main.ml", "index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+ppx_deriving = ">=5.2.1"
+pretty = "version"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+dune-libraries = "str"
diff --git a/src/lsp/cobol_common/srcloc.ml b/src/lsp/cobol_common/srcloc.ml
new file mode 100644
index 000000000..91c1c3946
--- /dev/null
+++ b/src/lsp/cobol_common/srcloc.ml
@@ -0,0 +1,652 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Ez_file.V1
+
+module TYPES = struct
+
+ (* Tags used to refine the representation of source locations below. *)
+ type raw_ = [ `Raw ]
+ type cpy_ = [ `Cpy ]
+ type rpl_ = [ `Rpl ]
+ type cat_ = [ `Cat ]
+
+ (** A location is any composition of simple lexing positions, *)
+ type srcloc = any_ slt
+
+ and any_ = [raw_|cpy_|rpl_|cat_]
+
+ (* represented using a source location tree. *)
+ and _ slt =
+ | Raw: raw -> [>raw_] slt
+ | Cpy: { copied: any_ slt; copyloc: copyloc } -> [>cpy_] slt
+ | Rpl: replacement -> [>rpl_] slt
+ | Cat: { left: left_ slt; right: right_ slt } -> [>cat_] slt
+ (* invariant: Cat {left = Cpy _ ; right = Cpy _}: the two copies are not
+ from the same file. *)
+
+ (* Raw lexical range *)
+ and lexloc = Lexing.position * Lexing.position
+ and raw = Lexing.position * Lexing.position * bool (* area-a flag *)
+
+ (* Representation of a file copy operation *)
+ and copyloc = { filename: string; copyloc: srcloc (* option *) }
+
+ and replacement =
+ {
+ old: any_ slt; (* should only keep ref. of starting pos if needed for
+ area-a detection... *)
+ new_: srcloc; (* location of replacement spec (e.g, pseudotext) *)
+ in_area_a: bool;
+ replloc: srcloc;
+ }
+
+ (* A (con)cat(enation) allows any sort of source location on its left... *)
+ and left_ = any_
+
+ (* ... but forbids other cats directly on its right. *)
+ and right_ = [raw_|cpy_|rpl_]
+
+ (** Values attached with a source location. *)
+ type 'a with_loc = { payload: 'a; loc: srcloc [@compare fun _ _ -> 0] }
+ [@@ deriving ord]
+
+end
+include TYPES
+
+(* For debugging: *)
+
+let pp_srcloc_struct: srcloc Pretty.printer =
+ let pp_lexloc ppf Lexing.{ pos_fname; pos_lnum; pos_cnum; pos_bol } =
+ Pretty.print ppf "%s:%d-%d" pos_fname pos_lnum (pos_cnum - pos_bol)
+ and pp_lexloc' ppf Lexing.{ pos_lnum; pos_cnum; pos_bol; _ } =
+ Pretty.print ppf "%d-%d" pos_lnum (pos_cnum - pos_bol)
+ in
+ let rec pp: type t. t slt Pretty.printer = fun ppf -> function
+ | Raw (s, e, _) ->
+ Pretty.print ppf "<%a|%a>"
+ pp_lexloc s pp_lexloc' e
+ | Cpy { copied; _ } ->
+ Pretty.print ppf "Cpy { copied = %a }"
+ pp copied
+ | Rpl { old; new_; replloc; _ } ->
+ Pretty.print ppf "Rpl { @[matched = %a;\
+ @ replacement = %a;\
+ @ replloc = %a@] }"
+ pp old pp new_ pp replloc
+ | Cat { left; right } ->
+ Pretty.print ppf "Cat { @[left = %a;@ right = %a@] }"
+ pp left pp right
+ in
+ pp
+
+(** {2 Manipulating source locations} *)
+
+(** copied, but original (replaced) position upon replacing *)
+let rec start_pos: type t. t slt -> Lexing.position = function
+ | Raw (s, _, _) -> s
+ | Cpy { copied; _ } -> start_pos copied
+ | Rpl { old; _ } -> start_pos old
+ | Cat { left; _ } -> start_pos left
+
+let start_pos_in ~filename =
+ let rec aux: type t. t slt -> Lexing.position option = function
+ | Raw (s, _, _) when s.pos_fname = filename -> Some s
+ | Raw _ -> None
+ | Cat { left; right } -> or_else left right
+ | Cpy { copied; copyloc = { copyloc; _ } } -> or_else copied copyloc
+ | Rpl { new_; old; replloc; _ } ->
+ match aux new_ with None -> or_else old replloc | res -> res
+ and or_else: type t u. t slt -> u slt -> _ = fun a b ->
+ match aux a with None -> aux b | res -> res
+ in
+ aux
+
+let end_pos_in ~filename =
+ let rec aux: type t. t slt -> Lexing.position option = function
+ | Raw (_, e, _) when e.pos_fname = filename -> Some e
+ | Raw _ -> None
+ | Cat { left; right } -> or_else right left
+ | Cpy { copied; copyloc = { copyloc; _ } } -> or_else copied copyloc
+ | Rpl { new_; old; replloc; _ } ->
+ match aux new_ with None -> or_else old replloc | res -> res
+ and or_else: type t u. t slt -> u slt -> _ = fun a b ->
+ match aux a with None -> aux b | res -> res
+ in
+ aux
+
+(** [forget_preproc ~favor_direction ~traverse_copies ~traverse_replaces loc]
+ eliminates any preprocessing operation from the source location [loc], and
+ returns a valid lexical range in {b a} file that participated in its
+ construction.
+
+ - [favor_direction] indicates whether to favor searching for the range from
+ the left or the right bound of the location;
+
+ - if [traverse_copies] is false, the location of {[COPY ...]} preprocessor
+ statemenents is considered as a whole and not decomposed. If
+ [traverse_copies] holds, returned ranges may belong to copybooks;
+
+ - if [traverse_replaces] is false, the location of text that is subject to
+ replacement is considered as a whole and not decomposed. This can make the
+ resulting range rather coarse in case of {[REPLACE]} or {[COPY
+ ... REPLACING]}, as the considered location is then that of the whole text
+ that participated in a match. On the contrary, the opposite case
+ ([traverse_replaces] holds) may lead to misleading results (with ranges that
+ appear in replacement pseudotext).
+*)
+let forget_preproc
+ ~(favor_direction: [`Left | `Right])
+ ~(traverse_copies: bool)
+ ~(traverse_replaces: bool) =
+ let rec aux: type t. t slt -> lexloc = function
+ | Raw (s, e, _) ->
+ s, e
+ | Cpy { copied; copyloc = { copyloc; _ } } ->
+ aux (if traverse_copies then copied else copyloc)
+ | Rpl { new_; old; _ } ->
+ aux (if traverse_replaces then new_ else old)
+ | Cat { left; right } ->
+ match favor_direction with
+ | `Left ->
+ let (Lexing.{ pos_fname = filename; _ } as s), e = aux left in
+ s, Option.value (end_pos_in ~filename right) ~default:e
+ | `Right ->
+ let s, (Lexing.{ pos_fname = filename; _ } as e) = aux right in
+ Option.value (start_pos_in ~filename left) ~default:s, e
+ in
+ aux
+
+(** Default projection. This is a shorthand for [forget_preproc
+ ~favor_direction:`Left ~traverse_copies:true ~traverse_replaces:false]. *)
+let as_lexloc: srcloc -> lexloc =
+ forget_preproc ~favor_direction:`Left
+ ~traverse_copies:true ~traverse_replaces:false
+
+let lookup_pos ~lookup ~lookup_name ~filename loc =
+ match lookup ~filename loc with
+ | None -> Fmt.invalid_arg "%s.%s: no part of \"%s\" was used to construct the \
+ given location (loc = %a)" __MODULE__ lookup_name filename
+ pp_srcloc_struct loc
+ | Some s -> s
+
+let start_pos_in = lookup_pos ~lookup:start_pos_in ~lookup_name:"start_pos_in"
+let end_pos_in = lookup_pos ~lookup:end_pos_in ~lookup_name:"end_pos_in"
+
+(** [lexloc_in ~filename loc] projects the source location [loc] on the file
+ [filename] by eliminating relevant preprocessor-related locations.
+
+ Raises {!Invalid_argument} in case no valid projection onto the file
+ [filename] can be found; this never happens if at least one lexical range of
+ the file [filename] participated in the construction of [loc]. *)
+let lexloc_in ~filename loc =
+ start_pos_in ~filename loc, end_pos_in ~filename loc
+
+let as_unique_lexloc = function
+ | Raw (s, e, _) -> Some (s, e)
+ | _ -> None
+
+(** [as_copy loc] returns a copybook filename associated with the location of
+ the {[COPY]} directive if [loc] directly results from such a directive, and
+ returns [None] otherwise. *)
+let as_copy = function
+ | Cpy { copyloc = { filename; copyloc }; _ } ->
+ Some { payload = filename; loc = copyloc }
+ | _ -> (* CHECKME: COPY ... REPLACING ...: Rpl should be nested below Cpy *)
+ None
+
+(* --- *)
+
+(** [in_area_a loc] indicates whether the location [loc] has a left-most raw
+ location that was built with the [in_area_a] flag. *)
+let rec in_area_a: srcloc -> bool = function
+ | Raw (_, _, a) -> a
+ | Cpy { copied; _ } -> in_area_a copied
+ | Rpl { in_area_a; _ } -> in_area_a
+ | Cat { left; _ } -> in_area_a left
+
+let scan ?(kind: [`TopDown | `BottomUp] = `TopDown) ~cpy ~rpl =
+ let rec aux: type t. t slt -> 'a -> 'a = fun loc -> match loc, kind with
+ | Raw _, _ -> Fun.id
+ | (Cpy { copied; copyloc }
+ , `TopDown ) -> fun acc -> acc |> cpy copyloc |> aux copied
+ | (Cpy { copied; copyloc }
+ , `BottomUp) -> fun acc -> acc |> aux copied |> cpy copyloc
+ | (Rpl { old; replloc; _ }
+ , `TopDown ) -> fun acc -> acc |> rpl replloc |> aux old
+ | (Rpl { old; replloc; _ }
+ , `BottomUp) -> fun acc -> acc |> aux old |> rpl replloc
+ | (Cat { left; right }, _) -> fun acc -> acc |> aux left |> aux right
+ in
+ aux
+
+let fold_lexlocs f loc acc =
+ let rec aux: type t. t slt -> 'a -> 'a = fun loc -> match loc with
+ | Raw (s, e, _) -> f (s, e)
+ | Cpy { copied; _ } -> aux copied
+ | Rpl { old; _ } -> aux old
+ | Cat { left; right } -> fun acc -> acc |> aux left |> aux right
+ in
+ aux loc acc
+
+let has_lexloc p loc =
+ try fold_lexlocs (fun lexloc () -> if p lexloc then raise Exit) loc (); false
+ with Exit -> true
+
+let retrieve_file_lines =
+ let module Cache =
+ Ephemeron.K1.Make (struct
+ include String
+ let hash = Hashtbl.hash
+ end)
+ in
+ let file_cache = lazy (Cache.create 3) in
+ fun file ->
+ let file_cache = Lazy.force file_cache in
+ try Cache.find file_cache file
+ with Not_found ->
+ let lines = EzFile.read_lines file in
+ Cache.add file_cache file lines;
+ lines
+
+type raw_loc = string * (int * int) * (int * int)
+
+let pp_file_loc ppf ((file, pos1, pos2): raw_loc) =
+ Pretty.print ppf "%s:%a" file Fmt.text_loc (pos1, pos2)
+
+(** Note this should always end with a newline character *)
+let pp_raw_loc: raw_loc Pretty.printer =
+ let b = lazy (Buffer.create 1000) in
+ let find_source (file, pos1, pos2) =
+ let line1 = fst pos1 in
+ let line2 = fst pos2 in
+ let col1 = snd pos1 in
+ let col2 = snd pos2 in
+ let col2, pad2 =
+ if line1 == line2 && col1 == col2 then succ col2, 1 else col2, 0 in
+ let lines = retrieve_file_lines file in
+ let b = Lazy.force b in
+ Buffer.clear b;
+ for l = max 1 (line1 - 3) to min (Array.length lines) (line2 + 2) do
+ let line = lines.(l - 1) in
+ let len = String.length line in
+ Printf.bprintf b "%4d %c %s\n" l
+ (if l>=line1 && l<=line2 then '>' else ' ')
+ line;
+ if l = line1 then
+ let str =
+ let len' = len + 1 + if l = line2 then pad2 else 0 in
+ String.mapi
+ (if l = line2
+ then fun idx c -> if idx > col1 && idx <= col2 then '^' else c
+ else fun idx c -> if idx > col1 then '^' else c)
+ (String.make (min len' (col2 + 1)) ' ')
+ in
+ Printf.bprintf b "---- %s\n" str;
+ else if l > line1 && l < line2 then
+ let str = String.make (len + 1) '^' in
+ Printf.bprintf b "---- %s\n" str;
+ else if l = line2 then
+ let str =
+ String.mapi
+ (fun idx c -> if idx <= col2 then '^' else c )
+ (String.make (min (len + 1 + pad2) (col2 + 1)) ' ')
+ in
+ Printf.bprintf b "---- %s\n" str;
+ done;
+ Buffer.contents b
+ in
+ fun ppf raw_loc ->
+ let text = try find_source raw_loc with _ -> "" in
+ Pretty.print ppf "%a:@\n@[@<0>%s@]" pp_file_loc raw_loc text
+
+let same_copyloc { filename = f1; _ } { filename = f2; _ } =
+ f1 = f2 (* berk *)
+
+let to_raw_loc
+ Lexing.({ pos_lnum = l1; pos_bol = b1; pos_cnum = c1; pos_fname; _ },
+ { pos_lnum = l2; pos_bol = b2; pos_cnum = c2; _ }) =
+ pos_fname, (l1, c1 - b1), (l2, c2 - b2)
+
+let pp_srcloc: srcloc Pretty.printer =
+ let pp_transform_operation ~partial ppf = function
+ | `Cpy { filename; copyloc }
+ when partial ->
+ Pretty.print ppf "%a:@;@[partially@ in@ `%s`,@ copied@ at@ this@ \
+ location@]"
+ pp_file_loc (to_raw_loc @@ as_lexloc copyloc) filename
+ | `Cpy { copyloc; _ } ->
+ Pretty.print ppf "%a:@;@[copied@ at@ this@ location@]"
+ pp_file_loc (to_raw_loc @@ as_lexloc copyloc)
+ | `Rpl replloc ->
+ Pretty.print ppf "%a:@;@[subject@ to@ this@ replacement@]"
+ pp_file_loc (to_raw_loc @@ as_lexloc replloc)
+ in
+ let pp_transform_operations ~partial =
+ Pretty.list ~fopen:"@[<2>" ~fsep:"@]@\n@[" ~fclose:"@]@\n" ~fempty:""
+ (pp_transform_operation ~partial)
+ in
+ let toplevel_transform_stack loc =
+ let rec aux acc = function
+ | Raw _ | Cat _ as loc -> List.rev acc, loc
+ | Cpy { copied; copyloc } -> aux (`Cpy copyloc :: acc) copied
+ | Rpl { old; replloc; _ } -> aux (`Rpl replloc :: acc) old
+ in
+ aux [] loc
+ and partial_transform_operations loc =
+ scan ~kind:`BottomUp loc []
+ ~cpy: begin fun copyloc acc ->
+ (* TODO: use physical equality instead? *)
+ if List.mem (`Cpy copyloc) acc
+ then acc
+ else List.cons (`Cpy copyloc) acc
+ end
+ ~rpl: begin fun replloc acc ->
+ if List.mem (`Rpl replloc) acc
+ then acc
+ else List.cons (`Rpl replloc) acc
+ end
+ in
+ fun ppf loc ->
+ let toplevel_transforms, loc = toplevel_transform_stack loc in
+ let lexloc = as_lexloc loc in
+ pp_raw_loc ppf (to_raw_loc lexloc);
+ pp_transform_operations ~partial:false ppf toplevel_transforms;
+ pp_transform_operations ~partial:true ppf (partial_transform_operations loc)
+
+let pp_file_loc ppf loc =
+ pp_file_loc ppf (to_raw_loc @@ as_lexloc loc)
+
+(** [raw ~in_area_a lexloc] builds a raw source location from a pair of left-
+ and right- lexing positions from the same file, optionally setting an
+ [in_area_a] flag (that defaults to [false]) to indicate whether the location
+ is the first on its line, and starts in Area A of the source format. *)
+let raw ?(in_area_a = false) ((s, e): lexloc) : srcloc =
+ assert Lexing.(s.pos_cnum <= e.pos_cnum); (* ensure proper use *)
+ let loc = Raw (s, e, in_area_a) in
+ if Lexing.(s.pos_fname != e.pos_fname) then
+ Pretty.error
+ "%a@\n>> Internal warning in `%s.raw`: file names mismatch (`%s` != `%s`)\
+ " pp_srcloc loc __MODULE__ s.pos_fname e.pos_fname;
+ loc
+
+let copy ~filename ~copyloc copied : srcloc =
+ Cpy { copied; copyloc = { filename; copyloc } }
+
+let replacement ~old ~new_ ~in_area_a ~replloc : srcloc =
+ Rpl { old; new_; in_area_a; replloc }
+
+
+(* let is_copy = function *)
+(* | Cpy _ -> true *)
+(* | _ -> false *)
+
+(* let rec last_copy_origin: type t. t slt -> string option = function *)
+(* | Raw _ -> None *)
+(* | Rpl { replaced; _ } -> *)
+(* last_copy_origin replaced *)
+(* | Cat {left; right} -> *)
+(* begin match last_copy_origin left with *)
+(* | None -> last_copy_origin right *)
+(* | _ as v -> v *)
+(* end *)
+(* | Cpy {copyloc = {filename; _}; _} -> Some filename *)
+
+(** [concat l1 l2] concatenates two adjacent source locations [l1] and [l2]. *)
+let rec concat: srcloc -> srcloc -> srcloc = fun l1 l2 -> match l1, l2 with
+ | Raw (s1, e1, in_area_a),
+ Raw (s2, e2, _)
+ when e1.pos_fname = s2.pos_fname && e1.pos_cnum = s2.pos_cnum - 1 ->
+ Raw (s1, e2, in_area_a)
+
+ | Cpy { copied = l1; copyloc = c1 },
+ Cpy { copied = l2; copyloc = c2 }
+ when same_copyloc c1 c2 ->
+ Cpy { copied = concat l1 l2; copyloc = c1 }
+
+ | (Cat { left; right = Cpy { copied = l1; copyloc = c1 } }),
+ (Cpy { copied = l2; copyloc = c2 })
+ when same_copyloc c1 c2 ->
+ Cat { left; right = Cpy { copied = concat l1 l2; copyloc = c1 } }
+
+ | Rpl { new_ = s1; old = l1; replloc; in_area_a }, (* unlikely *)
+ Rpl { new_ = s2; old = l2; replloc = replloc'; _ }
+ when l1 == l2 && replloc == replloc' -> (* note: physical equality *)
+ Rpl { new_ = concat s1 s2; old = l1; replloc; in_area_a }
+
+ | (Cat { left; right = Rpl { new_ = s1; old = l1; replloc; in_area_a }}),
+ (Rpl { new_ = s2; old = l2; replloc = replloc'; _ })
+ when l1 == l2 && replloc == replloc' -> (* note: physical equality *)
+ Cat { left; right = Rpl { new_ = concat s1 s2; old = l1;
+ replloc; in_area_a }}
+
+ | (Raw _ | Cpy _ | Rpl _ | Cat _ as left),
+ (Cpy _ | Rpl _ | Raw _ as right) ->
+ Cat { left; right }
+
+ | (Raw _ | Cpy _ | Rpl _ | Cat _ as l1),
+ (Cat { left = l2; right }) ->
+ Cat { left = concat l1 l2; right }
+
+let concat_srclocs: srcloc list -> srcloc option = fun l ->
+ List.fold_left begin fun acc loc -> match acc with
+ | None -> Some loc
+ | Some acc -> Some (concat acc loc)
+ end None l
+
+(** Direction for {!take} and {!trunc} below (internal) *)
+type direction = Prefix | Suffix
+
+let show_direction = function
+ | Prefix -> "prefix"
+ | Suffix -> "suffix"
+
+(** [take direction length l] computes a source location for the prefix or
+ suffix of length [length] of [l]. Shows some warnings on [stderr] in case
+ [length] exceeds the length of [l]. *)
+let take direction length loc =
+ (* Assumes raw lexlocs do not span over several lines *)
+ let open Lexing in
+ let rec take: type k. _ -> k slt -> _ = fun length -> function
+ | Raw (s, e, a) as loc ->
+ let len = e.pos_cnum - s.pos_cnum in
+ if len > length
+ then match direction with
+ | Prefix ->
+ Raw (s, { e with pos_cnum = s.pos_cnum + length }, a), 0
+ | Suffix ->
+ Raw ({ s with pos_cnum = e.pos_cnum - length }, e, false), 0
+ else loc, length - len
+ | Cpy ({ copied; _ } as cpy) ->
+ let copied, rem = take length copied in
+ Cpy { cpy with copied }, rem
+ | Rpl ({ new_; _ } as rpl) ->
+ let new_, rem = take length new_ in
+ Rpl { rpl with new_ }, rem
+ | Cat { left; right } -> match direction with
+ | Prefix ->
+ let left, rem = take length left in
+ if rem <= 0 then loc, rem else
+ let right, rem = take rem right in
+ concat left right, rem
+ | Suffix ->
+ let right, rem = take length right in
+ if rem <= 0 then loc, rem else
+ let left, rem = take rem left in
+ concat left right, rem
+ in
+ let loc', rem = take length loc in
+ if rem < 0 then
+ Pretty.error
+ "%a@\n>> Internal warning in `%s.take`: requested %s (%d) is longer than \
+ source location (by %d)@.\
+ " pp_srcloc loc __MODULE__ (show_direction direction) length (- rem);
+ loc'
+
+(** [trunc direction length l] truncates a prefix or suffix of length [length]
+ from a source location [l]. Shows some warnings on [stderr] in case
+ [length] exceeds the length of [l]. *)
+let trunc direction length loc =
+ (* Assumes raw lexlocs do not span over several lines *)
+ let open Lexing in
+ let rec cut: type k. _ -> k slt -> _ = fun length -> function
+ | (Raw _ | Cpy _ | Rpl _ | Cat _) as loc
+ when length == 0 ->
+ Some loc, 0
+ | Raw (s, e, a) ->
+ let len = e.pos_cnum - s.pos_cnum in
+ if len > length
+ then match direction with
+ | Prefix ->
+ Some (Raw ({ s with pos_cnum = s.pos_cnum + length }, e, false)), 0
+ | Suffix ->
+ Some (Raw (s, { e with pos_cnum = e.pos_cnum - length }, a)), 0
+ else None, length - len
+ | Cpy ({ copied; _ } as cpy) ->
+ begin match cut length copied with
+ | Some copied, rem -> Some (Cpy { cpy with copied }), rem
+ | res -> res
+ end
+ | Rpl ({ new_; _ } as rpl) ->
+ begin match cut length new_ with
+ | Some new_, rem -> Some (Rpl { rpl with new_ }), rem
+ | res -> res
+ end
+ | Cat { left; right } -> match direction with
+ | Prefix ->
+ begin match cut length left with
+ | Some left, rem -> Some (Cat { left; right }), rem
+ | None, rem -> cut rem right
+ end
+ | Suffix ->
+ begin match cut length right with
+ | Some right, rem -> Some (concat left right), rem
+ | None, rem -> cut rem left
+ end
+ in
+ match cut length loc with
+ | Some loc', rem when rem == 0 ->
+ loc'
+ | loc', rem ->
+ if rem < 0 then
+ Pretty.error
+ "%a@\n>> Internal warning in `%s.trunc`: taken out %s (%d) is longer \
+ than source location (by %d)@.\
+ " pp_srcloc loc __MODULE__ (show_direction direction) length (- rem);
+ Option.value loc' ~default:loc
+
+(** [prefix prefix_length l] computes a source location for the prefix of length
+ [prefix_length] of [l]. Shows some warnings on [stderr] in case
+ [prefix_length] exceeds the length of [l]. *)
+let prefix prefix_length loc = take Prefix prefix_length loc
+
+(** [suffix suffix_length l] computes a source location for the suffix of length
+ [suffix_length] of [l]. Shows some warnings on [stderr] in case
+ [suffix_length] exceeds the length of [l]. *)
+let suffix suffix_length loc = take Suffix suffix_length loc
+
+(** [trunc_prefix prefix_length l] truncates a prefix of length [prefix_length]
+ from a source location [l]. Shows some warnings on [stderr] in case
+ [prefix_length] exceeds the length of [l]. *)
+let trunc_prefix prefix_length loc = trunc Prefix prefix_length loc
+let trunc_suffix suffix_length loc = trunc Suffix suffix_length loc
+
+let sub loc ~pos ~len =
+ let loc = if pos > 0 then trunc_prefix pos loc else loc in
+ prefix len loc
+
+(** {2 Manipulating localized values} *)
+
+let pp pe ppf e = pe ppf e.payload (* ignore source localization *)
+let pp_with_loc = pp
+let flagit payload loc = { payload; loc }
+let payload: 'a with_loc -> 'a = fun e -> e.payload
+let loc: 'a with_loc -> srcloc = fun e -> e.loc
+let as_pair e = e.payload, e.loc
+let locfrom: 'a -> 'b with_loc -> 'a with_loc = fun payload b ->
+ flagit payload (loc b)
+let locmap: ('a -> 'b) -> 'a with_loc -> 'b with_loc = fun f a ->
+ flagit (f (payload a)) (loc a)
+
+module INFIX : sig
+ (* Meaning of letters:
+ * '~' means projection
+ * '&' means payload
+ * '@' means location
+ * '?' means map-option
+ *)
+ val ( &@ ): 'a -> srcloc -> 'a with_loc
+ val ( &@<- ): 'a -> 'b with_loc -> 'a with_loc
+
+ val ( ~& ): 'a with_loc -> 'a
+ val ( ~@ ): 'a with_loc -> srcloc
+ val ( ~&? ): 'a with_loc option -> 'a option
+ val ( ~@? ): 'a with_loc option -> srcloc option
+ val ( ~&@ ): 'a with_loc -> 'a * srcloc
+end = struct
+ (* Fabrice: the use of non-standard infix operators is a nightmare for
+ external reviewers and newcomers. *)
+
+ let ( &@ ) = flagit
+ let ( &@<- ) = locfrom
+ let ( ~& ) = payload
+ let ( ~&? ) e = Option.map (~&) e
+ let ( ~@ ) = loc
+ let ( ~@? ) e = Option.map (~@) e
+ let ( ~&@ ) = as_pair
+
+end
+open INFIX
+
+let lift_option: 'a option with_loc -> 'a with_loc option = fun a ->
+ Option.map (fun x -> x &@<- a) ~&a
+
+let lift_result: ('a, 'e) result with_loc -> ('a with_loc, 'e with_loc) result =
+ fun rs ->
+ Result.(fold ~&rs
+ ~ok:(fun a -> Ok (a &@<- rs))
+ ~error:(fun e -> Error (e &@<- rs)))
+
+let concat_locs: _ with_loc list -> srcloc option = fun l ->
+ List.fold_left begin fun acc { loc; _ } -> match acc with
+ | None -> Some loc
+ | Some acc -> Some (concat acc loc)
+ end None l
+
+let concat_strings_with_loc v w = (~&v ^ ~&w) &@ (concat ~@v ~@w)
+
+let copy_from ~filename ~copyloc { payload; loc } =
+ { payload; loc = copy ~filename ~copyloc loc }
+
+(* --- *)
+
+module COPYLOCS = struct
+ (** Helper to record and format chains of copied libraries. *)
+
+ type t = copyloc list (* reversed *)
+
+ let none: t = []
+ let append ~copyloc filename : t -> t = List.cons { filename; copyloc }
+ let mem: string -> t -> bool = fun f ->
+ List.exists (fun { filename; _ } -> filename = f)
+
+end
+
+(* TODO: move me to a better place. This type declaration has to be
+ shared by Common_ast and Common_preproc *)
+(* NB: not necessarily. One refers to pre-processing concept, the other to the
+ semantics of some COBOL statements like INSPECT or EXAMINE. *)
+type leading_or_trailing =
+ | Leading
+ | Trailing
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_common/srcloc.mli b/src/lsp/cobol_common/srcloc.mli
new file mode 100644
index 000000000..bb584946c
--- /dev/null
+++ b/src/lsp/cobol_common/srcloc.mli
@@ -0,0 +1,118 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module TYPES: sig
+ type lexloc = Lexing.position * Lexing.position
+ type srcloc
+ type 'a with_loc = { payload: 'a; loc: srcloc; }
+ [@@deriving ord]
+end
+type lexloc = TYPES.lexloc
+type srcloc = TYPES.srcloc
+type 'a with_loc = 'a TYPES.with_loc =
+ { payload: 'a; loc: srcloc; } [@@deriving ord]
+
+module INFIX: sig
+ (* Meaning of letters:
+ * '~' means projection
+ * '&' means payload
+ * '@' means location
+ * '?' means map-option
+ *)
+ val ( &@ ): 'a -> srcloc -> 'a with_loc
+ val ( &@<- ): 'a -> 'b with_loc -> 'a with_loc
+ val ( ~& ): 'a with_loc -> 'a
+ val ( ~&? ): 'a with_loc option -> 'a option
+ val ( ~@ ): 'a with_loc -> srcloc
+ val ( ~@? ): 'a with_loc option -> srcloc option
+ val ( ~&@ ): 'a with_loc -> 'a * srcloc
+end
+
+val pp_srcloc: srcloc Pretty.printer
+val pp_file_loc: srcloc Pretty.printer
+val raw
+ : ?in_area_a:bool
+ -> lexloc
+ -> srcloc
+val copy
+ : filename:string
+ -> copyloc:srcloc
+ -> srcloc
+ -> srcloc
+val replacement
+ : old:srcloc
+ -> new_: srcloc
+ -> in_area_a: bool
+ -> replloc: srcloc
+ -> srcloc
+
+val forget_preproc
+ : favor_direction:[`Left | `Right]
+ -> traverse_copies:bool
+ -> traverse_replaces:bool
+ -> srcloc
+ -> lexloc
+val as_lexloc
+ : srcloc
+ -> lexloc
+val lexloc_in
+ : filename: string
+ -> srcloc
+ -> lexloc
+val as_unique_lexloc
+ : srcloc
+ -> lexloc option
+val as_copy
+ : srcloc
+ -> string with_loc option
+
+val in_area_a: srcloc -> bool
+val start_pos: srcloc -> Lexing.position (* only suitable for Area A checks *)
+val start_pos_in: filename: string -> srcloc -> Lexing.position
+val end_pos_in: filename: string -> srcloc -> Lexing.position
+
+val fold_lexlocs: (lexloc -> 'a -> 'a) -> srcloc -> 'a -> 'a
+val has_lexloc: (lexloc -> bool) -> srcloc -> bool
+
+val concat: srcloc -> srcloc -> srcloc
+val concat_srclocs: srcloc list -> srcloc option
+val prefix: int -> srcloc -> srcloc
+val suffix: int -> srcloc -> srcloc
+val trunc_prefix: int -> srcloc -> srcloc
+val trunc_suffix: int -> srcloc -> srcloc
+val sub : srcloc -> pos:int -> len:int -> srcloc
+
+val pp: 'a Pretty.printer -> 'a with_loc Pretty.printer
+val pp_with_loc: 'a Pretty.printer -> 'a with_loc Pretty.printer
+val flagit: 'a -> srcloc -> 'a with_loc
+val payload: 'a with_loc -> 'a
+val loc: 'a with_loc -> srcloc
+val as_pair: 'a with_loc -> 'a * srcloc
+val locfrom: 'a -> 'b with_loc -> 'a with_loc
+val locmap: ('a -> 'b) -> 'a with_loc -> 'b with_loc
+
+val lift_option: 'a option with_loc -> 'a with_loc option
+val lift_result: ('a, 'e) result with_loc -> ('a with_loc, 'e with_loc) result
+val concat_locs: _ with_loc list -> srcloc option
+val concat_strings_with_loc: string with_loc -> string with_loc -> string with_loc
+val copy_from: filename:string -> copyloc:srcloc -> 'a with_loc -> 'a with_loc
+
+module COPYLOCS: sig
+ type t
+ val none: t
+ val append: copyloc:srcloc -> string -> t -> t
+ val mem: string -> t -> bool
+end
+
+type leading_or_trailing = Leading | Trailing
+[@@deriving show, ord]
diff --git a/src/lsp/cobol_common/tokenizing.ml b/src/lsp/cobol_common/tokenizing.ml
new file mode 100644
index 000000000..2a9f44a39
--- /dev/null
+++ b/src/lsp/cobol_common/tokenizing.ml
@@ -0,0 +1,31 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Srcloc.INFIX
+
+(** [fold_tokens ~tokenizer ~until ~f acc loc w] tokenizes [w] using
+ [tokenizer], and folds over generated tokens using [f]. *)
+let fold_tokens ~tokenizer ~until ?next_tokenizer ~f w acc =
+ let lb = Lexing.from_string ~with_positions:true ~&w in
+ let rec aux ~loc ~tokenizer acc = match tokenizer ~loc lb with
+ | t when until t ->
+ acc
+ | t ->
+ let len = Lexing.(lexeme_end lb - lexeme_start lb) in
+ let loc = Lazy.force loc in
+ let loc = lazy (Srcloc.trunc_prefix len loc)
+ and tloc = Srcloc.prefix len loc in
+ aux ~loc (f (t &@ tloc) acc)
+ ~tokenizer:(match next_tokenizer with Some f -> f t | _ -> tokenizer)
+ in
+ aux ~tokenizer ~loc:(lazy ~@w) acc
diff --git a/src/lsp/cobol_common/tokenizing.mli b/src/lsp/cobol_common/tokenizing.mli
new file mode 100644
index 000000000..6f548ac93
--- /dev/null
+++ b/src/lsp/cobol_common/tokenizing.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val fold_tokens
+ : tokenizer:((loc:Srcloc.srcloc Lazy.t -> Lexing.lexbuf -> 'a) as 't)
+ -> until:('a -> bool)
+ -> ?next_tokenizer:('a -> 't)
+ -> f:('a Srcloc.with_loc -> 'b -> 'b)
+ -> string Srcloc.with_loc -> 'b -> 'b
diff --git a/src/node-js-stubs/version.mlt b/src/lsp/cobol_common/version.mlt
similarity index 100%
rename from src/node-js-stubs/version.mlt
rename to src/lsp/cobol_common/version.mlt
diff --git a/src/lsp/cobol_common/visitor.ml b/src/lsp/cobol_common/visitor.ml
new file mode 100644
index 000000000..3f335bbe0
--- /dev/null
+++ b/src/lsp/cobol_common/visitor.ml
@@ -0,0 +1,219 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** {1 Tree Visitors}
+
+ Tree visitors as implemented here are objects that define one method for
+ each type of node to be visited. Such visitors are associated (and
+ implemented using) a set of functions that are visiting starting points.
+
+ {2 Conventions}
+
+ In the module of a visitor [V]:
+
+ - the (currently unique) visitor is defined as a class [folder];
+
+ - the action to be performed when visiting (folding) a type [t] is specified
+ using a method [fold_t] of [folder];
+
+ - the starting point for a type [t] is [V.fold_t].
+
+ {b Note:} a type {!type:Srcloc.with_loc} is denoted with a prime ([']). For
+ instance, the starting point for a node of type [t with_loc] will be
+ [V.fold_t']. This convention also guides the naming of utilities
+ below. *)
+
+open Srcloc.TYPES
+
+(** {2 Types}
+
+ The type of actions depends on the kind of visitor. For now, only a folding
+ visitor is available: *)
+
+(** Action to be performed when visiting a node: *)
+type 'a folding_action =
+ | SkipChildren of 'a (** do not visit any of the node's children, and continue
+ with the given value *)
+ | DoChildren of 'a (** visit the node's children *)
+ | DoChildrenAndThen of 'a * ('a -> 'a) (** visit the node's children, and then
+ call the given function *)
+
+(** {3 Utilities for writing visitors} *)
+
+module INFIX = struct
+ (** Temporary binding, until `|>` is properly indented like a monadic operator
+ by ocp-indent. *)
+ let ( >> ) = ( |> )
+end
+open INFIX
+
+let report = (* to be kept until visitors are complete *)
+ let module REPORTED =
+ Hashtbl.Make (struct
+ type t = string * string * int * string
+ let equal = (=)
+ let hash = Hashtbl.hash
+ end)
+ in
+ let reported_table = lazy (REPORTED.create 17) in
+ fun k file_name module_name line_num func_name ->
+ let tbl = Lazy.force reported_table in
+ if not (REPORTED.mem tbl (file_name, module_name, line_num, func_name))
+ then begin
+ Pretty.error "@[<2>%s:%u:@ (%s.%s):@ %s@ visitor@ implementation@]@."
+ file_name line_num module_name func_name k;
+ REPORTED.add tbl (file_name, module_name, line_num, func_name) ()
+ end
+
+(** {3 Specific visitors} *)
+
+(** Visitor that accumulates over the nodes of the tree. *)
+module Fold = struct
+
+ type 'a action = 'a folding_action
+ type ('x, 'a) fold = 'x -> 'a -> 'a folding_action
+
+ (** Some combinators to write more readable folding visitors *)
+
+ let skip_children x = SkipChildren x
+ let skip = skip_children (* alias *)
+ let do_children x = DoChildren x
+ let proceed = do_children (* alias *)
+ let do_children_and_then x f = DoChildrenAndThen (x, f)
+ let proceed_and_then = do_children_and_then (* alias *)
+
+ let default _ = do_children (* default action *)
+
+ (** Action handling *)
+
+ (** [handle fold continue node acc] first calls [fold node acc], and then
+ behaves according to the action returned. *)
+ let handle (fold: 'x -> 'a -> 'a action) ~(continue: 'x -> 'a -> 'a) n x =
+ match fold n x with
+ | SkipChildren x -> x
+ | DoChildren x -> continue n x
+ | DoChildrenAndThen (x, f) -> continue n x >> f
+
+ (** [leaf fold node acc] calls [fold node acc] and returns immediately (after
+ executing the post action, if [fold] returns
+ {!val:DoChildrenAndThen}). *)
+ let leaf (fold: 'x -> 'a -> 'a action) =
+ handle fold ~continue:(fun _ -> Fun.id)
+
+ (** Base folding visitor. *)
+ class ['a] folder = object
+ method fold_bool: bool -> 'a -> 'a action = default
+ method fold_char: char -> 'a -> 'a action = default
+ method fold_int: int -> 'a -> 'a action = default
+ method fold_string: string -> 'a -> 'a action = default
+ method fold_option: 'x. 'x option -> 'a -> 'a action = default
+ method fold_list: 'x. 'x list -> 'a -> 'a action = default
+ method fold': 'x. 'x with_loc -> 'a -> 'a action = default
+ end
+
+ (** Entry points for folding over some basic types. *)
+
+ let fold_bool (v: _ #folder) = leaf v#fold_bool
+ let fold_char (v: _ #folder) = leaf v#fold_char
+ let fold_int (v: _ #folder) = leaf v#fold_int
+ let fold_string (v: _ #folder) = leaf v#fold_string
+
+ (** Generic entry points. *)
+
+ let fold_option ~fold (v: _ #folder) =
+ handle v#fold_option
+ ~continue:(Option.fold ~none:Fun.id ~some:(fold v))
+
+ let fold_list ~fold (v: _ #folder) =
+ handle v#fold_list
+ ~continue:(fun l x -> List.fold_left (fun x a -> fold v a x) x l)
+
+ let fold' ~fold (v: _ #folder) =
+ handle v#fold' ~continue:(fun { payload; _ } -> fold v payload)
+
+ let fold_string' (v: _ #folder) =
+ fold' ~fold:fold_string v
+
+ let fold_string'_opt (v: _ #folder) =
+ fold_option ~fold:fold_string' v
+
+ let fold_with_loc_list ~fold (v: _ #folder) =
+ fold_list v ~fold:(fold' ~fold)
+
+ (** Helper to shorten definitions for traversal of nodes with source
+ locations *)
+ let handle' vfold ~fold (v: _ #folder) =
+ handle vfold ~continue:(fold' ~fold v)
+
+ (* --- *)
+
+ (** Reports a missing folding visitor implementation {e once}. *)
+ let todo a b c d _ x = report "missing" a b c d; x
+
+ (** Reports a partial folding visitor implementation {e once}. *)
+ let partial a b c d x = report "partial" a b c d; x
+
+end
+
+(* --- *)
+
+(** Folder that carries a context *)
+module Fold_with_context = struct
+
+ (* TODO: to be extended to the ASTs if really needed; priority is in completing
+ the basic one above first *)
+
+ type 'a action = 'a folding_action
+
+ let do_children _ctx x = DoChildren x
+ let proceed = do_children (* alias *)
+
+ let default _ = do_children (* default action *)
+
+ (* Action handling *)
+
+ let handle (fold: 'x -> 'c -> 'a -> 'a action) ~(continue: 'x -> 'c -> 'a -> 'a) ctx n x =
+ match fold ctx n x with
+ | SkipChildren x -> x
+ | DoChildren x -> continue ctx n x
+ | DoChildrenAndThen (x, f) -> continue ctx n x >> f
+
+ let leaf (fold: 'x -> 'c -> 'a -> 'a action) =
+ handle fold ~continue:(fun _ctx _ -> Fun.id)
+
+ class ['a, 'c] folder = object
+ method fold_bool: 'c -> bool -> 'a -> 'a action = default
+ method fold_char: 'c -> char -> 'a -> 'a action = default
+ method fold_int: 'c -> int -> 'a -> 'a action = default
+ method fold_string: 'c -> string -> 'a -> 'a action = default
+ method fold_option: 'x. 'c -> 'x option -> 'a -> 'a action = default
+ method fold_list: 'x. 'c -> 'x list -> 'a -> 'a action = default
+ end
+
+ let fold_bool (v: (_, _) #folder) = leaf v#fold_bool
+ let fold_char (v: (_, _) #folder) = leaf v#fold_char
+ let fold_int (v: (_, _) #folder) = leaf v#fold_int
+ let fold_string (v: (_, _) #folder) = leaf v#fold_string
+ let fold_option ~fold (v: (_, _) #folder) =
+ handle v#fold_option
+ ~continue:(Option.fold ~none:(fun _ctx -> Fun.id) ~some:(fold v))
+ let fold_list ~fold (v: (_, _) #folder) =
+ handle v#fold_list
+ ~continue:(fun ctx l x -> List.fold_left (fun x a -> fold v ctx x a) x l)
+
+end
+
+(* --- *)
+
+(* Fold by default. *)
+include Fold
diff --git a/src/lsp/cobol_config/README.md b/src/lsp/cobol_config/README.md
new file mode 100644
index 000000000..f796326f3
--- /dev/null
+++ b/src/lsp/cobol_config/README.md
@@ -0,0 +1,5 @@
+# Cobol_config package
+
+This package is used to parse config files and generate configurations to use `superbol`.
+
+For API documentation, please see [index.mld].
diff --git a/src/lsp/cobol_config/cobol_config.ml b/src/lsp/cobol_config/cobol_config.ml
new file mode 100644
index 000000000..2b821ca70
--- /dev/null
+++ b/src/lsp/cobol_config/cobol_config.ml
@@ -0,0 +1,278 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Basics
+
+include Types
+
+module Options = Options
+module Default = Default
+
+module DIAGS = Cobol_common.Diagnostics
+module FATAL = DIAGS.Fatal (* any error here should end up in exit. *)
+
+let print_options: Pretty.delayed = fun ppf ->
+ Pretty.list ~fopen:"@[" ~fsep:"@\n" ~fclose:"@]" (fun ppf v -> v#pp ppf)
+ ppf !all_configs
+
+(* --- *)
+
+let default = (module Default: T)
+
+let meet_support (s1: Conf_ast.support_value as 's) (s2: 's) : 's =
+ match s1, s2 with
+ | Ok, _ -> Ok
+ | Warning, (Warning | Archaic | Obsolete | Skip | Ignore | Error |
+ Unconformable) -> Warning
+ | Archaic, (Archaic | Obsolete | Skip | Ignore | Error |
+ Unconformable) -> Archaic
+ | Obsolete, (Obsolete | Skip | Ignore | Error | Unconformable) -> Obsolete
+ | Skip, (Skip | Ignore | Error | Unconformable) -> Skip
+ | Ignore, (Ignore | Error | Unconformable) -> Ignore
+ | Error, (Error | Unconformable) -> Error
+ | _ -> s2
+
+let make_conf conf =
+ let error k v =
+ FATAL.error "Unexpected error for `%s` key: %a" k Conf_ast.pp_value v
+ in
+ let conf =
+ List.fold_left
+ (fun conf elt ->
+ match elt with
+ | Conf_ast.Value {key = "reserved"; value} ->
+ begin match value with
+ | ContextWord s ->
+ Words.RESERVED.add_reserved (s^"*")
+ | String s ->
+ Words.RESERVED.add_reserved s
+ | Alias (Normal (alias, base)) ->
+ Words.RESERVED.add_alias alias base
+ | Alias (Context (alias, base)) ->
+ Words.RESERVED.add_alias (alias^"*") base
+ | _ -> error "reserved" value
+ end;
+ conf
+ | Value {key = "not-reserved"; value = String s } ->
+ Words.RESERVED.remove_reserved s;
+ Words.INTRINSIC.remove_intrinsic s;
+ Words.SYSTEM_NAMES.remove_system_name s;
+ Words.REGISTERS.remove_register s;
+ conf
+ | Value {key = "not-reserved"; value } ->
+ error "not-reserved" value
+ | Value {key = "intrinsic-function"; value = String s } ->
+ Words.INTRINSIC.add_intrinsic s;
+ conf
+ | Value {key = "intrinsic-function"; value } ->
+ error "intrinsic-function" value
+ | Value {key = "not-intrinsic-function"; value = String s} ->
+ Words.INTRINSIC.remove_intrinsic s;
+ conf
+ | Value {key = "not-intrinsic-function"; value} ->
+ error "not-intrinsic-function" value
+ | Value {key = "system-name"; value = String s} ->
+ Words.SYSTEM_NAMES.add_system_name s;
+ conf
+ | Value {key = "system-name"; value} ->
+ error "system-name" value
+ | Value {key = "not-system-name"; value = String s} ->
+ Words.SYSTEM_NAMES.remove_system_name s;
+ conf
+ | Value {key = "not-system-name"; value} ->
+ error "not-system-name" value
+ | Value {key = "register"; value = String s} ->
+ Words.REGISTERS.add_register s;
+ conf
+ | Value {key = "register"; value} ->
+ error "register" value
+ | Value {key = "not-register"; value = String s} ->
+ Words.REGISTERS.remove_register s;
+ conf
+ | Value {key = "not-register"; value} ->
+ error "not-register" value
+ | Value {key; value} ->
+ let value = match value with
+ | Support (Additional s) ->
+ begin match StringMap.find_opt key conf with
+ | Some (Conf_ast.Support (Additional v | Normal v)) ->
+ Conf_ast.Support (Normal (meet_support s v))
+ | _ -> value
+ end
+ | _ -> value
+ in
+ let conf = StringMap.add key value conf in
+ conf
+ | Include s ->
+ FATAL.error "Unresolved include: %s" s
+ | ReservedWords s ->
+ FATAL.error "Unresolved reserved words: %s.words" s)
+ StringMap.empty
+ conf
+ in
+ (conf,
+ Words.RESERVED.words (),
+ Words.INTRINSIC.intrinsic_functions (),
+ Words.SYSTEM_NAMES.system_names (),
+ Words.REGISTERS.registers ())
+
+
+let parse_file file =
+ let open Lexing in
+ let module I = Conf_parser.MenhirInterpreter in
+ let rec handle_parser_error lexbuf checkpoint =
+ match checkpoint with
+ | I.HandlingError env ->
+ begin match I.stack env with
+ | lazy Nil ->
+ let loc = Cobol_common.Srcloc.raw (lexbuf.lex_start_p, lexbuf.lex_curr_p) in
+ FATAL.error ~loc "Syntax error"
+ | lazy (Cons (I.Element (state, _, start_pos, end_pos), _)) ->
+ let loc = Cobol_common.Srcloc.raw (start_pos, end_pos) in
+ FATAL.error ~loc "Syntax error: %s" @@
+ try Conf_parser_messages.message (I.number state) with Not_found -> ""
+ end;
+ | I.Rejected ->
+ FATAL.error "Syntax error: input reject";
+ | _ -> parse lexbuf checkpoint
+ and parse lexbuf (checkpoint: Conf_ast.t I.checkpoint) =
+ I.loop_handle
+ Fun.id
+ (handle_parser_error lexbuf)
+ (fun () ->
+ let token = Conf_lexer.main lexbuf in
+ token, lexbuf.lex_start_p, lexbuf.lex_curr_p)
+ checkpoint
+ in
+ let ic = open_in file in
+ let lexbuf = Lexing.from_channel ~with_positions:true ic in
+ let ast =
+ try parse lexbuf (Conf_parser.Incremental.file lexbuf.lex_curr_p)
+ with Conf_lexer.LexError (msg, start_p, end_p) ->
+ let loc = Cobol_common.Srcloc.raw (start_p, end_p) in
+ FATAL.error ~loc "Lexing Error: %s" msg;
+ in
+ close_in ic;
+ ast
+
+let path_to_search =
+ lazy begin
+ let cwd = Ez_file.FileString.getcwd () in
+ let l = "/usr/local/share/gnucobol/config"::[] in
+ let l = match Sys.getenv_opt "COB_CONFIG_DIR" with
+ | Some d -> d::l
+ | None -> l
+ in
+ let xdg_conf = match Sys.getenv_opt "XDG_CONFIG_HOME" with
+ | None -> Ez_file.FileString.add_path (Sys.getenv "HOME") ".config"
+ | Some p -> p
+ in
+ cwd :: Ez_file.FileString.add_path xdg_conf "superbol" :: l
+ end
+
+let first_file paths filename =
+ Cobol_common.Basics.LIST.fold_left_while
+ Option.is_none
+ (fun _ dir ->
+ let filepath = Ez_file.FileString.add_path dir filename in
+ if Ez_file.FileString.exists filepath then
+ if not @@ Ez_file.FileString.is_directory filepath then
+ Some filepath
+ else
+ None
+ else
+ None)
+ None
+ paths
+
+
+let from_file (module Diags: DIAGS.STATEFUL) ?(dialect: dialect option) file =
+ let rec aux file =
+ let options = parse_file file in
+ let path_to_search =
+ Ez_file.FileString.dirname file :: Lazy.force path_to_search
+ in
+ List.fold_left begin fun acc option -> match option with
+ | Conf_ast.Value _ ->
+ acc @ [option]
+ | ReservedWords words
+ when (String.lowercase_ascii words) <> "off" &&
+ (String.lowercase_ascii words) <> "default" ->
+ let basename = String.lowercase_ascii words in
+ let filename = Ez_file.FileString.add_suffix basename ".words" in
+ begin match first_file path_to_search filename with
+ | Some file_path ->
+ acc @ aux file_path
+ | None ->
+ FATAL.error "Words@ file@ not@ found:@ %s" filename;
+ end
+ | ReservedWords words
+ when words = "default" ->
+ Words.RESERVED.add_reserved "DIALECT-ALL";
+ acc
+ | ReservedWords _ ->
+ acc
+ | Include file ->
+ begin match first_file path_to_search file with
+ | Some file_path ->
+ acc @ aux file_path
+ | None ->
+ FATAL.error "Configuration@ file@ not@ found:@ %s" file
+ end
+ end [] options
+ in
+ Pretty.error "@[Loading@ configuration@ from@ `%s'@]@." file;
+ let options = aux file in
+ let options, words, intrinsic, system_names, registers
+ = make_conf options in
+ let module Config =
+ From_file.Make (Diags) (struct
+ let config =
+ { name = match StringMap.find "name" options with
+ | Conf_ast.String s -> s
+ | v -> Pretty.failwith "Expecting a string for the `name' option, \
+ got: %a" Conf_ast.pp_value v }
+ let dialect = match dialect with
+ | Some d -> d
+ | None -> try DIALECT.of_name config.name with
+ | Invalid_argument _ -> FATAL.error "unknown dialect: %s" config.name
+ let options = options
+ let words = words
+ let intrinsic_functions = intrinsic
+ let system_names = system_names
+ let registers = registers
+ end)
+ in
+ (module Config: T)
+
+let try_from_file (module Diags: DIAGS.STATEFUL) dialect file =
+ match first_file (Lazy.force path_to_search) file with
+ | Some f ->
+ from_file (module Diags) ~dialect f
+ | None ->
+ FATAL.error "Unable@ to@ locate@ a@ configuration@ file@ for@ dialect:@ \
+ `%s'" (DIALECT.name dialect)
+
+let from_dialect (module Diags: DIAGS.STATEFUL) ~strict d =
+ let load_gnucobol_conf dialect ~strict confname =
+ try_from_file (module Diags) dialect
+ (Pretty.to_string "%s%s.conf" confname (if strict then "-strict" else ""))
+ in
+ match d with
+ | DIALECT.Default -> (module Default: T)
+ | COBOL85 -> load_gnucobol_conf d ~strict:false "cobol85"
+ | GnuCOBOL -> load_gnucobol_conf d ~strict:false "default"
+ | ACU -> load_gnucobol_conf d ~strict "acu"
+ | MicroFocus -> load_gnucobol_conf d ~strict "mf"
+ | GCOS -> load_gnucobol_conf d ~strict "gcos"
+ | IBM -> load_gnucobol_conf d ~strict "ibm"
diff --git a/src/lsp/cobol_config/cobol_config.mli b/src/lsp/cobol_config/cobol_config.mli
new file mode 100644
index 000000000..098d5592e
--- /dev/null
+++ b/src/lsp/cobol_config/cobol_config.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This library is used to build configuration modules, either from file or
+ from a dialect. All the [from_] functions will fail if a file is not found,
+ or use the default value of any options that is badly typed in the
+ configuration file or not set in the configuration file.*)
+
+include module type of Types
+
+module Options = Options
+module Default = Default
+
+val print_options: Format.formatter -> unit
+
+val default: (module T)
+
+val from_file
+ : (module Cobol_common.Diagnostics.STATEFUL)
+ -> ?dialect: Types.DIALECT.t
+ -> string
+ -> (module T)
+
+(** [from_dialect (module Diags) ?strict dialect] returns the configuration
+ module according to the dialect defaults. *)
+val from_dialect
+ : (module Cobol_common.Diagnostics.STATEFUL)
+ -> strict: bool
+ -> Types.DIALECT.t
+ -> (module T)
diff --git a/src/lsp/cobol_config/conf_ast.ml b/src/lsp/cobol_config/conf_ast.ml
new file mode 100644
index 000000000..86329e65f
--- /dev/null
+++ b/src/lsp/cobol_config/conf_ast.ml
@@ -0,0 +1,62 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+type support_value =
+ | Ok
+ | Warning
+ | Archaic
+ | Obsolete
+ | Skip
+ | Ignore
+ | Error
+ | Unconformable
+
+type support =
+ | Normal of support_value
+ | Additional of support_value
+
+type alias =
+ | Normal of string * string
+ | Context of string * string
+
+type value =
+ | Any of string
+ | Bool of bool
+ | Int of int
+ | String of string
+ | Support of support
+ | ContextWord of string
+ | Alias of alias
+
+let pp_value fmt = function
+ | Any s -> Pretty.print fmt "any (%s)" s
+ | Bool b -> Pretty.print fmt "boolean (%B)" b
+ | Int i -> Pretty.print fmt "integer (%d)" i
+ | String s -> Pretty.print fmt "string (%s)" s
+ | ContextWord s -> Pretty.print fmt "word (%s*)" s
+ | Support _ -> Pretty.print fmt "support"
+ | Alias (Context (a, v)) -> Pretty.print fmt "alias (%s*=%s)" a v
+ | Alias (Normal (a, v)) -> Pretty.print fmt "alias (%s=%s)" a v
+
+
+type set_value =
+ { key: string;
+ value: value; }
+
+type conf_node =
+ | ReservedWords of string
+ | Include of string
+ | Value of set_value
+
+type t = conf_node list
+
diff --git a/src/lsp/cobol_config/conf_lexer.mll b/src/lsp/cobol_config/conf_lexer.mll
new file mode 100644
index 000000000..484f6aa14
--- /dev/null
+++ b/src/lsp/cobol_config/conf_lexer.mll
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+{
+ open Lexing
+ open Conf_parser
+ exception LexError of string * Lexing.position * Lexing.position
+}
+
+let newline = '\r'* '\n'
+let spaces = [' ' '\t']
+let letter = ['a'-'z' 'A'-'Z']
+let digit = ['0'-'9']
+let punct = (newline | spaces)
+let true = "true"
+let false = "false"
+let yes = "yes"
+let no = "no"
+let boolean = true | false | yes | no
+let integer = ('+' | '-')? digit+
+let ident_chars = letter | '-' | digit
+let ident = letter ident_chars*
+let value_char = letter | digit
+let value = value_char (value_char | '-' | '_')*
+
+let reserved_words = "reserved-words"
+let reserved = "reserved"
+let not_reserved = "not-reserved"
+let intrinsic_function = "intrinsic-function"
+let not_intrinsic_function = "not-intrinsic-function"
+let system_name = "system-name"
+let not_system_name = "not-system-name"
+let register = "register"
+let not_register = "not-register"
+let include = "include"
+
+rule main = parse
+| newline { Lexing.new_line lexbuf; main lexbuf }
+| spaces { main lexbuf }
+| ":" { COLON }
+| "#" { single_line_comment lexbuf }
+| '"' { read_string (Buffer.create 17) lexbuf}
+| "*" { STAR }
+| "=" { EQ }
+| "+" { PLUS }
+| reserved_words { RESERVED_WORDS }
+| reserved { RESERVED }
+| not_reserved { NOT_RESERVED }
+| intrinsic_function { INTRINSIC_FUNCTION }
+| not_intrinsic_function { NOT_INTRINSIC_FUNCTION }
+| system_name { SYSTEM_NAME}
+| not_system_name { NOT_SYSTEM_NAME }
+| register { REGISTER }
+| not_register { NOT_REGISTER }
+| "ok" { OK }
+| "warning" { WARNING }
+| "archaic" { ARCHAIC }
+| "obsolete" { OBSOLETE }
+| "skip" { SKIP }
+| "ignore" { IGNORE }
+| "error" { ERROR }
+| "unconformable" { UNCONFORMABLE }
+| include { INCLUDE }
+| true | yes { BOOLEAN true }
+| false | no { BOOLEAN false }
+| integer as i { INT (int_of_string i) }
+| ident as i { IDENT i }
+| value as x { ANY x }
+| _ as c { raise @@ LexError (Format.sprintf "Invalid char: %c" c, lexbuf.lex_start_p, lexbuf.lex_curr_p) }
+| eof { EOF }
+
+and single_line_comment = parse
+| newline { new_line lexbuf; main lexbuf }
+| eof { EOF }
+| _ { single_line_comment lexbuf }
+
+and read_string buf = parse
+| '"' { STRING (Buffer.contents buf) }
+| '\\' '\\' { Buffer.add_string buf "\\"; read_string buf lexbuf }
+| '\\' '\ ' { Buffer.add_string buf "\ "; read_string buf lexbuf }
+| [^ '"' '\\']+ { Buffer.add_string buf (Lexing.lexeme lexbuf); read_string buf lexbuf }
+| _ as c { raise @@ LexError (Format.sprintf "Invalid char: %c" c, lexbuf.lex_start_p, lexbuf.lex_curr_p) }
+| eof { raise @@ LexError ("Unexpected end of string", lexbuf.lex_start_p, lexbuf.lex_curr_p) }
diff --git a/src/lsp/cobol_config/conf_parser.messages b/src/lsp/cobol_config/conf_parser.messages
new file mode 100644
index 000000000..44149219e
--- /dev/null
+++ b/src/lsp/cobol_config/conf_parser.messages
@@ -0,0 +1,173 @@
+file: WARNING
+##
+## Ends in an error in state: 0.
+##
+## file' -> . file [ # ]
+##
+## The known suffix of the stack is as follows:
+##
+##
+
+Expecting at least one rule in the configuration file.
+
+file: RESERVED WARNING
+##
+## Ends in an error in state: 2.
+##
+## word_rule -> RESERVED . option(COLON) ANY option(STAR) EQ ANY [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+## word_rule -> RESERVED . option(COLON) ANY option(STAR) [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## RESERVED
+##
+
+Expecting a ':', a word or an alias after 'reserved'.
+
+file: RESERVED COLON WARNING
+##
+## Ends in an error in state: 4.
+##
+## word_rule -> RESERVED option(COLON) . ANY option(STAR) EQ ANY [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+## word_rule -> RESERVED option(COLON) . ANY option(STAR) [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## RESERVED option(COLON)
+##
+
+Expecting a word or an alias after 'reserved'.
+
+file: RESERVED ANY WARNING
+##
+## Ends in an error in state: 5.
+##
+## word_rule -> RESERVED option(COLON) ANY . option(STAR) EQ ANY [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+## word_rule -> RESERVED option(COLON) ANY . option(STAR) [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## RESERVED option(COLON) ANY
+##
+
+Expecting another rule or end of file after a configuration rule.
+
+file: RESERVED ANY STAR WARNING
+##
+## Ends in an error in state: 7.
+##
+## word_rule -> RESERVED option(COLON) ANY option(STAR) . EQ ANY [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+## word_rule -> RESERVED option(COLON) ANY option(STAR) . [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## RESERVED option(COLON) ANY option(STAR)
+##
+
+Expecting another rule or end of file after a configuration rule.
+
+file: RESERVED ANY EQ WARNING
+##
+## Ends in an error in state: 8.
+##
+## word_rule -> RESERVED option(COLON) ANY option(STAR) EQ . ANY [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## RESERVED option(COLON) ANY option(STAR) EQ
+##
+
+Expecting another word after '='.
+
+file: INCLUDE WARNING
+##
+## Ends in an error in state: 16.
+##
+## rule -> INCLUDE . option(COLON) STRING [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## INCLUDE
+##
+
+Expecting a ':' or a string after 'include'.
+
+file: INCLUDE COLON WARNING
+##
+## Ends in an error in state: 17.
+##
+## rule -> INCLUDE option(COLON) . STRING [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## INCLUDE option(COLON)
+##
+
+Expecting a string after 'include'.
+
+file: IDENT SYSTEM_NAME
+##
+## Ends in an error in state: 19.
+##
+## rule -> IDENT . option(COLON) value [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## IDENT
+##
+
+Expecting a ':' or a value after an rule identifier.
+
+file: IDENT COLON SYSTEM_NAME
+##
+## Ends in an error in state: 20.
+##
+## rule -> IDENT option(COLON) . value [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## IDENT option(COLON)
+##
+
+Expecting a value after a rule identifier.
+
+file: IDENT PLUS SYSTEM_NAME
+##
+## Ends in an error in state: 25.
+##
+## support -> PLUS . support_value [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## PLUS
+##
+
+Expecting a support value after a '+'.
+
+file: INTRINSIC_FUNCTION WARNING
+##
+## Ends in an error in state: 40.
+##
+## word_rule -> word_key . option(COLON) any_or_string [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## word_key
+##
+
+Expecting a word for this configuration rule.
+
+file: INTRINSIC_FUNCTION COLON WARNING
+##
+## Ends in an error in state: 41.
+##
+## word_rule -> word_key option(COLON) . any_or_string [ SYSTEM_NAME RESERVED REGISTER NOT_SYSTEM_NAME NOT_RESERVED NOT_REGISTER NOT_INTRINSIC_FUNCTION INTRINSIC_FUNCTION INCLUDE IDENT EOF ]
+##
+## The known suffix of the stack is as follows:
+## word_key option(COLON)
+##
+
+Expecting a word for this configuration rule.
+
+file: INTRINSIC_FUNCTION ANY WARNING
+##
+## Ends in an error in state: 48.
+##
+## rules -> rule . [ EOF ]
+## rules -> rule . rules [ EOF ]
+##
+## The known suffix of the stack is as follows:
+## rule
+##
+
+Expecting another rule or end of file after a configuration rule.
+
diff --git a/src/lsp/cobol_config/conf_parser.mly b/src/lsp/cobol_config/conf_parser.mly
new file mode 100644
index 000000000..ca480252b
--- /dev/null
+++ b/src/lsp/cobol_config/conf_parser.mly
@@ -0,0 +1,111 @@
+(**************************************************************************)
+(* Copyright (c) 2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This file is distributed under the terms of the *)
+(* OCAMLPRO-NON-COMMERCIAL license. *)
+(* *)
+(**************************************************************************)
+
+%{
+open Conf_ast
+%}
+
+%token INT
+%token BOOLEAN (* Because of `yes`/`no` *)
+%token IDENT
+%token ANY
+%token STRING
+%token INCLUDE
+%token COLON
+%token STAR
+%token EQ
+%token PLUS
+
+%token OK
+%token WARNING
+%token ARCHAIC
+%token OBSOLETE
+%token SKIP
+%token IGNORE
+%token ERROR
+%token UNCONFORMABLE
+%token EOF
+
+%token RESERVED_WORDS
+%token RESERVED
+%token NOT_RESERVED
+%token INTRINSIC_FUNCTION
+%token NOT_INTRINSIC_FUNCTION
+%token SYSTEM_NAME
+%token NOT_SYSTEM_NAME
+%token REGISTER
+%token NOT_REGISTER
+
+%start file
+
+%%
+let file :=
+ | ~=rules; EOF; <>
+
+let rules :=
+ | r=rule; { [r] }
+ | r=rule; rl=rules; { r::rl }
+
+let rule :=
+ | INCLUDE; COLON?; ~=STRING;
+ | RESERVED_WORDS; COLON?; ~=any_or_string;
+ | ~=word_rule; <>
+ | key=IDENT; COLON?; value=value; { Value {key; value} }
+
+let word_rule :=
+ | RESERVED; COLON?; alias=any_or_string; o=STAR?; EQ; word=any_or_string;
+ { let alias = match o with
+ | Some _ -> Context (alias, word)
+ | None -> Normal (alias, word)
+ in
+ Value {key = "reserved"; value = Alias alias} }
+ | RESERVED; COLON?; value=any_or_string; o=STAR?;
+ { Value {key = "reserved"; value =
+ match o with
+ | Some _ -> ContextWord value;
+ | None -> String value; } }
+ | key=word_key; COLON?; value=any_or_string;
+ { Value {key; value = String value} }
+
+let word_key :=
+ | NOT_RESERVED; { "not-reserved" }
+ | INTRINSIC_FUNCTION; { "intrinsic-function" }
+ | NOT_INTRINSIC_FUNCTION; { "not-intrinsic-function" }
+ | SYSTEM_NAME; { "system-name" }
+ | NOT_SYSTEM_NAME; { "not-system-name" }
+ | REGISTER; { "register" }
+ | NOT_REGISTER; { "not-register" }
+
+let any_or_string :=
+ | ~=ANY; <>
+ | ~=STRING; <>
+ | ~=IDENT; <>
+
+let value :=
+ | ~=ANY;
+ | ~=BOOLEAN;
+ | ~=INT;
+ | ~=STRING;
+ | ~=IDENT;
+ | ~=support;
+
+let support :=
+| ~=support_value;
+| PLUS; ~=support_value;
+
+let support_value :=
+| OK; { Ok }
+| WARNING; { Warning }
+| ARCHAIC; { Archaic }
+| OBSOLETE; { Obsolete }
+| SKIP; { Skip }
+| IGNORE; { Ignore }
+| ERROR; { Error }
+| UNCONFORMABLE; { Unconformable }
+
diff --git a/src/lsp/cobol_config/default.ml b/src/lsp/cobol_config/default.ml
new file mode 100644
index 000000000..627f394ca
--- /dev/null
+++ b/src/lsp/cobol_config/default.ml
@@ -0,0 +1,311 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Module containing all the default options *)
+open Cobol_common.Basics
+
+let not_reserved =
+ ["TERMINAL"; "EXAMINE"]
+
+let default_aliases =
+ [ "AUTO-SKIP", "AUTO";
+ "AUTOTERMINATE", "AUTO";
+ "BACKGROUND-COLOUR", "BACKGROUND-COLOR";
+ "BEEP", "BELL";
+ "BINARY-INT", "BINARY-LONG";
+ "BINARY-LONG-LONG", "BINARY-DOUBLE";
+ "CELLS", "CELL";
+ "COLOURS", "COLORS";
+ "EMPTY-CHECK", "REQUIRED";
+ "EQUALS", "EQUAL";
+ "FOREGROUND-COLOUR", "FOREGROUND-COLOR";
+ "HIGH-VALUES", "HIGH-VALUE";
+ "INITIALISE", "INITIALIZE";
+ "INITIALISED", "INITIALIZED";
+ "LENGTH-CHECK", "FULL";
+ "LOW-VALUES", "LOW-VALUE";
+ "ORGANISATION", "ORGANIZATION";
+ "PIXELS", "PIXEL";
+ "SYNCHRONISED", "SYNCHRONIZED";
+ "TIMEOUT", "TIME-OUT";
+ "ZEROES", "ZERO";
+ "ZEROS", "ZERO"]
+
+module Default: Types.T = struct
+ open Types
+ let dialect = DIALECT.Default
+ let config = { name = DIALECT.name dialect }
+
+ let words =
+ let alias_for b = ReserveAlias { alias_for = b;
+ preserve_context_sensitivity = false } in
+ Reserved_words.words @
+ List.map (fun w -> w, NotReserved) not_reserved @
+ List.map (fun (a, b) -> a, alias_for b) default_aliases
+
+ let not_reserved = StringSet.of_list not_reserved
+ let intrinsic_functions = StringSet.diff Reserved_words.default_intrinsics not_reserved
+ let system_names = StringSet.diff Reserved_words.default_system_names not_reserved
+ let registers = StringSet.diff Reserved_words.default_registers not_reserved
+
+ (* int options *)
+ open Options
+ let tab_width
+ = tab_width#from_val ~config 8
+ let text_column
+ = text_column#from_val ~config 72
+ let pic_length
+ = pic_length#from_val ~config 255
+ let word_length
+ = word_length#from_val ~config 63
+ let literal_length
+ = literal_length#from_val ~config 8191
+ let numeric_literal_length
+ = numeric_literal_length#from_val ~config 38
+
+ (* any options *)
+ let defaultbyte
+ = defaultbyte#from_val ~config Init
+ let standard_define
+ = standard_define#from_val ~config GnuCOBOL
+ let format
+ = format#from_val ~config Auto
+ let binary_size
+ = binary_size#from_val ~config B_1_2_4_8
+ let binary_byteorder
+ = binary_byteorder#from_val ~config Big_endian
+ let assign_clause
+ = assign_clause#from_val ~config Dynamic
+ let screen_section_rules
+ = screen_section_rules#from_val ~config GC
+ let dpc_in_data
+ = dpc_in_data#from_val ~config XML
+
+ (* boolean options *)
+ let filename_mapping
+ = filename_mapping#from_val ~config true
+ let pretty_display
+ = pretty_display#from_val ~config true
+ let binary_truncate
+ = binary_truncate#from_val ~config true
+ let complex_odo
+ = complex_odo#from_val ~config false
+ let odoslide
+ = odoslide#from_val ~config false
+ let indirect_redefines
+ = indirect_redefines#from_val ~config false
+ let relax_syntax_checks
+ = relax_syntax_checks#from_val ~config false
+ let ref_mod_zero_length
+ = ref_mod_zero_length#from_val ~config true
+ let relax_level_hierarchy
+ = relax_level_hierarchy#from_val ~config false
+ let select_working
+ = select_working#from_val ~config false
+ let local_implies_recursive
+ = local_implies_recursive#from_val ~config false
+ let sticky_linkage
+ = sticky_linkage#from_val ~config false
+ let move_ibm
+ = move_ibm#from_val ~config false
+ let perform_osvs
+ = perform_osvs#from_val ~config false
+ let arithmetic_osvs
+ = arithmetic_osvs#from_val ~config false
+ let hostsign
+ = hostsign#from_val ~config false
+ let program_name_redefinition
+ = program_name_redefinition#from_val ~config true
+ let accept_update
+ = accept_update#from_val ~config false
+ let accept_auto
+ = accept_auto#from_val ~config false
+ let console_is_crt
+ = console_is_crt#from_val ~config false
+ let no_echo_means_secure
+ = no_echo_means_secure#from_val ~config false
+ let line_col_zero_default
+ = line_col_zero_default#from_val ~config true
+ let display_special_fig_consts
+ = display_special_fig_consts#from_val ~config false
+ let binary_comp_1
+ = binary_comp_1#from_val ~config false
+ let numeric_pointer
+ = numeric_pointer#from_val ~config false
+ let move_non_numeric_lit_to_numeric_is_zero
+ = move_non_numeric_lit_to_numeric_is_zero#from_val ~config false
+ let implicit_assign_dynamic_var
+ = implicit_assign_dynamic_var#from_val ~config true
+ let device_mnemonics
+ = device_mnemonics#from_val ~config false
+ let xml_parse_xmlss
+ = xml_parse_xmlss#from_val ~config true
+ let areacheck
+ = areacheck#from_val ~config false
+ let ebcdic_symbolic_characters
+ = ebcdic_symbolic_characters#from_val ~config false
+
+ (* support options *)
+ let comment_paragraphs
+ = comment_paragraphs#from_level ~config @@ Obsolete ()
+ let safe_partial_replacing_when_src_literal
+ = safe_partial_replacing_when_src_literal#from_level ~config @@ Obsolete `Unsafe
+ let control_division
+ = control_division#from_level ~config Unconformable
+ let memory_size_clause
+ = memory_size_clause#from_level ~config @@ Obsolete ()
+ let multiple_file_tape_clause
+ = multiple_file_tape_clause#from_level ~config @@ Obsolete ()
+ let label_records_clause
+ = label_records_clause#from_level ~config @@ Obsolete ()
+ let value_of_clause
+ = value_of_clause#from_level ~config @@ Obsolete ()
+ let data_records_clause
+ = data_records_clause#from_level ~config @@ Obsolete ()
+ let top_level_occurs_clause
+ = top_level_occurs_clause#from_level ~config @@ Ok ()
+ let same_as_clause
+ = same_as_clause#from_level ~config @@ Ok ()
+ let type_to_clause
+ = type_to_clause#from_level ~config @@ Ok ()
+ let usage_type
+ = usage_type#from_level ~config @@ Ok ()
+ let synchronized_clause
+ = synchronized_clause#from_level ~config @@ Ok ()
+ let sync_left_right
+ = sync_left_right#from_level ~config @@ Ok ()
+ let special_names_clause
+ = special_names_clause#from_level ~config @@ Ok ()
+ let goto_statement_without_name
+ = goto_statement_without_name#from_level ~config @@ Obsolete ()
+ let stop_literal_statement
+ = stop_literal_statement#from_level ~config @@ Obsolete ()
+ let stop_identifier_statement
+ = stop_identifier_statement#from_level ~config @@ Obsolete ()
+ let stop_error_statement
+ = stop_error_statement#from_level ~config Unconformable
+ let debugging_mode
+ = debugging_mode#from_level ~config @@ Ok ()
+ let use_for_debugging
+ = use_for_debugging#from_level ~config @@ Ok ()
+ let padding_character_clause
+ = padding_character_clause#from_level ~config @@ Obsolete ()
+ let next_sentence_phrase
+ = next_sentence_phrase#from_level ~config @@ Archaic ()
+ let listing_statements
+ = listing_statements#from_level ~config Skip
+ let title_statement
+ = title_statement#from_level ~config Skip
+ let entry_statement
+ = entry_statement#from_level ~config @@ Ok ()
+ let move_noninteger_to_alphanumeric
+ = move_noninteger_to_alphanumeric#from_level ~config Error
+ let move_figurative_constant_to_numeric
+ = move_figurative_constant_to_numeric#from_level ~config @@ Archaic ()
+ let move_figurative_space_to_numeric
+ = move_figurative_space_to_numeric#from_level ~config Error
+ let move_figurative_quote_to_numeric
+ = move_figurative_quote_to_numeric#from_level ~config @@ Obsolete ()
+ let odo_without_to
+ = odo_without_to#from_level ~config @@ Warning ()
+ let section_segments
+ = section_segments#from_level ~config Ignore
+ let alter_statement
+ = alter_statement#from_level ~config @@ Obsolete ()
+ let call_overflow
+ = call_overflow#from_level ~config @@ Archaic ()
+ let numeric_boolean
+ = numeric_boolean#from_level ~config @@ Ok ()
+ let hexadecimal_boolean
+ = hexadecimal_boolean#from_level ~config @@ Ok ()
+ let national_literals
+ = national_literals#from_level ~config @@ Ok ()
+ let hexadecimal_national_literals
+ = hexadecimal_national_literals#from_level ~config @@ Ok ()
+ let national_character_literals
+ = national_character_literals#from_level ~config @@ Warning ()
+ let hp_octal_literals
+ = hp_octal_literals#from_level ~config Unconformable
+ let acu_literals
+ = acu_literals#from_level ~config Unconformable
+ let word_continuation
+ = word_continuation#from_level ~config @@ Warning ()
+ let not_exception_before_exception
+ = not_exception_before_exception#from_level ~config @@ Ok ()
+ let accept_display_extensions
+ = accept_display_extensions#from_level ~config @@ Ok ()
+ let larger_redefines
+ = larger_redefines#from_level ~config Error
+ let symbolic_constant
+ = symbolic_constant#from_level ~config @@ Ok ()
+ let constant_78
+ = constant_78#from_level ~config @@ Ok ()
+ let constant_01
+ = constant_01#from_level ~config @@ Ok ()
+ let perform_varying_without_by
+ = perform_varying_without_by#from_level ~config @@ Ok ()
+ let reference_out_of_declaratives
+ = reference_out_of_declaratives#from_level ~config @@ Warning ()
+ let program_prototypes
+ = program_prototypes#from_level ~config @@ Ok ()
+ let call_convention_mnemonic
+ = call_convention_mnemonic#from_level ~config @@ Ok ()
+ let call_convention_linkage
+ = call_convention_linkage#from_level ~config @@ Ok ()
+ let numeric_value_for_edited_item
+ = numeric_value_for_edited_item#from_level ~config @@ Ok ()
+ let incorrect_conf_sec_order
+ = incorrect_conf_sec_order#from_level ~config @@ Ok ()
+ let define_constant_directive
+ = define_constant_directive#from_level ~config @@ Archaic ()
+ let free_redefines_position
+ = free_redefines_position#from_level ~config @@ Warning ()
+ let records_mismatch_record_clause
+ = records_mismatch_record_clause#from_level ~config @@ Warning ()
+ let record_delimiter
+ = record_delimiter#from_level ~config @@ Ok ()
+ let sequential_delimiters
+ = sequential_delimiters#from_level ~config @@ Ok ()
+ let record_delim_with_fixed_recs
+ = record_delim_with_fixed_recs#from_level ~config @@ Ok ()
+ let missing_statement
+ = missing_statement#from_level ~config @@ Warning ()
+ let missing_period
+ = missing_period#from_level ~config @@ Warning ()
+ let zero_length_literals
+ = zero_length_literals#from_level ~config @@ Ok ()
+ let xml_generate_extra_phrases
+ = xml_generate_extra_phrases#from_level ~config @@ Ok ()
+ let continue_after
+ = continue_after#from_level ~config @@ Ok ()
+ let goto_entry
+ = goto_entry#from_level ~config @@ Warning ()
+ let assign_variable
+ = assign_variable#from_level ~config @@ Ok ()
+ let assign_using_variable
+ = assign_using_variable#from_level ~config @@ Ok ()
+ let assign_ext_dyn
+ = assign_ext_dyn#from_level ~config @@ Ok ()
+ let assign_disk_from
+ = assign_disk_from#from_level ~config @@ Ok ()
+ let vsam_status
+ = vsam_status#from_level ~config Ignore
+ let self_call_recursive
+ = self_call_recursive#from_level ~config @@ Warning ()
+ let record_contains_depending_clause
+ = record_contains_depending_clause#from_level ~config Unconformable
+ let picture_l
+ = picture_l#from_level ~config @@ Ok ()
+end
+
+include Default
diff --git a/src/lsp/cobol_config/default.mli b/src/lsp/cobol_config/default.mli
new file mode 100644
index 000000000..b912ec9f2
--- /dev/null
+++ b/src/lsp/cobol_config/default.mli
@@ -0,0 +1,15 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module contains all the default configurations. *)
+include Types.T
diff --git a/src/lsp/cobol_config/dune b/src/lsp/cobol_config/dune
new file mode 100644
index 000000000..83040b777
--- /dev/null
+++ b/src/lsp/cobol_config/dune
@@ -0,0 +1,36 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_config)
+ (public_name cobol_config)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries pretty ppx_deriving menhirLib cobol_common )
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show))
+
+ )
+
+(ocamllex conf_lexer)
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_config))
+
+; use field 'dune-trailer' to add more stuff here
+
+(rule (targets conf_parser_messages.ml)
+ (deps conf_parser.messages conf_parser.mly)
+ (action
+ (with-stdout-to %{targets}
+ (run menhir --compile-errors %{deps}))))
+
+
+(menhir (modules conf_parser) (flags --inspection --table))
+
diff --git a/src/lsp/cobol_config/from_file.ml b/src/lsp/cobol_config/from_file.ml
new file mode 100644
index 000000000..45175a09d
--- /dev/null
+++ b/src/lsp/cobol_config/from_file.ml
@@ -0,0 +1,224 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Types
+open Options
+open Cobol_common.Basics
+
+module Make
+ (Diags: Cobol_common.Diagnostics.STATEFUL)
+ (Conf: sig
+ include Types.CONFIG
+ val options: Conf_ast.value StringMap.t
+ val words: Types.words_spec
+ val intrinsic_functions: StringSet.t
+ val system_names: StringSet.t
+ val registers: StringSet.t
+ end): T = struct
+ open Conf
+
+ exception LookupError
+
+ let warn t n v =
+ Diags.warn "`%s`@ expected@ a@ value@ of@ type@ %s,@ but@ got@ %a;@ \
+ resorting@ to@ the@ default@ value." n t Conf_ast.pp_value v
+
+ let not_found n =
+ Diags.warn "Could@ not@ find@ a@ configuration@ for@ `%s';@ using@ the@ \
+ default@ value." n
+
+ let find_any name =
+ match StringMap.find_opt name options with
+ | Some (Any v | String v) -> v
+ | Some (Int i) -> string_of_int i
+ | Some v ->
+ warn "any" name v;
+ raise LookupError
+ | None -> not_found name; raise LookupError
+
+ let find_bool name =
+ match StringMap.find_opt name options with
+ | Some Bool v -> v
+ | Some v ->
+ warn "boolean" name v;
+ raise LookupError
+ | None -> not_found name; raise LookupError
+
+ let find_int name =
+ match StringMap.find_opt name options with
+ | Some Int v -> v
+ | Some v ->
+ warn "int" name v;
+ raise LookupError
+ | None -> not_found name; raise LookupError
+
+ let find_support name =
+ match StringMap.find_opt name options with
+ | Some Support (Normal v| Additional v) -> v
+ | Some v ->
+ warn "support" name v;
+ raise LookupError
+ | None -> not_found name; raise LookupError
+
+
+ let config = config
+ let dialect = dialect
+
+ (* reserved_words *)
+ let words = words
+ let intrinsic_functions = intrinsic_functions
+ let system_names = system_names
+ let registers = registers
+
+
+ let parse_value finder v default =
+ try v#from_val ~config (finder v#name)
+ with LookupError -> default
+ let parse_int_value = parse_value find_int
+ let parse_bool_value = parse_value find_bool
+ let parse_string_value v default =
+ try v#from_string ~config (find_any v#name)
+ with LookupError -> default
+ let parse_support_value v default =
+ try v#from_ast ~config (find_support v#name)
+ with LookupError -> default
+
+ (* int values *)
+ let tab_width = parse_int_value tab_width Default.tab_width
+ let text_column = parse_int_value text_column Default.text_column
+ let pic_length = parse_int_value pic_length Default.pic_length
+ let word_length = parse_int_value word_length Default.word_length
+ let literal_length = parse_int_value literal_length Default.literal_length
+ let numeric_literal_length = parse_int_value numeric_literal_length
+ Default.numeric_literal_length
+
+ (* any values *)
+ let defaultbyte = parse_string_value defaultbyte Default.defaultbyte
+ let standard_define = parse_string_value standard_define Default.standard_define
+ let format = parse_string_value format Default.format
+ let binary_size = parse_string_value binary_size Default.binary_size
+ let binary_byteorder = parse_string_value binary_byteorder Default.binary_byteorder
+ let assign_clause = parse_string_value assign_clause Default.assign_clause
+ let screen_section_rules = parse_string_value screen_section_rules Default.screen_section_rules
+ let dpc_in_data = parse_string_value dpc_in_data Default.dpc_in_data
+
+ (* boolean values *)
+ let filename_mapping = parse_bool_value filename_mapping Default.filename_mapping
+ let pretty_display = parse_bool_value pretty_display Default.pretty_display
+ let binary_truncate = parse_bool_value binary_truncate Default.binary_truncate
+ let complex_odo = parse_bool_value complex_odo Default.complex_odo
+ let odoslide = parse_bool_value odoslide Default.odoslide
+ let indirect_redefines = parse_bool_value indirect_redefines Default.indirect_redefines
+ let relax_syntax_checks = parse_bool_value relax_syntax_checks Default.relax_syntax_checks
+ let ref_mod_zero_length = parse_bool_value ref_mod_zero_length Default.ref_mod_zero_length
+ let relax_level_hierarchy = parse_bool_value relax_level_hierarchy Default.relax_level_hierarchy
+ let select_working = parse_bool_value select_working Default.select_working
+ let local_implies_recursive = parse_bool_value local_implies_recursive Default.local_implies_recursive
+ let sticky_linkage = parse_bool_value sticky_linkage Default.sticky_linkage
+ let move_ibm = parse_bool_value move_ibm Default.move_ibm
+ let perform_osvs = parse_bool_value perform_osvs Default.perform_osvs
+ let arithmetic_osvs = parse_bool_value arithmetic_osvs Default.arithmetic_osvs
+ let hostsign = parse_bool_value hostsign Default.hostsign
+ let program_name_redefinition = parse_bool_value program_name_redefinition Default.program_name_redefinition
+ let accept_update = parse_bool_value accept_update Default.accept_update
+ let accept_auto = parse_bool_value accept_auto Default.accept_auto
+ let console_is_crt = parse_bool_value console_is_crt Default.console_is_crt
+ let no_echo_means_secure = parse_bool_value no_echo_means_secure Default.no_echo_means_secure
+ let line_col_zero_default = parse_bool_value line_col_zero_default Default.line_col_zero_default
+ let display_special_fig_consts = parse_bool_value display_special_fig_consts Default.display_special_fig_consts
+ let binary_comp_1 = parse_bool_value binary_comp_1 Default.binary_comp_1
+ let numeric_pointer = parse_bool_value numeric_pointer Default.numeric_pointer
+ let move_non_numeric_lit_to_numeric_is_zero = parse_bool_value move_non_numeric_lit_to_numeric_is_zero Default.move_non_numeric_lit_to_numeric_is_zero
+ let implicit_assign_dynamic_var = parse_bool_value implicit_assign_dynamic_var Default.implicit_assign_dynamic_var
+ let device_mnemonics = parse_bool_value device_mnemonics Default.device_mnemonics
+ let xml_parse_xmlss = parse_bool_value xml_parse_xmlss Default.xml_parse_xmlss
+ let areacheck = parse_bool_value areacheck Default.areacheck
+ let ebcdic_symbolic_characters = parse_bool_value ebcdic_symbolic_characters Default.ebcdic_symbolic_characters
+
+ (* support values *)
+ let comment_paragraphs = parse_support_value comment_paragraphs Default.comment_paragraphs
+ let safe_partial_replacing_when_src_literal = parse_support_value safe_partial_replacing_when_src_literal Default.safe_partial_replacing_when_src_literal
+ let control_division = parse_support_value control_division Default.control_division
+ let memory_size_clause = parse_support_value memory_size_clause Default.memory_size_clause
+ let multiple_file_tape_clause = parse_support_value multiple_file_tape_clause Default.multiple_file_tape_clause
+ let label_records_clause = parse_support_value label_records_clause Default.label_records_clause
+ let value_of_clause = parse_support_value value_of_clause Default.value_of_clause
+ let data_records_clause = parse_support_value data_records_clause Default.data_records_clause
+ let top_level_occurs_clause = parse_support_value top_level_occurs_clause Default.top_level_occurs_clause
+ let same_as_clause = parse_support_value same_as_clause Default.same_as_clause
+ let type_to_clause = parse_support_value type_to_clause Default.type_to_clause
+ let usage_type = parse_support_value usage_type Default.usage_type
+ let synchronized_clause = parse_support_value synchronized_clause Default.synchronized_clause
+ let sync_left_right = parse_support_value sync_left_right Default.sync_left_right
+ let special_names_clause = parse_support_value special_names_clause Default.special_names_clause
+ let goto_statement_without_name = parse_support_value goto_statement_without_name Default.goto_statement_without_name
+ let stop_literal_statement = parse_support_value stop_literal_statement Default.stop_literal_statement
+ let stop_identifier_statement = parse_support_value stop_identifier_statement Default.stop_identifier_statement
+ let stop_error_statement = parse_support_value stop_error_statement Default.stop_error_statement
+ let debugging_mode = parse_support_value debugging_mode Default.debugging_mode
+ let use_for_debugging = parse_support_value use_for_debugging Default.use_for_debugging
+ let padding_character_clause = parse_support_value padding_character_clause Default.padding_character_clause
+ let next_sentence_phrase = parse_support_value next_sentence_phrase Default.next_sentence_phrase
+ let listing_statements = parse_support_value listing_statements Default.listing_statements
+ let title_statement = parse_support_value title_statement Default.title_statement
+ let entry_statement = parse_support_value entry_statement Default.entry_statement
+ let move_noninteger_to_alphanumeric = parse_support_value move_noninteger_to_alphanumeric Default.move_noninteger_to_alphanumeric
+ let move_figurative_constant_to_numeric = parse_support_value move_figurative_constant_to_numeric Default.move_figurative_constant_to_numeric
+ let move_figurative_space_to_numeric = parse_support_value move_figurative_space_to_numeric Default.move_figurative_space_to_numeric
+ let move_figurative_quote_to_numeric = parse_support_value move_figurative_quote_to_numeric Default.move_figurative_quote_to_numeric
+ let odo_without_to = parse_support_value odo_without_to Default.odo_without_to
+ let section_segments = parse_support_value section_segments Default.section_segments
+ let alter_statement = parse_support_value alter_statement Default.alter_statement
+ let call_overflow = parse_support_value call_overflow Default.call_overflow
+ let numeric_boolean = parse_support_value numeric_boolean Default.numeric_boolean
+ let hexadecimal_boolean = parse_support_value hexadecimal_boolean Default.hexadecimal_boolean
+ let national_literals = parse_support_value national_literals Default.national_literals
+ let hexadecimal_national_literals = parse_support_value hexadecimal_national_literals Default.hexadecimal_national_literals
+ let national_character_literals = parse_support_value national_character_literals Default.national_character_literals
+ let hp_octal_literals = parse_support_value hp_octal_literals Default.hp_octal_literals
+ let acu_literals = parse_support_value acu_literals Default.acu_literals
+ let word_continuation = parse_support_value word_continuation Default.word_continuation
+ let not_exception_before_exception = parse_support_value not_exception_before_exception Default.not_exception_before_exception
+ let accept_display_extensions = parse_support_value accept_display_extensions Default.accept_display_extensions
+ let larger_redefines = parse_support_value larger_redefines Default.larger_redefines
+ let symbolic_constant = parse_support_value symbolic_constant Default.symbolic_constant
+ let constant_78 = parse_support_value constant_78 Default.constant_78
+ let constant_01 = parse_support_value constant_01 Default.constant_01
+ let perform_varying_without_by = parse_support_value perform_varying_without_by Default.perform_varying_without_by
+ let reference_out_of_declaratives = parse_support_value reference_out_of_declaratives Default.reference_out_of_declaratives
+ let program_prototypes = parse_support_value program_prototypes Default.program_prototypes
+ let call_convention_mnemonic = parse_support_value call_convention_mnemonic Default.call_convention_mnemonic
+ let call_convention_linkage = parse_support_value call_convention_linkage Default.call_convention_linkage
+ let numeric_value_for_edited_item = parse_support_value numeric_value_for_edited_item Default.numeric_value_for_edited_item
+ let incorrect_conf_sec_order = parse_support_value incorrect_conf_sec_order Default.incorrect_conf_sec_order
+ let define_constant_directive = parse_support_value define_constant_directive Default.define_constant_directive
+ let free_redefines_position = parse_support_value free_redefines_position Default.free_redefines_position
+ let records_mismatch_record_clause = parse_support_value records_mismatch_record_clause Default.records_mismatch_record_clause
+ let record_delimiter = parse_support_value record_delimiter Default.record_delimiter
+ let sequential_delimiters = parse_support_value sequential_delimiters Default.sequential_delimiters
+ let record_delim_with_fixed_recs = parse_support_value record_delim_with_fixed_recs Default.record_delim_with_fixed_recs
+ let missing_statement = parse_support_value missing_statement Default.missing_statement
+ let missing_period = parse_support_value missing_period Default.missing_period
+ let zero_length_literals = parse_support_value zero_length_literals Default.zero_length_literals
+ let xml_generate_extra_phrases = parse_support_value xml_generate_extra_phrases Default.xml_generate_extra_phrases
+ let continue_after = parse_support_value continue_after Default.continue_after
+ let goto_entry = parse_support_value goto_entry Default.goto_entry
+ let assign_variable = parse_support_value assign_variable Default.assign_variable
+ let assign_using_variable = parse_support_value assign_using_variable Default.assign_using_variable
+ let assign_ext_dyn = parse_support_value assign_ext_dyn Default.assign_ext_dyn
+ let assign_disk_from = parse_support_value assign_disk_from Default.assign_disk_from
+ let vsam_status = parse_support_value vsam_status Default.vsam_status
+ let self_call_recursive = parse_support_value self_call_recursive Default.self_call_recursive
+ let record_contains_depending_clause = parse_support_value record_contains_depending_clause Default.record_contains_depending_clause
+ let picture_l = parse_support_value picture_l Default.picture_l
+end
diff --git a/src/lsp/cobol_config/from_file.mli b/src/lsp/cobol_config/from_file.mli
new file mode 100644
index 000000000..1a8660b43
--- /dev/null
+++ b/src/lsp/cobol_config/from_file.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Basics
+
+(** This functor is used to build a config ({! Types.T}) module from a file *)
+module Make
+ (Diags: Cobol_common.Diagnostics.STATEFUL)
+ (Conf: sig
+ include Types.CONFIG
+ val options: Conf_ast.value StringMap.t
+ val words: Types.words_spec
+ val intrinsic_functions: StringSet.t
+ val system_names: StringSet.t
+ val registers: StringSet.t
+ end): Types.T
diff --git a/src/lsp/cobol_config/index.mld b/src/lsp/cobol_config/index.mld
new file mode 100644
index 000000000..7836e4fd3
--- /dev/null
+++ b/src/lsp/cobol_config/index.mld
@@ -0,0 +1,10 @@
+{1 Library cobol_config}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+This package is used to parse configuration files and generate the corresponding configuration to
+use inside [superbol].
+
+The entry point of this library is the module: {!Cobol_config}.
+
diff --git a/src/lsp/cobol_config/options.ml b/src/lsp/cobol_config/options.ml
new file mode 100644
index 000000000..21b047dd3
--- /dev/null
+++ b/src/lsp/cobol_config/options.ml
@@ -0,0 +1,645 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Types
+
+(** This module contains all the option available *)
+
+(* int options *)
+let tab_width: int value =
+ Value.int ~name:"tab-width"
+ "Number@ of@ spaces@ that@ are@ assumed@ for@ tabs."
+
+let text_column: int value =
+ Value.int ~name:"text-column"
+ "Right@ margin@ column@ number@ for@ fixed-form@ reference-format."
+
+let pic_length: int value =
+ Value.int ~name:"pic-length"
+ "Maximum@ size@ of@ a@ picture@ string."
+
+let word_length: int value =
+ Value.int ~name:"word-length"
+ "Maximum@ word-length @ for@ COBOL@ (=@ programmer@ defined)@ words."
+
+let literal_length: int value =
+ Value.int ~name:"literal-length"
+ "Maximum@ literal@ size@ in@ general."
+
+let numeric_literal_length: int value =
+ Value.int ~name:"numeric-literal-length"
+ "Maximum@ numeric@ literal@ size."
+
+(* any options *)
+let defaultbyte: defaultbyte value =
+ let kind = object
+ inherit [_] kind ~name:"defaultbyte"
+ method parse s: defaultbyte =
+ match s with
+ | "init" -> Init
+ | "none" -> None
+ | _ ->
+ if String.length s = 1 then
+ Char (s.[0])
+ else
+ begin match int_of_string_opt s with
+ | Some i when i >= 0 && i <= 255 ->
+ Char (Char.chr i)
+ | _ -> invalid_arg s
+ end
+ end
+ in
+ Value.def ~name:"defaultbyte" ~kind
+ "Default@ initialization@ for@ field@ without@ Value."
+
+let standard_define: standard value =
+ let kind = object
+ inherit [_] kind ~name:"standard-define"
+ method parse s: standard =
+ match int_of_string_opt s with
+ | Some i when i >= 0 && i <= 9 ->
+ begin match i with
+ | 0 -> GnuCOBOL
+ | 1 -> MicroFocus
+ | 2 -> IBM
+ | 3 -> MVS
+ | 4 -> BS2000
+ | 5 -> ACU
+ | 6 -> RM
+ | 7 -> STD85
+ | 8 -> STD2002
+ | 9 -> STD2014
+ | _ -> assert false (*unreachable*)
+ end
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"standard-define"
+ "Used@ standard"
+
+let format: source_format_spec value =
+ let kind = object
+ inherit [_] kind ~name:"format"
+ method parse s: source_format_spec =
+ match String.lowercase_ascii s with
+ | "fixed" -> SF SFFixed
+ | "free" -> SF SFFree
+ | "cobol85" -> SF SFFixed
+ | "variable" -> SF SFVariable
+ | "xopen" -> SF SFXOpen
+ | "xcard" -> SF SFxCard
+ | "terminal" -> SF SFTrm
+ | "cobolx" -> SF SFCOBOLX
+ | "auto" -> Auto
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"format"
+ "Default@ reference@ format."
+
+let binary_size: binary_size value =
+ let kind = object
+ inherit [_] kind ~name:"binary-size"
+ method parse s: binary_size =
+ match s with
+ | "2-4-8" -> B_2_4_8
+ | "1-2-4-8" -> B_1_2_4_8
+ | "1--8" -> B_1__8
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"binary-size"
+ ~short:"binary@ byte@ size"
+ "Binary@ byte@ size@ -@ defines@ the@ allocated@ bytes@ according@ to@ PIC."
+
+let binary_byteorder: binary_byteorder value =
+ let kind = object
+ inherit [_] kind ~name:"binary-byteorder"
+ method parse s: binary_byteorder =
+ match String.lowercase_ascii s with
+ | "native" -> Native
+ | "big-endian" -> Big_endian
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"binary-byteorder"
+ "Binary@ byte@ order."
+
+let assign_clause: assign_clause value =
+ let kind = object
+ inherit [_] kind ~name:"assign-clause"
+ method parse s: assign_clause =
+ match String.lowercase_ascii s with
+ | "dynamic" -> Dynamic
+ | "external" -> External
+ | "ibm" -> IBM
+ | "mf" -> MF
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"assign-clause"
+ ~short:"how@ to@ interpret@ 'ASSIGN@ word'"
+ "How@ to@ interpret@ 'ASSIGN@ word':@ as@ 'ASSIGN@ EXTERNAL@ word'@ or@ 'ASSIGN@ DYNAMIC@ word'"
+
+let screen_section_rules: screen_section_rules value =
+ let kind = object
+ inherit [_] kind ~name:"screen-section-rules"
+ method parse s: screen_section_rules =
+ match String.lowercase_ascii s with
+ | "acu" -> ACU
+ | "gc" -> GC
+ | "mf" -> MF
+ | "rm" -> RM
+ | "std" -> STD
+ | "xopen" -> XOPEN
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"screen-section-rules"
+ "Which@ compiler's@ rules@ to@ apply@ to@ SCREEN@ SECTION@ item@ clauses."
+
+let dpc_in_data: dpc_in_data value =
+ let kind = object
+ inherit [_] kind ~name:"dpc-in-data"
+ method parse s: dpc_in_data =
+ match String.lowercase_ascii s with
+ | "none" -> None
+ | "xml" -> XML
+ | "json" -> Json
+ | "all" -> All
+ | _ -> invalid_arg s
+ end in
+ Value.def ~kind ~name:"dpc-in-data"
+ "Wether@ DECIMAL@ POINT@ IS@ COMMA@ has@ effect@ in@ XML/JSON@ GENERATE."
+
+(* boolean options *)
+let filename_mapping: bool value =
+ Value.bool ~name:"filename-mapping"
+ "resolve@ file@ names@ at@ run@ time@ using@ environment@ variables"
+
+let pretty_display: bool value =
+ Value.bool ~name:"pretty-display"
+ "alternate@ formatting@ of@ numeric@ fields"
+
+let binary_truncate: bool value =
+ Value.bool ~name:"binary-truncate"
+ "numeric@ truncation@ according@ to@ ANSI"
+
+let complex_odo: bool value =
+ Value.bool ~name:"complex-odo"
+ "allow@ non-standard@ OCCURS@ DEPENDING@ ON@ syntax"
+
+let odoslide: bool value =
+ Value.bool ~name:"odoslide"
+ "adjust@ items@ following@ OCCURS@ DEPENDING@ (implies@ complex-odo)"
+
+let indirect_redefines: bool value =
+ Value.bool ~name:"indirect-redefines"
+ "allow@ REDEFINES@ to@ other@ than@ last@ equal@ level@ number"
+
+let relax_syntax_checks: bool value =
+ Value.bool ~name:"relax-syntax-checks"
+ "allow@ certain@ syntax@ variation@ (e.g.@ REDEFINES@ position)"
+
+let ref_mod_zero_length: bool value =
+ Value.bool ~name:"ref-mod-zero-length"
+ ~short:"allow@ zero@ length@ reference-modification"
+ "allow@ zero@ length@ reference-modification@ (only@ changed@ with@ EC-BOUND-REF-MOD@ active)"
+
+let relax_level_hierarchy: bool value =
+ Value.bool ~name:"relax-level-hierarchy"
+ "allow@ non-matching@ level@ numbers"
+
+let select_working: bool value =
+ Value.bool ~name:"select-working"
+ "require@ ASSING@ UNSING@ items@ to@ be@ in@ WORKING-STORAGE"
+
+let local_implies_recursive: bool value =
+ Value.bool ~name:"local-implies-recursive"
+ "LOCAL-STORAGE@ SECTION@ implies@ RECURSIVE@ attribute"
+
+let sticky_linkage: bool value =
+ Value.bool ~name:"sticky-linkage"
+ "LINKAGE@ SECTION@ items@ remain@ allocated@ between@ invocations"
+
+let move_ibm: bool value =
+ Value.bool ~name:"move-ibm"
+ "MOVE@ operates@ as@ on@ IBM@ (left@ to@ right,@ byte@ by@ byte)"
+
+let perform_osvs: bool value =
+ Value.bool ~name:"perform-osvs"
+ "exit@ point@ of@ any@ currently@ executing@ perfom@ is@ recognized@ if@ reached"
+
+let arithmetic_osvs: bool value =
+ Value.bool ~name:"arithmetic-osvs"
+ "limit@ precision@ in@ intermediate@ result@ to@ precision@ of@ final@ result@ (less@ accurate)"
+
+let hostsign: bool value =
+ Value.bool ~name:"hostsign"
+ "allow@ hexadecimal@ values@ 'F' for@ NUMERIC@ test@ of@ signed@ PACKED@ DECIMAL@ field"
+
+let program_name_redefinition: bool value =
+ Value.bool ~name:"program-name-redefinition"
+ "program@ names@ dont't@ lead@ to@ reserved@ identifier"
+
+let accept_update: bool value =
+ Value.bool ~name:"accept-update"
+ "set@ WITH@ UPDATE@ clause@ as@ default@ for@ ACCEPT@ dest-item,@ instead@ of@ WITH@ NO@ UPDATE"
+
+let accept_auto: bool value =
+ Value.bool ~name:"accept-auto"
+ "set@ WITH@ AUTO@ clause@ as@ default@ for@ ACCEPT@ dest-item,@ instead@ of@ WIHT@ TAB"
+
+let console_is_crt: bool value =
+ Value.bool ~name:"console-is-crt"
+ "assume@ CONSOLE@ IS@ CRT@ if@ not@ set@ otherwise"
+
+let no_echo_means_secure: bool value =
+ Value.bool ~name:"no-echo-means-secure"
+ "NO-ECHO@ hides@ input@ with@ asterisks@ like@ SECURE"
+
+let line_col_zero_default: bool value =
+ Value.bool ~name:"line-col-zero-default"
+ ~short:"assume@ a@ field@ DISPLAY@ starts@ at@ LINE@ 0@ COL@ 0"
+ "assume@ a@ field@ DISPLAY@ starts@ at@ LINE@ 0@ COL@ 0@ (i.e.@ at@ the@ cursor),@ not LINE@ 1@ COL@ 1"
+
+let display_special_fig_consts: bool value =
+ Value.bool ~name:"display-special-fig-consts"
+ "special@ behaviour@ of@ DISPLAY@ SPACE/ALL@ X'01'/ALL@ X'02'/ALL X'07'"
+
+let binary_comp_1: bool value =
+ Value.bool ~name:"binary-comp-1"
+ "COMP-1@ is@ a@ 16-bit@ signed@ integer"
+
+let numeric_pointer: bool value =
+ Value.bool ~name:"numeric-pointer"
+ "POINTER@ is@ 64-bit@ unsigned@ integer"
+
+let move_non_numeric_lit_to_numeric_is_zero: bool value =
+ Value.bool ~name:"move-non-numeric-lit-to-numeric-is-zero"
+ "imply@ zero@ in@ move@ of@ non-numeric@ literal@ to@ numeric@ items"
+
+let implicit_assign_dynamic_var: bool value =
+ Value.bool ~name:"implicit-assign-dynamic-var"
+ "implicitly@ define@ a@ variable@ if@ an@ ASSIGN@ DYNAMIC@ does@ not@ match@ any@ data@ item"
+
+let device_mnemonics: bool value =
+ Value.bool ~name:"device-mnemonics"
+ "specifying@ device@ by@ mnemonic"
+
+let xml_parse_xmlss: bool value =
+ Value.bool ~name:"xml-parse-xmlss"
+ "XML@ PARSE@ XMLSS"
+
+let areacheck: bool value =
+ Value.bool ~name:"areacheck"
+ ~short:"check@ contents@ of@ Area@ A@"
+ "check@ contents@ of@ Area@ A@ (when@ reference@ format@ supports@ Area@ A enforcement)@\n\
+ @[@[enabled@ checks@ include:@]@\n\
+ @[*@ division,@ section,@ paragraph@ names,@ level@ indicators@ (FD,@ SD,@ RD,@ \
+ and@ CD),@\n@[and@ toplevel@ numbers@ (01@ and@ 77)@ must@ start@ in@ Area@ A;@]@]@\n\
+ @[*@ statements@ must@ not@ start@ in@ Area A; and@]@\n\
+ @[*@ separator@ periods@ must@ not@ be@ within@ Area@ A@]@]"
+
+let ebcdic_symbolic_characters: bool value =
+ Value.bool ~name:"ebcdic-symbolic-characters"
+ ~short:"EBCDIC symbolic characters"
+ "EBCDIC symbolic characters in literals (\" \"135,151,151\"bar\"195, \
+ 194\"Z\" for \" foobarBAZ\")"
+
+(* support options *)
+(*NOTE: GnuCOBOL option name is "partial-replace-when-literal-src"*)
+let safe_partial_replacing_when_src_literal: [`Safe | `Unsafe] feature =
+ let feature_kind = object
+ inherit [_] FEATURE.feature_kind ~name:"safety support"
+ method parse s : [`Safe | `Unsafe] FEATURE.support_level =
+ match String.lowercase_ascii s with
+ | "ok" -> FEATURE.Ok `Safe
+ | "warning" -> Warning `Safe
+ | "archaic" -> Archaic `Safe
+ | "obsolete" -> Obsolete `Safe
+ | "skip" -> Ok `Unsafe (* special semantics *)
+ | "ignore" -> Ignore
+ | "error" -> Error
+ | "unconformable" -> Unconformable
+ | _ as s -> raise @@ Invalid_argument s
+ method from_ast s: [`Safe | `Unsafe] FEATURE.support_level =
+ match s with
+ | Conf_ast.Ok -> FEATURE.Ok `Safe
+ | Warning -> Warning `Safe
+ | Archaic -> Archaic `Safe
+ | Obsolete -> Obsolete `Safe
+ | Skip -> Ok `Unsafe
+ | Ignore -> Ignore
+ | Error -> Error
+ | Unconformable -> Unconformable
+ end in
+ FEATURE.def ~feature_kind ~name:"partial-replace-when-literal-src"
+ ~short:"partial@ replacing@ with@ literal@ source@ operands"
+ "Enable@ partial@ replacings@ (COPY...REPLACING/REPLACE@ \
+ LEADING/TRAILING)@ with@ literal@ source@ operands, and@ apply@ them@ \
+ even@ when@ they@ replace@ with@ spaces@ only."
+
+let comment_paragraphs: unit feature =
+ FEATURE.unit ~name:"comment-paragraphs"
+ ~short:"comment@ paragraph@ in@ IDENTIFICATION@ DIVISION"
+ "Comment@ paragraphs@ in@ IDENTIFICATION@ DIVISION@ (AUTHOR,@ \
+ DATE-WRITTEN,@ ...)."
+
+let control_division: unit feature =
+ FEATURE.unit ~name:"control-division"
+ "CONTROL@ DIVISION"
+
+let memory_size_clause: unit feature =
+ FEATURE.unit ~name:"memory-size-clause"
+ "MEMORY-SIZE@ clause"
+
+let multiple_file_tape_clause: unit feature =
+ FEATURE.unit ~name:"multiple-file-tape-clause"
+ "MULTIPLE-FILE-TAPE@ clause"
+
+let label_records_clause: unit feature =
+ FEATURE.unit ~name:"label-records-clause"
+ "LABEL_RECORDS@ clause"
+
+let value_of_clause: unit feature =
+ FEATURE.unit ~name:"value-of-clause"
+ "Value-OF@ clause"
+
+let data_records_clause: unit feature =
+ FEATURE.unit ~name:"data-records-clause"
+ "DATA-RECORDS@ clause"
+
+let top_level_occurs_clause: unit feature =
+ FEATURE.unit ~name:"top-level-occurs-clause"
+ "OCCURS@ clause@ on@ top-level"
+
+let same_as_clause: unit feature =
+ FEATURE.unit ~name:"same-as-clause"
+ "SAME@ AS@ clause"
+
+let type_to_clause: unit feature =
+ FEATURE.unit ~name:"type-to-clause"
+ "TYPE@ TO@ clause"
+
+let usage_type: unit feature =
+ FEATURE.unit ~name:"usage-type"
+ "USAGE@ type-name"
+
+let synchronized_clause: unit feature =
+ FEATURE.unit ~name:"synchronized-clause"
+ "SYNCHRONIZED@ clause"
+
+let sync_left_right: unit feature =
+ FEATURE.unit ~name:"sync-left-right"
+ "LEFT/RIGHT@ phrases@ in@ SYNCHRONIZED@ clause"
+
+let special_names_clause: unit feature =
+ FEATURE.unit ~name:"special-names-clause"
+ "SPECIAL-NAMES@ clause"
+
+let goto_statement_without_name: unit feature =
+ FEATURE.unit ~name:"goto-statement-without-name"
+ "GO@ TO@ statement without name"
+
+let stop_literal_statement: unit feature =
+ FEATURE.unit ~name:"stop-literal-statement"
+ "STOP-literal@ statement"
+
+let stop_identifier_statement: unit feature =
+ FEATURE.unit ~name:"stop-identifier-statement"
+ "STOP-identifier@ statement"
+
+let stop_error_statement: unit feature =
+ FEATURE.unit ~name:"stop-error-statement"
+ "STOP-error@ statement"
+
+let debugging_mode: unit feature =
+ FEATURE.unit ~name:"debugging-mode"
+ "DEBUGGING@ MODE@ and@ debugging@ indicator"
+
+let use_for_debugging: unit feature =
+ FEATURE.unit ~name:"use-for-debugging"
+ "USE@ FOR@ DEBUGGING"
+
+let padding_character_clause: unit feature =
+ FEATURE.unit ~name:"padding-character-clause"
+ "PADDING@ CHARACTER@ clause"
+
+let next_sentence_phrase: unit feature =
+ FEATURE.unit ~name:"next-sentence-phrase"
+ "NEXT@ SENTENCE@ phrase"
+
+let listing_statements: unit feature =
+ FEATURE.unit ~name:"listing-statements"
+ "listing-directive@ statements@ EJECT,@ SKIP1,@ SKIP2,@ SKIP3"
+
+let title_statement: unit feature =
+ FEATURE.unit ~name:"title-statement"
+ "listing-directive@ statement@ TITLE"
+
+let entry_statement: unit feature =
+ FEATURE.unit ~name:"entry-statement"
+ "ENTRY@ statement"
+
+let move_noninteger_to_alphanumeric: unit feature =
+ FEATURE.unit ~name:"move-noninteger-to-alphanumeric"
+ "move@ noninteger@ to@ alphanumeric"
+
+let move_figurative_constant_to_numeric: unit feature =
+ FEATURE.unit ~name:"move-figurative-constant-to-numeric"
+ "move@ figurative@ constants@ to@ numeric"
+
+let move_figurative_space_to_numeric: unit feature =
+ FEATURE.unit ~name:"move-figurative-space-to-numeric"
+ "move@ figurative@ constant@ SPACE@ to@ numeric"
+
+let move_figurative_quote_to_numeric: unit feature =
+ FEATURE.unit ~name:"move-figurative-quote-to-numeric"
+ "move@ figurative@ constant@ QUOTE@ to@ numeric"
+
+let odo_without_to: unit feature =
+ FEATURE.unit ~name:"odo-without-to"
+ "OCCURS@ DEPENDING@ ON@ without@ to"
+
+let section_segments: unit feature =
+ FEATURE.unit ~name:"section-segments"
+ "section@ segments"
+
+let alter_statement: unit feature =
+ FEATURE.unit ~name:"alter-statement"
+ "ALTER@ statement"
+
+let call_overflow: unit feature =
+ FEATURE.unit ~name:"call-overflow"
+ "OVERFLOW@ clause@ for@ CALL"
+
+let numeric_boolean: unit feature =
+ FEATURE.unit ~name:"numeric-boolean"
+ "boolean@ literal@ (B'1010')"
+
+let hexadecimal_boolean: unit feature =
+ FEATURE.unit ~name:"hexadecimal-boolean"
+ "hexadecimal-boolean@ literal@ (BX'A')"
+
+let national_literals: unit feature =
+ FEATURE.unit ~name:"national-literals"
+ "national@ literals@ (N'UTF-16 string')"
+
+let hexadecimal_national_literals: unit feature =
+ FEATURE.unit ~name:"hexadecimal-national-literals"
+ "hexadecimal-national@ literals@ (NX'265E')"
+
+let national_character_literals: unit feature =
+ FEATURE.unit ~name:"national-character-literals"
+ "non-standard@ national@ literals@ (NC'UTF-16 string')"
+
+let hp_octal_literals: unit feature =
+ FEATURE.unit ~name:"hp-octal-literals"
+ "HP@ COBOL@ octal@ literals (%%377)"
+
+let acu_literals: unit feature =
+ FEATURE.unit ~name:"acu-literals"
+ "ACUCOBOL-G@ literals@ (#B #O #H #X)"
+
+let word_continuation: unit feature =
+ FEATURE.unit ~name:"word-continuation"
+ "continuation@ of@ COBOL@ words"
+
+let not_exception_before_exception: unit feature =
+ FEATURE.unit ~name:"not-exception-before-exception"
+ "NOT@ ON@ EXCEPTION@ before@ ON@ EXCEPTION"
+
+let accept_display_extensions: unit feature =
+ FEATURE.unit ~name:"accept-display-extensions"
+ "extensions@ to@ ACCEPT@ and@ DISPLAY"
+
+let larger_redefines: unit feature =
+ FEATURE.unit ~name:"larger-redefines"
+ "allow@ larger@ REDEFINES@ items"
+
+let symbolic_constant: unit feature =
+ FEATURE.unit ~name:"symbolic-constant"
+ "constants@ defined@ in@ SPECIAL-NAMES"
+
+let constant_78: unit feature =
+ FEATURE.unit ~name:"constant-78"
+ ~short:"constant@ with@ level@ 78@ item"
+ "constant@ with@ level@ 78@ item@ (note:@ has@ left@ to@ right@ precedence@ in@ expressions)"
+
+let constant_01: unit feature =
+ FEATURE.unit ~name:"constant-01"
+ "constant@ wiht@ level@ 01@ CONSTANT@ AS/FROM@ item (COBOL@ 2002+)"
+
+let perform_varying_without_by: unit feature =
+ FEATURE.unit ~name:"perform-varying-without-by"
+ "PERFORM@ VARYING@ without@ BY@ phrase@ (implies@ BY@ 1)"
+
+let reference_out_of_declaratives: unit feature =
+ FEATURE.unit ~name:"reference-out-of-declaratives"
+ "references@ to@ sections@ not@ in@ DECLARATIVES@ from@ within@ DECLARATIVES"
+
+let program_prototypes: unit feature =
+ FEATURE.unit ~name:"program-prototypes"
+ "CALL/CANCEL@ with@ program-prototype-name"
+
+let call_convention_mnemonic: unit feature =
+ FEATURE.unit ~name:"call-convention-mnemonic"
+ "specifying@ call-convention@ by@ mnemonic"
+
+let call_convention_linkage: unit feature =
+ FEATURE.unit ~name:"call-convention-linkage"
+ "specifying@ call-convention@ by@ WITH@ ...@ LINKAGE"
+
+let numeric_value_for_edited_item: unit feature =
+ FEATURE.unit ~name:"numeric-value-for-edited-item"
+ "numeric@ literals@ in@ Value@ clause@ of@ numeric-edited@ items"
+
+let incorrect_conf_sec_order: unit feature =
+ FEATURE.unit ~name:"incorrect-conf-sec-order"
+ "incorrect@ order@ of@ CONFIGURATION@ SECTION@ paragraphs@ (OpenCOBOL/GnuCOBOL@ extension)"
+
+let define_constant_directive: unit feature =
+ FEATURE.unit ~name:"define-constant-directive"
+ "allow@ >>@ DEFINE@ CONSTANT@ var@ AS@ literal@ (OpenCOBOL/GnuCOBOL@ extension)"
+
+let free_redefines_position: unit feature =
+ FEATURE.unit ~name:"free-redefines-position"
+ "REDEFINES@ caluse@ not@ follwing@ entry-name@ in@ defintion"
+
+let records_mismatch_record_clause: unit feature =
+ FEATURE.unit ~name:"records-mismatch-record-clause"
+ "record@ sizes@ does@ not@ match@ RECORD@ clause"
+
+let record_delimiter: unit feature =
+ FEATURE.unit ~name:"record-delimiter"
+ "RECORD@ DELIMITER@ clause"
+
+let sequential_delimiters: unit feature =
+ FEATURE.unit ~name:"sequential-delimiters"
+ "BINARY-SEQUENTIAL@ and @ LINE-SEQUENTIAL@ phrases@ in@ RECORD@ DELIMITER"
+
+let record_delim_with_fixed_recs: unit feature =
+ FEATURE.unit ~name:"record-delim-with-fixed-recs"
+ "RECORD@ DELIMITER@ clause@ on@ file@ with@ fixed-length@ records"
+
+let missing_statement: unit feature =
+ FEATURE.unit ~name:"missing-statement"
+ "missing@ statement@ (e.g.@ empty@ IF/PERFORM)"
+
+let missing_period: unit feature =
+ FEATURE.unit ~name:"missing-period"
+ ~short:"missing@ period@ in@ PROCEDURE@ DIVISION"
+ "missing@ period@ in@ PROCEDURE@ DIVISION@ (when@ reference@ format@ supports@ Area@ A@ enforcement)"
+
+let zero_length_literals: unit feature =
+ FEATURE.unit ~name:"zero-length-literals"
+ "zero-length@ literals,@ e.g.@ ''@ and@ \"\""
+
+let xml_generate_extra_phrases: unit feature =
+ FEATURE.unit ~name:"xml-generate-extra-phrases"
+ "XML@ GENERATE's@ phrases@ other@ thant@ COUNT@ IN"
+
+let continue_after: unit feature =
+ FEATURE.unit ~name:"continue-after"
+ "AFTER@ phrase@ in@ CONTINUE@ statement"
+
+let goto_entry: unit feature =
+ FEATURE.unit ~name:"goto-entry"
+ "ENTRY@ FOR@ GO@ TO@ and@ GO@ TO@ ENTRY@ statements"
+
+let assign_variable: unit feature =
+ FEATURE.unit ~name:"assign-variable"
+ "ASSIGN@ [TO]@ variable@ in@ SELECT"
+
+let assign_using_variable: unit feature =
+ FEATURE.unit ~name:"assign-using-variable"
+ "ASSIGN@ USING/VARYING variable@ in@ SELECT"
+
+let assign_ext_dyn: unit feature =
+ FEATURE.unit ~name:"assign-ext-dyn"
+ "ASSIGN@ EXTERNAL/DYNAMIC@ in@ SELECT"
+
+let assign_disk_from: unit feature =
+ FEATURE.unit ~name:"assign-disk-from"
+ "ASSIGN@ DISK@ FROM@ variable@ in@ SELECT"
+
+let vsam_status: unit feature =
+ FEATURE.unit ~name:"vsam-status"
+ "VSAM@ status@ in@ FILE@ STATUS"
+
+let self_call_recursive: unit feature =
+ FEATURE.unit ~name:"self-call-recursive"
+ "CALL@ to@ own@ PROGRAM-ID@ implies@ RECURSIVE@ attribute"
+
+let record_contains_depending_clause: unit feature =
+ FEATURE.unit ~name:"record-contains-depending-clause"
+ "DEPENDING@ clause@ in@ RECORD@ CONTAINS"
+
+let picture_l: unit feature =
+ FEATURE.unit ~name:"picture-l"
+ "PICTURE@ string@ with@ 'L'@ character"
diff --git a/src/lsp/cobol_config/options.mli b/src/lsp/cobol_config/options.mli
new file mode 100644
index 000000000..bea4fb03e
--- /dev/null
+++ b/src/lsp/cobol_config/options.mli
@@ -0,0 +1,258 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Definition for all options *)
+open Types
+
+val tab_width: int value
+
+val text_column: int value
+
+val pic_length: int value
+
+val word_length: int value
+
+val literal_length: int value
+
+val numeric_literal_length: int value
+
+(* any options *)
+val defaultbyte: defaultbyte value
+
+val standard_define: standard value
+
+val format: source_format_spec value
+
+val binary_size: binary_size value
+
+val binary_byteorder: binary_byteorder value
+
+val assign_clause: assign_clause value
+
+val screen_section_rules: screen_section_rules value
+
+val dpc_in_data: dpc_in_data value
+
+(* boolean options *)
+val filename_mapping: bool value
+
+val pretty_display: bool value
+
+val binary_truncate: bool value
+
+val complex_odo: bool value
+
+val odoslide: bool value
+
+val indirect_redefines: bool value
+
+val relax_syntax_checks: bool value
+
+val ref_mod_zero_length: bool value
+
+val relax_level_hierarchy: bool value
+
+val select_working: bool value
+
+val local_implies_recursive: bool value
+
+val sticky_linkage: bool value
+
+val move_ibm: bool value
+
+val perform_osvs: bool value
+
+val arithmetic_osvs: bool value
+
+val hostsign: bool value
+
+val program_name_redefinition: bool value
+
+val accept_update: bool value
+
+val accept_auto: bool value
+
+val console_is_crt: bool value
+
+val no_echo_means_secure: bool value
+
+val line_col_zero_default: bool value
+
+val display_special_fig_consts: bool value
+
+val binary_comp_1: bool value
+
+val numeric_pointer: bool value
+
+val move_non_numeric_lit_to_numeric_is_zero: bool value
+
+val implicit_assign_dynamic_var: bool value
+
+val device_mnemonics: bool value
+
+val xml_parse_xmlss: bool value
+
+val areacheck: bool value
+
+val ebcdic_symbolic_characters: bool value
+
+(* support options *)
+val safe_partial_replacing_when_src_literal: [`Safe | `Unsafe] feature
+
+val comment_paragraphs: unit feature
+
+val control_division: unit feature
+
+val memory_size_clause: unit feature
+
+val multiple_file_tape_clause: unit feature
+
+val label_records_clause: unit feature
+
+val value_of_clause: unit feature
+
+val data_records_clause: unit feature
+
+val top_level_occurs_clause: unit feature
+
+val same_as_clause: unit feature
+
+val type_to_clause: unit feature
+
+val usage_type: unit feature
+
+val synchronized_clause: unit feature
+
+val sync_left_right: unit feature
+
+val special_names_clause: unit feature
+
+val goto_statement_without_name: unit feature
+
+val stop_literal_statement: unit feature
+
+val stop_identifier_statement: unit feature
+
+val stop_error_statement: unit feature
+
+val debugging_mode: unit feature
+
+val use_for_debugging: unit feature
+
+val padding_character_clause: unit feature
+
+val next_sentence_phrase: unit feature
+
+val listing_statements: unit feature
+
+val title_statement: unit feature
+
+val entry_statement: unit feature
+
+val move_noninteger_to_alphanumeric: unit feature
+
+val move_figurative_constant_to_numeric: unit feature
+
+val move_figurative_space_to_numeric: unit feature
+
+val move_figurative_quote_to_numeric: unit feature
+
+val odo_without_to: unit feature
+
+val section_segments: unit feature
+
+val alter_statement: unit feature
+
+val call_overflow: unit feature
+
+val numeric_boolean: unit feature
+
+val hexadecimal_boolean: unit feature
+
+val national_literals: unit feature
+
+val hexadecimal_national_literals: unit feature
+
+val national_character_literals: unit feature
+
+val hp_octal_literals: unit feature
+
+val acu_literals: unit feature
+
+val word_continuation: unit feature
+
+val not_exception_before_exception: unit feature
+
+val accept_display_extensions: unit feature
+
+val larger_redefines: unit feature
+
+val symbolic_constant: unit feature
+
+val constant_78: unit feature
+
+val constant_01: unit feature
+
+val perform_varying_without_by: unit feature
+
+val reference_out_of_declaratives: unit feature
+
+val program_prototypes: unit feature
+
+val call_convention_mnemonic: unit feature
+
+val call_convention_linkage: unit feature
+
+val numeric_value_for_edited_item: unit feature
+
+val incorrect_conf_sec_order: unit feature
+
+val define_constant_directive: unit feature
+
+val free_redefines_position: unit feature
+
+val records_mismatch_record_clause: unit feature
+
+val record_delimiter: unit feature
+
+val sequential_delimiters: unit feature
+
+val record_delim_with_fixed_recs: unit feature
+
+val missing_statement: unit feature
+
+val missing_period: unit feature
+
+val zero_length_literals: unit feature
+
+val xml_generate_extra_phrases: unit feature
+
+val continue_after: unit feature
+
+val goto_entry: unit feature
+
+val assign_variable: unit feature
+
+val assign_using_variable: unit feature
+
+val assign_ext_dyn: unit feature
+
+val assign_disk_from: unit feature
+
+val vsam_status: unit feature
+
+val self_call_recursive: unit feature
+
+val record_contains_depending_clause: unit feature
+
+val picture_l: unit feature
diff --git a/src/lsp/cobol_config/package.toml b/src/lsp/cobol_config/package.toml
new file mode 100644
index 000000000..848370474
--- /dev/null
+++ b/src/lsp/cobol_config/package.toml
@@ -0,0 +1,89 @@
+
+# name of package
+name = "cobol_config"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+generators = ["ocamllex"]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+preprocess = "pps ppx_deriving.show"
+
+# files to skip while updating at package level
+skip = ["main.ml", "index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+cobol_common = "version"
+ppx_deriving = ">=5.2.1"
+pretty = "version"
+[dependencies.menhir]
+libname = "menhirLib"
+version = ">=1.2"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+dune-trailer = """
+
+(rule (targets conf_parser_messages.ml)
+ (deps conf_parser.messages conf_parser.mly)
+ (action
+ (with-stdout-to %{targets}
+ (run menhir --compile-errors %{deps}))))
+
+
+(menhir (modules conf_parser) (flags --inspection --table))
+"""
diff --git a/src/lsp/cobol_config/reserved_words.ml b/src/lsp/cobol_config/reserved_words.ml
new file mode 100644
index 000000000..d20cc3f1e
--- /dev/null
+++ b/src/lsp/cobol_config/reserved_words.ml
@@ -0,0 +1,1676 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Basics
+
+(* Please, use `Word` module to access these words *)
+
+(** The list of all default reserved words. *)
+let reserved_words =
+ (* /!\ There's duplication between this list and the mapping of keywords to
+ tokens in `Cobol_parser.Keywords`.
+
+ TODO: Try to avoid this. The association seems to fit well in
+ `Cobol_parser', yet it depends on `Cobol_config`. Putting the actual
+ "all-dialect" config and other config values in a library `superbol_config`
+ might be suitable. *)
+ [ "3-D";
+ "ABSENT";
+ "ACCEPT";
+ "ACCESS";
+ "ACTION";
+ "ACTIVATING";
+ "ACTIVE-CLASS";
+ "ACTIVE-X";
+ "ACTUAL";
+ "ADD";
+ "ADDRESS";
+ "ADJUSTABLE-COLUMNS";
+ "ADVANCING";
+ "AFTER";
+ "ALIGNMENT";
+ "ALIGNED";
+ "ALL";
+ "ALLOCATE";
+ "ALLOWING";
+ "ALPHABET";
+ "ALPHABETIC";
+ "ALPHABETIC-LOWER";
+ "ALPHABETIC-UPPER";
+ "ALPHANUMERIC";
+ "ALPHANUMERIC-EDITED";
+ "ALSO";
+ "ALTER";
+ "ALTERNATE";
+ "AND";
+ "ANY";
+ "ANYCASE";
+ "ANUM";
+ "APPLY";
+ "ARE";
+ "AREA";
+ "AREAS";
+ "ARGUMENT-NUMBER";
+ "ARGUMENT-VALUE";
+ "ARITHMETIC";
+ "AS";
+ "ASCENDING";
+ "ASCII";
+ "ASSIGN";
+ "AT";
+ "ATTRIBUTE";
+ "ATTRIBUTES";
+ "AUTHOR";
+ "AUTO";
+ "AUTO-DECIMAL";
+ "AUTO-SPIN";
+ "AUTOMATIC";
+ "AWAY-FROM-ZERO";
+ "B-AND";
+ "B-NOT";
+ "B-OR";
+ "B-XOR";
+ "B-SHIFT-L";
+ "B-SHIFT-LC";
+ "B-SHIFT-R";
+ "B-SHIFT-RC";
+ "BACKGROUND-COLOR";
+ "BACKGROUND-HIGH";
+ "BACKGROUND-LOW";
+ "BACKGROUND-STANDARD";
+ "BACKWARD";
+ "BAR";
+ "BASED";
+ "BEFORE";
+ "BELL";
+ "BINARY";
+ "BINARY-C-LONG";
+ "BINARY-CHAR";
+ "BINARY-DOUBLE";
+ "BINARY-LONG";
+ "BINARY-SEQUENTIAL";
+ "BINARY-SHORT";
+ "BIT";
+ "BITMAP";
+ "BITMAP-END";
+ "BITMAP-HANDLE";
+ "BITMAP-NUMBER";
+ "BITMAP-START";
+ "BITMAP-TIMER";
+ "BITMAP-TRAILING";
+ "BITMAP-TRANSPARENT-COLOR";
+ "BITMAP-WIDTH";
+ "BLANK";
+ "BLINK";
+ "BLOCK";
+ "BOOLEAN";
+ "BOTTOM";
+ "BOX";
+ "BOXED";
+ "BULK-ADDITION";
+ "BUSY";
+ "BUTTONS";
+ "BY";
+ "BYTE";
+ "BYTES";
+ "BYTE-LENGTH";
+ "C";
+ "CALENDAR-FONT";
+ "CALL";
+ "CANCEL";
+ "CANCEL-BUTTON";
+ "CAPACITY";
+ "CARD-PUNCH";
+ "CARD-READER";
+ "CASSETTE";
+ "CCOL";
+ "CD";
+ "CELL";
+ "CELL-COLOR";
+ "CELL-DATA";
+ "CELL-FONT";
+ "CELL-PROTECTION";
+ "CENTER";
+ "CENTERED";
+ "CENTERED-HEADINGS";
+ "CENTURY-DATE";
+ "CF";
+ "CH";
+ "CHAIN";
+ "CHAINING";
+ "CHANGED";
+ "CHARACTER";
+ "CHARACTERS";
+ "CHECK-BOX";
+ "CLASS";
+ "CLASS-ID";
+ "CLASSIFICATION";
+ "CLEAR-SELECTION";
+ "CLINE";
+ "CLINES";
+ "CLOSE";
+ "COBOL";
+ "CODE";
+ "CODE-SET";
+ "COL";
+ "COLLATING";
+ "COLOR";
+ "COLORS";
+ "COLS";
+ "COLUMN";
+ "COLUMN-COLOR";
+ "COLUMN-DIVIDERS";
+ "COLUMN-FONT";
+ "COLUMN-HEADINGS";
+ "COLUMN-PROTECTION";
+ "COLUMNS";
+ "COMBO-BOX";
+ "COMMA";
+ "COMMAND-LINE";
+ "COMMIT";
+ "COMMON";
+ "COMMUNICATION";
+ "COMP";
+ "COMP-0";
+ "COMP-1";
+ "COMP-2";
+ "COMP-3";
+ "COMP-4";
+ "COMP-5";
+ "COMP-6";
+ "COMP-N";
+ "COMP-X";
+ "COMP-9";
+ "COMP-10";
+ "COMP-15";
+ "COMPUTATIONAL";
+ "COMPUTATIONAL-0";
+ "COMPUTATIONAL-1";
+ "COMPUTATIONAL-2";
+ "COMPUTATIONAL-3";
+ "COMPUTATIONAL-4";
+ "COMPUTATIONAL-5";
+ "COMPUTATIONAL-6";
+ "COMPUTATIONAL-N";
+ "COMPUTATIONAL-X";
+ "COMPUTE";
+ "CONDITION";
+ "CONFIGURATION";
+ "CONSTANT";
+ "CONTAINS";
+ "CONTENT";
+ "CONTINUE";
+ "CONTROL";
+ "CONTROLS";
+ "CONVERSION";
+ "CONVERTING";
+ "COPY";
+ "COPY-SELECTION";
+ "CORE-INDEX";
+ "CORR";
+ "CORRESPONDING";
+ "COUNT";
+ "CRT";
+ "CRT-UNDER";
+ "CSIZE";
+ "CURRENCY";
+ "CURRENT";
+ "CURSOR";
+ "CURSOR-COL";
+ "CURSOR-COLOR";
+ "CURSOR-FRAME-WIDTH";
+ "CURSOR-ROW";
+ "CURSOR-X";
+ "CURSOR-Y";
+ "CUSTOM-PRINT-TEMPLATE";
+ "CYCLE";
+ "CYL-INDEX";
+ "CYL-OVERFLOW";
+ "DASHED";
+ "DATA";
+ "DATA-COLUMNS";
+ "DATA-POINTER";
+ "DATA-TYPES";
+ "DATE";
+ "DATE-COMPILED";
+ "DATE-ENTRY";
+ "DATE-MODIFIED";
+ "DATE-WRITTEN";
+ "DAY";
+ "DAY-OF-WEEK";
+ "DE";
+ "DEBUGGING";
+ "DECIMAL-POINT";
+ "DECLARATIVES";
+ "DEFAULT";
+ "DEFAULT-BUTTON";
+ "DEFAULT-FONT";
+ "DELETE";
+ "DELIMITED";
+ "DELIMITER";
+ "DEPENDING";
+ "DESCENDING";
+ "DESTINATION";
+ "DESTROY";
+ "DETAIL";
+ "DISABLE";
+ "DISC";
+ "DISK";
+ "DISP";
+ "DISPLAY";
+ "DISPLAY-1";
+ "DISPLAY-COLUMNS";
+ "DISPLAY-FORMAT";
+ "DIVIDE";
+ "DIVIDER-COLOR";
+ "DIVIDERS";
+ "DIVISION";
+ "DOTDASH";
+ "DOTTED";
+ "DOUBLE";
+ "DOWN";
+ "DRAG-COLOR";
+ "DROP-DOWN";
+ "DROP-LIST";
+ "DUPLICATES";
+ "DYNAMIC";
+ "EBCDIC";
+ "EC";
+ "ECHO";
+ "EDITING";
+ "EGI";
+ "ELEMENT";
+ "ELSE";
+ "EMI";
+ "ENABLE";
+ "ENCODING";
+ "ENCRYPTION";
+ "END";
+ "END-ACCEPT";
+ "END-ADD";
+ "END-CALL";
+ "END-CHAIN";
+ "END-COLOR";
+ "END-COMPUTE";
+ "END-DELETE";
+ "END-DISPLAY";
+ "END-DIVIDE";
+ "END-EVALUATE";
+ "END-IF";
+ "END-JSON";
+ "END-MODIFY";
+ "END-MULTIPLY";
+ "END-OF-PAGE";
+ "END-PERFORM";
+ "END-READ";
+ "END-RECEIVE";
+ "END-RETURN";
+ "END-REWRITE";
+ "END-SEARCH";
+ "END-SEND";
+ "END-START";
+ "END-STRING";
+ "END-SUBTRACT";
+ "END-UNSTRING";
+ "END-WRITE";
+ "END-XML";
+ "ENGRAVED";
+ "ENSURE-VISIBLE";
+ "ENTRY";
+ "ENTRY-CONVENTION";
+ "ENTRY-FIELD";
+ "ENTRY-REASON";
+ "ENVIRONMENT";
+ "ENVIRONMENT-NAME";
+ "ENVIRONMENT-VALUE";
+ "EO";
+ "EOL";
+ "EOP";
+ "EOS";
+ "EQUAL";
+ "ERASE";
+ "ERROR";
+ "ESCAPE";
+ "ESCAPE-BUTTON";
+ "ESI";
+ "EVALUATE";
+ "EVENT";
+ "EVENT-LIST";
+ "EVERY";
+ "EXAMINE";
+ "EXCEPTION";
+ "EXCEPTION-OBJECT";
+ "EXCEPTION-VALUE";
+ "EXCLUSIVE";
+ "EXCLUSIVE-OR";
+ "EXHIBIT";
+ "EXIT";
+ "EXPAND";
+ "EXPANDS";
+ "EXTEND";
+ "EXTENDED-SEARCH";
+ "EXTERN";
+ "EXTERNAL";
+ "EXTERNAL-FORM";
+ "F";
+ "FACTORY";
+ "FALSE";
+ "FD";
+ "FH--FCD";
+ "FH--KEYDEF";
+ "FILE";
+ "FILE-CONTROL";
+ "FILE-ID";
+ "FILE-LIMIT";
+ "FILE-LIMITS";
+ "FILE-NAME";
+ "FILE-POS";
+ "FILL-COLOR";
+ "FILL-COLOR2";
+ "FILL-PERCENT";
+ "FILLER";
+ "FINAL";
+ "FINALLY";
+ "FINISH-REASON";
+ "FIRST";
+ "FIXED";
+ "FIXED-FONT";
+ "FIXED-WIDTH";
+ "FLAT";
+ "FLAT-BUTTONS";
+ "FLOAT";
+ "FLOAT-BINARY-128";
+ "FLOAT-BINARY-32";
+ "FLOAT-BINARY-64";
+ "FLOAT-DECIMAL-16";
+ "FLOAT-DECIMAL-34";
+ "FLOAT-EXTENDED";
+ "FLOAT-INFINITY";
+ "FLOAT-LONG";
+ "FLOAT-NOT-A-NUMBER";
+ "FLOAT-SHORT";
+ "FLOATING";
+ "FONT";
+ "FOOTING";
+ "FOR";
+ "FOREGROUND-COLOR";
+ "FOREVER";
+ "FORMAT";
+ "FRAME";
+ "FRAMED";
+ "FREE";
+ "FROM";
+ "FULL";
+ "FULL-HEIGHT";
+ "FUNCTION";
+ "FUNCTION-ID";
+ "FUNCTION-POINTER";
+ "GENERATE";
+ "GET";
+ "GIVING";
+ "GLOBAL";
+ "GO";
+ "GO-BACK";
+ "GO-FORWARD";
+ "GO-HOME";
+ "GO-SEARCH";
+ "GOBACK";
+ "GRAPHICAL";
+ "GREATER";
+ "GRID";
+ "GROUP";
+ "GROUP-USAGE";
+ "GROUP-VALUE";
+ "HANDLE";
+ "HAS-CHILDREN";
+ "HEADING";
+ "HEADING-COLOR";
+ "HEADING-DIVIDER-COLOR";
+ "HEADING-FONT";
+ "HEAVY";
+ "HEIGHT-IN-CELLS";
+ "HEX";
+ "HIDDEN-DATA";
+ "HIGH-COLOR";
+ "HIGH-VALUE";
+ "HIGHLIGHT";
+ "HOT-TRACK";
+ "HSCROLL";
+ "HSCROLL-POS";
+ "I-O";
+ "I-O-CONTROL";
+ "ICON";
+ "ID";
+ "IDENTIFICATION";
+ "IDENTIFIED";
+ "IF";
+ "IGNORE";
+ "IGNORING";
+ "IMPLEMENTS";
+ "IN";
+ "INDEPENDENT";
+ "INDEX";
+ "INDEXED";
+ "INDICATE";
+ "INHERITS";
+ "INITIAL";
+ "INITIALIZE";
+ "INITIALIZED";
+ "INITIATE";
+ "INPUT";
+ "INPUT-OUTPUT";
+ "INQUIRE";
+ "INSERTION-INDEX";
+ "INSERT-ROWS";
+ "INSPECT";
+ "INSTALLATION";
+ "INTERFACE";
+ "INTERFACE-ID";
+ "INTERMEDIATE";
+ "INTO";
+ "INTRINSIC";
+ "INVALID";
+ "INVOKE";
+ "IS";
+ "ITEM";
+ "ITEM-TEXT";
+ "ITEM-TO-ADD";
+ "ITEM-TO-DELETE";
+ "ITEM-TO-EMPTY";
+ "ITEM-VALUE";
+ "JSON";
+ "JUST";
+ "JUSTIFIED";
+ "KEPT";
+ "KEY";
+ "KEYBOARD";
+ "LABEL";
+ "LABEL-OFFSET";
+ "LARGE-FONT";
+ "LARGE-OFFSET";
+ "LAST";
+ "LAST-ROW";
+ "LAYOUT-DATA";
+ "LAYOUT-MANAGER";
+ "LC_ALL";
+ "LC_COLLATE";
+ "LC_CTYPE";
+ "LC_MESSAGES";
+ "LC_MONETARY";
+ "LC_NUMERIC";
+ "LC_TIME";
+ "LEADING";
+ "LEADING-SHIFT";
+ "LEAVE";
+ "LEFT";
+ "LEFT-JUSTIFY";
+ "LEFT-TEXT";
+ "LEFTLINE";
+ "LENGTH";
+ "LESS";
+ "LIKE";
+ "LIMIT";
+ "LIMITS";
+ "LINAGE";
+ "LINAGE-COUNTER";
+ "LINE";
+ "LINE-COUNTER";
+ "LINE-SEQUENTIAL";
+ "LINES";
+ "LINES-AT-ROOT";
+ "LINKAGE";
+ "LIST-BOX";
+ "LM-RESIZE";
+ "LOC";
+ "LOCAL-STORAGE";
+ "LOCALE";
+ "LOCATION";
+ "LOCK";
+ "LOCK-HOLDING";
+ "LONG-DATE";
+ "LOW-COLOR";
+ "LOW-VALUE";
+ "LOWER";
+ "LOWERED";
+ "LOWLIGHT";
+ "MAGNETIC-TAPE";
+ "MANUAL";
+ "MASS-UPDATE";
+ "MASTER-INDEX";
+ "MAX-LINES";
+ "MAX-PROGRESS";
+ "MAX-TEXT";
+ "MAX-VAL";
+ "MEDIUM-FONT";
+ "MEMORY";
+ "MENU";
+ "MERGE";
+ "MESSAGE";
+ "MESSAGE-TAG";
+ "METHOD";
+ "METHOD-ID";
+ "MICROSECOND-TIME";
+ "MIN-VAL";
+ "MINUS";
+ "MODE";
+ "MODIFY";
+ "MODULES";
+ "MOVE";
+ "MULTILINE";
+ "MULTIPLE";
+ "MULTIPLY";
+ "NAME";
+ "NAMED";
+ "NAMESPACE";
+ "NAMESPACE-PREFIX";
+ "NAT";
+ "NATIONAL";
+ "NATIONAL-EDITED";
+ "NATIVE";
+ "NAVIGATE-URL";
+ "NEAREST-AWAY-FROM-ZERO";
+ "NEAREST-EVEN";
+ "NEAREST-TOWARD-ZERO";
+ "NEGATIVE";
+ "NESTED";
+ "NEW";
+ "NEXT";
+ "NEXT-ITEM";
+ "NO";
+ "NO-AUTOSEL";
+ "NO-AUTO-DEFAULT";
+ "NO-BOX";
+ "NO-DIVIDERS";
+ "NO-ECHO";
+ "NO-F4";
+ "NO-FOCUS";
+ "NO-GROUP-TAB";
+ "NO-KEY-LETTER";
+ "NOMINAL";
+ "NO-SEARCH";
+ "NO-UPDOWN";
+ "NONE";
+ "NONNUMERIC";
+ "NORMAL";
+ "NOT";
+ "NOTAB";
+ "NOTHING";
+ "NOTIFY";
+ "NOTIFY-CHANGE";
+ "NOTIFY-DBLCLICK";
+ "NOTIFY-SELCHANGE";
+ "NULL";
+ "NULLS";
+ "NUM-COL-HEADINGS";
+ "NUM-ROWS";
+ "NUMBER";
+ "NUMBERS";
+ "NUMERIC";
+ "NUMERIC-EDITED";
+ "OBJECT";
+ "OBJECT-COMPUTER";
+ "OBJECT-REFERENCE";
+ "OCCURS";
+ "OF";
+ "OFF";
+ "OK-BUTTON";
+ "OMITTED";
+ "ON";
+ "ONLY";
+ "OPEN";
+ "OPTIONAL";
+ "OPTIONS";
+ "OR";
+ "ORDER";
+ "ORGANIZATION";
+ "OTHER";
+ "OTHERS";
+ "OUTPUT";
+ "OVERFLOW";
+ "OVERLAP-LEFT";
+ "OVERLAP-TOP";
+ "OVERLINE";
+ "OVERRIDE";
+ "PACKED-DECIMAL";
+ "PADDING";
+ "PAGE";
+ "PAGE-COUNTER";
+ "PAGE-SETUP";
+ "PAGED";
+ "PARAGRAPH";
+ "PARENT";
+ "PARSE";
+ "PASCAL";
+ "PASSWORD";
+ "PERFORM";
+ "PERMANENT";
+ "PF";
+ "PH";
+ "PHYSICAL";
+ "PIC";
+ "PICTURE";
+ "PIXEL";
+ "PLACEMENT";
+ "PLUS";
+ "POINTER";
+ "POP-UP";
+ "POS";
+ "POSITION";
+ "POSITION-SHIFT";
+ "POSITIVE";
+ "PREFIXED";
+ "PRESENT";
+ "PREVIOUS";
+ "PRINT";
+ "PRINT-NO-PROMPT";
+ "PRINT-PREVIEW";
+ "PRINTER";
+ "PRINTER-1";
+ "PRINTING";
+ "PRIORITY";
+ "PROCEDURE";
+ "PROCEDURE-POINTER";
+ "PROCEDURES";
+ "PROCEED";
+ "PROCESSING";
+ "PROGRAM";
+ "PROGRAM-ID";
+ "PROGRAM-POINTER";
+ "PROGRESS";
+ "PROHIBITED";
+ "PROMPT";
+ "PROPERTIES";
+ "PROPERTY";
+ "PROTECTED";
+ "PROTOTYPE";
+ "PURGE";
+ "PUSH-BUTTON";
+ "QUERY-INDEX";
+ "QUEUE";
+ "QUOTE";
+ "QUOTES";
+ "RADIO-BUTTON";
+ "RAISE";
+ "RAISED";
+ "RAISING";
+ "RANDOM";
+ "RD";
+ "READ";
+ "READ-ONLY";
+ "READERS";
+ "RECEIVE";
+ "RECEIVED";
+ "RECORD";
+ "RECORD-DATA";
+ "RECORD-OVERFLOW";
+ "RECORD-TO-ADD";
+ "RECORD-TO-DELETE";
+ "RECORDING";
+ "RECORDS";
+ "RECURSIVE";
+ "REDEFINES";
+ "REEL";
+ "REFERENCE";
+ "REFERENCES";
+ "REFRESH";
+ "REGION-COLOR";
+ "RELATION";
+ "RELATIVE";
+ "RELEASE";
+ "REMAINDER";
+ "REMARKS";
+ "REMOVAL";
+ "RENAMES";
+ "REORG-CRITERIA";
+ "REPEATED";
+ "REPLACE";
+ "REPLACING";
+ "REPORT";
+ "REPORTING";
+ "REPORTS";
+ "REPOSITORY";
+ "REQUIRED";
+ "REREAD";
+ "RERUN";
+ "RESERVE";
+ "RESET";
+ "RESET-GRID";
+ "RESET-LIST";
+ "RESET-TABS";
+ "RESUME";
+ "RETRY";
+ "RETURN";
+ "RETURNING";
+ "REVERSE";
+ "REVERSE-VIDEO";
+ "REVERSED";
+ "REWIND";
+ "REWRITE";
+ "RF";
+ "RH";
+ "RIGHT";
+ "RIGHT-ALIGN";
+ "RIGHT-JUSTIFY";
+ "RIMMED";
+ "ROLLBACK";
+ "ROUNDED";
+ "ROUNDING";
+ "ROW-COLOR";
+ "ROW-COLOR-PATTERN";
+ "ROW-DIVIDERS";
+ "ROW-FONT";
+ "ROW-HEADINGS";
+ "ROW-PROTECTION";
+ "RUN";
+ "S";
+ "SAME";
+ "SAVE-AS";
+ "SAVE-AS-NO-PROMPT";
+ "SCREEN";
+ "SCROLL";
+ "SCROLL-BAR";
+ "SD";
+ "SEARCH";
+ "SEARCH-OPTIONS";
+ "SEARCH-TEXT";
+ "SECONDS";
+ "SECTION";
+ "SECURE";
+ "SECURITY";
+ "SEGMENT";
+ "SEGMENT-LIMIT";
+ "SELECT";
+ "SELECT-ALL";
+ "SELECTION-INDEX";
+ "SELECTION-TEXT";
+ "SELF";
+ "SELF-ACT";
+ "SEND";
+ "SENTENCE";
+ "SEPARATE";
+ "SEPARATION";
+ "SEQUENCE";
+ "SEQUENTIAL";
+ "SET";
+ "SHADING";
+ "SHADOW";
+ "SHARING";
+ "SHORT-DATE";
+ "SHOW-LINES";
+ "SHOW-NONE";
+ "SHOW-SEL-ALWAYS";
+ "SIGN";
+ "SIGNED";
+ "SIGNED-INT";
+ "SIGNED-LONG";
+ "SIGNED-SHORT";
+ "SIZE";
+ "SMALL-FONT";
+ "SORT";
+ "SORT-MERGE";
+ "SORT-ORDER";
+ "SOURCE";
+ "SOURCE-COMPUTER";
+ "SOURCES";
+ "SPACE";
+ "SPACE-FILL";
+ "SPACES";
+ "SPECIAL-NAMES";
+ "SPINNER";
+ "SQUARE";
+ "STACK";
+ "STANDARD";
+ "STANDARD-1";
+ "STANDARD-2";
+ "STANDARD-BINARY";
+ "STANDARD-DECIMAL";
+ "START";
+ "START-X";
+ "START-Y";
+ "STATEMENT";
+ "STATIC";
+ "STATIC-LIST";
+ "STATUS";
+ "STATUS-BAR";
+ "STATUS-TEXT";
+ "STDCALL";
+ "STEP";
+ "STOP";
+ "STRING";
+ "STRONG";
+ "STYLE";
+ "SUB-QUEUE-1";
+ "SUB-QUEUE-2";
+ "SUB-QUEUE-3";
+ "SUBTRACT";
+ "SUBWINDOW";
+ "SUM";
+ "SUPER";
+ "SUPPRESS";
+ "SYMBOL";
+ "SYMBOLIC";
+ "SYNC";
+ "SYNCHRONIZED";
+ "SYSTEM-DEFAULT";
+ "SYSTEM-INFO";
+ "SYSTEM-OFFSET";
+ "TAB";
+ "TAB-TO-ADD";
+ "TAB-TO-DELETE";
+ "TABLE";
+ "TALLYING";
+ "TAPE";
+ "TEMPORARY";
+ "TERMINAL";
+ "TERMINAL-INFO";
+ "TERMINATE";
+ "TERMINATION-VALUE";
+ "TEST";
+ "TEXT";
+ "THAN";
+ "THEN";
+ "THREAD";
+ "THREADS";
+ "THROUGH";
+ "THRU";
+ "THUMB-POSITION";
+ "TILED-HEADINGS";
+ "TIME";
+ "TIME-OUT";
+ "TIMES";
+ "TITLE";
+ "TITLE-POSITION";
+ "TO";
+ "TOP";
+ "TOP-LEVEL";
+ "TOWARD-GREATER";
+ "TOWARD-LESSER";
+ "TRACK";
+ "TRACKS";
+ "TRACK-AREA";
+ "TRACK-LIMIT";
+ "TRADITIONAL-FONT";
+ "TRAILING";
+ "TRAILING-SHIFT";
+ "TRAILING-SIGN";
+ "TRANSFORM";
+ "TRANSPARENT";
+ "TREE-VIEW";
+ "TRUE";
+ "TRUNCATION";
+ "TYPE";
+ "TYPEDEF";
+ "U";
+ "UCS-4";
+ "UNBOUNDED";
+ "UNDERLINE";
+ "UNFRAMED";
+ "UNIT";
+ "UNIVERSAL";
+ "UNLOCK";
+ "UNSIGNED";
+ "UNSIGNED-INT";
+ "UNSIGNED-LONG";
+ "UNSIGNED-SHORT";
+ "UNSORTED";
+ "UNSTRING";
+ "UNTIL";
+ "UP";
+ "UPDATE";
+ "UPDATERS";
+ "UPON";
+ "UPPER";
+ "USAGE";
+ "USE";
+ "USE-ALT";
+ "USE-RETURN";
+ "USE-TAB";
+ "USER";
+ "USER-DEFAULT";
+ "USING";
+ "UTF-16";
+ "UTF-8";
+ "V";
+ "VAL-STATUS";
+ "VALID";
+ "VALIDATE";
+ "VALIDATE-STATUS";
+ "VALIDATING";
+ "VALUE";
+ "VALUES";
+ "VALUE-FORMAT";
+ "VARIABLE";
+ "VARIANT";
+ "VARYING";
+ "VERTICAL";
+ "VERY-HEAVY";
+ "VIRTUAL-WIDTH";
+ "VOLATILE";
+ "VPADDING";
+ "VSCROLL";
+ "VSCROLL-BAR";
+ "VSCROLL-POS";
+ "VTOP";
+ "WAIT";
+ "WEB-BROWSER";
+ "WHEN";
+ "WIDTH";
+ "WIDTH-IN-CELLS";
+ "WINDOW";
+ "WITH";
+ "WORDS";
+ "WORKING-STORAGE";
+ "WRAP";
+ "WRITE";
+ "WRITE-ONLY";
+ "WRITE-VERIFY";
+ "WRITERS";
+ "X";
+ "XML";
+ "XML-DECLARATION";
+ "XML-SCHEMA";
+ "XOR";
+ "Y";
+ "YYYYDDD";
+ "YYYYMMDD";
+ "ZERO";
+ "ZERO-FILL"; ]
+
+let words =
+ let reserve w = w, Types.ReserveWord { preserve_context_sensitivity = true } in
+ List.rev @@ List.rev_map reserve reserved_words
+
+(** The set of all available intrinsic functions *)
+let intrinsic_functions =
+ StringSet.of_list @@
+ [ "ABS";
+ "ABSOLUTE-VALUE";
+ "ACOS";
+ "ANNUITY";
+ "ASIN";
+ "ATAN";
+ "BASECONVERT";
+ "BIT-OF";
+ "BIT-TO-CHAR";
+ "BOOLEAN-OF-INTEGER";
+ "BYTE-LENGTH";
+ "CHAR";
+ "CHAR-NATIONAL";
+ "COMBINED-DATETIME";
+ "CONCAT";
+ "CONCATENATE";
+ "CONTENT-LENGTH";
+ "CONTENT-OF";
+ "CONVERT";
+ "COS";
+ "CURRENCY-SYMBOL";
+ "CURRENT-DATE";
+ "DATE-OF-INTEGER";
+ "DATE-TO-YYYYMMDD";
+ "DAY-OF-INTEGER";
+ "DAY-TO-YYYYDDD";
+ "DISPLAY-OF";
+ "E";
+ "EXCEPTION-FILE";
+ "EXCEPTION-FILE-N";
+ "EXCEPTION-LOCATION";
+ "EXCEPTION-LOCATION-N";
+ "EXCEPTION-STATEMENT";
+ "EXCEPTION-STATUS";
+ "EXP";
+ "EXP10";
+ "FACTORIAL";
+ "FIND-STRING";
+ "FORMATTED-CURRENT-DATE";
+ "FORMATTED-DATE";
+ "FORMATTED-DATETIME";
+ "FORMATTED-TIME";
+ "FRACTION-PART";
+ "HEX-OF";
+ "HEX-TO-CHAR";
+ "HIGHEST-ALGEBRAIC";
+ "INTEGER";
+ "INTEGER-OF-BOOLEAN";
+ "INTEGER-OF-DATE";
+ "INTEGER-OF-DAY";
+ "INTEGER-OF-FORMATTED-DATE";
+ "INTEGER-PART";
+ "LENGTH";
+ "LENGTH-AN";
+ "LOCALE-COMPARE";
+ "LOCALE-DATE";
+ "LOCALE-TIME";
+ "LOCALE-TIME-FROM-SECONDS";
+ "LOG";
+ "LOG10";
+ "LOWER-CASE";
+ "LOWEST-ALGEBRAIC";
+ "MAX";
+ "MEAN";
+ "MEDIAN";
+ "MIDRANGE";
+ "MIN";
+ "MOD";
+ "MODULE-CALLER-ID";
+ "MODULE-DATE";
+ "MODULE-FORMATTED-DATE";
+ "MODULE-ID";
+ "MODULE-NAME";
+ "MODULE-PATH";
+ "MODULE-SOURCE";
+ "MODULE-TIME";
+ "MONETARY-DECIMAL-POINT";
+ "MONETARY-THOUSANDS-SEPARATOR";
+ "NATIONAL-OF";
+ "NUMERIC-DECIMAL-POINT";
+ "NUMERIC-THOUSANDS-SEPARATOR";
+ "NUMVAL";
+ "NUMVAL-C";
+ "NUMVAL-F";
+ "ORD";
+ "ORD-MAX";
+ "ORD-MIN";
+ "PI";
+ "PRESENT-VALUE";
+ "RANDOM";
+ "RANGE";
+ "REM";
+ "REVERSE";
+ "SECONDS-FROM-FORMATTED-TIME";
+ "SECONDS-PAST-MIDNIGHT";
+ "SIGN";
+ "SIN";
+ "SQRT";
+ "STANDARD-COMPARE";
+ "STANDARD-DEVIATION";
+ "STORED-CHAR-LENGTH";
+ "SUBSTITUTE";
+ "SUBSTITUTE-CASE";
+ "SUM";
+ "TAN";
+ "TEST-DATE-YYYYMMDD";
+ "TEST-DAY-YYYYDDD";
+ "TEST-FORMATTED-DATETIME";
+ "TEST-NUMVAL";
+ "TEST-NUMVAL-C";
+ "TEST-NUMVAL-F";
+ "TRIM";
+ "UPPER-CASE";
+ "VARIANCE";
+ "WHEN-COMPILED";
+ "YEAR-TO-YYYY"; ]
+
+(** Disabled or unimplemented intrinsic functions *)
+let disabled_intrinsic =
+ StringSet.of_list @@
+ [ (*disabled*)
+ "ABSOLUTE-VALUE";
+ (*not implemented*)
+ "BASECONVERT";
+ "BOOLEAN-OF-INTEGER";
+ "CHAR-NATIONAL";
+ "CONVERT";
+ "DISPLAY-OF";
+ "EXCEPTION-FILE-N";
+ "EXCEPTION-LOCATION-N";
+ "FIND-STRING";
+ "INTEGER-OF-BOOLEAN";
+ "MODULE-NAME";
+ "NATIONAL-OF";
+ "STANDARD-COMPARE"; ]
+
+(** Defautls intrinsic functions *)
+let default_intrinsics =
+ StringSet.diff intrinsic_functions disabled_intrinsic
+
+(** Set of available system names *)
+let system_names =
+ StringSet.of_list @@
+ [ "SYSIN";
+ "SYSIPT";
+ "STDIN";
+ "SYSOUT";
+ "SYSLIST";
+ "SYSLST";
+ "SYSPCH";
+ "SYSPUNCH";
+ "STDOUT";
+ "PRINT";
+ "PRINTER";
+ "PRINTER-1";
+ "SYSERR";
+ "STDERR";
+ "CONSOLE";
+ "ALTERNATE-CONSOLE";
+ "ALTERNATE CONSOLE";
+ "TERMINAL";
+ "C01";
+ "C02";
+ "C03";
+ "C04";
+ "C05";
+ "C06";
+ "C07";
+ "C08";
+ "C09";
+ "C10";
+ "C11";
+ "C12";
+ "S01";
+ "S02";
+ "S03";
+ "S04";
+ "S05";
+ "CSP";
+ "FORMFEED";
+ "TOP";
+ "CALL-CONVENTION";
+ "SWITCH-0";
+ "SWITCH-1";
+ "SWITCH-2";
+ "SWITCH-3";
+ "SWITCH-4";
+ "SWITCH-5";
+ "SWITCH-6";
+ "SWITCH-7";
+ "SWITCH-8";
+ "SWITCH-9";
+ "SWITCH-10";
+ "SWITCH-11";
+ "SWITCH-12";
+ "SWITCH-13";
+ "SWITCH-14";
+ "SWITCH-15";
+ "SWITCH-16";
+ "SWITCH-17";
+ "SWITCH-18";
+ "SWITCH-19";
+ "SWITCH-20";
+ "SWITCH-21";
+ "SWITCH-22";
+ "SWITCH-23";
+ "SWITCH-24";
+ "SWITCH-25";
+ "SWITCH-26";
+ "SWITCH-27";
+ "SWITCH-28";
+ "SWITCH-29";
+ "SWITCH-30";
+ "SWITCH-31";
+ "SWITCH-32";
+ "SWITCH-33";
+ "SWITCH-34";
+ "SWITCH-35";
+ "SWITCH-36";
+ "SW0";
+ "SW1";
+ "SW2";
+ "SW3";
+ "SW4";
+ "SW5";
+ "SW6";
+ "SW7";
+ "SW8";
+ "SW9";
+ "SW10";
+ "SW11";
+ "SW12";
+ "SW13";
+ "SW14";
+ "SW15";
+ "SWITCH 0";
+ "SWITCH 1";
+ "SWITCH 2";
+ "SWITCH 3";
+ "SWITCH 4";
+ "SWITCH 5";
+ "SWITCH 6";
+ "SWITCH 7";
+ "SWITCH 8";
+ "SWITCH 9";
+ "SWITCH 10";
+ "SWITCH 11";
+ "SWITCH 12";
+ "SWITCH 13";
+ "SWITCH 14";
+ "SWITCH 15";
+ "SWITCH 16";
+ "SWITCH 17";
+ "SWITCH 18";
+ "SWITCH 19";
+ "SWITCH 20";
+ "SWITCH 21";
+ "SWITCH 22";
+ "SWITCH 23";
+ "SWITCH 24";
+ "SWITCH 25";
+ "SWITCH 26";
+ "SWITCH A";
+ "SWITCH B";
+ "SWITCH C";
+ "SWITCH D";
+ "SWITCH E";
+ "SWITCH F";
+ "SWITCH G";
+ "SWITCH H";
+ "SWITCH I";
+ "SWITCH J";
+ "SWITCH K";
+ "SWITCH L";
+ "SWITCH M";
+ "SWITCH N";
+ "SWITCH O";
+ "SWITCH P";
+ "SWITCH Q";
+ "SWITCH R";
+ "SWITCH S";
+ "SWITCH T";
+ "SWITCH U";
+ "SWITCH V";
+ "SWITCH W";
+ "SWITCH X";
+ "SWITCH Y";
+ "SWITCH Z";
+ "UPSI-0";
+ "UPSI-1";
+ "UPSI-2";
+ "UPSI-3";
+ "UPSI-4";
+ "UPSI-5";
+ "UPSI-6";
+ "UPSI-7";
+ "UPSI-8";
+ "USW-0";
+ "USW-1";
+ "USW-2";
+ "USW-3";
+ "USW-4";
+ "USW-5";
+ "USW-6";
+ "USW-7";
+ "USW-8";
+ "USW-9";
+ "USW-10";
+ "USW-11";
+ "USW-12";
+ "USW-13";
+ "USW-14";
+ "USW-15";
+ "USW-16";
+ "USW-17";
+ "USW-18";
+ "USW-19";
+ "USW-20";
+ "USW-21";
+ "USW-22";
+ "USW-23";
+ "USW-24";
+ "USW-25";
+ "USW-26";
+ "USW-27";
+ "USW-28";
+ "USW-29";
+ "USW-30";
+ "USW-31"; ]
+
+(** Disabled system names by default *)
+let disabled_system_names =
+ StringSet.of_list @@
+ [ "SW0";
+ "SW1";
+ "SW2";
+ "SW3";
+ "SW4";
+ "SW5";
+ "SW6";
+ "SW7";
+ "SW8";
+ "SW9";
+ "SW10";
+ "SW11";
+ "SW12";
+ "SW13";
+ "SW14";
+ "SW15";
+ "SWITCH 0";
+ "SWITCH 1";
+ "SWITCH 2";
+ "SWITCH 3";
+ "SWITCH 4";
+ "SWITCH 5";
+ "SWITCH 6";
+ "SWITCH 7";
+ "SWITCH 8";
+ "SWITCH 9";
+ "SWITCH 10";
+ "SWITCH 11";
+ "SWITCH 12";
+ "SWITCH 13";
+ "SWITCH 14";
+ "SWITCH 15";
+ "SWITCH 16";
+ "SWITCH 17";
+ "SWITCH 18";
+ "SWITCH 19";
+ "SWITCH 20";
+ "SWITCH 21";
+ "SWITCH 22";
+ "SWITCH 23";
+ "SWITCH 24";
+ "SWITCH 25";
+ "SWITCH 26";
+ "SWITCH A";
+ "SWITCH B";
+ "SWITCH C";
+ "SWITCH D";
+ "SWITCH E";
+ "SWITCH F";
+ "SWITCH G";
+ "SWITCH H";
+ "SWITCH I";
+ "SWITCH J";
+ "SWITCH K";
+ "SWITCH L";
+ "SWITCH M";
+ "SWITCH N";
+ "SWITCH O";
+ "SWITCH P";
+ "SWITCH Q";
+ "SWITCH R";
+ "SWITCH S";
+ "SWITCH T";
+ "SWITCH U";
+ "SWITCH V";
+ "SWITCH W";
+ "SWITCH X";
+ "SWITCH Y";
+ "SWITCH Z";
+ "UPSI-0";
+ "UPSI-1";
+ "UPSI-2";
+ "UPSI-3";
+ "UPSI-4";
+ "UPSI-5";
+ "UPSI-6";
+ "UPSI-7";
+ "UPSI-8";
+ "USW-0";
+ "USW-1";
+ "USW-2";
+ "USW-3";
+ "USW-4";
+ "USW-5";
+ "USW-6";
+ "USW-7";
+ "USW-8";
+ "USW-9";
+ "USW-10";
+ "USW-11";
+ "USW-12";
+ "USW-13";
+ "USW-14";
+ "USW-15";
+ "USW-16";
+ "USW-17";
+ "USW-18";
+ "USW-19";
+ "USW-20";
+ "USW-21";
+ "USW-22";
+ "USW-23";
+ "USW-24";
+ "USW-25";
+ "USW-26";
+ "USW-27";
+ "USW-28";
+ "USW-29";
+ "USW-30";
+ "USW-31"; ]
+
+(** Default system names *)
+let default_system_names =
+ StringSet.diff system_names disabled_system_names
+
+(** DIALECT-ALL-DEVICES system names *)
+let device_system_names =
+ StringSet.of_list @@
+ [ "SYSIN";
+ "SYSIPT";
+ "STDIN";
+ "SYSOUT";
+ "SYSLIST";
+ "SYSLST";
+ "SYSPCH";
+ "SYSPUNCH";
+ "STDOUT";
+ "PRINT";
+ "PRINTER";
+ "PRINTER-1";
+ "SYSERR";
+ "STDERR";
+ "CONSOLE";
+ "ALTERNATE-CONSOLE";
+ "ALTERNATE CONSOLE";
+ "TERMINAL"; ]
+
+(** DIALECT-ALL-FEATURES system names *)
+let feature_system_names =
+ StringSet.of_list @@
+ [ "C01";
+ "C02";
+ "C03";
+ "C04";
+ "C05";
+ "C06";
+ "C07";
+ "C08";
+ "C09";
+ "C10";
+ "C11";
+ "C12";
+ "S01";
+ "S02";
+ "S03";
+ "S04";
+ "S05";
+ "CSP";
+ "FORMFEED";
+ "TOP";
+ "CALL-CONVENTION"; ]
+
+(** DIALECT-ALL-SWITCHES system names *)
+let switch_system_names =
+ StringSet.of_list @@
+ [ "SWITCH-0";
+ "SWITCH-1";
+ "SWITCH-2";
+ "SWITCH-3";
+ "SWITCH-4";
+ "SWITCH-5";
+ "SWITCH-6";
+ "SWITCH-7";
+ "SWITCH-8";
+ "SWITCH-9";
+ "SWITCH-10";
+ "SWITCH-11";
+ "SWITCH-12";
+ "SWITCH-13";
+ "SWITCH-14";
+ "SWITCH-15";
+ "SWITCH-16";
+ "SWITCH-17";
+ "SWITCH-18";
+ "SWITCH-19";
+ "SWITCH-20";
+ "SWITCH-21";
+ "SWITCH-22";
+ "SWITCH-23";
+ "SWITCH-24";
+ "SWITCH-25";
+ "SWITCH-26";
+ "SWITCH-27";
+ "SWITCH-28";
+ "SWITCH-29";
+ "SWITCH-30";
+ "SWITCH-31";
+ "SWITCH-32";
+ "SWITCH-33";
+ "SWITCH-34";
+ "SWITCH-35";
+ "SWITCH-36";
+ "SW0";
+ "SW1";
+ "SW2";
+ "SW3";
+ "SW4";
+ "SW5";
+ "SW6";
+ "SW7";
+ "SW8";
+ "SW9";
+ "SW10";
+ "SW11";
+ "SW12";
+ "SW13";
+ "SW14";
+ "SW15";
+ "SWITCH 0";
+ "SWITCH 1";
+ "SWITCH 2";
+ "SWITCH 3";
+ "SWITCH 4";
+ "SWITCH 5";
+ "SWITCH 6";
+ "SWITCH 7";
+ "SWITCH 8";
+ "SWITCH 9";
+ "SWITCH 10";
+ "SWITCH 11";
+ "SWITCH 12";
+ "SWITCH 13";
+ "SWITCH 14";
+ "SWITCH 15";
+ "SWITCH 16";
+ "SWITCH 17";
+ "SWITCH 18";
+ "SWITCH 19";
+ "SWITCH 20";
+ "SWITCH 21";
+ "SWITCH 22";
+ "SWITCH 23";
+ "SWITCH 24";
+ "SWITCH 25";
+ "SWITCH 26";
+ "SWITCH A";
+ "SWITCH B";
+ "SWITCH C";
+ "SWITCH D";
+ "SWITCH E";
+ "SWITCH F";
+ "SWITCH G";
+ "SWITCH H";
+ "SWITCH I";
+ "SWITCH J";
+ "SWITCH K";
+ "SWITCH L";
+ "SWITCH M";
+ "SWITCH N";
+ "SWITCH O";
+ "SWITCH P";
+ "SWITCH Q";
+ "SWITCH R";
+ "SWITCH S";
+ "SWITCH T";
+ "SWITCH U";
+ "SWITCH V";
+ "SWITCH W";
+ "SWITCH X";
+ "SWITCH Y";
+ "SWITCH Z";
+ "UPSI-0";
+ "UPSI-1";
+ "UPSI-2";
+ "UPSI-3";
+ "UPSI-4";
+ "UPSI-5";
+ "UPSI-6";
+ "UPSI-7";
+ "UPSI-8";
+ "USW-0";
+ "USW-1";
+ "USW-2";
+ "USW-3";
+ "USW-4";
+ "USW-5";
+ "USW-6";
+ "USW-7";
+ "USW-8";
+ "USW-9";
+ "USW-10";
+ "USW-11";
+ "USW-12";
+ "USW-13";
+ "USW-14";
+ "USW-15";
+ "USW-16";
+ "USW-17";
+ "USW-18";
+ "USW-19";
+ "USW-20";
+ "USW-21";
+ "USW-22";
+ "USW-23";
+ "USW-24";
+ "USW-25";
+ "USW-26";
+ "USW-27";
+ "USW-28";
+ "USW-29";
+ "USW-30";
+ "USW-31"; ]
+
+(** Set of available registers *)
+let registers =
+ StringSet.of_list @@
+ [ "ADDRESS OF";
+ "COB-CRT-STATUS";
+ "DEBUG-ITEM";
+ "LENGTH OF";
+ "NUMBER-OF-CALL-PARAMETERS";
+ "RETURN-CODE";
+ "SORT-RETURN";
+ "TALLY";
+ "COL";
+ "LIN";
+ "WHEN-COMPILED";
+ "XML-CODE";
+ "XML-EVENT";
+ "XML-INFORMATION";
+ "XML-NAMESPACE";
+ "XML-NAMESPACE-PREFIX";
+ "XML-NNAMESPACE";
+ "XML-NNAMESPACE-PREFIX";
+ "XML-NTEXT";
+ "XML-TEXT";
+ "JSON-CODE";
+ "JSON-STATUS"; ]
+
+(** Disabled by default registers *)
+let must_be_enabled_registers =
+ StringSet.of_list @@
+ [ "COL";
+ "LIN"; ]
+
+(** Default registers *)
+let default_registers =
+ StringSet.diff registers must_be_enabled_registers
diff --git a/src/lsp/cobol_config/reserved_words.mli b/src/lsp/cobol_config/reserved_words.mli
new file mode 100644
index 000000000..a9b6c96de
--- /dev/null
+++ b/src/lsp/cobol_config/reserved_words.mli
@@ -0,0 +1,25 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open EzCompat
+
+val words : (string * Types.word_spec) list
+val default_intrinsics : StringSet.t
+val default_registers : StringSet.t
+val intrinsic_functions : StringSet.t
+val default_system_names : StringSet.t
+val switch_system_names : StringSet.t
+val device_system_names : StringSet.t
+val feature_system_names : StringSet.t
+val system_names : StringSet.t
+val registers : StringSet.t
diff --git a/src/lsp/cobol_config/types.ml b/src/lsp/cobol_config/types.ml
new file mode 100644
index 000000000..92af6a648
--- /dev/null
+++ b/src/lsp/cobol_config/types.ml
@@ -0,0 +1,502 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Module containing most of the types definitions used in {!Cobol_config}. *)
+
+open Cobol_common.Diagnostics.TYPES
+
+module DIAGS = Cobol_common.Diagnostics
+
+type doc = Pretty.simple
+
+(** Global configuration representative (default, gcos, gcos-strict, etc). Just
+ a name for now, but we could add some more info later (like configuration
+ files read). *)
+type configuration =
+ (* May become an object a well, if revelant *)
+ {
+ name: string; (* e.g, "default", "MicroFocus", "ACU", "GCOS" *)
+ }
+
+(** Any object with a pretty-printing method. *)
+class type showable =
+ object
+ method pp: Pretty.delayed
+ end
+
+(** Kind (type) of configuration options. *)
+class virtual ['a] kind ~name =
+ object
+ val name: string = name
+ method name = name
+ method pp: Pretty.delayed = fun ppf -> Pretty.string ppf name
+ method virtual parse: string -> 'a
+ end
+
+let all_configs: showable list ref = ref [] (* for listing of options *)
+let configurable_name_style = [`Yellow; `Bold]
+and configurable_kind_style = [`Cyan]
+
+(** Any object that is configurable. *)
+class virtual ['a] configurable ~name ~kind ?short doc =
+ let uncapitalize_heuristics s = match s.[1] with
+ | 'A' .. 'Z' | '-' -> s
+ | _ -> String.uncapitalize_ascii s
+ | exception Invalid_argument _ -> String.uncapitalize_ascii s
+ in
+ object (self)
+ val name: string = name
+ val kind: 'a kind = kind
+ val doc: doc = doc
+ method name = name
+ method short: doc = match short with
+ | Some s -> s
+ | None -> Pretty.Simple.map uncapitalize_heuristics doc
+ method pp ppf =
+ let pp_name = Pretty.styles configurable_name_style @@ Pretty.string
+ and pp_kind = Pretty.styles configurable_kind_style @@ Fmt.fmt "%t" in
+ Pretty.print ppf "@[<4>%a@ [%a]:@\n%(%)@]"
+ pp_name name pp_kind kind#pp doc
+ initializer begin
+ all_configs := (self :> showable) :: !all_configs;
+ end
+ end
+
+module FEATURE = struct
+ (** Optional features of COBOL dialects with support levels similar to those
+ in GnuCOBOL. *)
+
+ (** Values for support levels. Those that do not raise errors may come with
+ option-specific values, hence the type parameter. *)
+ type 'a support_level =
+ | Ok of 'a
+ | Warning of 'a
+ | Archaic of 'a
+ | Obsolete of 'a
+ | Skip
+ | Ignore
+ | Error
+ | Unconformable
+
+ (** Kind (type) of support level options *)
+ class virtual ['a] feature_kind ~name =
+ object(self)
+ inherit ['a support_level] kind ~name
+ method virtual from_ast: Conf_ast.support_value -> 'a support_level
+ method kind: 'a support_level kind = (self :> 'a support_level kind)
+ end
+
+
+ (** Generic kind of support, that carry no value; i.e, those are simple
+ flags. *)
+ let unit_kind =
+ object
+ inherit [unit] feature_kind ~name:"support"
+ method parse s = match String.lowercase_ascii s with
+ | "ok" -> Ok ()
+ | "warning" -> Warning ()
+ | "archaic" -> Archaic ()
+ | "obsolete" -> Obsolete ()
+ | "skip" -> Skip
+ | "ignore" -> Ignore
+ | "error" -> Error
+ | "unconformable" -> Unconformable
+ | _ as s -> raise @@ Invalid_argument s (* TODO: or error... *)
+ method from_ast: Conf_ast.support_value -> unit support_level = function
+ | Ok -> Ok ()
+ | Warning -> Warning ()
+ | Archaic -> Archaic ()
+ | Obsolete -> Obsolete ()
+ | Skip -> Skip
+ | Ignore -> Ignore
+ | Error -> Error
+ | Unconformable -> Unconformable
+ end
+
+ (** Internal representation of a binding from a feature and a support
+ level. *)
+ class ['a] support feature ~config level =
+ object (self)
+ val feature: 'a support_level configurable = feature
+ val level: 'a support_level = level
+ method verify ~loc : _ result =
+ let open Cobol_common.Diagnostics.One in
+ let short = feature#short and config = config.name in
+ match level with
+ | Ok s ->
+ Ok (s, None)
+ | Warning s ->
+ Ok (s, Some (warn ?loc "%(%)@ used" short))
+ | Archaic s ->
+ Ok (s, Some (warn ?loc "%(%)@ is@ archaic@ in@ %s" short config))
+ | Obsolete s ->
+ Ok (s, Some (warn ?loc "%(%)@ is@ obsolete@ in@ %s" short config))
+ | Skip ->
+ Error None
+ | Ignore ->
+ Error (Some (warn ?loc "%(%)@ ignored" short))
+ | Error ->
+ Error (Some (error ?loc "%(%)@ used" short))
+ | Unconformable ->
+ Error (Some (error ?loc "%(%)@ does@ not@ conform@ to@ \
+ %s" short config))
+ method verify' ~loc : _ option with_diags = (* transitional *)
+ match self#verify ~loc with
+ | Ok (s, diag) -> DIAGS.some_result s ~diags:(DIAGS.Set.maybe diag)
+ | Error diag -> DIAGS.no_result ~diags:(DIAGS.Set.maybe diag)
+ method level = level
+ end
+
+ (** Type of optional COBOL dialect features. *)
+ class ['a] feature ~(feature_kind: 'a feature_kind) ~name ?short doc =
+ object (self)
+ inherit ['a support_level]
+ configurable ~kind:feature_kind#kind ~name ?short doc
+ method from_level: config:configuration -> 'a support_level -> 'a support =
+ new support (self :> 'a support_level configurable)
+ method from_string: config:configuration -> string -> 'a support =
+ fun ~config s -> self#from_level ~config (feature_kind#kind#parse s)
+ method from_ast: config:configuration -> Conf_ast.support_value -> 'a support =
+ fun ~config s -> self#from_level ~config (feature_kind#from_ast s)
+ end
+
+ type 'a t = 'a feature
+
+ (** Definitions *)
+ let def = new feature
+ let unit = new feature ~feature_kind:unit_kind
+
+end
+type 'a feature = 'a FEATURE.t (* alias *)
+type 'a feature_support = 'a FEATURE.support
+
+(* TODO: add min/max for int values. *)
+module Value = struct
+ (** Valued (typed) options. *)
+
+ (** Internal representation of typed option binding. *)
+ class ['a] v option ~config:_ v =
+ object
+ val option: 'a configurable = option
+ method value: 'a = v
+ end
+
+ (** Type of valued options *)
+ class ['a] value ~kind ~name ?short doc =
+ object (self)
+ inherit ['a] configurable ~kind ~name ?short doc
+ method from_val: config:configuration -> 'a -> 'a v =
+ new v (self :> 'a configurable)
+ method from_string ~(config:configuration) str: 'a v =
+ let value = kind#parse str in
+ new v (self :> 'a configurable) ~config value
+ end
+
+ type 'a t = 'a value
+
+ (** Definitions *)
+ let def ~name = new value ~name
+
+ let kind_from_fmt ~name fmt =
+ object
+ inherit [_] kind ~name
+ method parse s = Scanf.sscanf s fmt Fun.id
+ end
+
+ let int = def ~kind:(kind_from_fmt ~name:"int" "%d")
+ let bool = def ~kind:(kind_from_fmt ~name:"bool" "%B")
+
+end
+type 'a valued_option = 'a Value.v (* alias *)
+type 'a value = 'a Value.t (* alias *)
+
+type defaultbyte =
+ | Char of char (* int values will be translated to char *)
+ | Init
+ | None
+
+type standard =
+ | GnuCOBOL
+ | MicroFocus
+ | IBM
+ | MVS
+ | BS2000
+ | ACU
+ | RM
+ | STD85
+ | STD2002
+ | STD2014
+
+type source_format =
+ | SFFree
+ | SFFixed
+ | SFVariable
+ | SFXOpen
+ | SFxCard
+ | SFCRT
+ | SFTrm
+ | SFCOBOLX
+
+type source_format_spec =
+ | Auto
+ | SF of source_format
+
+type binary_size =
+ | B_2_4_8
+ | B_1_2_4_8
+ | B_1__8
+
+type binary_byteorder =
+ | Native
+ | Big_endian
+
+(* TODO: Check if IBM and MF change the behavior compared with Dynamic and External *)
+type assign_clause =
+ | Dynamic
+ | External
+ | IBM
+ | MF
+
+type screen_section_rules =
+ | ACU
+ | GC
+ | MF
+ | RM
+ | STD
+ | XOPEN
+
+type dpc_in_data =
+ | None
+ | XML
+ | Json
+ | All
+
+type words_spec = (string * word_spec) list
+and word_spec =
+ | ReserveWord of
+ {
+ preserve_context_sensitivity: bool;
+ }
+ | ReserveAlias of
+ {
+ alias_for: string;
+ preserve_context_sensitivity: bool;
+ }
+ | NotReserved
+
+module DIALECT = struct
+
+ let all_canonical_names =
+ [ "default";
+ "gnucobol"; "microfocus"; "mf"; "acu"; "gcos"; "ibm"; "cobol85";
+ "GnuCOBOL"; "MicroFocus"; "MF"; "ACU"; "GCOS"; "IBM"; "COBOL85" ]
+
+ type t =
+ | Default
+ | COBOL85
+ | GnuCOBOL
+ | MicroFocus
+ | ACU
+ | GCOS
+ | IBM
+
+ let name: t -> string = function
+ | Default -> "default"
+ | COBOL85 -> "COBOL85"
+ | GnuCOBOL -> "GnuCOBOL"
+ | MicroFocus -> "MicroFocus"
+ | ACU -> "ACU"
+ | GCOS -> "GCOS"
+ | IBM -> "IBM"
+
+ let of_string: string -> t = fun s ->
+ match String.lowercase_ascii s with
+ | "default" -> Default
+ | "cobol85" -> COBOL85
+ | "gnucobol" -> GnuCOBOL
+ | "microfocus" | "mf" -> MicroFocus
+ | "acu" -> ACU
+ | "gcos" -> GCOS
+ | "ibm" -> IBM
+ | _ -> invalid_arg s
+
+ let of_name: string -> t = function
+ | "COBOL 85" -> COBOL85
+ | "GnuCOBOL" -> GnuCOBOL (*TODO: or maybe default *)
+ | "Micro Focus COBOL" | "Micro Focus COBOL (lax)" -> MicroFocus
+ | "IBM COBOL" | "IBM COBOL (lax)" -> IBM
+ | "GCOS" | "GCOS (lax)" -> GCOS
+ | "ACUCOBOL-GT" | "ACUCOBOL-GT (lax)" -> ACU
+ | s -> of_string s
+
+end
+type dialect = DIALECT.t
+
+module type CONFIG = sig
+ val dialect: dialect
+ val config: configuration
+end
+
+module type PP_OPTS = sig
+ (** Preprocessor options*)
+
+ (* int options *)
+ val tab_width: int valued_option
+
+ (* support options *)
+ val comment_paragraphs: unit feature_support
+ val safe_partial_replacing_when_src_literal: [`Safe | `Unsafe] feature_support
+end
+
+module type COMP_OPTS = sig
+ (** Compiler options *)
+
+ (* reserved words *)
+ val words: words_spec
+ val intrinsic_functions: Cobol_common.Basics.StringSet.t
+ val system_names: Cobol_common.Basics.StringSet.t
+ val registers: Cobol_common.Basics.StringSet.t
+
+ (* int options *)
+ val text_column: int valued_option
+ val pic_length: int valued_option
+ val word_length: int valued_option
+ val literal_length: int valued_option
+ val numeric_literal_length: int valued_option
+
+ (* any options *)
+ val defaultbyte: defaultbyte valued_option
+ val standard_define: standard valued_option
+ val format: source_format_spec valued_option
+ val binary_size: binary_size valued_option
+ val binary_byteorder: binary_byteorder valued_option
+ val assign_clause: assign_clause valued_option
+ val screen_section_rules: screen_section_rules valued_option
+ val dpc_in_data: dpc_in_data valued_option
+
+ (* boolean options *)
+ val filename_mapping: bool valued_option
+ val pretty_display: bool valued_option
+ val binary_truncate: bool valued_option
+ val complex_odo: bool valued_option
+ val odoslide: bool valued_option
+ val indirect_redefines: bool valued_option
+ val relax_syntax_checks: bool valued_option
+ val ref_mod_zero_length: bool valued_option
+ val relax_level_hierarchy: bool valued_option
+ val select_working: bool valued_option
+ val local_implies_recursive: bool valued_option
+ val sticky_linkage: bool valued_option
+ val move_ibm: bool valued_option
+ val perform_osvs: bool valued_option
+ val arithmetic_osvs: bool valued_option
+ val hostsign: bool valued_option
+ val program_name_redefinition: bool valued_option
+ val accept_update: bool valued_option
+ val accept_auto: bool valued_option
+ val console_is_crt: bool valued_option
+ val no_echo_means_secure: bool valued_option
+ val line_col_zero_default: bool valued_option
+ val display_special_fig_consts: bool valued_option
+ val binary_comp_1: bool valued_option
+ val numeric_pointer: bool valued_option
+ val move_non_numeric_lit_to_numeric_is_zero: bool valued_option
+ val implicit_assign_dynamic_var: bool valued_option
+ val device_mnemonics: bool valued_option
+ val xml_parse_xmlss: bool valued_option
+ val areacheck: bool valued_option
+ val ebcdic_symbolic_characters: bool valued_option
+
+ (* support options *)
+ val control_division: unit feature_support
+ val memory_size_clause: unit feature_support
+ val multiple_file_tape_clause: unit feature_support
+ val label_records_clause: unit feature_support
+ val value_of_clause: unit feature_support
+ val data_records_clause: unit feature_support
+ val top_level_occurs_clause: unit feature_support
+ val same_as_clause: unit feature_support
+ val type_to_clause: unit feature_support
+ val usage_type: unit feature_support
+ val synchronized_clause: unit feature_support
+ val sync_left_right: unit feature_support
+ val special_names_clause: unit feature_support
+ val goto_statement_without_name: unit feature_support
+ val stop_literal_statement: unit feature_support
+ val stop_identifier_statement: unit feature_support
+ val stop_error_statement: unit feature_support
+ val debugging_mode: unit feature_support
+ val use_for_debugging: unit feature_support
+ val padding_character_clause: unit feature_support
+ val next_sentence_phrase: unit feature_support
+ val listing_statements: unit feature_support
+ val title_statement: unit feature_support
+ val entry_statement: unit feature_support
+ val move_noninteger_to_alphanumeric: unit feature_support
+ val move_figurative_constant_to_numeric: unit feature_support
+ val move_figurative_space_to_numeric: unit feature_support
+ val move_figurative_quote_to_numeric: unit feature_support
+ val odo_without_to: unit feature_support
+ val section_segments: unit feature_support
+ val alter_statement: unit feature_support
+ val call_overflow: unit feature_support
+ val numeric_boolean: unit feature_support
+ val hexadecimal_boolean: unit feature_support
+ val national_literals: unit feature_support
+ val hexadecimal_national_literals: unit feature_support
+ val national_character_literals: unit feature_support
+ val hp_octal_literals: unit feature_support
+ val acu_literals: unit feature_support
+ val word_continuation: unit feature_support
+ val not_exception_before_exception: unit feature_support
+ val accept_display_extensions: unit feature_support
+ val larger_redefines: unit feature_support
+ val symbolic_constant: unit feature_support
+ val constant_78: unit feature_support
+ val constant_01: unit feature_support
+ val perform_varying_without_by: unit feature_support
+ val reference_out_of_declaratives: unit feature_support
+ val program_prototypes: unit feature_support
+ val call_convention_mnemonic: unit feature_support
+ val call_convention_linkage: unit feature_support
+ val numeric_value_for_edited_item: unit feature_support
+ val incorrect_conf_sec_order: unit feature_support
+ val define_constant_directive: unit feature_support
+ val free_redefines_position: unit feature_support
+ val records_mismatch_record_clause: unit feature_support
+ val record_delimiter: unit feature_support
+ val sequential_delimiters: unit feature_support
+ val record_delim_with_fixed_recs: unit feature_support
+ val missing_statement: unit feature_support
+ val missing_period: unit feature_support
+ val zero_length_literals: unit feature_support
+ val xml_generate_extra_phrases: unit feature_support
+ val continue_after: unit feature_support
+ val goto_entry: unit feature_support
+ val assign_variable: unit feature_support
+ val assign_using_variable: unit feature_support
+ val assign_ext_dyn: unit feature_support
+ val assign_disk_from: unit feature_support
+ val vsam_status: unit feature_support
+ val self_call_recursive: unit feature_support
+ val record_contains_depending_clause: unit feature_support
+ val picture_l: unit feature_support
+end
+
+module type T = sig
+ include CONFIG
+ include PP_OPTS
+ include COMP_OPTS
+end
+
+type t = (module T)
diff --git a/src/polka-js-stubs/version.mlt b/src/lsp/cobol_config/version.mlt
similarity index 100%
rename from src/polka-js-stubs/version.mlt
rename to src/lsp/cobol_config/version.mlt
diff --git a/src/lsp/cobol_config/words.ml b/src/lsp/cobol_config/words.ml
new file mode 100644
index 000000000..62cced9ab
--- /dev/null
+++ b/src/lsp/cobol_config/words.ml
@@ -0,0 +1,154 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Basics
+
+module FATAL = Cobol_common.Diagnostics.Fatal
+
+type kind =
+ | DialectAll
+ | DialectAllDevices
+ | DialectAllSwitches
+ | DialectAllFeatures
+ | Word of string
+
+let kind_of_string = function
+ | "DIALECT-ALL" -> DialectAll
+ | "DIALECT-ALL-DEVICES" -> DialectAllDevices
+ | "DIALECT-ALL-SWITCHES" -> DialectAllSwitches
+ | "DIALECT-ALL-FEATURES" -> DialectAllFeatures
+ | s -> Word s
+
+(** Module containing all the modules used to build all the reserved words sets *)
+
+(*NOTE: no `mli` as this module is not to be used outside of `Cobol_config` *)
+
+(** This module is used to build reserved words set and aliases map. *)
+module RESERVED = struct
+
+ let conf : Types.words_spec ref = ref []
+ let cons s = conf := s :: !conf
+
+ let categorize word =
+ if Str.last_chars word 1 = "*"
+ then String.sub word 0 (String.length word - 1), true
+ else word, false
+
+ let add_reserved str =
+ match kind_of_string str with
+ | DialectAll ->
+ conf := List.rev_append Reserved_words.words !conf
+ | Word str ->
+ let w, preserve_context_sensitivity = categorize str in
+ cons (w, Types.ReserveWord { preserve_context_sensitivity })
+ | _ -> Pretty.failwith "Wrong DIALECT-* word" str
+
+ let add_alias alias alias_for =
+ let w, preserve_context_sensitivity = categorize alias in
+ cons (w, Types.ReserveAlias { preserve_context_sensitivity; alias_for })
+
+ let remove_reserved w =
+ cons (w, Types.NotReserved)
+
+ let words () = List.rev !conf
+
+end
+
+(** Module used to build the intrinsic functions set *)
+module INTRINSIC = struct
+ let intrinsic = ref Reserved_words.default_intrinsics
+
+ let add_intrinsic word =
+ match kind_of_string word with
+ | DialectAll ->
+ intrinsic := StringSet.union Reserved_words.intrinsic_functions !intrinsic
+ | Word word ->
+ if not @@ StringSet.mem word Reserved_words.intrinsic_functions then
+ FATAL.error "Unknown intrinsic function %s" word
+ else
+ intrinsic := StringSet.add word !intrinsic
+ | _ -> Pretty.failwith "Wrong DIALECT-* word" word
+
+ let remove_intrinsic word =
+ match kind_of_string word with
+ | DialectAll ->
+ intrinsic :=
+ StringSet.filter (fun v -> not @@ StringSet.mem v Reserved_words.intrinsic_functions) !intrinsic
+ | Word word ->
+ intrinsic := StringSet.remove word !intrinsic
+ | _ -> Pretty.failwith "Wrong DIALECT-* word" word
+
+ let intrinsic_functions () = !intrinsic
+end
+
+(** Module used to build the system names set *)
+module SYSTEM_NAMES = struct
+ let system_names = ref Reserved_words.default_system_names
+
+ let add_system_name name =
+ match kind_of_string name with
+ | DialectAll ->
+ system_names := StringSet.union Reserved_words.system_names !system_names
+ | DialectAllDevices ->
+ system_names := StringSet.union Reserved_words.device_system_names !system_names
+ | DialectAllSwitches ->
+ system_names := StringSet.union Reserved_words.switch_system_names !system_names
+ | DialectAllFeatures ->
+ system_names := StringSet.union Reserved_words.feature_system_names !system_names
+ | Word name ->
+ if StringSet.mem name Reserved_words.system_names then
+ system_names := StringSet.add name !system_names
+ else
+ FATAL.error "Unknown system name: %s" name
+
+ let remove_system_name name =
+ match kind_of_string name with
+ | DialectAll ->
+ system_names := StringSet.diff !system_names Reserved_words.system_names
+ | DialectAllDevices ->
+ system_names := StringSet.diff !system_names Reserved_words.device_system_names
+ | DialectAllSwitches ->
+ system_names := StringSet.diff !system_names Reserved_words.switch_system_names
+ | DialectAllFeatures ->
+ system_names := StringSet.diff !system_names Reserved_words.feature_system_names
+ | Word name ->
+ system_names := StringSet.remove name !system_names
+
+ let system_names () = !system_names
+end
+
+(** Module used to build the registers set *)
+module REGISTERS = struct
+ let registers = ref Reserved_words.default_registers
+
+ let add_register register =
+ match kind_of_string register with
+ | DialectAll ->
+ registers := StringSet.union !registers Reserved_words.default_registers
+ | Word register ->
+ if not @@ StringSet.mem register Reserved_words.registers then
+ FATAL.error "Unknown register: %s" register
+ else
+ registers := StringSet.add register !registers
+ | _ -> Pretty.failwith "Wrong DIALECT-* word %S" register
+
+ let remove_register register =
+ match kind_of_string register with
+ | DialectAll ->
+ registers := StringSet.diff !registers Reserved_words.default_registers
+ | Word register ->
+ registers := StringSet.remove register !registers
+ | _ -> Pretty.failwith "Wrong DIALECT-* word %S" register
+
+ let registers () = !registers
+end
diff --git a/src/lsp/cobol_data/README.md b/src/lsp/cobol_data/README.md
new file mode 100644
index 000000000..4e12a3100
--- /dev/null
+++ b/src/lsp/cobol_data/README.md
@@ -0,0 +1,6 @@
+# Cobol_data package
+
+This package contains some data structure for COBOL, as well as some logic on the COBOL variables
+and values such as `Picture` or `Types`.
+
+For API documentation, please see [index.mld].
diff --git a/src/lsp/cobol_data/cobol_data.ml b/src/lsp/cobol_data/cobol_data.ml
new file mode 100644
index 000000000..a3ad8bba1
--- /dev/null
+++ b/src/lsp/cobol_data/cobol_data.ml
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module implements functions to type the COBOL data.*)
+
+module Types = struct
+ include Types
+ type picture = Picture.t
+ type group = Group.t
+
+ include Compilation_unit.TYPES
+ type compilation_units = Compilation_unit.SET.t
+ type +'a compilation_units_map = 'a Compilation_unit.MAP.t
+end
+
+include Env
+module Group = Group
+module Mangling = Mangling
+module Picture = Picture
+module Pictured_ast = Pictured_ast
+module Qualmap = Qualmap
+module Compilation_unit = Compilation_unit
+module Typing = Typing
diff --git a/src/lsp/cobol_data/compilation_unit.ml b/src/lsp/cobol_data/compilation_unit.ml
new file mode 100644
index 000000000..299c6a238
--- /dev/null
+++ b/src/lsp/cobol_data/compilation_unit.ml
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open EzCompat
+
+module TYPES = struct
+ (** Representation of compilation units *)
+ type compilation_unit =
+ {
+ cu_name: string;
+ cu_loc: Cobol_common.Srcloc.srcloc;
+ cu_env: Env.PROG_ENV.t; (* TODO: Env{ironment}.t *)
+ cu_wss: Group.t list;
+ }
+end
+include TYPES
+
+type t = compilation_unit
+
+let compare_by_name { cu_name = n1; _ } { cu_name = n2; _ } =
+ String.compare n1 n2
+
+(* --- *)
+
+module M = struct
+ type nonrec t = t
+ let compare = compare_by_name
+end
+
+module SET: sig
+ include Set.S with type elt = compilation_unit
+ and type t = Set.Make (M).t
+ val find_by_name: string -> t -> compilation_unit
+ val find_at_loc: Cobol_common.Srcloc.srcloc -> t -> compilation_unit
+ val assoc: (compilation_unit -> 'a) -> t -> 'a Map.Make (M).t
+ type register = private compilation_unit StringMap.t
+ val register: t -> register
+end = struct
+ include Set.Make (M)
+ module MAP = Map.Make (M)
+
+ let find_by_name name cus =
+ let cu = find_first (fun cu -> String.compare cu.cu_name name >= 0) cus in
+ if cu.cu_name = name then cu else raise Not_found
+ let find_at_loc loc cus =
+ let cu = find_first (fun cu -> Stdlib.compare cu.cu_loc loc >= 0) cus in
+ if cu.cu_loc = loc then cu else raise Not_found
+ let assoc f cus =
+ to_seq cus |> Seq.map (fun cu -> cu, f cu) |> MAP.of_seq
+
+ type register = compilation_unit StringMap.t
+ let register cus : register =
+ to_seq cus |> Seq.map (fun cu -> cu.cu_name, cu) |>
+ StringMap.of_seq
+
+end
+
+module MAP: sig
+ include Map.S with type key = compilation_unit
+ and type +'a t = 'a Map.Make (M).t
+ val compilation_units: 'a t -> SET.t
+ val find_by_name: string -> 'a t -> compilation_unit * 'a
+end = struct
+ include Map.Make (M)
+ let compilation_units map =
+ to_seq map |> Seq.map fst |> SET.of_seq
+ let find_by_name name map =
+ let cu, v = find_first (fun cu -> String.compare cu.cu_name name >= 0) map in
+ if cu.cu_name = name then cu, v else raise Not_found
+end
diff --git a/src/lsp/cobol_data/dune b/src/lsp/cobol_data/dune
new file mode 100644
index 000000000..b0e94ac17
--- /dev/null
+++ b/src/lsp/cobol_data/dune
@@ -0,0 +1,26 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_data)
+ (public_name cobol_data)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries ppx_deriving cobol_parser cobol_ast )
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show))
+
+ )
+
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_data))
+
+; use field 'dune-trailer' to add more stuff here
+
diff --git a/src/lsp/cobol_data/env.ml b/src/lsp/cobol_data/env.ml
new file mode 100644
index 000000000..b8c27146a
--- /dev/null
+++ b/src/lsp/cobol_data/env.ml
@@ -0,0 +1,112 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_ast
+open Types
+
+module StringSet = Cobol_common.Basics.StringSet
+module StringMap = Cobol_common.Basics.StringMap
+module CharSet = Cobol_common.Basics.CharSet
+module FATAL = Cobol_common.Diagnostics.Fatal
+
+(*FIXME: Quite a bit of rework for c translation and analysis alike *)
+
+(* For data item:
+ * name
+ * type
+ * declaration loc
+ * sub_items?
+ * data_size
+ * is global
+ * default value
+ * picture *)
+
+(* For program:
+ * name
+ * nested_progs (just the name maybe?)
+ * data_items
+ * curr_signs (maybe char set)
+ * decimal_point (maybe algebric)
+ * entry arguments *)
+
+module NameSet = Set.Make(struct
+ type t = name
+ let compare = String.compare
+ end)
+
+module Names = NameSet
+
+module DATA_ITEM = struct
+ type condition = {
+ target: qualname;
+ values: condition_name_value list;
+ } [@@deriving show]
+
+ type t =
+ { name: name;
+ typ: data_type option;
+ size: int;
+ global: bool;
+ value: data_value_clause option;
+ renames: qualname list;
+ condition: condition option;
+ redefines: qualname option;
+ constant: constant_value option; }
+ [@@deriving show]
+
+ let make name =
+ { name = name;
+ typ = None;
+ size = 0;
+ global = false;
+ value = None;
+ renames = [];
+ redefines = None;
+ constant = None;
+ condition = None; }
+end
+
+module PROG_ENV = struct
+ type t =
+ { name: name;
+ parent_prog: t option;
+ data_items: DATA_ITEM.t Qualmap.t;
+ currency_signs: CharSet.t;
+ decimal_point: char;
+ using_items: NameSet.t; }
+
+ let make ?parent name =
+ match parent with
+ | None ->
+ { name = name;
+ parent_prog = None;
+ data_items = Qualmap.empty;
+ currency_signs = CharSet.empty;
+ decimal_point = '.';
+ using_items = NameSet.empty }
+ | Some parent ->
+ { parent with
+ name = name;
+ parent_prog = Some parent;
+ (* CHECKME: directly inherit those? Even better: extract the
+ non-environment-specific part into a `prog` structure, with a
+ `prog_env` that is the (inherited and augmented) environment, and
+ specific `prog_data`/`prog_using`. *)
+ data_items = Qualmap.empty;
+ using_items = NameSet.empty }
+
+end
+
+module ENV = struct
+ include StringMap
+end
diff --git a/src/lsp/cobol_data/group.ml b/src/lsp/cobol_data/group.ml
new file mode 100644
index 000000000..5b0388fa9
--- /dev/null
+++ b/src/lsp/cobol_data/group.ml
@@ -0,0 +1,448 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_ast
+open Cobol_common.Srcloc.TYPES
+open Cobol_common.Srcloc.INFIX
+open Pictured_ast.Data_sections
+
+(** This module implements data_groups which are how we group together all the
+ {!Cobol_parser.Ptree.data_description} in grouped items before typing them. *)
+
+(*TODO: Maybe renames can be a list of qualnames*)
+type t' =
+ | Renames of {name: name; targets: t list }
+ | ConditionName of {name: name; values: condition_name_value list; target: t }
+ | Constant of { name: name; value: constant_value with_loc;
+ constant_item_descr: constant_item_descr }
+ | Elementary of { name: name; data_item: data_item_descr }
+ | Group of { name: name; elements: t list; data_item: data_item_descr }
+[@@deriving show]
+
+and t = t' with_loc
+[@@deriving show]
+
+let pp_data_group_list ppf =
+ Pretty.list ~fsep:"@ " ~fopen:"@[" ~fclose:"@]" ~fempty:""
+ pp ppf
+
+let name_of: t -> name = fun g -> match ~&g with
+ | Group {name; _} | Elementary {name; _} | ConditionName {name; _}
+ | Constant {name; _} | Renames {name; _} ->
+ name
+
+(* let name_location g = ~@(name_of g) *)
+
+(** [group_at_level level acc groups] returns all the groups with the level [level]. The value
+ returned is of type
+ {!type:(data_item * condition_name_item list * (data_item * condition_name_item list) list) list}
+ which represent the group at level [level] and the condition names associated with every entry of
+ the group and a list of subgroups associated with every item of the group at level [level]. *)
+let rec group_at_level level acc (group: working_storage_item_descr list) =
+ match group with
+ | [] -> acc
+ | (Data hd)::tl ->
+ let conditions, rest = conditions_from [] tl in
+ let sub_group, rest = subgroup_of [] level rest in
+ group_at_level level ((hd, conditions, sub_group)::acc) rest
+ | (CondName cond)::rest ->
+ begin match acc with
+ | (hd, conds, sub_group)::tl ->
+ group_at_level level ((hd, cond::conds, sub_group)::tl) rest
+ | _ -> invalid_arg "Empty list"
+ end
+ | _ -> invalid_arg "Expecting Data or CondName"
+
+(** [conditions_from acc group] returns a list of condition names and the rest of the group from [group]. *)
+and conditions_from acc group =
+match group with
+ | (CondName cond)::tl ->
+ conditions_from (cond::acc) tl
+ | _ ->
+ List.rev acc, group
+
+(** [subgroup_from acc level group] returns a list of elements that are subordinate to the level
+ [level] and the rest of the group [group] which is not contained in the current subgroup
+ (i.e any item following an item of level [level] or lower including the item of level
+ [level] or lower). *)
+and subgroup_of acc curr_level group =
+ match group with
+ | [] -> List.rev acc, []
+ | (Data ({data_level; _} as hd))::tl ->
+ if data_level > curr_level then
+ subgroup_of ((hd, [])::acc) curr_level tl
+ else
+ List.rev acc, group
+ | (CondName cond)::rest ->
+ begin match acc with
+ | (hd, conds)::tl ->
+ subgroup_of ((hd, (cond::conds))::tl) curr_level rest
+ | _ ->
+ invalid_arg "Empty list"
+ end
+ | _ ->
+ invalid_arg "Expecting Data or CondName"
+
+(** [subgroup_of' level group] has the same behavior as [subgroup_of level acc group] but
+ the [group] is of type {!type:(data_item * condition_name_item list) list} instead of type
+ {!type:working_storage_item_descr list}*)
+let subgroup_of' curr_level (group: (data_item * condition_name_item list) list) =
+ let rec aux acc curr_level group =
+ match group with
+ | [] -> (List.rev acc, [])
+ | (({data_level; _}, _) as hd)::tl ->
+ if ~&data_level > ~&curr_level then
+ aux (hd::acc) curr_level tl
+ else
+ List.rev acc, group
+ in
+ aux [] curr_level group
+
+(** [group_at_level' level group] has the same behavior as [group_at_level level acc group] but
+ the [group] is of type {!type:(data_item * 'a) list} instead of type {!type:working_storage_item_descr list}*)
+let group_at_level' level group =
+ let rec aux acc level group =
+ match group with
+ | [] -> acc
+ | hd::tl ->
+ let sub_group, rest = subgroup_of' level tl in
+ aux ((hd, sub_group)::acc) level rest
+ in
+ aux [] level group
+
+(** [make_data_subgroup (module Diags) group] returns a {!t list} from a {!(dde * condition_name list) list}
+ specifically for groups of levels higher than 1 and different of 77. *)
+let make_data_subgroup (module Diags: Cobol_common.Diagnostics.STATEFUL) group =
+ let rec aux group =
+ match group with
+ | [] -> invalid_arg "Empty list"
+ | (({data_name; _}: data_item) as data_item, cond_names)::[] ->
+ begin match data_name with
+ | Some { payload = DataName name; loc } ->
+ let element = Elementary {name = ~&name;
+ data_item = Data data_item } &@ loc in
+ element :: List.map
+ (fun {condition_name; condition_name_values; _} ->
+ ConditionName { name = ~&condition_name;
+ values = condition_name_values;
+ target = element } &@<- condition_name)
+ cond_names
+ | _ -> invalid_arg "Expecting a name"
+ end
+ | ({data_level = level; _}, _)::_ ->
+ let groups = List.rev (group_at_level' level group) in
+ List.flatten @@ List.map
+ (fun (({ data_name = name; _ } as data_item, cond_names), sub_groups) ->
+ match name with
+ | Some { payload = DataName name; loc } ->
+ begin match sub_groups with
+ | [] ->
+ let element = Elementary { name = ~&name;
+ data_item = Data data_item } &@ loc in
+ element::
+ (List.map
+ (fun {condition_name = name; condition_name_values = values; _} ->
+ ConditionName { name = ~&name; values;
+ target = element } &@<- name)
+ cond_names)
+ | sub_groups ->
+ let group = Group { name = ~&name; elements = aux sub_groups;
+ data_item = Data data_item } &@ loc in
+ group::
+ (List.map
+ (fun {condition_name = name; condition_name_values = values; _} ->
+ ConditionName {name = ~&name; values;
+ target = group} &@<- name)
+ cond_names)
+ end
+ | _ -> invalid_arg "Expecting a name")
+ groups
+ in
+ aux group
+
+(** [make_data_group (module Diags) group] makes a {!(t list, unit) result} from a
+ {!working_storage_item_descr list} which respect the hierarchy of the list in entry and results
+ in error if any of the elements of the entry list does not respect the COBOL data groups rules. *)
+let make_data_group (module Diags: Cobol_common.Diagnostics.STATEFUL) group =
+ match (group: working_storage_item_descr list) with (* TODO: with_loc *)
+ | [Constant {constant_name; constant_value; _} as constant_item_descr] ->
+ begin match constant_name with
+ | Some { payload = DataName name; loc } ->
+ Result.ok [Constant { name = ~&name;
+ value = constant_value;
+ constant_item_descr } &@ loc ]
+ | _ ->
+ Diags.error "Undefined constant name";
+ Result.Error ()
+ end
+ | [Data { data_name; _ } as data_item] ->
+ begin match data_name with
+ | Some { payload = DataName name; loc } ->
+ Result.ok @@ [Elementary {name = ~&name; data_item } &@ loc ]
+ | _ ->
+ Diags.error "Unkown data item";
+ Result.Error ()
+ end
+ | CondName {condition_name = {loc; _}; _}::_ ->
+ Diags.error ~loc "A@ condition@ name@ must@ follow@ another@ data@ item@ entry";
+ Result.Error ()
+ | Data {data_level = level; _} ::_ ->
+ let same_level_groups = List.rev (group_at_level level [] group) in
+ List.map
+ (fun (data_item, cond_names, sub_group) ->
+ let name =
+ match data_item.data_name with
+ | Some {payload = DataName name; _} ->
+ Result.Ok name
+ | _ ->
+ Diags.error "Unnamed data item";
+ Result.Error ()
+ in
+ match sub_group with
+ | [] ->
+ Result.map
+ (fun name ->
+ let element = Elementary {name = ~&name;
+ data_item = Data data_item} &@<- name in
+ element::
+ List.map
+ (fun {condition_name = name; condition_name_values = values; _} ->
+ ConditionName { name = ~&name; values;
+ target = element } &@<- name)
+ cond_names)
+ name
+ | lst ->
+ Result.map
+ (fun name ->
+ let group =
+ Group { name = ~&name;
+ elements = make_data_subgroup (module Diags) lst;
+ data_item = Data data_item } &@<- name
+ in
+ group::
+ (List.map
+ (fun {condition_name = name; condition_name_values = values; _} ->
+ ConditionName {name = ~&name; values;
+ target = group} &@<- name)
+ cond_names))
+ name)
+ same_level_groups
+ |> Cobol_common.join_all
+ |> Result.map List.flatten
+ | _ -> Result.error ()
+
+(** [group_of_name name group] return a list of groups that are named [name]. *)
+let groups_of_name {payload=group_name;_} group =
+ let rec aux acc group =
+ match ~&group with
+ | Elementary {name; _} | Group {name; _} when name = group_name ->
+ group::acc
+ | Group {elements; _} ->
+ List.fold_left aux acc elements
+ | _ ->
+ acc
+ in
+ aux [] group
+
+(** [group_of_list name_list groups] returns a list of groups from [groups] whose name correspond to
+ [name_list], the groups must respect the hierarchy of name list with the following rules:
+ - [name_list] should be hierarchical with the first value being the lowest level name (i.e level 01 first),
+ - if [name_list] is empty all the groups from [groups] are returned. *)
+let rec groups_of_list name_list groups =
+ match name_list with
+ | [] -> groups
+ | hd::tl ->
+ let groups =
+ List.flatten @@ List.fold_left (fun acc group ->
+ (groups_of_name hd group)::acc)
+ []
+ groups
+ in
+ groups_of_list tl groups
+
+(** [group_range (module Diags) first last group] returns a list of every {!Elementary _} or
+ {!Group _} which are defined between [first] and [last] (included).
+ [first] and [last] should be qualified names that are in the form of a list, with
+ lowest level name first.
+ [first] should not be the name of any item succeding [last] in the group and [last] should
+ not be name of any item defined before [first].
+ [first] and [last] should be the name of item defined inside [group].
+ [first] and [last] should not be ambigious as to which item they define. *)
+let group_range (module Diags: Cobol_common.Diagnostics.STATEFUL) first last group =
+ let rec aux (first, last, first_found, last_found, acc) group =
+ if first_found && last_found then
+ first, last, first_found, last_found, acc
+ else
+ match ~&group with
+ | Elementary {name; _} ->
+ if first_found && not @@ last_found then
+ let last_found =
+ match last with
+ | hd::[] when name = ~&hd -> true
+ | _ -> false
+ in
+ first, last, first_found, last_found, group::acc
+ else
+ begin match first with
+ | hd::[] when name = ~&hd ->
+ let last_found =
+ match last with
+ | hd::[] when name = ~&hd -> true
+ | _ -> false
+ in
+ first, last, true, last_found, group::acc
+ | _ ->
+ first, last, first_found, last_found, acc
+ end
+ | Group {name; elements; _} ->
+ if first_found && not last_found then
+ let last_found =
+ match last with
+ | hd::[] when name = ~&hd -> true
+ | _ -> false
+ in
+ match last with
+ | hd::[] when name = ~&hd ->
+ List.fold_left aux (first, last, first_found, last_found, acc) elements
+ | hd::tl when name = ~&hd ->
+ List.fold_left aux (first, tl, first_found, last_found, acc) elements
+ | _ ->
+ first, last, first_found, last_found, group::acc
+ else
+ let _, _, first_found, last_found, acc =
+ (* Fmt.pr "Name: %a, First: %a\n" pp_name name Fmt.(list pp_name) first; *)
+ let first =
+ match first with
+ | hd::tl when name = ~&hd ->
+ (* Fmt.pr "New first: %a\n" Fmt.(list pp_name) tl; *)
+ tl
+ | _ -> first
+ in
+ let last =
+ match last with
+ | hd::tl when name = ~&hd ->
+ tl
+ | _ ->
+ last
+ in
+ List.fold_left aux (first, last, first_found, last_found, acc) elements
+ in
+ first, last, first_found, last_found, acc
+ | _ -> first, last, first_found, last_found, acc
+
+ in
+ let _, _, _, _, groups = aux (first, last, false, false, []) group in
+ groups
+
+(** [make_renames (module Diags) group renames] returns a list of {!(t, unit) result} which
+ are all of the form [Renames _] and correspond to renaming items from the group [group]. *)
+let make_renames (module Diags: Cobol_common.Diagnostics.STATEFUL) group renames =
+ (* TODO: take `rename with_loc` entries, with more "general" locations *)
+ List.fold_left begin fun acc { rename_to; rename_renamed; rename_through; _ } ->
+ match rename_through with
+ | Some through_name ->
+ (* TODO: avoid reliance on a list representation. *)
+ let first = Cobol_ast.list_of_qualname rename_renamed in
+ let last = Cobol_ast.list_of_qualname through_name in
+ let groups =
+ group_range
+ (module Diags: Cobol_common.Diagnostics.STATEFUL)
+ first
+ last
+ (List.hd group)
+ in
+ Ok (Renames {name = ~&rename_to;
+ targets = List.rev groups} &@<- rename_to) :: acc
+ | None ->
+ let name_list = Cobol_ast.list_of_qualname rename_renamed in
+ let sub_groups = groups_of_list name_list group in
+ if List.length sub_groups <> 1 then
+ begin
+ Diags.error ~loc:~@rename_to "Could not find a unique name to rename.";
+ Error () :: acc
+ end
+ else
+ let group = List.hd sub_groups in
+ Ok (Renames {name = ~&rename_to;
+ targets = [group]} &@<- rename_to) :: acc
+ end [] renames
+
+(** [of_working_storage (module Diags) wss] returns the list of groups from wss in a hierarchical
+ form. *)
+let of_working_storage
+ (module Diags: Cobol_common.Diagnostics.STATEFUL)
+ (wss: working_storage_item_descr with_loc list) =
+ let groups =
+ List.fold_left (fun acc {payload; loc} ->
+ Result.bind acc (fun acc ->
+ match (payload: working_storage_item_descr) with
+ | Constant _ ->
+ Result.ok @@ ([payload], None)::acc
+ | Data {data_level = level; _} when ~&level = 1 || ~&level = 77 ->
+ Result.ok @@ ([payload], None)::acc
+ | Data _ ->
+ begin match acc with
+ | (payload_list, None)::tl ->
+ Result.ok @@ (payload::payload_list, None)::tl
+ | (_, Some _)::_ ->
+ Diags.error ~loc "A@ renames@ entry@ can@ only@ be@ followed@ by@ a@ 01,@ 66,@ 77@ \
+ or@ 88@ level@ data@ item.";
+ Result.Error ()
+ | [] ->
+ Diags.error ~loc "A@ non@ 01@ or@ 77@ level@ must@ follow@ a@ 01@ level@ data@ item.";
+ Result.Error ()
+ end
+ | Renames rename ->
+ begin match acc with
+ | (data_list, None)::tl ->
+ Result.ok @@ (data_list, Some ([rename]))::tl
+ | (data_list, Some renames)::tl ->
+ Result.ok @@ (data_list, Some (rename::renames))::tl
+ | [] ->
+ Diags.error ~loc "A@ 66@ level@ entry@ must@ follow@ directly@ a@ record@ entry.";
+ Result.Error ()
+ end
+ | CondName _ ->
+ begin match acc with
+ | (data_list, renames)::tl ->
+ Result.ok @@ (payload::data_list, renames)::tl
+ | [] ->
+ Diags.error ~loc "An@ 88@ level@ entry@ must@ follow@ another@ data@ entry.";
+ Result.Error ()
+ end))
+ (Result.Ok [])
+ wss
+ |> Result.map (List.map (fun (data, renames) -> List.rev data, Option.map List.rev renames))
+ |> Result.map List.rev
+ in
+ Result.bind groups (fun groups ->
+ Cobol_common.join_all @@
+ List.map (fun (group, rename) ->
+ let group = make_data_group (module Diags) group in
+ Result.bind group (fun group ->
+ Option.fold
+ ~none:[]
+ ~some:(fun renames -> make_renames (module Diags) group renames)
+ rename
+ |> Cobol_common.join_all
+ |> Result.map (fun renames ->
+ List.map (function
+ | { payload = Group {name; elements; data_item}; loc } ->
+ Group { name;
+ elements = elements@renames;
+ data_item } &@ loc
+ | _ as elem ->
+ elem)
+ group)))
+ groups)
+ |> Result.map List.flatten
diff --git a/src/lsp/cobol_data/group.mli b/src/lsp/cobol_data/group.mli
new file mode 100644
index 000000000..0fe6e7a84
--- /dev/null
+++ b/src/lsp/cobol_data/group.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module implements a hierarchical version of cobol data items.*)
+open Cobol_ast
+open Pictured_ast.Data_sections
+open Cobol_common.Srcloc.TYPES
+
+(** The type of hierarchical data items from cobol, used to describe different sections of the
+ data division such as working storage section or linkage section. *)
+type t' = (* TODO: extract `name` *)
+ | Renames of { name: name; targets: t list }
+ | ConditionName of { name: name; values: condition_name_value list; target: t }
+ | Constant of { name: name; value: constant_value with_loc;
+ constant_item_descr: constant_item_descr }
+ | Elementary of { name: name; data_item: data_item_descr }
+ | Group of { name: name; elements: t list; data_item: data_item_descr }
+[@@deriving show]
+
+and t = t' with_loc
+[@@deriving show]
+
+val pp_data_group_list: Format.formatter -> t list -> unit
+
+(** Extract the name from any kind of data item. *)
+val name_of: t -> name
+
+(* (\** Extract the location of the name of a data group. *\) *)
+(* val name_location: t -> srcloc *)
+
+(** Convert a list of located {!t constant_or_data_descr_entry} to a list of {!t t}*)
+val of_working_storage
+ : (module Cobol_common.Diagnostics.STATEFUL)
+ -> working_storage_item_descr with_loc list
+ -> (t list, unit) result
diff --git a/src/lsp/cobol_data/index.mld b/src/lsp/cobol_data/index.mld
new file mode 100644
index 000000000..ff46d881f
--- /dev/null
+++ b/src/lsp/cobol_data/index.mld
@@ -0,0 +1,10 @@
+{1 Library cobol_data}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+This package contains data structures for reprensenting COBOL programs and values, as well as some
+logic on the COBOL data items and values such ast {!Cobol_data.Picture} or {!Cobol_data.Types}.
+
+The entry point of this library is the module: {!Cobol_data}.
+
diff --git a/src/lsp/cobol_data/mangling.ml b/src/lsp/cobol_data/mangling.ml
new file mode 100644
index 000000000..7af5f476c
--- /dev/null
+++ b/src/lsp/cobol_data/mangling.ml
@@ -0,0 +1,46 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.INFIX
+open Cobol_ast
+
+exception Not_mangled
+
+let filler_num = ref 0
+
+let new_filler_num () =
+ let num = !filler_num in
+ incr filler_num;
+ num
+
+let new_filler_string () =
+ Printf.sprintf "Filler-%u" (new_filler_num ())
+
+(* TODO: Here we should employ types instead to describe that the "naming" pass,
+ if any, has been performed on the AST; just like for picture strings. *)
+
+(* TODO: Define a type (GADT) where we cannot have (Some Filler) instead. Or
+ just don't name fillers and refer w.r.t parents in environment. *)
+
+let mangle_data_name ~default_loc data_name = match data_name with
+ | Some { payload = DataName _; _ } ->
+ data_name
+ | _ ->
+ let filler_name = new_filler_string () &@ default_loc in
+ Some (DataName filler_name &@ default_loc)
+
+let mangled_data_name data_name = match data_name with
+ | Some { payload = DataName name; _ } ->
+ ~&name
+ | _ ->
+ raise Not_mangled
diff --git a/src/lsp/cobol_data/mangling.mli b/src/lsp/cobol_data/mangling.mli
new file mode 100644
index 000000000..e43e4621c
--- /dev/null
+++ b/src/lsp/cobol_data/mangling.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module aims to implement mangling functions for the COBOL AST.*)
+
+
+open Cobol_ast
+
+(** This exception is raised when a not mangled name is given in a context where it is expected for
+ the name to be mangled *)
+exception Not_mangled
+
+(** This function mangles an entry name option, by changing every [None] or [Some (Filler)] entries
+ into [Some (Name "Filler")] where is incremented every time a new [None] or [Some (Filler)]
+ entry is encountered. It does not change any other [entry_name] value. *)
+val mangle_data_name
+ : default_loc: Cobol_common.Srcloc.srcloc
+ -> data_name with_loc option
+ -> data_name with_loc option
+
+(** This function returns the name as a string if it is in the form of [Some (Name name)] and
+ raises the [Not_mangled] exception if the pattern of the [entry_name] is different. *)
+val mangled_data_name: data_name with_loc option -> string
diff --git a/src/lsp/cobol_data/package.toml b/src/lsp/cobol_data/package.toml
new file mode 100644
index 000000000..185b1e40c
--- /dev/null
+++ b/src/lsp/cobol_data/package.toml
@@ -0,0 +1,76 @@
+
+# name of package
+name = "cobol_data"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+# generators = [ "ocamllex", "menhir" ]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+preprocess = "pps ppx_deriving.show"
+
+# files to skip while updating at package level
+skip = ["index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+cobol_ast = "version"
+cobol_parser = "version"
+ppx_deriving = ">=5.2.1"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+# ...
diff --git a/src/lsp/cobol_data/picture.ml b/src/lsp/cobol_data/picture.ml
new file mode 100644
index 000000000..e279d0fe6
--- /dev/null
+++ b/src/lsp/cobol_data/picture.ml
@@ -0,0 +1,1151 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common
+open Srcloc.TYPES
+module CHARS = Cobol_common.Basics.CharSet
+
+module TYPES = struct
+
+ type symbol =
+ | A
+ | B
+ | CR
+ | CS
+ | DB
+ | DecimalSep
+ | E
+ | GroupingSep
+ | L
+ | Minus
+ | N
+ | Nine
+ | One
+ | P
+ | Plus
+ | S
+ | Slant
+ | Star
+ | V
+ | X
+ | Z
+ | Zero
+
+ let pp_symbol ppf = function
+ | A -> Fmt.char ppf 'A'
+ | B -> Fmt.char ppf 'B'
+ | CR -> Fmt.string ppf "CR"
+ | CS -> Fmt.fmt "currency@ symbol" ppf
+ | DB -> Fmt.string ppf "DB"
+ | DecimalSep -> Fmt.fmt "decimal@ point" ppf
+ | E -> Fmt.char ppf 'E'
+ | GroupingSep -> Fmt.fmt "grouping@ separator" ppf
+ | Minus -> Fmt.char ppf '-'
+ | N -> Fmt.char ppf 'N'
+ | Nine -> Fmt.char ppf '9'
+ | One -> Fmt.char ppf '1'
+ | P -> Fmt.char ppf 'P'
+ | Plus -> Fmt.char ppf '+'
+ | L -> Fmt.char ppf 'L'
+ | S -> Fmt.char ppf 'S'
+ | Slant -> Fmt.char ppf '/'
+ | Star -> Fmt.char ppf '*'
+ | V -> Fmt.char ppf 'V'
+ | X -> Fmt.char ppf 'X'
+ | Z -> Fmt.char ppf 'Z'
+ | Zero -> Fmt.char ppf '0'
+
+ type symbols =
+ {
+ symbol: symbol;
+ symbol_occurences: int;
+ }
+ [@@deriving show]
+
+ type editions =
+ {
+ basics: basic_edition list;
+ floating: floating_insertion option;
+ zerorepl: zero_replacement option;
+ }
+ [@@deriving show]
+
+ and basic_edition =
+ | SimpleInsertion of simple_insertion
+ | SpecialInsertion of special_insertion
+ | FixedInsertion of fixed_insertion
+
+ (* The following may later becore mappings from Int to symbols, and even
+ become abstract to maintain some level of integrity on the integers
+ involved. *)
+ and simple_insertion =
+ {
+ simple_insertion_symbols: symbols;
+ simple_insertion_offset: int;
+ }
+
+ and special_insertion =
+ {
+ special_insertion_offset: int;
+ special_insertion_length: int;
+ }
+
+ and fixed_insertion =
+ {
+ fixed_insertion_symbol: symbol;
+ fixed_insertion_offset: int;
+ }
+
+ and floating_insertion =
+ {
+ floating_insertion_symbol: symbol;
+ floating_insertion_ranges: floating_range list;
+ }
+
+ and zero_replacement =
+ {
+ zero_replacement_symbol: symbol;
+ zero_replacement_ranges: floating_range list;
+ }
+
+ and floating_range =
+ {
+ floating_range_offset: int;
+ floating_range_length: int;
+ }
+
+ type category =
+ | Alphabetic of
+ {
+ length: int;
+ }
+ | Alphanumeric of
+ {
+ length: int;
+ insertions: simple_insertion list;
+ }
+ | Boolean of
+ {
+ length: int;
+ }
+ | National of
+ {
+ length: int;
+ insertions: simple_insertion list;
+ }
+ | FixedNum of
+ {
+ digits: int;
+ scale: int;
+ with_sign: bool;
+ editions: editions;
+ }
+ | FloatNum of
+ {
+ digits: int;
+ scale: int;
+ with_sign: bool;
+ exponent_digits: int;
+ editions: basic_edition list;
+ }
+
+
+ let pp_category ppf = function
+ | Alphabetic { length } ->
+ Fmt.fmt "ALPHABETIC(%u)" ppf length
+ | Alphanumeric { length; insertions = [] } ->
+ Fmt.fmt "ALPHANUMERIC(%u)" ppf length
+ | Alphanumeric { length; insertions = _ } ->
+ Fmt.fmt "ALPHANUMERIC-EDITED(%u)" ppf length
+ | Boolean { length } ->
+ Fmt.fmt "BOOLEAN(%u)" ppf length
+ | National { length; insertions = [] } ->
+ Fmt.fmt "NATIONAL(%u)" ppf length
+ | National { length; insertions = _ } ->
+ Fmt.fmt "NATIONAL-EDITED(%u)" ppf length
+ | FixedNum { digits; scale; with_sign;
+ editions = { basics = [];
+ floating = None;
+ zerorepl = None } } ->
+ Fmt.fmt "NUMERIC(@[digits = %u,@;scale = %d,@;with_sign = %B@])" ppf
+ digits scale with_sign
+ | FixedNum { digits; scale; with_sign; editions } ->
+ Fmt.fmt "NUMERIC-EDITED(@[digits = %u,@;scale = %d,@;\
+ with_sign = %B,@;editions = %a@])" ppf
+ digits scale with_sign pp_editions editions
+ | FloatNum { digits; scale; with_sign; exponent_digits; editions = [] } ->
+ Fmt.fmt "FLOAT(@[digits = %u,@;scale = %d,@;exponent_digits = \
+ %u,@;with_sign = %B@])" ppf
+ digits scale exponent_digits with_sign
+ | FloatNum { digits; scale; with_sign; exponent_digits; editions } ->
+ Fmt.fmt "FLOAT(@[digits = %u,@;scale = %d,@;exponent_digits = \
+ %u,@;with_sign = %B,@;%a@])" ppf
+ digits scale exponent_digits with_sign
+ (Fmt.list pp_basic_edition) editions
+
+
+ type picture =
+ {
+ category: category;
+ pic: symbols list;
+ }
+ [@@deriving show]
+
+ type picture_config = {
+ max_pic_length : int ;
+ decimal_char: char ;
+ currency_signs: Cobol_common.Basics.CharSet.t ;
+ }
+
+ type error =
+ | May_only_appear_once of int
+ | May_not_follow of int * int
+ | Parenthesis_must_be_preceded_by_picture_symbol
+ | Unexpected_char of char
+ | Extraneous_symbol_in_exponent
+ | Symbol_may_only_appear_once of symbol
+ | Symbol_must_be_at_start of symbol
+ | Symbol_must_be_at_end of symbol
+ | Symbol_must_be_at_start_or_end of symbol
+ | Symbols_are_mutually_exclusive of symbol * symbol
+ | Unexpected_symbol of symbol * category option
+ | Empty_picture_string
+ | Picture_length_exceeds_limit of (* length *) int * (* max_len *) int
+ | Missing_symbol_in_exponent
+ | Missing_digits_in_exponent
+ | Picture_describes_empty_data_item
+ | Numeric_item_cannot_exceed_38_digits of int
+
+ module type ENV = sig
+ val decimal_char: char
+ val currency_signs: Cobol_common.Basics.CharSet.t
+ end
+
+end
+
+type t = TYPES.picture
+[@@deriving show]
+
+open TYPES
+
+module Symbol = struct type t = symbol let compare = Stdlib.compare end
+module Symbols = Set.Make (Symbol)
+module SymbolsMap = Map.Make (Symbol)
+
+(* --- *)
+
+let is_edited = function
+ | Alphabetic _
+ | Boolean _
+ | Alphanumeric { insertions = []; _ }
+ | National { insertions = []; _ }
+ | FixedNum { editions = { basics = []; floating = None; zerorepl = None }; _ }
+ | FloatNum { editions = []; _ } -> false
+ | _ -> true
+
+let data_size: category -> int = function
+ | Alphabetic { length }
+ | Boolean { length }
+ | Alphanumeric { length; _ } -> length
+ | National { length; _ } -> length * 2
+ | FixedNum { digits; _ } -> digits
+ | FloatNum { digits; exponent_digits; _ } -> digits + exponent_digits
+
+let edited_size: category -> int =
+ let simple_insertion_size { simple_insertion_symbols = symbols; _ } =
+ symbols.symbol_occurences
+ and special_insertion_size { special_insertion_length = n; _ } = n in
+ let simple_insertions_size =
+ List.fold_left (fun s i -> s + simple_insertion_size i) 0
+ and basic_editions_size basics =
+ List.fold_left begin fun s -> function
+ | SimpleInsertion i -> s + simple_insertion_size i
+ | SpecialInsertion i -> s + special_insertion_size i
+ | FixedInsertion _ -> s + 1
+ end 0 basics
+ in
+ let editions_size { basics; floating; _ } =
+ basic_editions_size basics + if floating = None then 0 else 1
+ in
+ function
+ | Alphabetic { length }
+ | Boolean { length } ->
+ length
+ | Alphanumeric { length; insertions } ->
+ length +
+ simple_insertions_size insertions
+ | National { length; insertions } ->
+ length * 2 +
+ simple_insertions_size insertions
+ | FixedNum { digits; with_sign; editions; _ } ->
+ digits + editions_size editions +
+ if with_sign then 1 else 0 (* WARNING: depends on SIGN/SEPARATE phrase *)
+ | FloatNum { digits; exponent_digits; editions; _ } ->
+ digits + exponent_digits + basic_editions_size editions
+
+let size = edited_size
+
+(* --- *)
+
+(* NOTE: During construction edition lists in categories are in reversed
+ order. *)
+
+let reverse_editions =
+ let reverse_floating { floating_insertion_symbol;
+ floating_insertion_ranges } =
+ { floating_insertion_symbol;
+ floating_insertion_ranges = List.rev floating_insertion_ranges }
+ and reverse_zerorepl { zero_replacement_symbol;
+ zero_replacement_ranges } =
+ { zero_replacement_symbol;
+ zero_replacement_ranges = List.rev zero_replacement_ranges }
+ in
+ function
+ | Alphabetic _ | Boolean _ as c ->
+ c
+ | Alphanumeric { length; insertions } ->
+ Alphanumeric {length; insertions = List.rev insertions }
+ | National { length; insertions } ->
+ National {length; insertions = List.rev insertions }
+ | FixedNum { digits; scale; with_sign;
+ editions = { basics; floating; zerorepl } } ->
+ let basics = List.rev basics
+ and floating = Option.map reverse_floating floating
+ and zerorepl = Option.map reverse_zerorepl zerorepl in
+ FixedNum { digits; scale; with_sign;
+ editions = { basics; floating; zerorepl } }
+ | FloatNum { digits; scale; with_sign; exponent_digits; editions } ->
+ FloatNum { digits; scale; with_sign; exponent_digits;
+ editions = List.rev editions }
+
+
+
+
+let as_simple_insertions = function
+ | { floating = Some _; _ } ->
+ raise Exit
+ | { basics; _ } ->
+ List.map begin function
+ | SimpleInsertion i -> i
+ | SpecialInsertion _
+ | FixedInsertion _ -> raise Exit
+ end basics
+
+
+let append_insertion ({ basics; floating; _ } as editions) symbols offset =
+ let has_any_fixed_insertion =
+ List.exists (function FixedInsertion _ -> true | _ -> false)
+ in
+ let rec previous_fixed_insertion acc = function
+ | [] ->
+ Ok None
+ | FixedInsertion { fixed_insertion_symbol = s;
+ fixed_insertion_offset = o } :: tl
+ when s = symbols.symbol ->
+ if has_any_fixed_insertion acc
+ then Error () (* no fixed insertion is allowed in floating string *)
+ else Ok (Some (o, List.rev_append acc tl))
+ | i :: tl ->
+ previous_fixed_insertion (i :: acc) tl
+ in
+ let new_range = { floating_range_offset = offset;
+ floating_range_length = symbols.symbol_occurences } in
+ match floating with
+ | Some { floating_insertion_symbol = s;
+ floating_insertion_ranges = ranges }
+ when s = symbols.symbol ->
+ let editions =
+ { editions with
+ floating = Some { floating_insertion_symbol = s;
+ floating_insertion_ranges = new_range :: ranges } }
+ in
+ Ok (editions, symbols.symbol_occurences) (* all symbols count as digits *)
+ | _
+ when symbols.symbol_occurences = 1 -> (* fixed insertion with a priori
+ non-floating symbol *)
+ let editions = (* (further checked in check_editions) *)
+ { editions with
+ basics = FixedInsertion { fixed_insertion_symbol = symbols.symbol;
+ fixed_insertion_offset = offset } :: basics }
+ in
+ Ok (editions, 0) (* no more digit *)
+ | Some _ -> (* invalid floating insertion with new symbol *)
+ Error ()
+ | None ->
+ match previous_fixed_insertion [] basics with
+ | Ok None ->
+ let editions =
+ { editions with
+ floating = Some { floating_insertion_symbol = symbols.symbol;
+ floating_insertion_ranges = [new_range] } }
+ in
+ Ok (editions, symbols.symbol_occurences - 1)
+ | Ok (Some (previous_offset, basics)) ->
+ let old_range = { floating_range_offset = previous_offset;
+ floating_range_length = 1 } in
+ let editions =
+ { editions with
+ basics;
+ floating = Some { floating_insertion_symbol = symbols.symbol;
+ floating_insertion_ranges = [new_range;
+ old_range] } }
+ in
+ Ok (editions, symbols.symbol_occurences)
+ | Error () ->
+ Error ()
+
+
+let append_zero_replacement ({ zerorepl; _ } as editions) symbols offset =
+ let new_range = { floating_range_offset = offset;
+ floating_range_length = symbols.symbol_occurences } in
+ match zerorepl with
+ | None ->
+ Ok { editions with
+ zerorepl = Some { zero_replacement_symbol = symbols.symbol;
+ zero_replacement_ranges = [new_range] } }
+ | Some { zero_replacement_symbol = s;
+ zero_replacement_ranges = ranges }
+ when s = symbols.symbol ->
+ Ok { editions with
+ zerorepl = Some { zero_replacement_symbol = s;
+ zero_replacement_ranges = new_range :: ranges } }
+ | Some _ ->
+ Error ()
+
+
+let append category ~after_v ({ symbol; symbol_occurences = n } as symbols) =
+ let error = Result.Error (category, symbol) in
+ let alphanum length insertions =
+ Ok (Alphanumeric { length; insertions })
+ and numeric
+ ?(with_sign = false)
+ ?(editions = { basics = []; floating = None; zerorepl = None })
+ digits scale =
+ FixedNum { digits; scale; with_sign; editions }
+ and float
+ ?(with_sign = false)
+ ?(editions = [])
+ digits scale exponent_digits =
+ FloatNum { digits; scale; with_sign; exponent_digits; editions }
+ in
+ let append_A = function
+ | Alphabetic { length } ->
+ Ok (Alphabetic { length = length + n })
+ | Alphanumeric { length; insertions } ->
+ Ok (Alphanumeric { length = length + n; insertions })
+ | FixedNum { digits; scale = 0; with_sign = false; editions } ->
+ (try alphanum (digits + n) (as_simple_insertions editions)
+ with Exit -> error) (* 'cause of non-simple insertions *)
+ | _ -> error
+ and append_9 = function
+ | Alphabetic { length } ->
+ alphanum (length + n) []
+ | Alphanumeric { length; insertions } ->
+ alphanum (length + n) insertions
+ | FixedNum { digits; scale; with_sign; editions } ->
+ Ok (numeric (digits + n) (if after_v then scale + n else scale)
+ ~with_sign ~editions)
+ | FloatNum { digits; scale; with_sign; exponent_digits; editions } ->
+ Ok (float digits scale (exponent_digits + n) ~with_sign ~editions)
+ | _ -> error
+ and append_X = function
+ | Alphabetic { length } ->
+ alphanum (length + n) []
+ | Alphanumeric { length; insertions } ->
+ alphanum (length + n) insertions
+ | FixedNum { digits; scale = 0; with_sign = false; editions } ->
+ (try alphanum (digits + n) (as_simple_insertions editions)
+ with Exit -> error)
+ | _ -> error
+ and append_P = function
+ | FixedNum { digits; scale; with_sign; editions } ->
+ Ok (numeric ~with_sign ~editions
+ (digits + n)
+ (scale + if digits = 0 then n else - n))
+ | _ -> error
+ and append_simple_insertion =
+ let simple_insertion c =
+ { simple_insertion_symbols = symbols;
+ simple_insertion_offset = size c }
+ in
+ function
+ | Alphabetic { length } as c ->
+ alphanum length [simple_insertion c]
+ | Alphanumeric { length; insertions } as c ->
+ alphanum length (simple_insertion c :: insertions)
+ | FixedNum { digits; scale; with_sign; editions } as c ->
+ let editions =
+ { editions with
+ basics = SimpleInsertion (simple_insertion c) :: editions.basics } in
+ Ok (numeric ~with_sign ~editions digits scale)
+ | _ -> error
+ and append_fixed_or_floating_insertion = function
+ | FixedNum { digits; scale; with_sign; editions } as c
+ when not with_sign || digits > 0 -> (* forbidden in between S and digits *)
+ (match append_insertion editions symbols (edited_size c) with
+ | Ok (editions, digits') ->
+ let digits = digits + digits'
+ and scale = if after_v then scale + digits' else scale in
+ Ok (numeric ~with_sign ~editions digits scale)
+ | Error () -> error)
+ | _ -> error
+ and append_special_insertion offset = function
+ | FixedNum { digits; scale; with_sign; editions } ->
+ let special = SpecialInsertion { special_insertion_offset = offset;
+ special_insertion_length = n } in
+ Ok (numeric ~with_sign digits scale
+ ~editions:{ editions with basics = special :: editions.basics })
+ | _ -> error
+ and append_zero_replacement = function
+ | FixedNum { digits; scale; with_sign; editions } as c ->
+ (match append_zero_replacement editions symbols (edited_size c) with
+ | Ok editions ->
+ let digits = digits + n
+ and scale = if after_v then scale + n else scale in
+ Ok (numeric ~with_sign ~editions digits scale)
+ | Error () -> error)
+ | _ -> error
+ and append_E = function
+ | FixedNum { digits; scale; with_sign;
+ editions = { basics; floating = None; zerorepl = None } } ->
+ Ok (float digits scale 0 ~with_sign ~editions:basics)
+ | _ -> error
+ in
+ (* TODO: always numeric-edited when BLANK WHEN ZERO *)
+ match category, symbol with
+ | None, (A | L) ->
+ Ok (Alphabetic { length = n })
+ | None, X ->
+ Ok (Alphanumeric { length = n; insertions = [] })
+ | None, One ->
+ Ok (Boolean { length = n })
+ | None, N ->
+ Ok (National { length = n; insertions = [] })
+ | None, Nine ->
+ Ok (numeric n 0)
+ | None, S ->
+ Ok (numeric 0 0 ~with_sign:true)
+ | None, V ->
+ Ok (numeric 0 0)
+ | None, P ->
+ Ok (numeric n n)
+ | None, (Zero | B | Slant) -> (* default to numeric if prefix *)
+ append_simple_insertion (numeric 0 0)
+ | None, GroupingSep -> (* simple insertion *)
+ append_simple_insertion (numeric 0 0)
+ | None, (CS | Plus | Minus | CR | DB) -> (* fixed or floating insertion *)
+ append_fixed_or_floating_insertion (numeric 0 0)
+ | None, DecimalSep -> (* special insertion *)
+ append_special_insertion 0 (numeric 0 0)
+ | None, (Z | Star) ->
+ append_zero_replacement (numeric 0 0)
+ | Some c, A ->
+ append_A c
+ | Some c, X ->
+ append_X c
+ | Some (Boolean { length }), One ->
+ Ok (Boolean { length = length + n })
+ | Some (National { length; insertions }), N ->
+ Ok (National { length = length + n; insertions })
+ | Some c, Nine ->
+ append_9 c
+ | Some c, P ->
+ append_P c
+ | Some (FixedNum _ as c), V when not after_v ->
+ Ok c
+ | Some c, E ->
+ append_E c
+ | Some (FloatNum { exponent_digits = 0; _ } as c), Plus ->
+ (* NOTE: that + seems to be mandatory according to ISO/IEC 2014; this is
+ checked at (E+ check) below. *)
+ Ok c
+ | Some c, (Zero | B | Slant) ->
+ append_simple_insertion c
+ | Some c, GroupingSep -> (* simple insertion *)
+ append_simple_insertion c
+ | Some c, (CS | Plus | Minus | CR | DB) -> (* fixed insertion *)
+ append_fixed_or_floating_insertion c
+ | Some c, DecimalSep -> (* special insertion *)
+ append_special_insertion (edited_size c) c
+ | Some c, (Z | Star) ->
+ append_zero_replacement c
+ | _ ->
+ error
+
+exception INVALIDCHAR of char
+
+let symbol_of_char config c =
+ match c with
+ | c when CHARS.mem c config.currency_signs -> CS
+ | '.' | ',' as c when c == config.decimal_char -> DecimalSep
+ | '.' | ',' -> GroupingSep
+ | '*' -> Star
+ | '+' -> Plus
+ | '-' -> Minus
+ | '/' -> Slant
+ | '0' -> Zero
+ | '1' -> One
+ | '9' -> Nine
+ | 'A' -> A
+ | 'B' -> B
+ | 'E' -> E
+ | 'L' -> L
+ | 'N' -> N
+ | 'P' -> P
+ | 'S' -> S
+ | 'V' -> V
+ | 'X' -> X
+ | 'Z' -> Z
+ | c -> raise @@ INVALIDCHAR c
+
+ let symbol_precedence_index
+ ~max_idx ~after_v ~after_e ~idx ~zero_suppress_or_floating_insert
+ : symbol -> int = function
+ | B | Zero | Slant -> 0
+ | GroupingSep -> 1
+ | DecimalSep -> 2
+ | Plus when after_e -> 3
+ | Plus | Minus when not zero_suppress_or_floating_insert && idx < max_idx -> 4
+ | Plus | Minus when not zero_suppress_or_floating_insert -> 5
+ | CR | DB -> 6
+ | CS when not zero_suppress_or_floating_insert && idx < 2 -> 7
+ | CS when not zero_suppress_or_floating_insert -> 8
+ | Z | Star when not after_v -> 9
+ | Z | Star -> 10
+ | Plus | Minus when not after_v -> 11
+ | Plus | Minus -> 12
+ | CS when not after_v -> 13
+ | CS -> 14
+ | Nine -> 15
+ | A | X -> 16
+ | L -> 17
+ | S -> 18
+ | V -> 19
+ | P when not after_v -> 20
+ | P -> 21
+ | One -> 22
+ | N -> 23
+ | E -> 24
+
+let precedence_table =
+ (* An 'x' indicates that the symbol in the colon may precede the symbol of the
+ row.
+ B , . + + + CR cs cs Z Z + + cs cs 9 A L S V P P 1 N E
+ 0 - - DB * * - - X
+ / *)
+ Array.map (fun xs -> Array.init 25 (fun i -> xs.[i * 3 + 1] = 'x')) [|
+ " x x x x x x x x x x x x x x x x ";
+ " x x x x x x x x x x x x x x ";
+ " x x x x x x x x ";
+ " x ";
+ " ";
+ " x x x x x x x x x x x x x ";
+ " x x x x x x x x x x x x x ";
+ " x ";
+ " x x x x x x x x x x ";
+ " x x x x x ";
+ " x x x x x x x x x ";
+ " x x x x ";
+ " x x x x x x x ";
+ " x x x x ";
+ " x x x x x x x ";
+ " x x x x x x x x x x x x x x x x ";
+ " x x x x ";
+ " ";
+ " ";
+ " x x x x x x x x x x ";
+ " x x x x x x x x x x ";
+ " x x x x x ";
+ " x ";
+ " x x ";
+ " x x x x x ";
+ |]
+
+exception BREAK of int (* Internal exception *)
+
+
+let char_order_checker_for_pic_string () =
+ (* From GnuCOBOL, itself inspired by the standard's way of specifying
+ precedence. *)
+ let seen = Array.make 25 false in
+ let check_char_order symbol_precedence =
+ try
+ Array.iteri begin fun i -> function
+ | false when seen.(i) -> raise @@ BREAK i
+ | _ -> ()
+ end precedence_table.(symbol_precedence);
+ seen.(symbol_precedence) <- true;
+ Ok ()
+ with BREAK prev_precedence ->
+ seen.(symbol_precedence) <- true;
+ let diag =
+ if symbol_precedence = prev_precedence then
+ May_only_appear_once symbol_precedence
+ else
+ May_not_follow ( symbol_precedence, prev_precedence )
+ in
+ Error diag
+ in
+ let reset () =
+ Array.(fill seen 0 (length seen) false)
+ in
+ check_char_order, reset
+
+ (* Maybe not in ISO/IEC 2014: Z/CS, B/* *)
+let mutual_exclusions =
+ SymbolsMap.of_seq @@ List.to_seq [
+ B, Symbols.singleton Star;
+ CS, Symbols.singleton Z;
+ DecimalSep, Symbols.of_list [P; V];
+ P, Symbols.singleton DecimalSep;
+ Star, Symbols.of_list [Z; B];
+ V, Symbols.singleton DecimalSep;
+ Z, Symbols.of_list [Star; CS];
+ ]
+
+ type exp_sequence_state =
+ | ExpNone
+ | ExpWaitingPlus
+ | ExpWaitingDigits
+
+ type acc =
+ {
+ v_idx: int option; (* Some _ => V, P, or DecimalSep \in seen *)
+ e_idx: int option;
+ seen: Symbols.t; (* Records only some symbols *)
+ exp_sequence: exp_sequence_state;
+ errors: ( error * (int*int)) list ;
+ }
+
+ let with_error acc loc error = { acc with errors = (error, loc) :: acc.errors }
+
+ module SCANNING = struct
+ type 'a string_parser = string -> 'a
+
+ let mk_parser spec cstr : _ string_parser = fun str ->
+ Scanf.sscanf str spec cstr
+
+ let try_parse (specs: 'a string_parser list) str pos len =
+ let str = String.sub str pos (len-pos) in
+ let rec try_parse = function
+ | [] -> None
+ | f :: tl -> try Some (f str) with
+ | End_of_file | Scanf.Scan_failure _ -> try_parse tl
+ in
+ try_parse specs
+
+
+ let single symbol =
+ { symbol; symbol_occurences = 1 }
+
+ let rec pic_symbol ?expect ~config s pos len =
+
+ let lookahead c n l suff =
+ let pos = len - String.length suff in
+ let c = Char.uppercase_ascii c in
+ let symbol = symbol_of_char config c in
+ match expect with
+ | Some cc when cc <> c ->
+ { symbol; symbol_occurences = n }, l
+ | _ ->
+ (* look ahead for further occurences *)
+ match pic_symbol ~expect:c ~config s pos len with
+ | Some ({ symbol = s'; symbol_occurences = n' }, l')
+ when s' = symbol ->
+ { symbol; symbol_occurences = n + n' }, l' + l
+ | _ ->
+ { symbol; symbol_occurences = n }, l
+ | exception INVALIDCHAR _ -> (* delay for better location *)
+ { symbol; symbol_occurences = n }, l
+ in
+ if pos = len then
+ None
+ else
+ try_parse [
+ (* NOTE: those scanners allow spaces to be inserted in PICTURE
+ strings; this should be ok as parsed tokens should contain no
+ space characters; plus this may allow more readable string
+ internally. *)
+ mk_parser "CR%s%!" (fun _suff -> single CR, 2);
+ mk_parser "DB%s%!" (fun _suff -> single DB, 2);
+ mk_parser "%c(%u)%n%s%!" lookahead;
+ mk_parser "%c%s%!" (fun c -> lookahead c 1 1)
+ ] s pos len
+
+
+ end
+
+
+let of_string config str =
+
+ let len = String.length str in
+ let next_symbols pos acc =
+ (* Lookup and characterize next sequence of consecutive characters: *)
+ match SCANNING.pic_symbol ~config str pos len with
+ | None when pos = len -> (* end of PICTURE string *)
+ None, acc
+ | None ->
+ None,
+ let c = str.[pos] in
+ if c = '('
+ then with_error acc (pos,1)
+ Parenthesis_must_be_preceded_by_picture_symbol
+ else with_error acc (pos,1) ( Unexpected_char c )
+ | Some (symbols, span) ->
+ let pos' = pos + span in
+ Some (symbols, (pos,span), pos'), acc
+ | exception INVALIDCHAR c ->
+ None,
+ with_error acc (pos, 1) ( Unexpected_char c )
+ in
+
+ let rec of_string_rec acc category pic idx pos =
+ match next_symbols pos acc with
+ | None, acc ->
+ category, pic, acc, idx - 1 (* all done *)
+ | Some ( symbols, (_, span as loc), pos' ), acc ->
+ let after_v = acc.v_idx <> None in
+ let acc, ok = match check_occurences acc symbols loc with
+ | Ok acc -> acc, true
+ | Error acc -> acc, false
+ in
+ let acc, ok = match check_positions acc symbols loc idx pos' with
+ | Ok acc -> acc, ok
+ | Error acc -> acc, false
+ in
+ let acc, ok = match check_mutual_exclutions acc symbols loc with
+ | Ok acc -> acc, ok
+ | Error acc -> acc, false
+ in
+ if ok then
+ let category = append ~after_v category symbols in
+ let acc = match symbols.symbol with
+ | V | DecimalSep when acc.v_idx = None ->
+ { acc with v_idx = Some idx }
+ | P when acc.v_idx = None ->
+ let v_idx = match category with
+ | Ok c | Error (Some c, _)
+ when data_size c = symbols.symbol_occurences -> idx - 1
+ | Error (None, _) -> idx - 1
+ | _ -> idx + symbols.symbol_occurences
+ in
+ { acc with v_idx = Some v_idx }
+ | E ->
+ { acc with e_idx = Some idx; exp_sequence = ExpWaitingPlus }
+ | Plus when acc.exp_sequence = ExpWaitingPlus ->
+ { acc with exp_sequence = ExpWaitingDigits }
+ | Plus when acc.exp_sequence = ExpWaitingDigits ->
+ with_error acc loc Extraneous_symbol_in_exponent
+ | _ ->
+ acc
+ in
+ check acc ~loc category (symbols :: pic) (idx + span) pos'
+ else (* skip symbol(s) *)
+ of_string_rec acc category pic (idx + span) pos'
+
+ and check_occurences acc symbols loc =
+ match symbols.symbol with (* check occurences *)
+ | CR | DB | E | S | V | L | DecimalSep as s ->
+ if Symbols.mem s acc.seen || symbols.symbol_occurences > 1
+ then Error ( with_error acc loc ( Symbol_may_only_appear_once s ) )
+ else Ok { acc with seen = Symbols.add s acc.seen }
+ | P | Z | Star |CS | B as s -> (* record for mutual exclutions *)
+ Ok { acc with seen = Symbols.add s acc.seen }
+ | _ ->
+ Ok acc
+
+ and check_positions acc symbols loc idx pos =
+ match symbols.symbol with (* check for some positions (quite ad hoc) *)
+ | L | S as s when idx <> 0 ->
+ Error ( with_error acc loc ( Symbol_must_be_at_start s ) )
+ | CR | DB as s when pos < len ->
+ Error ( with_error acc loc ( Symbol_must_be_at_end s ) )
+ | P when idx = 0 ||
+ idx = 1 && Symbols.(mem S acc.seen || mem V acc.seen) ||
+ idx = 2 && Symbols.(mem S acc.seen && mem V acc.seen) ||
+ pos = len || String.sub str pos (len-pos) = "V" ->
+ Ok acc
+ | P as s ->
+ Error ( with_error acc loc ( Symbol_must_be_at_start_or_end s ))
+ | _ ->
+ Ok acc
+
+ and check_mutual_exclutions acc symbols loc =
+ match SymbolsMap.find_opt symbols.symbol mutual_exclusions with
+ | None ->
+ Ok acc
+ | Some set ->
+ let violations = Symbols.inter set acc.seen in
+ if Symbols.is_empty violations then Ok acc else
+ Result.error @@ Symbols.fold ( fun s acc ->
+ with_error acc loc ( Symbols_are_mutually_exclusive ( symbols.symbol, s ))
+ ) violations acc
+
+ and check acc ~loc category' pic idx suff =
+ match category' with
+ | Ok category ->
+ of_string_rec acc (Some category) pic idx suff
+ | Error (c, s) ->
+ c, pic,
+ with_error acc loc ( Unexpected_symbol (s, c)),
+ idx - 1
+ in
+ let category, pic, acc, max_idx =
+ of_string_rec {
+ v_idx = None;
+ e_idx = None;
+ exp_sequence = ExpNone;
+ seen = Symbols.empty;
+ errors = [];
+ } None [] 0 0
+ in
+ let loc = (0, len) in
+ (* Last remaining checks; global checks should come here. *)
+ let acc = match pic with
+ | [] ->
+ with_error acc loc Empty_picture_string
+ | _ when len > config.max_pic_length ->
+ with_error acc loc
+ ( Picture_length_exceeds_limit ( len, config.max_pic_length ))
+ | _ -> acc
+ in
+
+ let acc = match acc.exp_sequence with (* (E+ check) *)
+ | ExpWaitingPlus ->
+ with_error acc loc Missing_symbol_in_exponent
+ | _ -> acc
+ in
+ let acc = match category with
+ | Some (FloatNum { exponent_digits = 0; _ }) ->
+ with_error acc loc Missing_digits_in_exponent
+ | _ -> acc
+ in
+
+ let acc = match Option.map (fun c -> c, data_size c) category with
+ | None ->
+ acc
+ | Some (_, 0) ->
+ (* In GnuCOBOL, note the `U` in: "PICTURE string must contain at least
+ one of the set A, N, U, X, Z, 1, 9 and *; or at least two of the
+ set +, - and the currency symbol" *)
+ with_error acc loc Picture_describes_empty_data_item
+ | Some ((FixedNum _ | FloatNum _), data_size) when data_size > 38 ->
+ with_error acc loc ( Numeric_item_cannot_exceed_38_digits data_size )
+ | _ -> acc
+ in
+
+ let pic = List.rev pic in
+
+ let _, acc =
+ (* Check precedence rules w.r.t the standards. This also ensures some
+ form of well-formedness of the editions. *)
+ let symbol_precedence_index = symbol_precedence_index ~max_idx in
+ let check_char_order, reset = char_order_checker_for_pic_string () in
+ let floating_symbolp = match category with
+ | Some (FixedNum { editions = { floating = Some f; _ }; _ }) ->
+ fun p -> p = f.floating_insertion_symbol
+ | _ ->
+ fun _ -> false
+ in
+ List.fold_left begin fun (idx, acc) { symbol; symbol_occurences = n } ->
+ if symbol = E then reset (); (* consider exponent string separately *)
+ let prec idx =
+ symbol_precedence_index symbol ~idx
+ ~after_v:(Option.fold ~some:(fun i -> idx > i) ~none:false acc.v_idx)
+ ~after_e:(Option.fold ~some:(fun i -> idx > i) ~none:false acc.e_idx)
+ ~zero_suppress_or_floating_insert:(floating_symbolp symbol)
+ in
+ let acc =
+ match check_char_order (prec idx) with
+ | Error diag -> with_error acc loc diag
+ | Ok () when n = 1 -> acc
+ | Ok () -> (* check twice on repeated symbols *)
+ match check_char_order (prec (idx + n - 1)) with
+ | Error diag -> with_error acc loc diag
+ | Ok () -> acc
+ in
+ idx + n, acc
+ end (0, acc) pic
+ in
+
+ let pic =
+ let default = Alphanumeric { length = 0; insertions = [] } in
+ {
+ category = Option.fold ~some:reverse_editions ~none:default category;
+ pic;
+ }
+ in
+ match acc.errors with
+ | [] -> Ok pic
+ | errors -> Error ( errors, pic )
+
+
+let pp_meaning_of_precedence_index config ppf = function
+ | 0 -> Fmt.pf ppf "B, 0 or /"
+ | 1 -> Fmt.pf ppf "grouping@ separator ('%c')"
+ (if config.decimal_char = '.' then ',' else '.')
+ | 2 -> Fmt.pf ppf "decimal@ point ('%c')" config.decimal_char
+ | 3 -> Fmt.pf ppf "the sign of floating exponent"
+ | 4 -> Fmt.pf ppf "a leading +/- sign"
+ | 5 -> Fmt.pf ppf "a trailing +/- sign"
+ | 6 -> Fmt.pf ppf "CR or DB"
+ | 7 -> Fmt.pf ppf "a leading currency symbol"
+ | 8 -> Fmt.pf ppf "a trailing currency symbol"
+ | 9 -> Fmt.pf ppf "a Z or * which is before the decimal point"
+ | 10 -> Fmt.pf ppf "a Z or * which is after the decimal point"
+ | 11 -> Fmt.pf ppf "a floating +/- string which is before the decimal point"
+ | 12 -> Fmt.pf ppf "a floating +/- string which is after the decimal point"
+ | 13 -> Fmt.pf ppf "a floating currency symbol string which is before the \
+ decimal point"
+ | 14 -> Fmt.pf ppf "a floating currency symbol string which is after the \
+ decimal point"
+ | 15 -> Fmt.pf ppf "9"
+ | 16 -> Fmt.pf ppf "A or X"
+ | 17 -> Fmt.pf ppf "L"
+ | 18 -> Fmt.pf ppf "S"
+ | 19 -> Fmt.pf ppf "V"
+ | 20 -> Fmt.pf ppf "a P which is before the decimal point"
+ | 21 -> Fmt.pf ppf "a P which is after the decimal point"
+ | 22 -> Fmt.pf ppf "1"
+ | 23 -> Fmt.pf ppf "N"
+ | 24 -> Fmt.pf ppf "E"
+ | _ as d -> Fmt.pf ppf "an unkown character of value: %d" d
+
+let pp_error ~config ppf error =
+ match error with
+ | May_only_appear_once symbol_precedence ->
+ Format.fprintf ppf
+ "%a@ may@ only@ appear@ once@ in@ a@ PICTURE@ string"
+ (pp_meaning_of_precedence_index config) symbol_precedence
+ | May_not_follow ( symbol_precedence, prev_precedence ) ->
+ Format.fprintf ppf
+ "%a@ may@ not@ follow@ %a"
+ (pp_meaning_of_precedence_index config) symbol_precedence
+ (pp_meaning_of_precedence_index config) prev_precedence
+ | Parenthesis_must_be_preceded_by_picture_symbol ->
+ Format.fprintf ppf
+ "Parenthesis@ must@ be@ preceded@ by@ a@ picture@ symbol"
+ | Unexpected_char c ->
+ Format.fprintf ppf
+ "Unexpected@ character@ %c@ in@ PICTURE@ string" c
+ | Extraneous_symbol_in_exponent ->
+ Format.fprintf ppf "Extraneous@ +@ symbol(s)@ in@ exponent"
+ | Symbol_may_only_appear_once s ->
+ Format.fprintf ppf "%a@ may@ only@ occur@ once@ in@ a@ \
+ PICTURE@ string" pp_symbol s
+ | Symbol_must_be_at_start s ->
+ Format.fprintf ppf "%a@ must@ be@ at@ start@ of@ PICTURE@ string"
+ pp_symbol s
+ | Symbol_must_be_at_end s ->
+ Format.fprintf ppf "%a@ must@ be@ at@ end@ of@ PICTURE@ string"
+ pp_symbol s
+ | Symbol_must_be_at_start_or_end s ->
+ Format.fprintf ppf
+ "%a@ must@ be@ at@ start@ or@ end@ of@ PICTURE@ string"
+ pp_symbol s
+ | Symbols_are_mutually_exclusive ( s1, s2 ) ->
+ Format.fprintf ppf "%a@ and@ %a@ are@ mutually@ exclusive@ in@ a@ \
+ PICTURE@ string"
+ pp_symbol s1 pp_symbol s2
+ | Unexpected_symbol (s, c) ->
+ Format.fprintf ppf "Unexpected@ %a@ in@ PICTURE@ string%a"
+ pp_symbol s
+ Fmt.(option (fun ppf -> fmt "@ of@ category@ %a" ppf pp_category))
+ (Option.map reverse_editions c)
+ | Empty_picture_string ->
+ Format.fprintf ppf "Empty@ PICTURE@ string"
+ | Picture_length_exceeds_limit ( len, max_length ) ->
+ Format.fprintf ppf
+ "length@ of@ PICTURE@ string@ exeeds@ allowed@ size@ (max@ length:@ \
+ %d,@ given@ length:%d)" max_length len
+ | Missing_symbol_in_exponent ->
+ Format.fprintf ppf "Missing@ +@ symbol@ in@ exponent"
+ | Missing_digits_in_exponent ->
+ Format.fprintf ppf "Missing@ digits@ in@ exponent"
+ | Picture_describes_empty_data_item ->
+ Format.fprintf ppf
+ "PICTURE@ string@ describes@ an@ empty@ data@ item"
+ | Numeric_item_cannot_exceed_38_digits len ->
+ Format.fprintf ppf
+ "Numeric@ item@ cannot@ be@ longer@ than@ 38@ digits, %d found" len
+
+module Make (Config: Cobol_config.T) (Env: ENV) = struct
+
+ module DIAGS = Cobol_common.Diagnostics
+
+ let add_diag acc ~loc fmt =
+ DIAGS.kerror ~loc (fun diag -> DIAGS.Set.cons diag acc ) fmt
+
+ let add_hint acc ~loc fmt =
+ DIAGS.khint ~loc (fun diag -> DIAGS.Set.cons diag acc ) fmt
+
+ let add_diags acc ~loc ~config error =
+ let acc = add_diag acc ~loc "%a" (pp_error ~config) error in
+ match error with
+ | Picture_describes_empty_data_item ->
+ add_hint acc ~loc
+ "PICTURE@ string@ must@ contain@ at@ least@ one@ of@ \
+ the@ set@ A,@ N,@ X,@ Z,@ 1,@ 9@ and@ *;@ or@ at@ \
+ least@ two@ of@ the@ set@ +,@ -@ and@ the@ currency@ \
+ symbol"
+ | _ -> acc
+
+ exception InvalidPicture of
+ string with_loc * Cobol_common.Diagnostics.diagnostics * picture
+
+ let of_string ( { payload ; loc } as str ) =
+
+ let config = {
+ max_pic_length = Config.pic_length#value ;
+ decimal_char = Env.decimal_char ;
+ currency_signs = Env.currency_signs ;
+ } in
+ match of_string config payload with
+ | Error ( errors, pic ) ->
+ let diags = List.fold_left (fun acc ( error, (pos,len) ) ->
+ let loc = Srcloc.sub loc ~pos ~len in
+ add_diags acc ~loc ~config error) DIAGS.Set.none errors
+ in
+ raise @@ InvalidPicture (str, diags, pic)
+ | Ok pic -> { payload = pic ; loc }
+
+end
+
+
+let config = { max_pic_length = 100; decimal_char = '.' ;
+ currency_signs = CHARS.add '$' CHARS.empty }
+
+let unit_test ?(config=config) ~expect picture =
+ let ppf = Format.str_formatter in
+ begin
+ match of_string config picture with
+ | Ok pic ->
+ pp_picture ppf pic ;
+ | Error ( errors, _ ) ->
+ List.iter (fun ( error, (pos,len) )->
+ Format.fprintf ppf "Loc: %d (%d)@." pos len;
+ pp_error ~config ppf error;
+ Format.fprintf ppf "@.";
+ ) errors
+ end;
+ let res = Format.flush_str_formatter () in
+ if res <> expect then begin
+ Printf.eprintf "Unit test %S failed:\n%!" picture;
+ Printf.eprintf " Result:\n";
+ Printf.eprintf "{|%s|} ;\n" res;
+ Printf.eprintf " Expected:\n";
+ Printf.eprintf "{|%s|} ;\n%!" expect;
+ false
+ end
+ else
+ true
diff --git a/src/lsp/cobol_data/picture.mli b/src/lsp/cobol_data/picture.mli
new file mode 100644
index 000000000..c21d93a77
--- /dev/null
+++ b/src/lsp/cobol_data/picture.mli
@@ -0,0 +1,213 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+
+(* --- *)
+
+module TYPES: sig
+ type symbol =
+ | A
+ | B
+ | CR
+ | CS
+ | DB
+ | DecimalSep
+ | E
+ | GroupingSep
+ | L
+ | Minus
+ | N
+ | Nine
+ | One
+ | P
+ | Plus
+ | S
+ | Slant
+ | Star
+ | V
+ | X
+ | Z
+ | Zero
+
+ type symbols =
+ {
+ symbol: symbol;
+ symbol_occurences: int;
+ }
+
+ type category =
+ | Alphabetic of
+ {
+ length: int;
+ }
+ | Alphanumeric of
+ {
+ length: int;
+ insertions: simple_insertion list;
+ }
+ | Boolean of
+ {
+ length: int;
+ }
+ | National of
+ {
+ length: int;
+ insertions: simple_insertion list;
+ }
+ | FixedNum of
+ {
+ digits: int;
+ scale: int;
+ with_sign: bool;
+ editions: editions;
+ }
+ | FloatNum of
+ {
+ digits: int;
+ scale: int;
+ with_sign: bool;
+ exponent_digits: int;
+ editions: basic_edition list;
+ }
+
+ and editions =
+ {
+ basics: basic_edition list;
+ floating: floating_insertion option;
+ zerorepl: zero_replacement option;
+ }
+
+ and basic_edition =
+ | SimpleInsertion of simple_insertion
+ | SpecialInsertion of special_insertion
+ | FixedInsertion of fixed_insertion
+
+ and simple_insertion =
+ {
+ simple_insertion_symbols: symbols;
+ simple_insertion_offset: int;
+ }
+
+ and special_insertion =
+ {
+ special_insertion_offset: int;
+ special_insertion_length: int;
+ }
+
+ and fixed_insertion =
+ {
+ fixed_insertion_symbol: symbol;
+ fixed_insertion_offset: int;
+ }
+
+ and floating_insertion =
+ {
+ floating_insertion_symbol: symbol;
+ floating_insertion_ranges: floating_range list;
+ }
+
+ and zero_replacement =
+ {
+ zero_replacement_symbol: symbol;
+ zero_replacement_ranges: floating_range list;
+ }
+
+ and floating_range =
+ {
+ floating_range_offset: int;
+ floating_range_length: int;
+ }
+
+ val pp_category: category Pretty.printer
+
+ type picture =
+ {
+ category: category;
+ pic: symbols list;
+ }
+ [@@deriving show]
+
+ type picture_config = {
+ max_pic_length : int ;
+ decimal_char: char ;
+ currency_signs: Cobol_common.Basics.CharSet.t ;
+ }
+
+ type error =
+ | May_only_appear_once of int
+ | May_not_follow of int * int
+ | Parenthesis_must_be_preceded_by_picture_symbol
+ | Unexpected_char of char
+ | Extraneous_symbol_in_exponent
+ | Symbol_may_only_appear_once of symbol
+ | Symbol_must_be_at_start of symbol
+ | Symbol_must_be_at_end of symbol
+ | Symbol_must_be_at_start_or_end of symbol
+ | Symbols_are_mutually_exclusive of symbol * symbol
+ | Unexpected_symbol of symbol * category option
+ | Empty_picture_string
+ | Picture_length_exceeds_limit of (* length *) int * (* max_len *) int
+ | Missing_symbol_in_exponent
+ | Missing_digits_in_exponent
+ | Picture_describes_empty_data_item
+ | Numeric_item_cannot_exceed_38_digits of int
+
+
+ (* Nicolas' style interface :-) *)
+ module type ENV = sig
+ val decimal_char: char
+ val currency_signs: Cobol_common.Basics.CharSet.t
+ end
+
+end
+
+type t = TYPES.picture
+[@@deriving show]
+
+open TYPES
+
+(** [is_edited c] indicates whether the given category represents an edited
+ item *)
+val is_edited: category -> bool
+
+(** data size (in "characters" --- probably with implemententor specific
+ semantics) *)
+val data_size: category -> int
+
+(** display size, after editions; corresponds to "size" in standards *)
+val size: category -> int
+
+val of_string: picture_config -> string ->
+ ( TYPES.picture,
+ ( TYPES.error * (int*int)) (* = (error, (pos,len)) *)
+ list
+ * TYPES.picture
+ ) result
+
+module Make (Config: Cobol_config.T) (Env: ENV) : sig
+
+ exception InvalidPicture of
+ string with_loc * Cobol_common.Diagnostics.diagnostics * picture
+
+ val of_string: string with_loc -> t with_loc
+end
+
+val pp_meaning_of_precedence_index :
+ TYPES.picture_config -> Format.formatter -> int -> unit
+
+(** Verifies that the picture string is interpreted as `expect`,
+ i.e. the result of `pp_picture`. If not, displays the difference on
+ stderr and returns `false` *)
+val unit_test :
+ ?config:TYPES.picture_config -> expect:string -> string -> bool
diff --git a/src/lsp/cobol_data/pictured_ast.ml b/src/lsp/cobol_data/pictured_ast.ml
new file mode 100644
index 000000000..087f48010
--- /dev/null
+++ b/src/lsp/cobol_data/pictured_ast.ml
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(* NB: not sure we need the full pictured AST. We may only need (part of)
+ Data_sections/division. *)
+
+open Cobol_ast
+
+module CharSet = Cobol_common.Basics.CharSet
+
+module Misc_sections =
+ Cobol_ast.Raw.Misc_sections
+module Picture = struct
+ type picture = Picture.t with_loc [@@deriving show]
+end
+module Data_sections =
+ Cobol_ast.Raw.Data_sections (Picture)
+module Data_division =
+ Cobol_ast.Raw.Data_division (Data_sections)
+module Statements =
+ Cobol_ast.Raw.Statements
+module Proc_division =
+ Cobol_ast.Raw.Proc_division (Statements)
+module Compilation_group =
+ Cobol_ast.Raw.Compilation_group
+ (Misc_sections) (Data_division) (Proc_division)
+
+include Compilation_group
+include Proc_division
+include Statements
+include Data_division
+include Data_sections
+include Picture
+include Misc_sections
diff --git a/src/lsp/cobol_data/qualmap.ml b/src/lsp/cobol_data/qualmap.ml
new file mode 100644
index 000000000..b94adc5dd
--- /dev/null
+++ b/src/lsp/cobol_data/qualmap.ml
@@ -0,0 +1,204 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_ast
+open Cobol_common.Srcloc.INFIX
+
+module QUAL_NAME = struct
+ type t = qualname [@@deriving show]
+
+ let compare = Cobol_ast.compare_qualname
+
+end
+
+module QualNameMap = struct
+ include Map.Make(QUAL_NAME)
+ let pp ?(sep=(fun fmt -> Fmt.pf fmt "@;")) pp_elt fmt m =
+ iter
+ (fun key elt ->
+ Fmt.pf fmt "%a: %a%t" pp_qualname key pp_elt elt sep)
+ m
+end
+
+module QualNameSet = struct
+ include Set.Make(QUAL_NAME)
+ let pp ?(sep=(fun fmt -> Fmt.pf fmt "@ ")) fmt s =
+ iter
+ (fun elt ->
+ Fmt.pf fmt "%a%t" pp_qualname elt sep)
+ s
+end
+
+module NameSet = struct
+ include Set.Make(struct
+ open Cobol_common.Srcloc.TYPES
+ type t = name with_loc
+ let compare {payload = p1; _} {payload = p2; _} =
+ compare p1 p2
+ end)
+ let pp ppf s = Fmt.(braces (seq pp_name')) ppf (to_seq s) [@@warning "-32"] (*unused, for debug mainly*)
+end
+
+type 'a binding = {
+ value: 'a;
+ full_key: QUAL_NAME.t;
+ simple_name: name;
+ contained_in: name with_loc list; (*Invariant: The first element is the 01 name, with the following
+ ones in increasing level numbers *)
+} [@@deriving show]
+
+type 'a t = {
+ base_keys: QualNameSet.t;
+ bindings: 'a binding QualNameMap.t;
+} [@@deriving show]
+
+let empty = { base_keys = QualNameSet.empty;
+ bindings = QualNameMap.empty; }
+
+(** [take_after pred list] returns the list with all the elements that are after
+ the first element that verifies [pred element] or the empty list if no
+ element verifies [pred]. *)
+let rec take_after pred = function
+ | hd::tl when pred hd -> tl
+ | _::tl -> take_after pred tl
+ | [] -> []
+
+(** [get_lower_key qualname] returns {!qualname} without the last [Name _] in
+ it, or [Name name] when qualname is [Qual (name, Name _) | Name name] *)
+let rec get_lower_key qualname =
+ match qualname with
+ | Qual (n, Name _) ->
+ (Name n: qualname)
+ | Qual (n, qn) ->
+ let rest = get_lower_key qn in
+ Qual (n, rest)
+ | _ -> qualname
+
+(** [find_with_subkey key map] returns the map with all the qualnames that can be accessed
+ with the key [key]. *)
+let rec find_with_subkey key map =
+ match key with
+ | Qual (_, Qual _) ->
+ (*we first look for all the items that are contained in the last qualifier. *)
+ let highest_level_name = Cobol_ast.major_qualifier_of_qualname key in
+ let new_map =
+ QualNameMap.filter_map
+ (fun _ ({contained_in; _} as binding) ->
+ let rest =
+ take_after (fun {payload; _} ->
+ payload = ~&highest_level_name) contained_in
+ in
+ if rest <> [] then
+ Some ({binding with contained_in = rest})
+ else
+ None)
+ map
+ in
+ (* We keep looking for an item without the last qualifier *)
+ find_with_subkey (get_lower_key key) new_map
+ | Qual (_, Name n ) ->
+ let new_map =
+ QualNameMap.filter
+ (fun _ {contained_in; _ } ->
+ List.exists (fun {payload; _} -> payload = ~&n) contained_in)
+ map
+ in
+ (* We keep looking for an item without the last qualifier *)
+ find_with_subkey (get_lower_key key) new_map
+ | Name name ->
+ QualNameMap.filter
+ (fun _ ({simple_name; _}) -> simple_name = ~&name)
+ map
+
+let find_binding key map =
+ if QualNameSet.mem key map.base_keys then
+ (QualNameMap.find key map.bindings)
+ else
+ let simple_name' = Cobol_ast.qualifier_of_qualname key in
+ (* We look for all the qualnames that have the simple name `simple_name'`. *)
+ let new_map =
+ QualNameMap.filter (fun _ {simple_name; _} -> simple_name = ~&simple_name') map.bindings
+ in
+ (* If we find several then we look for names with the subkey `key`. *)
+ let new_map = find_with_subkey key new_map in
+ if QualNameMap.cardinal new_map = 1 then
+ (snd @@ QualNameMap.choose new_map)
+ else
+ raise Not_found
+
+(** [find qualname map] returns the unique element [e] of [map] that can be qualified with
+ [qualname]. Raises [Not_found] if the element is not unique, or does not exists in [map]. *)
+let find key map =
+ (find_binding key map).value
+
+(** [find_opt qualname map] returns [Some elt] if [elt] is the unique element of [map] that
+ can be qualified by [qualname]. It returns [None] if there is no element or the uniqueness
+ is not respected. *)
+let find_opt key map =
+ try Some (find key map)
+ with Not_found -> None
+
+(** [find_all qualname map] returns all the elements that can be qualified with [qualname] in [map]. *)
+let find_all key map =
+ let simple_name' = Cobol_ast.qualifier_of_qualname key in
+ let new_map =
+ QualNameMap.filter (fun _ {simple_name; _} -> simple_name = ~&simple_name') map.bindings
+ |> find_with_subkey key
+ in
+ let binding_list = List.of_seq @@ QualNameMap.to_seq new_map in
+ List.map (fun (_, elt) -> (elt.full_key, elt.value)) binding_list
+
+(** [find_full_qualname qualname map] returns the full name of [qualname] if it is unique *)
+let find_full_qualname key map =
+ (find_binding key map).full_key
+
+(** [find_full_qualname_opt qualname map] returns [Some full_name] with [full_name] being the
+ fully qualified name of [qualname] if it exists, [None] otherwise*)
+let find_full_qualname_opt key map =
+ try Some ((find_binding key map).full_key)
+ with _ -> None
+
+let make_contained_in key =
+ let rec aux acc key =
+ match key with
+ | Qual (name, qn) ->
+ aux (name::acc) qn
+ | Name name ->
+ name::acc
+ in
+ match (key: qualname) with
+ | Qual (_, qn) -> aux [] qn
+ | Name _ -> []
+
+(** [add qualname value map] returns [map] with [value] bound to the key [qualname]. [qualname] is
+ assumed to be the fully qualified name of [value].*)
+let add key elt map =
+ let binding =
+ { value = elt;
+ full_key = key;
+ simple_name = ~&(Cobol_ast.qualifier_of_qualname key);
+ contained_in = make_contained_in key; }
+ in
+ { base_keys = QualNameSet.add key map.base_keys;
+ bindings = QualNameMap.add key binding map.bindings; }
+
+(** [iter f map] iters over all the values of [map], note that the first argument of [f] is the fully
+ qualified name of the element. *)
+let iter f map =
+ QualNameMap.iter (fun key {value; _} -> f key value) map.bindings
+
+(** [fold f map init] folds over all the key values bindings of [map], note that the first argument
+ of [f] is fully qualified name of the element. *)
+let fold f map init =
+ QualNameMap.fold (fun key {value; _} acc -> f key value acc) map.bindings init
+
diff --git a/src/lsp/cobol_data/qualmap.mli b/src/lsp/cobol_data/qualmap.mli
new file mode 100644
index 000000000..54037111e
--- /dev/null
+++ b/src/lsp/cobol_data/qualmap.mli
@@ -0,0 +1,48 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_ast
+
+type 'a t [@@deriving show]
+
+val empty: 'a t
+
+(** [find qualname map] returns the unique element [e] of [map] that can be qualified with
+ [qualname]. Raises [Not_found] if the element is not unique, or does not exists in [map]. *)
+val find: qualname -> 'a t -> 'a
+
+(** [find_opt qualname map] returns [Some elt] if [elt] is the unique element of [map] that
+ can be qualified by [qualname]. It returns [None] if there is no element or the uniqueness
+ is not respected. *)
+val find_opt: qualname -> 'a t -> 'a option
+
+(** [find_all qualname map] returns all the elements that can be qualified with [qualname] in [map]
+ with their fully qualified name. *)
+val find_all: qualname -> 'a t -> (qualname * 'a) list
+
+(** [find_full_qualname qualname map] returns the full name of [qualname] if it is unique *)
+val find_full_qualname: qualname -> 'a t -> qualname
+
+(** [find_full_qualname_opt qualname map] returns [Some full_name] with [full_name] being the
+ fully qualified name of [qualname] if it exists, [None] otherwise*)
+val find_full_qualname_opt: qualname -> 'a t -> qualname option
+
+(** [add qualname value map] returns [map] with [value] bound to the key [qualname]. [qualname] is
+ assumed to be the fully qualified name of [value].*)
+val add: qualname -> 'a -> 'a t -> 'a t
+
+(** [iter f map] iters over all the values of [map]. *)
+val iter: (qualname -> 'a -> unit) -> 'a t -> unit
+
+(** [fold f map init] folds over all the key values bindings of [map] *)
+val fold: (qualname -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
diff --git a/src/lsp/cobol_data/types.ml b/src/lsp/cobol_data/types.ml
new file mode 100644
index 000000000..1389241cf
--- /dev/null
+++ b/src/lsp/cobol_data/types.ml
@@ -0,0 +1,106 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(* open Cobol_common.Srcloc.TYPES *)
+(* open Cobol_common.Srcloc.INFIX *)
+(* open Cobol_ast *)
+
+(* TODO: those properties should be re-introduced later when relevant; they are
+ commented for now as they do not appear necessary to the classicfication of
+ data items. *)
+
+(* type bit_length = *)
+(* | L16 *)
+(* | L32 *)
+(* | L62 [@@deriving show] *)
+
+(* type pointer_length = *)
+(* | L4 *)
+(* | L8 [@@deriving show] *)
+
+(* type numeric_format = { *)
+(* signed: bool; *)
+(* integer_length: int; *)
+(* decimal_length: int; *)
+(* } [@@deriving show] *)
+
+(* type numeric_encoding = *)
+(* | Ascii *)
+(* | Bcd *)
+(* | Int of bit_length *)
+(* | Float of bit_length [@@deriving show] *)
+
+(* (\* NOTE: The numeric does not support yet the floating point format of the 2014 standard *\) *)
+(* type numeric = *)
+(* (numeric_format * numeric_encoding) [@@deriving show] *)
+
+(* type alphanumeric_category = *)
+(* | Alphanumeric of int *)
+(* | AlphanumericEdited of int [@@deriving show] *)
+
+(* type national_category = (\* UTF-16 *\) *)
+(* | National of int *)
+(* | NationalEdited of int [@@deriving show] *)
+
+type elementary_data_class =
+ | Alphabetic
+ | Alphanumeric
+ | Boolean
+ | Index
+ | National
+ | Numeric
+ | Object
+ | Pointer
+[@@deriving show]
+
+(* (\* TODO: Remove name from types *\) *)
+
+type data_type =
+ | Elementary of elementary_data_class leveled pictured
+ | Table of table_type leveled
+ | Group of data_type Cobol_ast.with_loc list leveled
+[@@deriving show]
+
+and 'a leveled = {
+ typ: 'a;
+ level: int;
+} [@@deriving show]
+
+and 'a pictured = 'a * Picture.t option [@@deriving show]
+
+and table_type = {
+ elements_type: data_type Cobol_ast.with_loc;
+ length: table_length;
+}
+
+and table_length =
+ | Fixed of Cobol_ast.integer
+ | OccursDepending of (* TODO: get rid of that (duplicate of AST nodes) *)
+ { (* TODO: resolve depending before building the final type repr. *)
+ min_size: Cobol_ast.integer;
+ max_size: Cobol_ast.integer;
+ depending: Cobol_ast.qualname Cobol_ast.with_loc;
+ } [@@deriving show]
+
+(* let loc_of = function *)
+(* | Elementary typ_loc -> ~@typ_loc *)
+(* | Group fields_loc -> ~@fields_loc *)
+(* | Table elements_loc -> ~@elements_loc *)
+
+(* let level_of = function *)
+(* | Elementary { payload = {level; _}, _; _ } *)
+(* | Group { payload = {level; _}; _ } *)
+(* | Table { payload = {level; _}; _ } -> level *)
+
+(* let pp_cob_data_type_loc fmt data_type = *)
+(* pp_cob_data_type fmt data_type *)
diff --git a/src/lsp/cobol_data/typing.ml b/src/lsp/cobol_data/typing.ml
new file mode 100644
index 000000000..ea32e7089
--- /dev/null
+++ b/src/lsp/cobol_data/typing.ml
@@ -0,0 +1,294 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.INFIX
+open Pictured_ast.Data_sections
+open Types
+open Cobol_ast
+
+let cobol_class_of_picture: Picture.t -> Types.elementary_data_class = fun pic ->
+ match pic.category with
+ | Alphabetic _ -> Alphabetic
+ | Alphanumeric _ -> Alphanumeric
+ | Boolean _ -> Boolean
+ | National _ -> National
+ | FixedNum _ | FloatNum _ -> Numeric
+
+let rec of_data_group
+ ((module Diags: Cobol_common.Diagnostics.STATEFUL) as diags)
+ program_environment data_group =
+ match ~&data_group with
+ | Group.Elementary {data_item = Data dde; name = _} ->
+ let level = ~&(dde.data_level) and loc = ~@data_group in
+ let picture, usage, occurs =
+ List.fold_left begin fun (pic, usage, occurs) { payload = clause; _ } ->
+ match clause with
+ | DataPicture { payload = { picture = pic; _ }; _ } ->
+ Some pic, usage, occurs
+ | DataUsage usage_clause ->
+ pic, Some usage_clause, occurs
+ | DataOccurs occurs_clause ->
+ pic, usage, Some occurs_clause
+ | _ ->
+ pic, usage, occurs
+ end (None, None, None) dde.data_clauses
+ in
+ let element =
+ match picture, usage with
+ | Some pic, None ->
+ Ok (Elementary ({ typ = cobol_class_of_picture ~&pic; level },
+ Some ~&pic) &@ loc)
+ | None, Some usage ->
+ begin match usage with
+ | Index ->
+ Ok (Elementary ({typ = Index; level}, None) &@ loc)
+ | Pointer _
+ | FunctionPointer _
+ | ProgramPointer _ ->
+ Ok (Elementary ({typ = Pointer; level}, None) &@ loc)
+ (* | ProgramPointer _ -> *)
+ (* Result.ok @@ Elementary (({typ = Types.Pointer (\* L8 *\); level}, None) &@ loc) *)
+ | ObjectReference _ ->
+ Ok (Elementary ({typ = Types.Object; level}, None) &@ loc)
+ | _ ->
+ Diags.error ~loc "Missing@ PICTURE@ clause";
+ Result.Error ()
+ end
+ | Some picture, Some usage ->
+ let cobol_class = cobol_class_of_picture ~&picture in
+ begin match usage, cobol_class with
+ | (Binary | PackedDecimal), Numeric ->
+ Ok (Elementary ({ typ = cobol_class; level }, Some ~&picture) &@ loc)
+ | (Binary | PackedDecimal), _ ->
+ Diags.error ~loc
+ "The picture associated with a USAGE clause of type BINARY \
+ (COMP) or PACKED-DECIMAL must be a numeric picture";
+ Error ()
+ | _ ->
+ Ok (Elementary ({typ = cobol_class; level}, Some ~&picture) &@ loc)
+ end
+ | None, None ->
+ Diags.error ~loc "Missing@ USAGE@ or@ PICTURE@ clause@ for@ \
+ elementary@ item";
+ Error ()
+ in
+ Result.bind
+ element
+ (fun element -> match occurs with
+ | Some occurs_clause ->
+ begin match occurs_clause with
+ | OccursFixed occurs_fixed ->
+ Ok (Table { typ = { elements_type = element;
+ length = Fixed occurs_fixed.times };
+ level } &@ loc)
+ | OccursDepending { from; to_; depending; _ } ->
+ let length = Types.OccursDepending { min_size = from;
+ max_size = to_;
+ depending } in
+ Ok (Table { typ = { elements_type = element; length }; level } &@ loc)
+ | OccursDynamic _ ->
+ Diags.warn ~loc "Table with dynamic capacity are not implemented yet.";
+ Result.Error ()
+ end
+ | None -> Result.Ok element)
+ | Group {elements = dgl; data_item = Data dde; name = _} ->
+ let level = ~&(dde.data_level) and loc = ~@data_group in
+ let elements =
+ (* If a group has usage clause then it is applied to every elementary
+ item of this group. *)
+ try
+ let usage =
+ List.find (function { payload = DataUsage _; _ } -> true | _ -> false)
+ dde.data_clauses
+ in
+ let rec prepend_usage usage ({ payload; loc } as dg) =
+ match payload with
+ | Group.Elementary ({data_item = Data ({ data_clauses;
+ _} as data_item);
+ _ } as element) ->
+ let data_item = Data { data_item with
+ data_clauses = usage :: data_clauses } in
+ Group.Elementary { element with data_item } &@ loc
+ | Group ({ elements; _ } as group) ->
+ let elements = List.map (prepend_usage usage) elements in
+ Group.Group { group with elements } &@ loc
+ | _ ->
+ dg
+ in
+ List.map (prepend_usage usage) dgl
+ with Not_found -> dgl
+ in
+ let elements =
+ List.map
+ (fun dg -> of_data_group diags program_environment dg)
+ elements
+ |> Cobol_common.join_all
+ in
+ let occurs =
+ List.find_opt begin fun ddc -> match ~&ddc with
+ | DataOccurs _ -> true
+ | _ -> false
+ end dde.data_clauses
+ in
+ Result.map
+ (fun elements ->
+ match occurs with
+ | Some { payload = DataOccurs occurs_clause; _ } ->
+ let group = Group { typ = elements; level } &@ loc in
+ begin
+ match occurs_clause with
+ | OccursFixed occurs_fixed ->
+ Types.Table { typ = { elements_type = group;
+ length = Fixed occurs_fixed.times };
+ level } &@ loc
+ | OccursDepending { from; to_; depending; _ } ->
+ let length =
+ Types.OccursDepending { min_size = from;
+ max_size = to_;
+ depending }
+ in
+ Table { typ = { elements_type = group; length }; level } &@ loc
+ | _ -> failwith "Not implemented yet"
+ end
+ | Some _ -> failwith "Unreachable"
+ | None -> Group { typ = elements; level } &@ loc)
+ elements
+ | Renames { targets; _ } ->
+ (* RENAMES rules: first and last must not be occurs or subordinate to occurs, but can
+ have occurs subordinate to them. These subordinate occurs must be of
+ fixed length. *)
+ let loc = ~@data_group in
+ let has_occurs = function
+ | { payload = DataOccurs _; _ } -> true
+ | _ -> false
+ and has_complex_occurs = function
+ | { payload = DataOccurs (OccursDepending _ |
+ OccursDynamic _); _ } -> true
+ | _ -> false
+ in
+ let rec check_data_group is_first_or_last (data_group: Group.t) =
+ match ~&data_group with
+ | Renames _ | Constant _ -> true
+ | ConditionName _ ->
+ Diags.error ~loc "RENAMES@ may@ not@ reference@ a@ level@ 88.";
+ false
+ | Elementary { data_item = Data data_item; _ }
+ | Group { data_item = Data data_item; _ }
+ when is_first_or_last &&
+ List.exists has_occurs data_item.data_clauses ->
+ Diags.error ~loc "Forbidden@ RENAMES@ of@ data@ item@ with@ \
+ OCCURS@ clause.";
+ false
+ | Elementary _
+ | Group _
+ when is_first_or_last ->
+ true
+ | Elementary { data_item = Data data_item; _ }
+ when List.exists has_complex_occurs data_item.data_clauses ->
+ Diags.error ~loc "RENAMES@ cannot@ reference@ a@ data@ item@ with@ \
+ OCCURS@ DEPENDING@ or@ OCCURS@ DYNAMIC@ clause";
+ false
+ | Elementary _ ->
+ true
+ | Group { data_item = Data data_item; _ }
+ when List.exists has_complex_occurs data_item.data_clauses ->
+ Diags.error ~loc "RENAMES@ cannot@ reference@ a@ data@ item@ with@ \
+ OCCURS@ DEPENDING@ or@ OCCURS@ DYNAMIC@ clause";
+ false
+ | Group { elements; _ } ->
+ List.for_all (check_data_group false) elements
+ in
+ begin match targets with
+ | hd::[] ->
+ if check_data_group true hd then
+ of_data_group diags program_environment hd
+ else
+ Error ()
+ | (hd::tl) ->
+ let tl_rev = List.rev tl in
+ let last = List.hd tl_rev in
+ let middle = List.rev @@ List.tl tl_rev in
+ if check_data_group true hd && check_data_group true last
+ && List.for_all (check_data_group false) middle
+ then
+ let elements =
+ List.map (of_data_group diags program_environment) targets
+ |> Cobol_common.join_all
+ in
+ Result.map (fun elements -> Group {typ = elements; level = 66} &@ loc) elements
+ else
+ Error ()
+ | [] ->
+ Diags.error ~loc "The@ RENAMES@ clause@ cannot@ be@ typed@ (empty@ group@ types)";
+ Error ()
+ end
+ | Constant _ ->
+ Diags.error "Not implemented yet: Type of constant.";
+ Result.Error ()
+ | ConditionName {name = _; _} ->
+ (* Condition-names are not elementary data items. Instead, they are
+ subordicate to a group. *)
+ (* Ok (Elementary (({typ = Conditional; level = 88L }, None) &@<- data_group)) *)
+ Diags.error "Not implemented yet: Type of condition name";
+ Result.Error ()
+
+(*TODO: * Check if first or last item has an occurs clauses.
+ * Take into account subordinates occurs clauses: Idea:
+ - In the environment make a fixed lenght table have the same number of sub items as
+ the number of occurs, i.e 10 TAB PIC XX OCCURS 3 TIMES would have the sub items
+ TAB1, TAB2, TAB3 of type Alphanumeric 2.
+*)
+(* let of_rename_entry (prog_env: Cobol_env.PROG_ENV.t) dde_before rename_entry =
+ let renamed_qualname = QualMap.find_full_qualname ~&rename_entry.renamed_item prog_env.data_items in
+ match ~&rename_entry.through_opt with
+ | None ->
+ let renamed_data_item = QualMap.find renamed_qualname prog_env.data_items in
+ let data_item_type = match renamed_data_item.typ with
+ | None -> failwith "Please type the classic data items before typing the renames entry."
+ | Some (typ) -> typ
+ in
+ data_item_type
+ | Some(through_item) ->
+ let through_qualname = QualMap.find_full_qualname through_item prog_env.data_items in
+ let paths = Cobol_data_group.range_of_data_groups renamed_qualname through_qualname [dde_before] in
+ let renamed_elements = List.fold_left (fun acc (occurs, path) ->
+ let data_item_qualname = Group.of_list path in
+ let data_item = QualMap.find data_item_qualname prog_env.data_items in
+ let data_name = data_item.name in
+ let data_type = match data_item.typ with
+ | None -> failwith "The items must be typed"
+ | Some typ -> typ
+ in
+ let rec add_occurs acc n data_name data_type =
+ match n with
+ | 1 -> List.rev acc
+ | _ ->
+ let new_name = Format.sprintf "__%s_%d" data_name (n - 2) in
+ add_occurs ({field_name = new_name; field_type = data_type}::acc) (n-1) data_name data_type
+ in
+ let new_list =
+ add_occurs
+ [{field_name = ~&data_name; field_type = data_type}]
+ occurs
+ ~&data_name
+ data_type
+ in
+ acc@new_list
+ ) [] paths
+ in
+ let typ =
+ Cobol_types.Group ({ typ = renamed_elements; level = 66L } &@<-
+ rename_entry) in
+ let name = ~&rename_entry.data_name in
+ print_endline ([%derive.show: (string * cob_data_type)] (~&name, typ));
+ typ *)
diff --git a/src/superbol-vscode-platform/version.mlt b/src/lsp/cobol_data/version.mlt
similarity index 100%
rename from src/superbol-vscode-platform/version.mlt
rename to src/lsp/cobol_data/version.mlt
diff --git a/src/lsp/cobol_indent/TODO.md b/src/lsp/cobol_indent/TODO.md
new file mode 100644
index 000000000..c5fcdafdc
--- /dev/null
+++ b/src/lsp/cobol_indent/TODO.md
@@ -0,0 +1,15 @@
+TODO:
+ - Implement continued literal over multiple lines
+ - Bug of tokenizer. Words joined by a "." are not well identified. e.x. According to the lexer, "PROGRAM-ID. HELLO" are 3 TextWords, but "PROGRAM-ID.HELLO." is a single TextWord (which causes error of indenter). (Both are legal in GnuCOBOL)
+ - Not satisfied with the `Cobol_preproc.fold_text_lines`, this function has an argument which is the name of file, so when using lsp, every time using the formatting, we must save the file first, it is not convenient.
+ - Use a new type (other than `context_kind`) to represent the `scope`
+ - Rewrite the `indent_config` (like ocp-indent, we may let the client to decide if it activates some features like alignment of argument)
+ - PERFORM statement has two formats, inline or out-of-line. Not easy to distinguish these two formats without parsing. Now, we regard only "PERFORM {word} TIMES ..." "PERFORM WITH ..." "PERFORM TEST ..." "PERFORM UNTIL ..." "PERFORM VARYING ..." as inline format.
+ There is a bug, since the `ident` of `"PERFORM ident TIMES ..."` can contain more than 1 word like "PERFORM X (3) TIMES ...".
+ - Maybe do the preprocessing to link some successive keywords. ex. "ON" "SIZE" "ERROR" -> "ON_SIZE_ERROR" (the code will be more brief if we do this)
+ - Only support standard ISO/IEC 1989:2014
+ - Careful check for method/interface/factory/function.... I have not verified if there is difference (of indentation) between these compilation unit.
+ - Add check of clause in ENV DIVISION if need be
+ - Refine the check of phrase/clause of PROCEDURE/DATA DIVISION
+ - Find a better way to solve the keyword conflict "(ON)EXCEPTION"
+ - The NEXT SENTENCE phrase inside IF/SEARCH statement, it seems that the GnuCOBOL implements it differently than described in the standard of COBOL, however, I am not sure since I cannot test it in mainframe.(In GnuCOBOL, it allows `IF (conditon) [THEN] NEXT SENTENCE {nested-statement}.` But according to the standard, the THEN branche must be `NEXT SENTENCE` or `nested-statement` but cannot contain both)
diff --git a/src/lsp/cobol_indent/cobol_indent.ml b/src/lsp/cobol_indent/cobol_indent.ml
new file mode 100644
index 000000000..449ab69cb
--- /dev/null
+++ b/src/lsp/cobol_indent/cobol_indent.ml
@@ -0,0 +1,30 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(* If you delete or rename this file, you should add
+ 'src/cobol_indent/main.ml' to the 'skip' field in "drom.toml" *)
+
+module Type = Indent_type
+
+(*return the result of indentation. use user-defined indent_config*)
+let indent_range' = Indenter.indent_range'
+
+(*indent the whole file and print*)
+let indent_file ~source_format ~file ~indent_config =
+ indent_range' ~source_format ~range:None ~indent_config ~file
+ |> Fmt.pr "%s"
+
+(*indent a range of file and print*)
+let indent_range ~source_format ~file ~range ~indent_config =
+ indent_range' ~source_format ~range ~indent_config ~file
+ |> Fmt.pr "%s"
diff --git a/src/lsp/cobol_indent/dune b/src/lsp/cobol_indent/dune
new file mode 100644
index 000000000..6ba8996d0
--- /dev/null
+++ b/src/lsp/cobol_indent/dune
@@ -0,0 +1,26 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_indent)
+ (public_name cobol_indent)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries fmt cobol_preproc cobol_common )
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+
+
+ )
+
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_indent))
+
+; use field 'dune-trailer' to add more stuff here
+
diff --git a/src/lsp/cobol_indent/indent_check.ml b/src/lsp/cobol_indent/indent_check.ml
new file mode 100644
index 000000000..b16877590
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_check.ml
@@ -0,0 +1,1218 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc
+open Cobol_common.Basics
+
+open Indent_type
+open Indent_keywords
+open Indent_util
+
+(*
+ Remark:
+ In general, `check_{scope-name}` handles the tokens of that scope,
+ and will call a child "check function" to check its child scope in some cases,
+ and go back to its parent "check function" when this scope is terminated.
+
+ ex.
+ `check_data_div` will call `check_RD` if it encounters a token "RD".
+ When the RD is terminated by a ".", it will call the `check_data_div`.
+ i.e.
+ When `check_data_div` is called, and if encounter "RD",
+ the `check_data_div` handle this token, update the arguments
+ and call `check_RD`.
+ When inside RD, encounter a ".", handle this ".", update the
+ arguments and go back to `check_data_div`.
+
+ In general, the `check_{scope-name}` does not treat the token which opens the scope itself.
+ However, for the reason of brevity (and scope inference for incomplete code),
+ the `check_ident_div` handles the token `IDENT_DIV` itself
+ ... `check_env_div` ................. `ENV_DIV` ......
+ ... `check_data_div` ................. `DATA_DIV` ......
+ ... `check_proc_div_header` ........... `PROC_DIV` ......
+ ... `check_copy_replace` .............. `COPY/REPLACE` ...
+
+*)
+
+type text = Cobol_preproc.Text.t
+
+let rec check_ident_div (text:text) (state:indent_state) (ifcheck:bool) =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload = TextWord "IDENTIFICATION"; loc} :: {payload = TextWord "DIVISION"; _}
+ :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until_division context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context COMPILATION_UNIT context in
+ let context = push_context IDENT_DIV context in
+ check_ident_div wordlist {state with context; acc} false
+
+ (*TODO:Careful check for method/interface/factory/function....
+ if any difference (of indentation) between these compilation unit *)
+ | {payload = TextWord ("PROGRAM-ID"|"CLASS-ID"|"FACTORY"|"FUCNTION-ID"
+ |"INTERFACE-ID"|"METHOD-ID"|"OBJECT"); loc}
+ :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until_division context in
+ begin match context with
+ | (IDENT_DIV, _) :: (COMPILATION_UNIT, offset) :: _ ->
+ let acc = check_pos loc offset acc ifcheck in
+ check_ident_div wordlist {state with context; acc} false
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context COMPILATION_UNIT context in
+ let context = push_context IDENT_DIV context in
+ check_ident_div wordlist {state with context; acc} false
+ end
+
+ | {payload = TextWord "OPTIONS"; loc}
+ :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until COMPILATION_UNIT context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context PARAGRAPH context in
+ check_ident_div wordlist {state with context; acc} false
+
+ (*jump to ENVIRONMENT DIVISION*)
+ | {payload = TextWord "ENVIRONMENT"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_env_div text {state with scope = ENV_DIV} ifcheck
+ (*jump to DATA DIVISION*)
+ | {payload = TextWord "DATA"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_data_div text {state with scope = DATA_DIV} ifcheck
+ (*jump to PROCEDURE DIVISION*)
+ | {payload = TextWord "PROCEDURE"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_proc_div_header text {state with scope = PROC_DIV_HEADER} ifcheck
+
+ (*end compilation_unit*)
+ | {payload = TextWord "END"; loc }
+ :: {payload = TextWord ("PROGRAM"|"CLASS"|"FACTORY"|"FUNCTION"
+ |"OBJECT"|"METHOD"|"INTERFACE"); _} :: wordlist ->
+ end_compilation_unit loc wordlist state ifcheck
+
+ | {payload;loc} :: wordlist as _text ->
+ begin match payload with
+ | CDirWord _ ->
+ check_ident_div wordlist state false
+ | TextWord "." ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_ident_div wordlist {state with context; acc} false
+ | TextWord ("COPY"|"REPLACE") ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_ident_div wordlist {state with context; acc} false
+ end
+
+
+(*************ENVIRONMENT DIVISION****************)
+(*TODO:Add check of clause in ENV DIVISION if need be*)
+and check_env_div (text:text) (state:indent_state) (ifcheck:bool) =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload = TextWord "ENVIRONMENT"; loc} :: {payload = TextWord "DIVISION"; _} :: wordlist ->
+ let context = pop_until_compilation_unit context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context ENV_DIV context in
+ check_env_div wordlist {state with context; acc} false
+ | {payload = TextWord _; loc} :: {payload = TextWord "SECTION"; _}
+ :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until SECTION context in
+ let context =
+ match context with
+ | (SECTION, _) :: context
+ | context -> context
+ in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context SECTION context in
+ check_env_div wordlist {state with context; acc} false
+ | {payload = TextWord ("SOURCE-COMPUTER"|"OBJECT-COMPUTER"|"SPECIAL-NAMES"|"REPOSITORY"
+ |"FILE-CONTROL"|"I-O-CONTROL"); loc}
+ :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until SECTION context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context PARAGRAPH context in
+ check_env_div wordlist {state with context; acc} false
+ (*jump to other division*)
+ | {payload = TextWord "IDENTIFICATION"; _} :: {payload = TextWord "DIVISION"; _} :: _
+ | {payload = TextWord ("PROGRAM-ID"|"CLASS-ID"|"FACTORY"|"FUCNTION-ID"
+ |"INTERFACE-ID"|"METHOD-ID"|"OBJECT"); _}
+ :: {payload = TextWord "."; _} :: _ ->
+ check_ident_div text {state with scope = IDENT_DIV} ifcheck
+ | {payload = TextWord "DATA"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_data_div text {state with scope = DATA_DIV} ifcheck
+ | {payload = TextWord "PROCEDURE"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_proc_div_header text {state with scope = PROC_DIV_HEADER} ifcheck
+
+ (*end compilation_unit*)
+ | {payload = TextWord "END"; loc }
+ :: {payload = TextWord ("PROGRAM"|"CLASS"|"FACTORY"|"FUNCTION"
+ |"OBJECT"|"METHOD"|"INTERFACE"); _} :: wordlist ->
+ end_compilation_unit loc wordlist state ifcheck
+
+ | {payload; loc} :: wordlist as _text->
+ begin
+ match payload with
+ | CDirWord _ ->
+ check_env_div wordlist state false
+ | TextWord ("COPY"|"REPLACE") ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | TextWord "SELECT" ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context SELECT context in
+ check_env_div wordlist {state with context; acc} false
+ | TextWord "." ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_env_div wordlist {state with context; acc} false
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_env_div wordlist {state with context; acc} false
+ end
+
+(*************DATA DIVISION****************)
+(*TODO: Refine the check of clause of DATA DIVISION*)
+and check_data_div (text:text) (state:indent_state) ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload = TextWord "DATA"; loc } :: {payload = TextWord "DIVISION"; _}
+ :: wordlist ->
+ let context = pop_until_compilation_unit context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DATA_DIV context in
+ check_data_div wordlist {state with context; acc} false
+ | {payload = TextWord _; loc} :: {payload = TextWord "SECTION"; _} :: wordlist ->
+ let context = pop_until SECTION context in
+ let context =
+ match context with
+ | (SECTION, _) :: context
+ | context -> context
+ in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context SECTION context in
+ check_data_div wordlist {state with context; acc} false
+ | {payload = TextWord "IDENTIFICATION"; _} :: {payload = TextWord "DIVISION"; _} :: _
+ | {payload = TextWord ("PROGRAM-ID"|"CLASS-ID"|"FACTORY"|"FUCNTION-ID"
+ |"INTERFACE-ID"|"METHOD-ID"|"OBJECT"); _}
+ :: {payload = TextWord "."; _} :: _ ->
+ check_ident_div text {state with scope = IDENT_DIV} ifcheck
+ | {payload = TextWord "ENVIRONMENT"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_proc_div text {state with scope = ENV_DIV} ifcheck
+ | {payload = TextWord "PROCEDURE"; _} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ check_proc_div_header text {state with scope = PROC_DIV_HEADER} ifcheck
+ (*end compilation_unit*)
+ | {payload = TextWord "END"; loc }
+ :: {payload = TextWord ("PROGRAM"|"CLASS"|"FACTORY"|"FUNCTION"
+ |"OBJECT"|"METHOD"|"INTERFACE"); _} :: wordlist ->
+ end_compilation_unit loc wordlist state ifcheck
+
+ | {payload; loc} :: wordlist as _text ->
+ match payload with
+ | CDirWord _ ->
+ check_data_div wordlist state false
+ | TextWord word ->
+ begin match data_context_of_str word with
+ | Compiler_directive _ ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | Entry (FD|RD|SD as key) ->
+ let context = pop_until SECTION context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context key context in
+ check_fun key wordlist {state with scope = key; context; acc} false
+ (*Data declaration*)
+ (*77-level data description entry*)
+ | Entry (LEVEL 77) ->
+ let context = pop_until SECTION context in
+ let context = push_context DATA_DESC context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_desc wordlist {state with scope = DATA_DESC; context; acc} false
+ (*rename clause*)
+ | Entry (LEVEL 66) ->
+ let context = pop_until (LEVEL 1) context in
+ let context = push_context DATA_DESC context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_desc wordlist {state with scope = DATA_DESC; context; acc} false
+ | Entry (LEVEL level as key) ->
+ let context = reduce_level level context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context key context in
+ let context = push_context DATA_DESC context in
+ check_data_desc wordlist {state with scope = DATA_DESC; context; acc} false
+ | PERIOD ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_div wordlist {state with context; acc} false
+ | No_keyword ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_div wordlist {state with context; acc} false
+ | _ -> failwith @@ failure_msg loc
+ end
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_div wordlist {state with context; acc} false
+
+and check_data_div_entry clauses key (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist as _text ->
+ match payload with
+ | CDirWord _ ->
+ check_data_div_entry clauses key wordlist state ifcheck
+ | TextWord ("COPY"|"REPLACE") ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | TextWord str when StringSet.mem str clauses ->
+ let context = pop_until key context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DATA_DIV_CLAUSE context in
+ check_data_div_entry clauses key wordlist {state with context; acc} false
+ | TextWord "." ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_div wordlist {state with scope = DATA_DIV; context; acc} false
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_data_div_entry clauses key wordlist {state with acc} false
+
+and check_FD text state ifcheck = check_data_div_entry
+ (StringSet.of_list ["EXTERNAL"; "GLOBAL"; "FORMAT"; "BLOCK"; "CODE-SET"; "RECORD"; "LINAGE"])
+ FD text state ifcheck
+
+and check_RD text state ifcheck = check_data_div_entry
+ (StringSet.of_list ["GLOBAL"; "CODE"; "CONTROL"; "CONTROLS"; "PAGE"])
+ RD text state ifcheck
+
+and check_SD text state ifcheck =
+ check_data_div_entry (StringSet.of_list ["RECORD"]) SD text state ifcheck
+
+(*TODO: if necessary, distinguish data description with screen description*)
+and check_data_desc text state ifcheck =
+ check_data_div_entry
+ (StringSet.of_list
+ [(*keyword of data description entry*)
+ "REDEFINES"; "TYPEDES"; "ALIGNED"; "ANY"; "BASED"; "BLANK"; "CONSTANT"; "DYNAMIC";
+ "EXTERNAL"; "GLOBAL"; "GROUP-USAGE"; "JUST"; "JUSTIFIED"; "OCCURS"; "PIC"; "PICTURE";
+ "PROPERTY"; "SAME"; "SELECT"; "SIGN"; "LEADING"; "TAILING"; "SYNCHRONIZED"; "SYNC";
+ "TYPE"; "CLASS"; "DEFAULT"; "DESTINATION"; "INVALID"; "PRESENT";
+ "VARYING"; "VALIDATE-STATUS"; "VAL-STATUS"; "VALUE"; "VALUES";
+ (*keyword of screen description entry*)
+ "LINE"; "COL"; "COLUMN"; "ERASE"; "FULL"; "AUTO"; "SECURE"; "REQUIRED"; "DISPLAY";
+ "NATIONAL"; "BELL"; "BLINK"; "HIGHTLIGHT"; "LOWLIGHT"; "REVERSE-VIDEO"; "UNDERLINE";
+ "FOREGROUND-COLOR"; "BACKGROUND-COLOR"; "USING"
+ (*TODO: The clauses FROM, TO are omitted here, since they can appear inside other clauses,
+ which makes the problem a little complex.*)
+ ])
+ DATA_DESC text state ifcheck
+
+
+(*************PROCEDURE DIVISION****************)
+and check_proc_div_header (text:text) (state:indent_state) ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload = TextWord "PROCEDURE"; loc} :: {payload = TextWord "DIVISION"; _} :: wordlist
+ ->
+ let context = pop_until_compilation_unit context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context PROC_DIV context in
+ let context = push_context PROC_DIV_HEADER context in
+ check_proc_div_header wordlist {state with context; acc} false
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_proc_div_header wordlist state ifcheck
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | Compiler_directive _ ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | No_keyword ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_proc_div_header wordlist {state with acc} false
+ | Phrase (USING|RAISING|BY as key) ->
+ handle_phrase key loc wordlist state ifcheck
+ | Inline_phrase ->
+ handle_inline_phrase loc wordlist state ifcheck
+ (*PERIOD here means the real beginning of the procedure divisoin*)
+ | PERIOD ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ (*for better indentation, we suppose that when procedure division begins,
+ there is an implicit paragraph just after the procedure division. *)
+ let context = push_context PARAGRAPH context in
+ check_proc_div wordlist {state with scope = PROC_DIV; context; acc} false
+ | _ ->
+ failwith @@ failure_msg loc
+ end
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_proc_div_header wordlist {state with context; acc} false
+
+and check_proc_div (text:text) (state:indent_state) ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | {payload = TextWord "IDENTIFICATION"; _} :: {payload = TextWord "DIVISION"; _}
+ :: _
+ | {payload = TextWord ("PROGRAM-ID"|"CLASS-ID"|"FACTORY"|"FUCNTION-ID"
+ |"INTERFACE-ID"|"METHOD-ID"|"OBJECT"); _}
+ :: {payload = TextWord "."; _} :: _ ->
+ check_ident_div text {state with scope = IDENT_DIV} ifcheck
+
+ | {payload = TextWord "DECLARATIVES"; loc} :: {payload = TextWord "."; _} :: wordlist ->
+ let context = pop_until PROC_DIV context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DECLARATIVES context in
+ let context = push_context PARAGRAPH context in
+ check_proc_div wordlist {state with context; acc} false
+ | {payload = TextWord "END"; loc} :: {payload = TextWord "DECLARATIVES"; _}
+ :: {payload = TextWord "."; _}:: wordlist ->
+ let context = pop_until DECLARATIVES context in
+ begin match context with
+ | (DECLARATIVES, _) :: context ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ (*for better indentation, we suppose that when procedure division begins,
+ there is an implicit paragraph just after the procedure division. *)
+ let context = push_context PARAGRAPH context in
+ check_proc_div wordlist {state with context; acc} false
+ | _ -> failwith @@ failure_msg loc end
+
+ | {payload = TextWord name; loc} :: {payload = TextWord "SECTION"; _}
+ :: {payload = TextWord "."; _} :: wordlist when not @@ is_statement name ->
+ let context =
+ match context with
+ | (PARAGRAPH, _) :: (SECTION, _) :: context
+ | (PARAGRAPH, _) :: context
+ | context -> context
+ in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context SECTION context in
+ let context = push_context PARAGRAPH context in
+ check_proc_div wordlist {state with context; acc} false
+ | {payload = TextWord name; loc} :: {payload = TextWord "."; _} :: wordlist
+ when not @@ is_statement name ->
+ let context =
+ match context with
+ | (PARAGRAPH, _) :: context -> context
+ | _ -> context
+ in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ let context = push_context PARAGRAPH context in
+ check_proc_div wordlist {state with context; acc} false
+ (*end compilation_unit*)
+ | {payload = TextWord "END"; loc }
+ :: {payload = TextWord ("PROGRAM"|"CLASS"|"FACTORY"|"FUNCTION"
+ |"OBJECT"|"METHOD"|"INTERFACE"); _} :: wordlist ->
+ end_compilation_unit loc wordlist state ifcheck
+
+ (*TODO: find a better way to distinguish PERFORM(inline) and PERFORM_CLOSED(out-of-line)*)
+ (*A bug here, TODO.md for details*)
+ | {payload = TextWord "PERFORM"; loc } :: _ :: {payload = TextWord "TIMES"; _} :: wordlist
+ | {payload = TextWord "PERFORM"; loc } :: {payload = TextWord ("UNTIL"|"VARYING"|"WITH"|"TEST"); _}
+ :: wordlist ->
+ handle_open_scope PERFORM loc wordlist state ifcheck
+
+ | {payload; loc} :: wordlist ->
+ begin match payload with
+ | CDirWord _ ->
+ check_proc_div wordlist state ifcheck
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | Compiler_directive _ ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | Open_scope keyword ->
+ handle_open_scope keyword loc wordlist state ifcheck
+ | _ ->
+ (* if all keywords of statements are implemented, this case never happens*)
+ (*failwith ("error proc_div: "^ word)*)
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ check_proc_div wordlist {state with acc} false
+ end
+ | _ ->
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ check_proc_div wordlist {state with acc} false
+ end
+ | [] -> state
+
+
+(* General statement, handles "common tokens" which can follow any statement *)
+(* Notice that we cannot know when a statement terminates in general*)
+(* When the code is in a statement not explicitly terminated,
+ the next token can be
+ 1. keyword of other statement, "MOVE/ADD/DISPLAY..."
+ 2. "when" "else" "on size error" ... (it means the statement is nested)
+ 3. keyword inside the statement . ex. phrase/clause
+ 4. "END-xxx"
+ 5. PEROID *)
+(*
+ `check_statement` should be regarded as an auxiliary function,
+ `check_statement` does not recursively call itself directly.
+
+ At the begin, I define this function with the intention of reducing the duplicate code,
+ because inside any statement, there are a lot of "common token" to treat,
+ especially "NOT ON SIZE ERROR..." which are too long, hard to write.
+ TODO: maybe we had better do some preprocess,
+ ex. {TextWord "ON";loc} :: {TextWord "SIZE";_} :: {TextWord "ERROR";_} :: ...
+ -> {TextWord "ON_SIZE_ERROR";loc} :: ...
+
+ The `check_statement` is called by other functions like `check_if_stmt`,
+ look at how `check_if_stmt` works:
+ If the current token is a statement-specific token (like `THEN`)
+ (or "common token" easy to write like `PERIOD`, `No_keyword`... ),
+ treat the current token and call recursively itself,
+ Otherwise
+ call `check_statement`.
+*)
+and check_statement (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ (*TODO:
+ Maybe do the preprocessing to link some successive keywords.
+ ex. "ON" "SIZE" "ERROR" -> "ON_SIZE_ERROR"
+ (the code will be more brief if we do this)*)
+ | {payload = TextWord "ON"; loc } :: {payload = TextWord "SIZE"; _}
+ :: {payload = TextWord "ERROR"; _} :: wordlist
+ | {payload = TextWord "SIZE"; loc} :: {payload = TextWord "ERROR"; _} :: wordlist ->
+ handle_conditional_statement loc ON_SIZE_ERROR wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc } :: {payload = TextWord "ON"; _}
+ :: {payload = TextWord "SIZE"; _} :: {payload = TextWord "ERROR"; _}:: wordlist
+ | {payload = TextWord "NOT"; loc }
+ :: {payload = TextWord "SIZE"; _} :: {payload = TextWord "ERROR"; _}:: wordlist ->
+ handle_conditional_statement loc NOT_ON_SIZE_ERROR wordlist state ifcheck
+ | {payload = TextWord "AT"; loc} :: {payload = TextWord "END"; _} :: wordlist
+ | {payload = TextWord "END"; loc} :: wordlist ->
+ handle_conditional_statement loc AT_END wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc} :: {payload = TextWord "AT"; _}
+ :: {payload = TextWord "END"; _} :: wordlist
+ | {payload = TextWord "NOT"; loc} :: {payload = TextWord "END"; _} :: wordlist ->
+ handle_conditional_statement loc NOT_AT_END wordlist state ifcheck
+ | {payload = TextWord "ON"; loc} :: {payload = TextWord "EXCEPTION"; _} :: wordlist
+ (* TODO: Find a better way to solve the keyword conflict "(ON)EXCEPTION".
+ the "ON EXCEPTION" can be simplified to "EXCEPTION",
+ but "EXCEPTION" can appear inside some statements(RAISE/GOBACK/USE)
+ I use a quite strange way to solve the problem (cannot be generalized)
+ See `check_raise_stmt` `check_goback_stmt` `check_use_stmt`
+ *)
+ | {payload = TextWord "EXCEPTION"; loc} :: wordlist ->
+ handle_conditional_statement loc ON_EXCEPTION wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc} :: {payload = TextWord "ON"; _}
+ :: {payload = TextWord "EXCEPTION"; _} :: wordlist
+ | {payload = TextWord "NOT"; loc}
+ :: {payload = TextWord "EXCEPTION"; _} :: wordlist ->
+ handle_conditional_statement loc NOT_ON_EXCEPTION wordlist state ifcheck
+ | {payload = TextWord "INVALID"; loc } :: {payload = TextWord "KEY"; _} :: wordlist
+ | {payload = TextWord "INVALID"; loc } :: wordlist ->
+ handle_conditional_statement loc INVALID_KEY wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc } :: {payload = TextWord "INVALID"; _}
+ :: {payload = TextWord "KEY"; _} :: wordlist
+ | {payload = TextWord "NOT"; loc } :: {payload = TextWord "INVALID"; _}
+ :: wordlist ->
+ handle_conditional_statement loc NOT_INVALID_KEY wordlist state ifcheck
+ | {payload = TextWord "AT"; loc } :: {payload = TextWord ("END-OF-PAGE"|"EOP"); _} :: wordlist
+ | {payload = TextWord ("END-OF-PAGE"|"EOP"); loc} :: wordlist ->
+ handle_conditional_statement loc AT_END_OF_PAGE wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc} :: {payload = TextWord "AT"; _}
+ :: {payload = TextWord ("END-OF-PAGE"|"EOP"); _} :: wordlist
+ | {payload = TextWord "NOT"; loc}
+ :: {payload = TextWord ("END-OF-PAGE"|"EOP"); _} :: wordlist ->
+ handle_conditional_statement loc NOT_AT_END_OF_PAGE wordlist state ifcheck
+ | {payload = TextWord "ON"; loc } :: {payload = TextWord "OVERFLOW"; _} :: wordlist
+ | {payload = TextWord "OVERFLOW"; loc} :: wordlist ->
+ handle_conditional_statement loc ON_OVERFLOW wordlist state ifcheck
+ | {payload = TextWord "NOT"; loc } :: {payload = TextWord "ON"; _}
+ :: {payload = TextWord "OVERFLOW"; _} :: wordlist
+ | {payload = TextWord "NOT"; loc }
+ :: {payload = TextWord "OVERFLOW"; _} :: wordlist ->
+ handle_conditional_statement loc NOT_ON_OVERFLOW wordlist state ifcheck
+
+ (*TODO: find a better way to distinguish PERFORM(inline) and PERFORM_CLOSED(out-of-line)*)
+ (*A bug here, TODO.md for details*)
+ | {payload = TextWord "PERFORM"; loc } :: _ :: {payload = TextWord "TIMES"; _} :: wordlist
+ | {payload = TextWord "PERFORM"; loc } :: {payload = TextWord ("UNTIL"|"VARYING"|"WITH"|"TEST"); _}
+ :: wordlist ->
+ handle_open_scope PERFORM loc wordlist state ifcheck
+
+ | {payload = TextWord "ELSE"; loc} :: {payload = TextWord "IF"; _} :: wordlist ->
+ let context = exp_scope_termination THEN context in
+ begin match context with
+ | (THEN, _) :: (IF, _) :: context' ->
+ let acc = check_pos loc (offset_of_context context') acc ifcheck in
+ check_if_stmt wordlist {state with scope = IF; context; acc} false
+ | _ -> failwith @@ failure_msg loc
+ end
+(*
+ | {payload = TextWord "NEXT"; loc} :: {payload = TextWord "SENTENCE"; _} :: wordlist
+
+ The GnuCOBOL handles NEXT SENTENCE differently than described in the standard of COBOL.
+ According the standard 1985/1989:2014
+ ```
+ IF x > 1 THEN NEXT SENTENCE
+ DISPLAY "STH" .
+ ```
+ This DISPLAY statement should be the next statement of IF statement.
+ But the result of GnuCOBOL shows that
+ the DISPLAY statement is inside the THEN phrase(even though it is never reached).
+ However, I am not sure since I cannot test the case in the mainframe.
+
+ We must care about this case. Because the NEXT SENTENCE in fact terminates the
+ Then branch of IF statement, so this IF statement can be implicitly terminated. *)
+
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_fun state.scope wordlist state ifcheck
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | Compiler_directive _ ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | Close_scope keyword ->
+ handle_close_scope keyword loc wordlist state ifcheck
+ | Open_scope keyword ->
+ handle_open_scope keyword loc wordlist state ifcheck
+
+ | Phrase THEN -> (*only for THEN inside INTIALIZE statement*)
+ handle_inline_phrase loc wordlist state ifcheck
+
+ | Phrase keyword ->
+ handle_phrase keyword loc wordlist state ifcheck
+ | Inline_phrase ->
+ handle_inline_phrase loc wordlist state ifcheck
+ | PERIOD ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let scope = match context with
+ (*this case appears when indent a incomplet code, which begins directly with statement*)
+ (*In general we avoid defining `state.scope` to `STATEMENT`,
+ it is better to define `state.scope` to a specific statement like `IF`, `ADD`.
+ `check_statement` is an auxiliary function *)
+ | (BEGIN, _) :: _ -> STATEMENT
+ | (scope, _) :: _ -> scope
+ | [] -> failwith @@ failure_msg loc
+ in
+ check_proc_div wordlist {state with scope; context; acc} false
+ | No_keyword
+ | _ ->
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ check_fun state.scope wordlist {state with acc} false
+ end
+ | _ ->
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ check_fun state.scope wordlist {state with acc} false
+
+(* if in need, we can seperate some statements from this general statement.
+ ex. the `check_if_stmt` below
+
+ in `check_if_stmt`, and `check_statement`, we handle `THEN` differently
+ (`THEN` inside `IF` statement or `INITIALIZE` statement)
+ of course, we can remove `check_if_stmt`, and add the check of context in
+ `handle_then` to make it work correctly
+
+ we can define the check_accept, check_display... for each statement,
+ however, there are too many duplicate code to write...
+ we could do that if the finer analysis is needed. *)
+and check_if_stmt (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_if_stmt wordlist state ifcheck
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | Compiler_directive _ ->
+ check_copy_replace text {state with scope = COPY_REPLACE} ifcheck
+ | Phrase THEN ->
+ handle_if_then loc wordlist state ifcheck
+ | Open_scope keyword ->
+ handle_open_scope keyword loc wordlist state ifcheck
+ | No_keyword ->
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset acc ifcheck in
+ check_if_stmt wordlist {state with acc} false
+ (*other case, call the general function*)
+ | _ -> check_statement text state ifcheck
+ end
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_if_stmt wordlist {state with acc} false
+
+(* TODO: Find a better way to solve the keyword conflict "(ON)EXCEPTION"*)
+(*`check_raise_stmt`, `check_goback_stmt`, `check_use_stmt` are to solve the keyword conflict of "EXCEPTION"*)
+(* the idea: when the RAISE/GOBACK/USE statement do not allow an "EXCEPTION" phrase any more,
+ add a DUMMY token onto the `context`,
+ when check the wordlist, check the `context` top, if there is a DUMMY token,
+ call `check_statement` *)
+and check_raise_stmt (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_raise_stmt wordlist state ifcheck
+ | TextWord _ when context = [] || fst @@ List.hd context <> DUMMY_EXCEPTION ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DUMMY_EXCEPTION context in
+ check_raise_stmt wordlist {state with acc; context} false
+ | _ ->
+ check_statement text state ifcheck
+
+and check_goback_stmt (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_goback_stmt wordlist state ifcheck
+ | TextWord "." ->
+ let context = handle_period context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let scope = match context with
+ | (BEGIN, _) :: _ -> STATEMENT (*ERROR PRONE*)
+ | (scope, _) :: _ -> scope
+ | [] -> failwith @@ failure_msg loc
+ in
+ check_proc_div wordlist {state with scope; context; acc} false
+ | TextWord "RAISING" ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context RAISING context in
+ check_goback_stmt wordlist {state with context; acc} false
+ | TextWord "LAST"
+ (*"GOBACK [RAISING LAST EXCEPTION]"*)
+ when context <> [] && fst @@ List.hd context = RAISING ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_goback_stmt wordlist {state with acc} false
+ | TextWord _
+ when context <> [] && fst @@ List.hd context = RAISING ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DUMMY_EXCEPTION context in
+ check_goback_stmt wordlist {state with context; acc} false
+ | _ ->
+ check_statement text state ifcheck
+
+and check_use_stmt (text:text) state ifcheck =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ ->
+ check_use_stmt wordlist state ifcheck
+ | TextWord ("GLOBAL"|"AFTER"|"STANDARD") ->
+ (*the keyword which can appear before "EXCEPTION"*)
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_use_stmt wordlist {state with acc} false
+ | TextWord _ when context = [] || fst @@ List.hd context <> DUMMY_EXCEPTION ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context DUMMY_EXCEPTION context in
+ check_use_stmt wordlist {state with acc; context} false
+ | _ ->
+ check_statement text state ifcheck
+(* / *)
+
+(*For alignment of arguments*)
+(*fst_arg: if is the first argument in the line*)
+and check_arguments (text:text) state ifcheck ~fst_arg =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ begin match payload with
+ | CDirWord _ -> check_arguments wordlist state ifcheck ~fst_arg
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | No_keyword when fst_arg ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let pos = start_pos loc in
+ let offset = pos.pos_cnum - pos.pos_bol in
+ let offset_change =
+ match acc with
+ | [] -> 0
+ | {lnum; _} :: _ when lnum <> pos.pos_lnum -> 0
+ | x :: _ -> x.offset_modif - x.offset_orig
+ in
+ let context =
+ match context with
+ | (ARGUMENT, _) :: context' ->
+ (ARGUMENT, offset + offset_change) :: context'
+ | _ -> failwith @@ failure_msg loc
+ in
+ check_arguments wordlist {state with acc; context} false ~fst_arg:false
+ | No_keyword -> check_arguments wordlist state false ~fst_arg:false
+ | _ ->
+ let scope, context =
+ match context with
+ | (ARGUMENT, _) :: ((TO|FROM|INTO|BY|GIVING), _) :: ((prev, _) :: _ as context)
+ | (ARGUMENT, _) :: ((prev, _) :: _ as context) -> prev, context
+ | _ -> failwith @@ failure_msg loc
+ in
+ check_fun scope text {state with scope; context} ifcheck
+ end
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_arguments wordlist {state with acc} false ~fst_arg
+ end
+
+and check_add_stmt (text:text) state ifcheck =
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ match payload with
+ | CDirWord _ -> check_add_stmt wordlist state ifcheck
+ | TextWord word ->
+ begin match proc_context_of_str word with
+ | No_keyword ->
+ let context = push_context ARGUMENT state.context in
+ check_arguments text {state with scope = ARGUMENT; context} ifcheck ~fst_arg:true
+ | Phrase keyword -> handle_phrase keyword loc wordlist state ifcheck
+ | _ -> check_statement text state ifcheck
+ end
+ | _ -> failwith @@ failure_msg loc
+
+and check_subtract_stmt text state ifcheck = check_add_stmt text state ifcheck
+and check_multiply_stmt text state ifcheck = check_add_stmt text state ifcheck
+and check_divide_stmt text state ifcheck = check_add_stmt text state ifcheck
+(* / *)
+
+
+(* there are some handle_functions.
+ different from check_function,
+ the check_function will call itself again (possibly stay in its scope) (except `check_statement`)
+ the handle_function handles one token and go directly to another scope *)
+and handle_open_scope keyword loc wordlist state ifcheck =
+ let context = imp_scope_termination state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ let context = push_context keyword context in
+ match keyword with
+ (*TODO: find a better way to handle the nested IF statement.
+ If need to indent the condition expression, must change this*)
+ | IF ->
+ let context = push_context THEN context in
+ check_fun keyword wordlist {state with scope = keyword; context; acc} false
+ | _ ->
+ check_fun keyword wordlist {state with scope = keyword; context; acc} false
+
+and handle_close_scope keyword loc wordlist state ifcheck =
+ let context = exp_scope_termination keyword state.context in
+ match context with
+ | (key, _) :: ((prev, offset) :: _ as context) when key = keyword ->
+ let acc = check_pos loc offset state.acc ifcheck in
+ let scope =
+ (*this case appears when indent a incomplet code, which begins directly with statement*)
+ (*In general we avoid defining `state.scope` to `STATEMENT`,
+ it is better to define `state.scope` to a specific statement like `IF`, `ADD`.
+ `check_statement` is an auxiliary function *)
+ if prev = BEGIN then STATEMENT
+ else prev
+ in
+ check_fun scope wordlist {state with scope; context; acc} false
+ | _ -> failwith @@ failure_msg loc
+
+and handle_if_then loc wordlist state ifcheck =
+ let context = imp_scope_termination state.context in
+ match context with
+ | (THEN, _):: (IF, _) :: context' ->
+ let acc = check_pos loc (offset_of_context context') state.acc ifcheck in
+ check_fun state.scope wordlist {state with scope = THEN; context; acc} false
+ | _ ->
+ failwith @@ failure_msg loc
+
+and handle_else loc wordlist state ifcheck =
+ let context = exp_scope_termination THEN state.context in
+ match context with
+ | (THEN, _) :: ((IF, _) :: context' as context) ->
+ let acc = check_pos loc (offset_of_context context') state.acc ifcheck in
+ let context = push_context ELSE context in
+ check_fun state.scope wordlist {state with scope = ELSE; context; acc} false
+ |_ ->
+ failwith @@ failure_msg loc
+
+(*for alignment of argument*)
+and handle_operator keyword loc wordlist state ifcheck =
+ let context = phrase_termination state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ let context = push_context keyword context in
+ let context = push_context ARGUMENT context in
+ check_arguments wordlist {state with acc; context; scope = ARGUMENT} false ~fst_arg:true
+
+and handle_to loc wordlist state ifcheck =
+ handle_operator TO loc wordlist state ifcheck
+
+and handle_into loc wordlist state ifcheck =
+ handle_operator INTO loc wordlist state ifcheck
+
+and handle_from loc wordlist state ifcheck =
+ handle_operator FROM loc wordlist state ifcheck
+
+and handle_giving loc wordlist state ifcheck =
+ handle_operator GIVING loc wordlist state ifcheck
+
+and handle_by loc wordlist state ifcheck =
+ let context = phrase_termination_until USING state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ let context = push_context BY context in
+ let context = push_context ARGUMENT context in
+ check_arguments wordlist {state with acc; context; scope = ARGUMENT} false ~fst_arg:true
+
+(*using-phrase is the only phrase that we treat more carefully
+ using-phrase can contain by content/reference phrase. *)
+and handle_using loc text state ifcheck =
+ let context = phrase_termination state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ let context = push_context USING context in
+ check_using text {state with acc; context; scope = USING} false
+
+and check_using (text:text) state ifcheck =
+ match text with
+ | [] -> state
+ | {payload = TextWord "BY"; loc} :: {payload = TextWord ("REFERENCE"|"CONTENT"|"VALUE"); _} :: wordlist
+ | {payload = TextWord ("REFERENCE"|"CONTENT"|"VALUE"); loc} :: wordlist ->
+ handle_by loc wordlist state ifcheck
+ | {payload = TextWord word; _} :: _ ->
+ begin match proc_context_of_str word with
+ | No_keyword ->
+ let context = push_context ARGUMENT state.context in
+ check_arguments text {state with context; scope = ARGUMENT} ifcheck ~fst_arg:true
+ | _ -> check_statement text state ifcheck
+ (*Since using-phrase alse appears in the procedure division header,
+ it is not appropriate to call check_statement here.
+ However, no bug found untilnow.*)
+ end
+ | _ -> check_statement text state ifcheck
+(* / *)
+
+
+and handle_phrase keyword loc wordlist state ifcheck =
+ match keyword with
+ | TO -> handle_to loc wordlist state ifcheck
+ | INTO -> handle_into loc wordlist state ifcheck
+ | GIVING -> handle_giving loc wordlist state ifcheck
+ | FROM -> handle_from loc wordlist state ifcheck
+ | BY -> handle_by loc wordlist state ifcheck
+ | USING -> handle_using loc wordlist state ifcheck
+ | ELSE -> handle_else loc wordlist state ifcheck
+ | WHEN -> handle_when loc wordlist state ifcheck
+ | _ ->
+ let context = phrase_termination state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ match context with
+ | (prev, _) :: _ ->
+ let context = push_context keyword context in
+ check_fun prev wordlist {state with scope = prev; context; acc} false
+ | _ -> failwith @@ failure_msg loc
+
+and handle_inline_phrase loc wordlist state ifcheck =
+ let context = phrase_termination state.context in
+ let offset = offset_of_context context in
+ let acc = check_pos loc offset state.acc ifcheck in
+ match context with
+ | (prev, _) :: _ ->
+ check_fun prev wordlist {state with scope = prev; context; acc} false
+ | _ -> failwith @@ failure_msg loc
+
+
+and handle_conditional_statement loc keyword wordlist state ifcheck =
+ let help keyword rev_keyword keyword_associated =
+ let context, acc = state.context, state.acc in
+ let context = phrase_termination context in
+ match context with
+ (*special case, SEARCH statement contains only `AT_END` but not `NOT_AT_END`*)
+ | (SEARCH, offset) :: _ when keyword = AT_END ->
+ let acc = check_pos loc offset acc ifcheck in
+ let context = push_context SEARCH_AT_END context in
+ check_fun keyword wordlist {state with scope = keyword; context; acc} false
+ (* take `ON_SIZE_ERROR` for an example*)
+ (* when the `ON_SIZE_ERROR` is just after an `ADD`, it must match this `ADD`*)
+ | (key, offset) :: _ when List.mem key keyword_associated ->
+ let acc = check_pos loc offset acc ifcheck in
+ let context = push_context keyword context in
+ check_fun keyword wordlist {state with scope = keyword; context; acc} false
+ (* when the `ON_SIZE_ERROR` is not just after `ADD`,
+ there must be a `NOT_ON_SIZE_ERROR` in the `context`, match them*)
+ | _ ->
+ let context = exp_scope_termination rev_keyword context in
+ match context with
+ | (key, _) :: context when key = rev_keyword ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context HELPTOKEN context in
+ check_fun keyword wordlist {state with scope = keyword; context; acc} false
+ | _ -> failwith @@ failure_msg loc
+ in
+ match keyword with
+ | ON_SIZE_ERROR ->
+ help ON_SIZE_ERROR NOT_ON_SIZE_ERROR [ADD; SUBTRACT; MULTIPLY; DIVIDE; COMPUTE]
+ | NOT_ON_SIZE_ERROR ->
+ help NOT_ON_SIZE_ERROR ON_SIZE_ERROR [ADD; SUBTRACT; MULTIPLY; DIVIDE; COMPUTE]
+ | AT_END ->
+ help AT_END NOT_AT_END [READ; RETURN; SEARCH]
+ | NOT_AT_END ->
+ help NOT_AT_END AT_END [READ; RETURN; SEARCH]
+ | ON_EXCEPTION ->
+ help ON_EXCEPTION NOT_ON_EXCEPTION [ACCEPT; CALL; DISPLAY]
+ | NOT_ON_EXCEPTION ->
+ help NOT_ON_EXCEPTION ON_EXCEPTION [ACCEPT; CALL; DISPLAY]
+ | INVALID_KEY ->
+ help INVALID_KEY NOT_INVALID_KEY [READ; WRITE; REWRITE; START; DELETE]
+ | NOT_INVALID_KEY ->
+ help NOT_INVALID_KEY INVALID_KEY [READ; WRITE; REWRITE; START; DELETE]
+ | AT_END_OF_PAGE ->
+ help AT_END_OF_PAGE NOT_AT_END_OF_PAGE [WRITE]
+ | NOT_AT_END_OF_PAGE ->
+ help NOT_AT_END_OF_PAGE AT_END_OF_PAGE [WRITE]
+ | ON_OVERFLOW ->
+ help ON_OVERFLOW NOT_ON_OVERFLOW [CALL; STRING; UNSTRING]
+ | NOT_ON_OVERFLOW ->
+ help NOT_ON_OVERFLOW ON_OVERFLOW [CALL; STRING; UNSTRING]
+ | _ -> failwith @@ failure_msg loc
+
+
+and handle_when loc wordlist state ifcheck =
+ let context = phrase_termination state.context in
+ match context with
+ | (key, offset) :: _ when key = EVALUATE || key = SEARCH ->
+ let acc = check_pos loc offset state.acc ifcheck in
+ let context = push_context WHEN context in
+ check_fun state.scope wordlist {state with scope = WHEN; context; acc} false
+ | _ ->
+ let rec pop_until_ context =
+ match context with
+ | (key, _) :: context when (key <> SEARCH_AT_END) && (key <> WHEN) ->
+ pop_until_ context
+ | _ -> context
+ in
+ let context = pop_until_ context in
+ match context with
+ | (WHEN, _) :: context' ->
+ let acc = check_pos loc (offset_of_context context') state.acc ifcheck in
+ check_fun state.scope wordlist {state with scope = WHEN; context; acc} false
+ | (SEARCH_AT_END, _) :: context ->
+ let acc = check_pos loc (offset_of_context context) state.acc ifcheck in
+ let context = push_context WHEN context in
+ check_fun state.scope wordlist {state with scope = WHEN; context; acc} false
+ | _ ->
+ failwith @@ failure_msg loc
+
+
+and end_compilation_unit loc wordlist ({context; acc; _} as state) ifcheck =
+ let context = exp_scope_termination COMPILATION_UNIT context in
+ let context =
+ match context with
+ | (COMPILATION_UNIT, _) :: context -> context
+ | _ -> failwith @@ failure_msg loc
+ in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_ident_div wordlist {state with scope = IDENT_DIV; context; acc} false
+
+
+(*Remark: if the COPY does not copy a complete paragraph/statement/data entry...,
+ but a phrase/clause/identifier..., the check_copy_replace does not work *)
+and check_copy_replace (text:text) (state:indent_state) (ifcheck:bool) =
+ let context, acc = state.context, state.acc in
+ match text with
+ | [] -> state
+ | {payload; loc} :: wordlist ->
+ let pos = start_pos loc in
+ begin match payload with
+ | TextWord "COPY" ->
+ let offset_orig = pos.pos_cnum - pos.pos_bol in
+ (*no check*)
+ let offset = offset_orig + offset_of_keyword COPY in
+ let context = (COPY, offset) :: context in
+ check_copy_replace wordlist {state with context} false
+ | TextWord "REPLACE" ->
+ let offset_orig = pos.pos_cnum - pos.pos_bol in
+ (*no check*)
+ let offset = offset_orig + offset_of_keyword REPLACE in
+ let context = (REPLACE, offset) :: context in
+ check_copy_replace wordlist {state with context} false
+ | TextWord "REPLACING" ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let context = push_context REPLACING_COPY context in
+ check_copy_replace wordlist {state with context; acc} false
+ | TextWord "." ->
+ let rec help context =
+ match context with
+ | ((REPLACING_COPY|COPY|REPLACE), _) :: context ->
+ help context
+ | _ -> context
+ in
+ let context = help context in
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ let scope = (*ERROR-PRONE*)
+ if context = [] then failwith @@ failure_msg loc
+ else fst @@ List.hd context
+ in
+ check_fun scope wordlist
+ {state with scope; context; acc}
+ false
+ | _ ->
+ let acc = check_pos loc (offset_of_context context) acc ifcheck in
+ check_copy_replace wordlist {state with context; acc} false
+ end
+
+
+(***********************************)
+(* in order to indent incomplete souce code
+ the indenter must infer the scope where the code begins.
+
+ The inference is limited.
+ It works only if the code begins with
+ - division
+ - section
+ - paragraph (*line begins with "No_keyword ." will be infered as paragraph*)
+ - entry (*line begins with number will be infered as level-numbr*)
+ - statement
+ - COPY/REPLACE
+
+ The inference function does not handle any keyword but does the inference
+ and return the call of
+ - `check_ident_div`
+ - `check_end_div`
+ - `check_data_div`
+ - `check_proc_header_div`
+ - `check_proc_div`
+ - `check_statement`
+ - `check_copy_replace`
+
+ (**WARNING**)
+ we cannot return the call of `check_if_stmt`, `check_RD` or `check_data_desc`
+ Because the keyword "IF" is not handled inside `check_if_stmt` but handled by the previous layer.
+ the keyword "RD" is not handled inside `check_RD` but handled inside `check_data_div` ...
+
+ Due to the incomplete code, the indentation becomes error-prone, must consider all possible cases
+ when pop the context.
+*)
+and infer_scope (text:text) (state:indent_state) ifcheck =
+ let base_context loc =
+ let base_offset =
+ let pos = start_pos loc in
+ pos.pos_cnum - pos.pos_bol
+ in
+ [(BEGIN, base_offset)]
+ in
+ match text with
+ (*jump to COPY_REPLACE*)
+ | {payload = TextWord ("COPY"|"REPLACE"); loc} :: _ ->
+ let context = base_context loc in
+ check_copy_replace text {state with scope = COPY_REPLACE; context} ifcheck
+ (*jump to IDENTIFICATION DIVISION*)
+ | {payload = TextWord "IDENTIFICATION"; loc} :: {payload = TextWord "DIVISION"; _}
+ :: {payload = TextWord "."; _} ::_
+ | {payload = TextWord ("PROGRAM-ID"|"CLASS-ID"|"FACTORY"|"FUCNTION-ID"|"INTERFACE-ID"
+ |"METHOD-ID"|"OBJECT"|"OPTIONS"|"AUTHOR"|"DATE-WRITTEN"|"INSTALLATION"|"SECURITY"|"DATE-COMPILED"); loc}
+ :: {payload = TextWord "."; _} :: _ ->
+ let context = base_context loc in
+ check_ident_div text {state with scope = IDENT_DIV; context} ifcheck
+ (*jump to ENVIRONMENT DIVISION*)
+ | {payload = TextWord "NVIRONMENT"; loc} :: {payload = TextWord "DIVISION"; _}
+ :: {payload = TextWord "."; _} :: _
+ | {payload = TextWord ("INPUT-OUTPUT"|"CONFIGURATION"); loc } :: {payload = TextWord "SECTION"; _}
+ :: {payload = TextWord "."; _} :: _
+ | {payload = TextWord ("SOURCE-COMPUTER"|"OBJECT-COMPUTER"|"SPECIAL-NAMES"|"REPOSITORY"
+ |"FILE-CONTROL"|"I-O-CONTROL"); loc} :: {payload = TextWord "."; _} :: _
+ | {payload = TextWord "SELECT";loc} :: _ ->
+ let context = base_context loc in
+ check_env_div text {state with scope = ENV_DIV; context} ifcheck
+ (*jump to DATA DIVISION*)
+ | {payload = TextWord "DATA"; loc} :: {payload = TextWord "DIVISION"; _} :: _
+ | {payload = TextWord ("FILE"|"WORKING-STORAGE"|"LOCAL-STORAGE"|"LINKAGE"|"REPORT"|"SCREEN"); loc }
+ :: {payload = TextWord "SECTION"; _} :: {payload = TextWord "."; _} :: _
+ | {payload = TextWord ("FD"|"RD"|"SD"); loc } :: _ ->
+ let context = base_context loc in
+ check_data_div text {state with scope = DATA_DIV; context} ifcheck
+ | {payload = TextWord str; loc } :: {payload = TextWord str2;_} :: _
+ when ifcheck && is_data_decl str && str2 <> "." ->
+ let context = base_context loc in
+ check_data_div text {state with scope = DATA_DIV; context} ifcheck
+ (*jump to PROCEDURE DIVISION header*)
+ | {payload = TextWord "PROCEDURE"; loc} :: {payload = TextWord "DIVISION"; _} :: _ ->
+ let context = base_context loc in
+ check_proc_div_header text {state with scope = PROC_DIV_HEADER; context} ifcheck
+ (*jump to PROCEDURE DIVISION*)
+ | {payload = TextWord "DECLARATIVES" ; loc} :: _
+ | {payload = TextWord "END"; loc} :: _ ->
+ let context = base_context loc in
+ check_proc_div text {state with scope = PROC_DIV; context} ifcheck
+ | {payload = TextWord str; loc} :: {payload = TextWord "SECTION"; _}
+ :: {payload = TextWord "."; _} :: _
+ | {payload = TextWord str; loc} :: {payload = TextWord "."; _} :: _
+ when not @@ is_statement str ->
+ let context = base_context loc in
+ check_proc_div text {state with scope = PROC_DIV; context} ifcheck
+ | {payload = TextWord str; loc} :: _
+ when is_statement str ->
+ let context = base_context loc in
+ begin match proc_context_of_str str with
+ | Open_scope key ->
+ check_statement text {state with scope = key; context} ifcheck
+ | _ -> failwith @@ failure_msg loc
+ end
+ | [] -> state
+ | {payload = TextWord str; loc} :: _->
+ failwith ("error infer division: "^str^failure_msg loc )
+ | {loc;_ } :: _ -> failwith @@ "error infer division" ^ failure_msg loc
+
+
+and check_fun = function
+ | BEGIN -> infer_scope
+ | COPY_REPLACE -> check_copy_replace
+ | IDENT_DIV -> check_ident_div
+ | ENV_DIV -> check_env_div
+ | DATA_DIV | LEVEL _ -> check_data_div
+ | DATA_DESC -> check_data_desc
+ | FD -> check_FD
+ | RD -> check_RD
+ | SD -> check_SD
+ | PROC_DIV_HEADER -> check_proc_div_header
+ | PROC_DIV | SECTION | PARAGRAPH | DECLARATIVES ->
+ check_proc_div
+ | IF -> check_if_stmt
+ | RAISE -> check_raise_stmt
+ | GOBACK -> check_goback_stmt
+ | USE -> check_use_stmt
+ | ARGUMENT -> check_arguments ~fst_arg:true
+ | ADD -> check_add_stmt
+ | SUBTRACT -> check_subtract_stmt
+ | MULTIPLY -> check_multiply_stmt
+ | DIVIDE -> check_divide_stmt
+ | USING -> check_using
+ | STATEMENT | _ -> check_statement
+
+
+let check_indentation (text:text) (state:indent_state) =
+ match state.range with
+ | None ->
+ check_fun state.scope text state true
+ | Some {start_line; end_line} ->
+ let lnum =
+ match text with
+ | {loc; _} :: _ ->
+ (start_pos loc).pos_lnum
+ | _ -> 0
+ in
+ if (lnum >= start_line) && (lnum <= end_line) then
+ check_fun state.scope text state true
+ else
+ state
diff --git a/src/lsp/cobol_indent/indent_check.mli b/src/lsp/cobol_indent/indent_check.mli
new file mode 100644
index 000000000..e5f3b9508
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_check.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val check_indentation
+ :Cobol_preproc.Text.t
+ -> Indent_type.indent_state
+ -> Indent_type.indent_state
diff --git a/src/lsp/cobol_indent/indent_config.ml b/src/lsp/cobol_indent/indent_config.ml
new file mode 100644
index 000000000..2125523eb
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_config.ml
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Indent_type
+open Indent_keywords
+
+
+(*
+TODO:
+ Need to be rewritten,
+ like ocp-indent, we may let the client to decide if
+ it activates some features like alignment of argument
+*)
+
+(*we read the file user_def, and save it into the Hashtable offset_table*)
+let rec build_table strlist offset_table =
+ let help str1 =
+ let str2 = String.split_on_char ';' str1 in
+ let name = List.hd str2 in
+ let value = List.nth str2 1 in
+ name, Int32.to_int @@ Int32.of_string value
+ in
+ match strlist with
+ | "" :: _ -> ()
+ | str :: stl ->
+ let x,y = help str in
+ Hashtbl.add offset_table x y;
+ build_table stl offset_table
+ | _ -> ()
+
+let offset_table = Hashtbl.create 16
+(*default offset table*)
+let () =
+ List.iter
+ (fun (a, b) -> Hashtbl.add offset_table a b)
+ [ "DEFAULT", 4; (* DEFAULT offset *) (*Do not remove this one*)
+ "DISPLAY", 8;
+ "USING", 6;
+ "REPLACING_COPY", 10;
+ "INTO", 5;
+ "REPLACE", 8;
+ "SELECT", 7;
+ "PARAGRAPH", 4;
+ (*if need to indent the nested-program, set "PROC_DIV" to no zero*)
+ "PROC_DIV", 1;
+ (*if need to show more information about the different hierarchy of code,
+ these offsets can be set *)
+ "IDENT_DIV", 0;
+ "ENV_DIV", 0;
+ "DATA_DIV", 0;
+ "DECLARATIVES", 0;
+ "SECTION", 0 ]
+
+let set_config ~indent_config =
+ let str = Ez_file.V1.EzFile.read_file indent_config in
+ let strlist = String.split_on_char '\n' str in
+ build_table strlist offset_table
+
+let offset_of_keyword keyword =
+ match keyword with
+ (*WARNING: these tokens must have offset 0*)
+ | COMPILATION_UNIT
+ | DATA_DESC
+ | THEN | ELSE
+ | DUMMY_EXCEPTION
+ | ARGUMENT -> 0
+ | _ ->
+ let str = string_of_keyword keyword in
+ match Hashtbl.find_opt offset_table str with
+ | Some x -> x
+ | None ->
+ try Hashtbl.find offset_table "DEFAULT" with Not_found -> 0
diff --git a/src/lsp/cobol_indent/indent_config.mli b/src/lsp/cobol_indent/indent_config.mli
new file mode 100644
index 000000000..d5661f506
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_config.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(*set the indentation configuration*)
+val set_config : indent_config:string -> unit
+
+val offset_of_keyword: Indent_type.context_kind -> int
diff --git a/src/lsp/cobol_indent/indent_keywords.ml b/src/lsp/cobol_indent/indent_keywords.ml
new file mode 100644
index 000000000..366841b04
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_keywords.ml
@@ -0,0 +1,179 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Indent_type
+
+(*data division *)
+let data_context_of_str : string -> data_context = function
+ | "." -> PERIOD
+ | "COPY" -> Compiler_directive COPY
+ | "REPLACE" -> Compiler_directive REPLACE
+ | "FD" -> Entry FD
+ | "RD" -> Entry RD
+ | "SD" -> Entry SD
+ | s when (s >= "1" && s <= "9")
+ || (s >= "01" && s <= "99") ->
+ let level = Int32.to_int @@ Int32.of_string s in
+ Entry (LEVEL level)
+ | _ -> No_keyword
+
+
+(*procedure division*)
+
+(*keyword of statement*)
+let keyword_stmt =
+ [ (*standard 1989*)
+ "ACCEPT"; "ADD"; "ALLOCATE"; "CALL"; "CANCEL"; "CLOSE"; "COMPUTE"; "CONTINUE";
+ "DELETE"; "DISPLAY"; "DIVIDE"; "EVALUATE"; "EXIT"; "FREE";
+ "GENERATE"; "GO"; "GOBACK"; "IF"; "INITIALIZE"; "INITIATE"; "INSPECT"; "INVOKE";
+ "MERGE"; "MOVE"; "MULTIPLY"; "OPEN"; "PERFORM";
+ "RAISE"; "READ"; "RELEASE"; "RESUME"; "RETURN"; "REWRITE";
+ "SEARCH"; "SET"; "SORT"; "STOP"; "START"; "STRING"; "SUBTRACT"; "SUPPRESS";
+ "TERMINATE"; "UNLOCK"; "UNSTRING"; "USE"; "VALIDATE"; "WRITE";
+ (*standard 1985*)
+ "ALTER"; "DISABLE"; "ENABLE"; "PURGE"; "RECEIVE"; "SEND";]
+let keyword_stmt_tbl = Hashtbl.create 16
+let () =
+ List.iter (fun x ->
+ Hashtbl.add keyword_stmt_tbl x ())
+ keyword_stmt
+let is_statement = Hashtbl.mem keyword_stmt_tbl
+
+
+let str_proc_keyword_tbl = Hashtbl.create 16
+let keyword_str_tbl = Hashtbl.create 16
+
+let () =
+ (*add statement with end-xxx*)
+ List.iter
+ (fun (a, b) ->
+ Open_scope b |> Hashtbl.add str_proc_keyword_tbl a;
+ Close_scope b |> Hashtbl.add str_proc_keyword_tbl ("END-"^a);
+ Hashtbl.add keyword_str_tbl b a)
+ [ ("ACCEPT", ACCEPT); ("ADD", ADD); ("CALL", CALL); ("COMPUTE", COMPUTE);
+ ("DELETE", DELETE); ("DISPLAY", DISPLAY); ("DIVIDE", DIVIDE);
+ ("EVALUATE", EVALUATE); ("IF", IF); ("MULTIPLY", MULTIPLY);
+ ("READ", READ); ("RETURN", RETURN); ("REWRITE", REWRITE);
+ ("SEARCH", SEARCH); ("START", START); ("STRING", STRING);
+ ("SUBTRACT", SUBTRACT); ("UNSTRING", UNSTRING); ("WRITE", WRITE)];
+
+ List.iter
+ (fun (a, b) ->
+ Open_scope b |> Hashtbl.add str_proc_keyword_tbl a;
+ Hashtbl.add keyword_str_tbl b a)
+ [ (*without END-XXX *)
+ ("ALLOCATE", ALLOCATE); ("CANCEL", CANCEL); ("CLOSE", CLOSE); ("CONTINUE", CONTINUE);
+ ("EXIT", EXIT); ("FREE", FREE); ("GENERATE", GENERATE); ("GO", GO);
+ ("GOBACK", GOBACK); ("INITIALIZE", INITIALIZE); ("INITIATE", INITIATE);
+ ("INSPECT", INSPECT); ("INVOKE", INVOKE); ("MERGE", MERGE); ("MOVE", MOVE);
+ ("OPEN", OPEN); ("RAISE", RAISE); ("RELEASE", RELEASE); ("RESUME", RESUME);
+ ("SET", SET); ("SORT", SORT); ("STOP", STOP); ("SUPPRESS", SUPPRESS);
+ ("TERMINATE", TERMINATE); ("UNLOCK", UNLOCK); ("USE", USE); ("VALIDATE", VALIDATE);
+ (*standard 1985*)
+ ("ALTER", ALTER); ("DISABLE", DISABLE); ("ENABLE", ENABLE);
+ ("PURGE", PURGE); ("RECEIVE", RECEIVE); ("SEND", SEND);];
+
+ (*add other keyword (phrase/clause inside statement)*)
+ List.iter
+ (fun (a, b) ->
+ Hashtbl.add str_proc_keyword_tbl a (Phrase b);
+ Hashtbl.add keyword_str_tbl b a)
+ [ ("AFTER", AFTER); ("AT", AT); ("BEFORE", BEFORE); ("BY", BY);
+ ("CONVERTING", CONVERTING); ("ELSE", ELSE); ("FROM", FROM);
+ ("GIVING", GIVING); ("INTO", INTO); ("REPLACING", REPLACING);
+ ("SEQUENCE", SEQUENCE); ("TALLYING", TALLYING); ("THEN", THEN);
+ ("TO", TO); ("UNTIL", UNTIL); ("USING", USING); ("VARYING", VARYING);
+ ("WHEN", WHEN); ("RAISING", RAISING) ];
+
+ (*add inline_phrase*)
+ List.iter
+ (fun a -> Hashtbl.add str_proc_keyword_tbl a Inline_phrase)
+ [ "INITIALIZED"; "RETURNING"; "REMAINDER";
+ "INPUT"; "OUTPUT"; "WITH"; "ADVANCING";
+ "IGNORING"; "DEFAULT"; "SHARING"; "LOCK"; "POINTER"];
+
+ (*For now, Other_keyword is only for avoiding bugs in check_argument *)
+ List.iter
+ (fun a -> Hashtbl.add str_proc_keyword_tbl a Other_keyword)
+ [ "ON"; "SIZE"; "ERROR"; "NOT"; "EXCEPTION"; "OVERFLOW";
+ "END"; "EXCEPTION"; "INVALID"; "KEY"; "PAGE"; "EOP"];
+ (*special case*)
+ List.iter (fun (a, b) -> Hashtbl.add str_proc_keyword_tbl a b)
+ [ ( ".", PERIOD);
+ ("COPY", Compiler_directive COPY);
+ ("REPLACE", Compiler_directive REPLACE);
+ (*special case*)
+ ("PERFORM", Open_scope PERFORM_CLOSED);
+ ("END-PERFORM", Close_scope PERFORM)]
+
+(*add other keywords into keyword_str_tbl*)
+let () =
+ List.iter
+ (fun (a, b) -> Hashtbl.add keyword_str_tbl a b)
+ [ (COPY, "COPY"); (REPLACING_COPY, "REPLACING_COPY"); (REPLACE, "REPLACE");
+ (IDENT_DIV, "IDENT_DIV"); (ENV_DIV, "ENV_DIV"); (SELECT, "SELECT");
+ (DATA_DIV, "DATA_DIV"); (DATA_DESC, "DATA_DESC");
+ (FD, "FD"); (SD, "SD"); (RD, "RD"); (DATA_DIV_CLAUSE, "DATA_DIV_CLAUSE");
+ (PROC_DIV, "PROC_DIV"); (SECTION, "SECTION"); (PARAGRAPH, "PARAGRAPH");
+ (DECLARATIVES, "DECLARATIVES"); (COMPILATION_UNIT, "COMPILATION_UNIT");
+
+ (ON_SIZE_ERROR, "ON_SIZE_ERROR"); (NOT_ON_SIZE_ERROR, "NOT_ON_SIZE_ERROR");
+ (ON_EXCEPTION, "ON_EXCEPTION"); (NOT_ON_EXCEPTION, "NOT_ON_EXCEPTION");
+ (INVALID_KEY, "INVALID_KEY"); (NOT_INVALID_KEY, "NOT_INVALID_KEY");
+ (AT_END_OF_PAGE, "AT_END_OF_PAGE"); (NOT_AT_END_OF_PAGE, "NOT_AT_END_OF_PAGE");
+ (ON_OVERFLOW, "ON_OVERFLOW"); (NOT_ON_OVERFLOW, "NOT_ON_OVERFLOW");
+ (AT_END, "AT_END"); (NOT_AT_END, "NOT_AT_END");
+ (PERFORM, "PERFORM"); (PERFORM_CLOSED, "PERFORM");
+ (DUMMY_EXCEPTION, "DUMMY_EXCEPTION")]
+
+
+let proc_context_of_str str =
+ match Hashtbl.find_opt str_proc_keyword_tbl str with
+ | Some x -> x
+ | _ -> No_keyword
+
+let string_of_keyword keyword =
+ match Hashtbl.find_opt keyword_str_tbl keyword with
+ | Some x -> x
+ | _ -> "DEFAULT"
+
+
+(*not implicitly terminable*)
+let keyword_not_imp_terminable = Hashtbl.create 16
+let () =
+ List.iter (fun a -> Hashtbl.add keyword_not_imp_terminable a ())
+ [
+ IF; WHEN; PERFORM; THEN; ELSE;
+ ON_SIZE_ERROR; NOT_ON_SIZE_ERROR; HELPTOKEN;
+ ON_EXCEPTION; NOT_ON_EXCEPTION;
+ ON_OVERFLOW; NOT_ON_OVERFLOW;
+ AT_END; NOT_AT_END; SEARCH_AT_END;
+ AT_END_OF_PAGE; NOT_AT_END_OF_PAGE;
+ INVALID_KEY; NOT_INVALID_KEY;
+
+ IDENT_DIV; ENV_DIV; DATA_DIV; PROC_DIV;
+ DECLARATIVES; PARAGRAPH; SECTION;
+ BEGIN; COMPILATION_UNIT;
+ ]
+let is_not_imp_terminable = Hashtbl.mem keyword_not_imp_terminable
+
+
+let keyword_phrase = Hashtbl.create 16
+let () =
+ List.iter (fun a -> Hashtbl.add keyword_phrase a ())
+ [
+ USING; REPLACING; TALLYING; SEQUENCE; TO;
+ GIVING; AT; INTO; VARYING; AFTER; UNTIL;
+ FROM; BY; ARGUMENT
+ ]
+let is_phrase = Hashtbl.mem keyword_phrase
diff --git a/src/lsp/cobol_indent/indent_keywords.mli b/src/lsp/cobol_indent/indent_keywords.mli
new file mode 100644
index 000000000..17bdfb8fd
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_keywords.mli
@@ -0,0 +1,27 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val string_of_keyword: Indent_type.context_kind -> string
+
+val data_context_of_str: string -> Indent_type.data_context
+
+val proc_context_of_str: string -> Indent_type.proc_context
+
+(* To check whether the string is a keyword of statement *)
+val is_statement: string -> bool
+
+(* To check whether the keyword is implicitly terminable *)
+val is_not_imp_terminable: Indent_type.context_kind -> bool
+
+(* To check whether the keyword is a keyword of phrase *)
+val is_phrase: Indent_type.context_kind -> bool
diff --git a/src/lsp/cobol_indent/indent_type.ml b/src/lsp/cobol_indent/indent_type.ml
new file mode 100644
index 000000000..897c42eb3
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_type.ml
@@ -0,0 +1,169 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(*TODO: this type mix the keyword(ex. MOVE) and context(ex. COMPILATION_UNIT)*)
+type context_kind =
+ | BEGIN (*the default scope*)
+ | COMPILATION_UNIT (*compilation_unit*)
+ (* | PROGRAM| FUNCTION| CLASS| INTERFACE| FACTORY| OBJECT| METHOD *)
+ | COPY_REPLACE
+ | COPY
+ | REPLACING_COPY
+ | REPLACE
+ | IDENT_DIV
+ | ENV_DIV
+ | SELECT (*in FILE-CONTROL*)
+
+ | DATA_DIV
+ | DATA_DESC
+ (*TODO: DATA_DIV_CLAUSE is the token for all clause inside data division.
+ define different tokens for different clauses this if need be*)
+ | DATA_DIV_CLAUSE
+ | FD | RD | SD
+ | LEVEL of int
+ (*procedure division*)
+ | PROC_DIV
+ | PROC_DIV_HEADER
+ | DECLARATIVES
+ | STATEMENT
+ | SECTION
+ | PARAGRAPH
+ (******token of keyword in ProcDiv******)
+ | ACCEPT | ADD | ALLOCATE | CALL | CANCEL | CLOSE | COMPUTE | CONTINUE
+ | DELETE | DISPLAY | DIVIDE | EVALUATE | EXIT | FREE
+ | GENERATE | GO | GOBACK | IF | INITIALIZE | INITIATE | INSPECT | INVOKE
+ | MERGE | MOVE | MULTIPLY | OPEN
+ | RAISE | READ | RELEASE | RESUME | RETURN | REWRITE
+ | SEARCH | SET | SORT | START | STOP | STRING | SUBTRACT | SUPPRESS
+ | TERMINATE | UNLOCK | UNSTRING | USE | VALIDATE | WRITE
+ (*specil case:
+ PERFORM_CLOSED can be implicitly terminated,
+ but PERFORM not.
+ ex.
+ "PERFORM PARA1" is PERFORM_CLOSED, it does not have the END-PERFORM;
+ "PERFORM 3 Times {nested-statement}" is PERFORM, it must be ended with END-PERFORM
+ (*TODO: according to standard ISO_IEC_1989_2014, it could be terminated by "."
+ but by test of gnucobol, it must be ended with a END-PERFORM...
+ We suppose that the "." can terminate a PERFORM statement.*)
+ *)
+ | PERFORM | PERFORM_CLOSED
+ (*Phrase/clause inside statement*)
+ | ON_SIZE_ERROR | NOT_ON_SIZE_ERROR
+ | AT_END | NOT_AT_END | SEARCH_AT_END
+ | ON_EXCEPTION | NOT_ON_EXCEPTION
+ | INVALID_KEY | NOT_INVALID_KEY
+ | AT_END_OF_PAGE | NOT_AT_END_OF_PAGE
+ | ON_OVERFLOW | NOT_ON_OVERFLOW
+ | HELPTOKEN
+ (*
+ We only implement these phrases/clauses (which influence the indentation)
+ Other phrases/clauses are considered as inline
+ *)
+ | AFTER (*INSPECT/PERFORM/WRITE*)
+ | AT (*DISPLAY/ACCEPT*)
+ | BEFORE (*INSPECT/PRFORM/WRITE*)
+ | BY (*CALL/INVOKE/DIVIDE/INITIALIZE/INSPECT/MULTIPLY/PERFORM/SET/proc-div-header*)
+ | CONVERTING (*INSPECT*)
+ | ELSE (*IF*)
+ | FROM (*ACCEPT/PERFORM/RELEASE/REWRITE/SUBTRACT/WRITE*)
+ | GIVING (*ADD/SUBTRACT/MULTIPLY/DIVIDE/MERGE/SORT*)
+ | INTO (*DIVIDE/READ/RETURN/STRING/UNSTRING*)
+ | RAISING (*EXIT/GOBACK/proc-div-header*)
+ | REPLACING (*INITIALIZE/INSPECT*)
+ | SEQUENCE (*MERGE/SORT*) (*COLLATING SEQUENCE*)
+ | TALLYING (*INSPECT/UNSTRING*)
+ | THEN (*IF*)
+ | TO (*ADD/INITIALIZE/INSPECT/MOVE/SET*)
+ | UNTIL (*PERFORM*)
+ | USING (*CALL/MERGE/INVOKE/SORT/proc-div-header*)
+ | VARYING (*SEARCH/PERFORM*)
+ | WHEN (*EVALUATE/SEARCH*)
+
+ | DUMMY_EXCEPTION (*a help token to solve a bug*)
+ (*Not a keyword, used for alignment of argument*)
+ | ARGUMENT
+
+ (*Statement of standard 1985.
+ To avoid possible keyword conflict,
+ the phrases inside these statements are not implemented *)
+ | ALTER | DISABLE | ENABLE | PURGE | RECEIVE | SEND
+
+(* data_context is used in the data division*)
+type data_context =
+ | PERIOD
+ | Compiler_directive of context_kind
+ | Entry of context_kind
+ | No_keyword
+
+(* proc_context is used in the procedure division*)
+(* When checking indentation of Procedur Division,
+ All "combination of keywords" will be checked first by the pattern matching
+ of string,
+ i.e. sth like "ELSE IF", "ON SIZE ERROR" ...
+ Then, we transform the string to token of proc_context (1 string -> 1 token)
+*)
+type proc_context =
+ | PERIOD
+ | Compiler_directive of context_kind
+ | Open_scope of context_kind
+ | Close_scope of context_kind
+ | Phrase of context_kind
+ (* We define Inline_phrase in order to terminate the phrase before it.*)
+ | Inline_phrase
+ (* Other word which has no influence on the indentation is mapped to
+ No_keyword or Other_keyword. *)
+ | No_keyword
+ | Other_keyword
+
+(*to record the indentation error
+
+ lnum: the line number of the indentation error
+ offset_orig: original offset
+ offset_modif: correct offset
+
+ex.
+ _______________________
+ |Para1.
+ | move 3 to 4.
+ |
+
+ it comes an indenteur_record
+ {lnum = 2 (line num of "move" in the whole file i.e. pos_lnum) ;
+ offset_orig = 1;
+ offset_modif = 4 (set in user_define, offset of paragraph) }
+*)
+type indent_record =
+ { lnum:int;
+ offset_orig:int;
+ offset_modif: int}
+
+type range = {start_line:int;
+ end_line :int }
+
+type context = (context_kind * int) list
+
+type indent_state =
+ {
+ scope: context_kind; (*indicate where the current code is*)
+ context: context; (*the stack of (context_kind, offset)*)
+ acc: indent_record list;
+ range : range option;
+
+ (*TODO:
+ - Use a new type for `scope`
+ - it may be strange to save range into the accumulator
+ since range is decided at the begin and does not change any more.
+ However, due to the limitation of the API "fold_text_lines",
+ I find no good method to do it.
+ *)
+ }
diff --git a/src/lsp/cobol_indent/indent_util.ml b/src/lsp/cobol_indent/indent_util.ml
new file mode 100644
index 000000000..45530e552
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_util.ml
@@ -0,0 +1,150 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc
+
+open Indent_type
+open Indent_keywords
+
+let check_pos (pos:Lexing.position) (offset:int) (ind_recds:indent_record list) ~print_errors=
+ let real_offset = pos.pos_cnum - pos.pos_bol in
+ if real_offset <> offset then
+ begin
+ if print_errors then
+ begin
+ let newsrcloc = raw (pos,pos) in
+ Fmt.pr "%a" Cobol_common.Srcloc.pp_srcloc newsrcloc;
+ Fmt.pr "Indentation error : the offset is %d, but expected offset is %d\n\n" real_offset offset
+ end;
+ {lnum = pos.pos_lnum;
+ offset_orig = real_offset;
+ offset_modif = offset }
+ :: ind_recds
+ end
+ else
+ ind_recds
+
+(* print_errors for debug *)
+let check_pos = check_pos ~print_errors:false
+
+let check_pos srcloc offset ind_recds ifcheck =
+ if ifcheck
+ then
+ let pos = start_pos srcloc in
+ check_pos pos offset ind_recds
+ else ind_recds
+
+let failure_msg loc =
+ let pos = start_pos loc in
+ let lnum, cnum = pos.pos_lnum, pos.pos_cnum - pos.pos_bol in
+ "line: "^ (string_of_int lnum) ^" character: "^ (string_of_int cnum)
+
+let offset_of_keyword = Indent_config.offset_of_keyword
+
+let offset_of_context context =
+ match context with
+ | [] -> failwith "empty context"
+ | _ -> snd @@ List.hd context
+
+let push_context key context =
+ (key, offset_of_keyword key + offset_of_context context) :: context
+
+
+(*for DATA DECLARATION*)
+let is_data_decl (str:string) =
+ match Int32.of_string_opt str with
+ | None -> false
+ | _ -> true
+
+let rec reduce_level i context =
+ match context with
+ | (LEVEL j, _) :: context
+ when j >= i ->
+ reduce_level i context
+ | _ ->
+ context
+
+(*used for "." *)
+let rec handle_period context =
+ match context with
+ | []
+ | ((BEGIN | COMPILATION_UNIT
+ | IDENT_DIV | ENV_DIV| DATA_DIV | PROC_DIV
+ | DECLARATIVES | LEVEL _| PARAGRAPH | SECTION), _) :: _ ->
+ context
+ | _ :: context ->
+ handle_period context
+
+(* explicit scope termination*)
+(* for END DECLARATIVES./END-XXX/ELSE/END PROGRAM/...*)
+(* when using this function, [keyword] is always in [context] *)
+let rec exp_scope_termination (keyword:context_kind) context =
+ match context with
+ | (x, _) :: context when x <> keyword ->
+ exp_scope_termination keyword context
+ | _ ->
+ context
+
+(* similar to exp_scope_termination, but we allow that [keyword] is not in [context]*)
+(* must be careful to use [pop_until] and [exp_scope_termination].
+ since we may indent a range of code, we cannot hope that the previous layer of
+ [keyword] is already inside [context]:
+ ex. maybe we indent a range of code which is a paragraph of procedure division,
+ then the `SECTION` `PROC_DIV` is not in the initial context
+ (but if we indent the whole file, `PROC_DIV` are always before `PARAGRAPH`) *)
+let rec pop_until (keyword:context_kind) context =
+ match context with
+ | (( BEGIN | COMPILATION_UNIT | IDENT_DIV | DATA_DIV
+ | ENV_DIV | PROC_DIV | DECLARATIVES), _) :: _ ->
+ context
+ | (x, _) :: context when x <> keyword ->
+ pop_until keyword context
+ | _ ->
+ context
+
+(*pop the scope until the scope of division*)
+let rec pop_until_division context =
+ match context with
+ | [] | ( (BEGIN|COMPILATION_UNIT|IDENT_DIV|DATA_DIV|ENV_DIV|PROC_DIV), _) :: _ -> context
+ | _ :: context ->
+ pop_until_division context
+
+
+(*pop the scope until the scope of compilation_unit*)
+let rec pop_until_compilation_unit context =
+ match context with
+ | [] | ( (BEGIN|COMPILATION_UNIT), _) :: _ -> context
+ | _ :: context -> pop_until_compilation_unit context
+
+
+(*implicit scope termination*)
+let rec imp_scope_termination context =
+ match context with
+ | (keyword, _) :: context
+ when not @@ is_not_imp_terminable keyword ->
+ imp_scope_termination context
+ | _ -> context
+
+(*terminate phrase inside statement*)
+let rec phrase_termination context =
+ match context with
+ | (key, _) :: context when is_phrase key ->
+ phrase_termination context
+ | _ -> context
+
+let rec phrase_termination_until keyword context =
+ match context with
+ | (key, _) :: context
+ when is_phrase key && key <> keyword ->
+ phrase_termination_until keyword context
+ | _ -> context
diff --git a/src/lsp/cobol_indent/indent_util.mli b/src/lsp/cobol_indent/indent_util.mli
new file mode 100644
index 000000000..b61e59c22
--- /dev/null
+++ b/src/lsp/cobol_indent/indent_util.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Indent_type
+
+val check_pos: Cobol_common.Srcloc.srcloc -> int -> indent_record list -> bool -> indent_record list
+
+val failure_msg: Cobol_common.Srcloc.srcloc -> string
+
+val offset_of_keyword: context_kind -> int
+
+val offset_of_context: context -> int
+
+val push_context: context_kind -> context -> context
+
+val is_data_decl: string -> bool
+
+val reduce_level: int -> context -> context
+
+val handle_period: context -> context
+
+val exp_scope_termination: context_kind -> context -> context
+
+val pop_until: context_kind -> context -> context
+
+val pop_until_division: context -> context
+
+val pop_until_compilation_unit: context -> context
+
+val imp_scope_termination: context -> context
+
+val phrase_termination: context -> context
+
+val phrase_termination_until: context_kind -> context -> context
diff --git a/src/lsp/cobol_indent/indenter.ml b/src/lsp/cobol_indent/indenter.ml
new file mode 100644
index 000000000..8669ba597
--- /dev/null
+++ b/src/lsp/cobol_indent/indenter.ml
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Indent_type
+
+(*
+ source_format: source format
+ str: the string representation of the source Cobol code
+ rdl: the indentation error information of the source code
+ range: range of file to indent
+ result: the Cobol code correctly indented (string)
+*)
+let indenter ~source_format (str:string) (rdl:indent_record list) range =
+ let do_one_record (strl:string list) (rd:indent_record) =
+ let lnum = rd.lnum in
+ let offset = rd.offset_modif - rd.offset_orig in
+ let str = List.nth strl (lnum - 1) in
+ let newstr =
+ match source_format with
+ | Cobol_config.SF SFFree ->
+ if offset > 0 then
+ let space = String.make offset ' ' in
+ space^str
+ else
+ String.sub str (-offset) (String.length str + offset)
+ (*TODO: must change if Auto <> SF SFFixed once*)
+ | SF SFFixed | Auto ->
+ let len = String.length str in
+ let str1 = String.sub str 0 7 in
+ let str = String.sub str 7 (len-7) in
+ let str =
+ if offset > 0 then
+ let space = String.make offset ' ' in
+ space^str
+ else
+ String.sub str (-offset) (String.length str + offset)
+ in
+ str1^str
+ (*TODO*)
+ | _ -> str
+ in
+ List.mapi (fun i str -> if i = lnum - 1 then newstr else str) (strl)
+ in
+ let strl = String.split_on_char '\n' str in
+ let strl = List.fold_left (fun acc rd -> do_one_record acc rd) strl rdl in
+ let strl =
+ match range with
+ | None -> strl
+ | Some {start_line; end_line} ->
+ EzList.drop (start_line - 1) @@ EzList.take end_line strl
+ in
+ String.concat "\n" strl
+
+(*indent a range of file, with the default indent_config*)
+let indent_range' ~source_format ~range ~file =
+ let file_content = Ez_file.V1.EzFile.read_file file in
+ let check_indent = Indent_check.check_indentation in
+ let state = {
+ scope = BEGIN;
+ context = [];
+ acc = [];
+ range;
+ }
+ in
+ (*
+ Not satisfied with the `Cobol_preproc.fold_text_lines`,
+ this function has an argument which is the name of file,
+ so when using lsp, every time using the formatting,
+ we must save the file before, it is not convenient.
+ *)
+ let state =
+ Cobol_preproc.fold_text_lines ~on_period_only:false ~source_format check_indent file state
+ in
+ let ind_recds = state.acc in
+ indenter ~source_format file_content ind_recds state.range
+
+(*indent a range of file, with the user-defined indent_config*)
+let indent_range' ~source_format ~indent_config ~range ~file =
+ match indent_config with
+ | Some indent_config ->
+ Indent_config.set_config ~indent_config;
+ indent_range' ~source_format ~range ~file
+ | None ->
+ indent_range' ~source_format ~range ~file
diff --git a/src/lsp/cobol_indent/indenter.mli b/src/lsp/cobol_indent/indenter.mli
new file mode 100644
index 000000000..38d3993d7
--- /dev/null
+++ b/src/lsp/cobol_indent/indenter.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(*indent a range of file, with the user-defined or default indent_config*)
+val indent_range'
+ : source_format:Cobol_config.source_format_spec
+ -> indent_config:string option
+ -> range:Indent_type.range option
+ -> file:string
+ -> string
diff --git a/src/lsp/cobol_indent/index.mld b/src/lsp/cobol_indent/index.mld
new file mode 100644
index 000000000..1ad2895bc
--- /dev/null
+++ b/src/lsp/cobol_indent/index.mld
@@ -0,0 +1,9 @@
+{1 Library cobol_indent}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+
+
+The entry point of this library is the module: {!Cobol_indent}.
+
diff --git a/src/lsp/cobol_indent/package.toml b/src/lsp/cobol_indent/package.toml
new file mode 100644
index 000000000..ff44cbb50
--- /dev/null
+++ b/src/lsp/cobol_indent/package.toml
@@ -0,0 +1,76 @@
+
+# name of package
+name = "cobol_indent"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+# generators = [ "ocamllex", "menhir" ]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+# preprocess = "pps ppx_deriving_encoding"
+
+# files to skip while updating at package level
+skip = ["index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+cobol_common = "version"
+cobol_preproc = "version"
+fmt = ">=0.9"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+# ...
diff --git a/src/lsp/cobol_indent/user_def b/src/lsp/cobol_indent/user_def
new file mode 100644
index 000000000..d5188968b
--- /dev/null
+++ b/src/lsp/cobol_indent/user_def
@@ -0,0 +1 @@
+DEFAULT;4
\ No newline at end of file
diff --git a/src/vscode-debugadapter/version.mlt b/src/lsp/cobol_indent/version.mlt
similarity index 100%
rename from src/vscode-debugadapter/version.mlt
rename to src/lsp/cobol_indent/version.mlt
diff --git a/src/lsp/cobol_lsp/README.md b/src/lsp/cobol_lsp/README.md
new file mode 100644
index 000000000..d2566f836
--- /dev/null
+++ b/src/lsp/cobol_lsp/README.md
@@ -0,0 +1,5 @@
+# Cobol_lsp package
+
+This package contains all the logic for an LSP server for COBOL.
+
+For API documentation, please see [index.mld].
diff --git a/src/lsp/cobol_lsp/TODO.md b/src/lsp/cobol_lsp/TODO.md
new file mode 100644
index 000000000..cac27abc0
--- /dev/null
+++ b/src/lsp/cobol_lsp/TODO.md
@@ -0,0 +1,3 @@
+TODO:
+* Module `Cobol_lsp.Location`
+* `Qualname` visitor
diff --git a/src/lsp/cobol_lsp/cobol_lsp.ml b/src/lsp/cobol_lsp/cobol_lsp.ml
new file mode 100644
index 000000000..6cb56e92b
--- /dev/null
+++ b/src/lsp/cobol_lsp/cobol_lsp.ml
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+include Lsp_server_loop
+
+(* --- *)
+
+(** {1 Modules and functions exported for testing purposes}
+
+ Signatures of modules below may change unexpectedly. *)
+
+module INTERNAL = struct
+ module Types = struct
+ include Lsp_imports
+ include Lsp_diagnostics.TYPES
+ include Lsp_lookup.TYPES
+ include Lsp_document.TYPES
+ include Lsp_project.TYPES
+ include Lsp_project_cache.TYPES
+ include Lsp_server.TYPES
+ end
+ module Diagnostics = Lsp_diagnostics
+ module Lookup = Lsp_lookup
+ module Project = Lsp_project
+ module Project_cache = Lsp_project_cache
+ module Document = Lsp_document
+ module Server = Lsp_server
+ module Loop = Lsp_server_loop
+ module Request = Lsp_request.INTERNAL
+ module Utils = Lsp_utils
+end
diff --git a/src/lsp/cobol_lsp/dune b/src/lsp/cobol_lsp/dune
new file mode 100644
index 000000000..97e0418cf
--- /dev/null
+++ b/src/lsp/cobol_lsp/dune
@@ -0,0 +1,26 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_lsp)
+ (public_name cobol_lsp)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries toml pretty lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common )
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show))
+
+ )
+
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_lsp))
+
+; use field 'dune-trailer' to add more stuff here
+
diff --git a/src/lsp/cobol_lsp/index.mld b/src/lsp/cobol_lsp/index.mld
new file mode 100644
index 000000000..6d0c5ce02
--- /dev/null
+++ b/src/lsp/cobol_lsp/index.mld
@@ -0,0 +1,9 @@
+{1 Library cobol_lsp}
+
+Superbol is a set of utilities for COBOL developers,
+that can be selected by sub-commands.
+
+This package is an LSP server for COBOL.
+
+The entry point of this library is the module: {!Cobol_lsp}.
+
diff --git a/src/lsp/cobol_lsp/lsp_completion.ml b/src/lsp/cobol_lsp/lsp_completion.ml
new file mode 100644
index 000000000..29794d137
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_completion.ml
@@ -0,0 +1,103 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common
+open Cobol_common.Basics
+(* open Cobol_common.Srcloc.TYPES *)
+open Cobol_common.Srcloc.INFIX
+
+open Lsp_completion_keywords
+open Lsp.Types
+
+let name_proposals ast ~filename pos =
+ let visitor = object
+ inherit [StringSet.t] Cobol_parser.PTree_visitor.folder
+
+ method! fold_compilation_unit' cu =
+ if Lsp_position.is_in_srcloc ~filename pos ~@cu
+ then Visitor.do_children
+ else Visitor.skip_children
+
+ method! fold_name name acc =
+ Visitor.skip_children @@ StringSet.add name acc
+
+ end
+ in
+ Cobol_parser.PTree_visitor.fold_compilation_group visitor ast StringSet.empty
+ |> StringSet.elements
+
+(*If need be, get the qualname_proposals "X OF Y"... from the definition maps*)
+
+
+(*TODO: If the partial parsing could give more information
+ like in which statement the position is(or even better, in which clause/phrase),
+ Then we can remove the keywords that cannot appear in this statement from
+ the keyword list.
+*)
+(* type div =
+| Ident_div
+| Env_div
+| Data_div
+| Proc_div
+
+let keyword_proposals ast pos =
+ let visitor = object
+ inherit [div option] Cobol_parser.PTree_visitor.folder
+
+ method! fold_data_division' {loc; _} _ =
+ Visitor.skip_children @@
+ if Lsp_position.is_in_srcloc pos loc
+ then Some Data_div
+ else None
+
+ method! fold_procedure_division' {loc; _} _ =
+ Visitor.skip_children @@
+ if Lsp_position.is_in_srcloc pos loc
+ then Some Proc_div
+ else None
+
+ end
+ in
+ match Cobol_parser.PTree_visitor.fold_compilation_group visitor ast None with
+ | Some Proc_div -> keywords_proc
+ | Some Data_div -> keywords_data (*does not work*)
+ | _ -> [] *)
+
+let keyword_proposals _ast _pos = keywords_all
+
+let completion_items text (pos:Position.t) ast =
+ let filename = Lsp.Uri.to_path (Lsp.Text_document.documentUri text) in
+ let range =
+ let line = pos.line in
+ let character = pos.character in
+ let texts = String.split_on_char '\n' @@ Lsp.Text_document.text text in
+ let text_line = List.nth texts line in
+ let index = 1 + String.rindex_from text_line (character - 1) ' ' in
+ let position_start = Position.create ~character:index ~line in
+ Range.create ~start:position_start ~end_:pos
+ in
+
+ let names = name_proposals ast ~filename pos in
+ let keywords = keyword_proposals ast pos in
+ let words = names @ keywords in
+
+ List.map (fun x ->
+ let textedit = TextEdit.create ~newText:x ~range in
+ (*we may change the ~sortText/preselect for reason of priority *)
+ CompletionItem.create
+ ~label:x
+ ~sortText:x
+ ~preselect:false
+ ~textEdit:(`TextEdit textedit)
+ ())
+ words
diff --git a/src/lsp/cobol_lsp/lsp_completion_keywords.ml b/src/lsp/cobol_lsp/lsp_completion_keywords.ml
new file mode 100644
index 000000000..93744e549
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_completion_keywords.ml
@@ -0,0 +1,329 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(* open Cobol_common.Basics *)
+
+let keywords_all = fst @@ List.split Cobol_parser.Text_keywords.keywords
+
+
+(* TODO: Too many keywords, hard to classification *)
+
+(* let keywords_proc =
+ let keywords = [
+ "ACCEPT"; "ADD";
+ "CALL"; "COMPUTE";
+ "DELETE"; "DISPLAY"; "DIVIDE";
+ "EVALUATE";
+ "IF";
+ "MULTIPLY";
+ "PERFORM";
+ "READ"; "RETURN"; "REWRITE";
+ "SEARCH"; "START"; "STRING"; "SUBTRACT";
+ "UNSTRING";
+ "WRITE";
+ ] in
+ (List.map (fun x -> "END-"^x) keywords) @ keywords
+
+ @ [
+ "ALLOCATE";
+ "CANCEL"; "CLOSE"; "CONTINUE";
+ "EXIT";
+ "FREE";
+ "GO"; "GOBACK"; "GENERATE";
+ "INITIALIZE"; "INITIATE"; "INSPECT"; "INVOKE";
+ "MERGE"; "MOVE";
+ "OPEN";
+ "RAISE"; "RELEASE"; "RESUME";
+ "SET"; "SORT"; "STOP"; "SUPPRESS";
+ "TERMINATE";
+ "UNLOCK"; "USE";
+ "VALIDATE";
+
+ "ON SIZE ERROR"; "NOT ON SIZE ERROR";
+ "ON EXCEPTION"; "NOT ON EXCEPTION";
+ "AT END"; "NOT AT END";
+ "INVALID KEY"; "NOT INVALID KEY";
+ "AT END OF PAGE"; "NOT AT END OF PAGE";
+ "AT EOP"; "NOT AT EOP";
+ "ON OVERFLOW"; "NOT ON OVERFLOW";
+ "SIZE"; "ERROR"; "INVALIDE"; "KEY"; "EXCEPTION"; "EOP"; "END"; "PAGE"; "OVERFLOW";
+
+ "SECTION"; "FUNCTION"; "DIRECTIVE";
+
+ "WHEN"; "ELSE";
+
+ "WITH"; "IN"; "INTO"; "FROM"; "TO"; "NOT"; "ON"; "BY"; "AT"; "OF";
+ "AND"; "ALSO"; "OR"; "IS"; "EQUAL";
+
+ ]
+
+(*TODO: (If need)
+ If the partial parsing could give more information
+ like in which statement the position is(or even better, in which clause/phrase),
+ Then we can remove the keywords that cannot appear in this statement from
+ the keyword list.
+*)
+
+(* let keywords_accept = [
+ "ACCEPT"; "FROM"; "LINE NUMBER"; "COL NUMBER"; "COLUMN NUMBER";
+ "DATE"; "DAY"; "DAY-OF-WEEK"; "TIME"; "YYYYMMDD"; "YYYYDDD";
+ "AT"; "ON EXCEPTION"; "NOT ON EXCEPTION"; "EXCEPTION"
+ ] *)
+
+let keywords_proc_other = [
+
+ (*ACCEPT*)
+ "DATE"; "DAY"; "DAY-OF-WEEK"; "TIME"; "YYYYMMDD"; "YYYYDDD";
+ "LINE"; "NUMBER"; "COL"; "COLUMN"; "CHARACTERS";
+ "LINE NUMBER"; "COL NUMBER"; "COLUMN NUMBER";
+
+ (*ALLOCATE*)
+ "INITIALIZED"; "RETURNING"; "CHARACTERS";
+
+ (*CALL*)
+ "USING BY REFERENCE"; "USING BY CONTENT";
+ (* "RETURNING";(*remove duplicate word*) *)
+ "BY REFERENCE"; "BY CONTENT"; "REFERENCE"; "CONTENT"; "USING";
+
+ (*CLOSE*)
+ "REEL"; "UNIT";
+ "FOR"; "FOR REMOVAL"; "REMOVAL";
+ "WITH NO REWIND";
+ "WITH LOCK";
+
+ (*DELETE*)
+ "RECORD";
+
+ (*DISPLAY*)
+ "UPON";
+ (* "LINE"; "NUMBER"; "COL"; "COLUMN"; "CHARACTERS";
+ "LINE NUMBER"; "COL NUMBER"; "COLUMN NUMBER"; *)
+ "WITH NO ADVANCING"; "ADVANCING";
+
+ (*DIVIDE*)
+ (* "INTO"; "BY" *)
+ "GIVING";
+
+ (*EVALUATE*)
+ "ALSO"; "OTHER";
+ "TRUE"; "FALSE"; "ANY";
+ "THROUGH"; "THRU";
+
+ (*EXIT*)
+ "PROGRAM"; "METHOD"; "PARAGRAPH"; "CYCLE";
+ "LAST EXCEPTION"; "RAISING";
+
+ (*GO*)
+ "DEPENDING ON"; "DEPENDING";
+
+ (*GOBACK*)
+ (* "RASING"; "EXCEPTION";
+ "LAST EXCEPTION"; *)
+
+ (*IF*)
+ "NEXT SENTENCE"; "NEXT"; "SENTENCE"; "THEN";
+
+ (*INITIALIZE*)
+ "WITH FILLER"; "ALL"; "VALUE";
+ "THEN REPLACING"; "DATA"; "THEN TO DEFAULT";
+ "ALPHABETIC"; "ALPHANUMERIC"; "ALPHANUMERIC-EDITED";
+ "BOOLEAN"; "DATA-POINTER"; "FUNCTION-POINTER";
+ "NATIONAL"; "NATIONAL-EDITED"; "NUMERIC";
+ "NUMERIC-EDITED"; "OBJECT-REFERENCE"; "PROGRAM-POINTER";
+
+ (*INSPECT*)
+ "TALLYING"; "REPLACING"; "CONVERTING";
+ "LEADING"; "BEFORE"; "AFTER"; "INITIAL"; "BEFORE INITIAL"; "AFTER INITIAL";
+ "OMITTED"; "CHARACTERS"; "FIRST";
+
+ (*INVOKE*)
+ "USING BY REFERENCE";
+ "USING BY CONTENT";
+ "USING BY VALUE";
+
+ (*MERGE*)
+ "ON ASCENDING KEY"; "ASCENDING KEY"; "ASCENDING"; "KEY";
+ "ON DESCENDING KEY"; "DESCENDING KEY"; "DESCENDING";
+ "COLLATING SEQUENCE";
+ "OUTPUT PROCEDURE";
+ "PROCEDURE";
+
+ (*MOVE*)
+ "CORR"; "CORRESPONDING";
+
+ (*OPEN*)
+ "INPUT"; "OUTPUT"; "I-O"; "EXTEND";
+ "SHARING WITH";
+ "ALL OTHER";
+ "NO OTHER";
+ "READ ONLY";
+
+ (*PERFORM*)
+ "WITH TEST"; "UNTIL"; "VARYING";
+
+ (*READ*)
+ "PREVIOUS"; "PREVIOUS RECORD";
+ "ADVANCING ON LOCK";
+ (*sharing-phrase*)
+ "IGNORING LOCK";
+ "WITH NO LOCK";
+
+ (*RESUME*)
+ "NEXT STATEMENT"; "STATEMENT";
+
+ (*SET*)
+ "UP BY"; "DOWN BY"; "OFF"; "ATTRIBUTE";
+ "ADDRESS"; "ADDRESS OF";
+ "BELL"; "BLINK"; "HIGHLIGHT"; "LOWLIGHT"; "REVERSE-VIDEO"; "UNDERLINE";
+ "LOCALE"; "LC_ALL"; "LC_COLLATE"; "LC_CTYPE"; "LC_MESSAGES"; "LC_MONETARY";
+ "LC_NUMERIC";"LC_TIME"; "USER-DEFAULT"; "SYSTEM-DEFAULT";
+ "CONTENT OF"; "FARTHEST-FROM-ZERO"; "IN-ARITHMETIC-RANGE";
+ "FLOAT-INFINITY"; "FLOAT-NOT-A-NUMBER";
+ "FLOAT-NOT-A-NUMBER-SIGNALING"; "NEAREST-TO-ZERO";
+ "IN-ARITHMETIC-RANGE"; "NEGATIVE"; "POSITIVE"; "SIGN";
+
+ (*SORT*)
+ "WITH DUPLICATES IN ORDER";
+ "INPUT PROCEDURE IS";
+ "OUTPUT PROCEDURE IS";
+
+ (*START*)
+ "WITH LENGTH";
+ "FIRST";
+ "LAST";
+
+ (*STOP*)
+ "WITH ERROR STATUS";
+ "WITH NORMAL STATUS";
+ "STOP RUN";
+
+ (*STRING*)
+ "DELIMITED BY";
+
+ (*SUPPRESS*)
+ "SUPPRESS PRINTING";
+
+ (*UNLOCK*)
+ "RECORDS";
+
+ (*UNSTRING*)
+ "DELIMITER IN"; "COUNT IN";
+ "TALLYING IN";
+
+ (*USE*)
+ "GLOBAL";
+ "AFTER STANDARD";
+ "BEFORE REPORTING";
+ "EC"; "EXCEPTION CONDITION";
+ "EO"; "EXCEPTION OBJECT";
+ "AFTER STANDARD";
+
+ (*WRITE*)
+ "BEFORE ADVANCING";
+ "AFTER ADVANCING";
+ "ADVANCING";
+ "LINES";
+ "FILE";
+]
+
+
+let keywords_data = [
+ "DATA"; "DIVISION"; "SECTION";
+ "WORKING-STORAGE SECTION"; "FILE SECTION"; "REPORT SECTION"; "LOCAL-STORAGE SECTION";
+ "LINKAGE SECTION"; "SCREEN SECTION"; "SD";
+
+ "FD"; "IS"; "EXTERNAL"; "GLOBAL"; "AS"; "FORMAT"; "BIT"; "CHARACTER"; "NUMERIC";
+ "BLOCK"; "CONTAINS"; "TO"; "CHARACTERS"; "RECORDS"; "CODE-SET"; "FOR"; "ALPHANUMERIC";
+ "NATIONAL"; "REPORT"; "REPORTS"; "ARE";
+
+ "CONSTANT";
+
+ "BYTE-LENGTH"; "LENGTH"; "FROM";
+
+ "RD"; "CODE"; "CONTROL"; "CONTROLS"; "FINAL"; "PAGE"; "LIMIT"; "LIMITS";
+ "LINE"; "LINES"; "COLS"; "COLUMNS"; "HEADING"; "FIRST"; "DE"; "DETAIL";
+ "LAST"; "CH"; "CONTROL HEADING"; "FOOTING";
+
+ "USAGE"; "DISPLAY"; "NATIONAL"; "BLANK"; "WHEN"; "PRESENT"; "GROUP"; "OCCURS";
+ "DEPENDING ON"; "DEPENDING"; "ON"; "STEP";
+
+ "REDEFINES"; "TYPEDEF"; "STRONG"; "ALIGNED"; "ANY LENGTH"; "ANY"; "LENGTH"; "BASED";
+ "BLANK WHEN ZERO"; "BLANK"; "ZERO"; "RECORD"; "DYNAMIC";
+ "GROUP-USAGE"; "GROUP-USAGE IS BIT"; "GROUP-USAGE IS NATIONAL";
+ "JUST"; "JUSTIFIED"; "RIGHT"; "JUST RIGHT"; "JUSTIFIED RIGHT";
+ "PROPERTY"; "WITH"; "NO"; "SET"; "GET"; "FINAL";
+ "SAME AS"; "SIGN"; "LEADING"; "TRAILING"; "SEPARATE"; "SEPARATE CHARACTER";
+ "SYNCHRONIZED"; "SYNC"; "LEFT"; "RIGHT";
+ "TYPE"; "DESTINATION";
+ "INVALID WHEN"; "INVALID";
+ "PRESENT WHEN"; "PRESENT";
+ "VARYING"; "FROM"; "BY";
+ "RENAMES"; "THROUGH"; "THRU";
+
+ "PLUS"; "MINUS"; "BLANK SCREEN"; "FULL"; "AUTO"; "SECURE"; "REQUIRED"; "TIMES";
+ "USAGE IS DISPLAY"; "USAGE IS NATIONAL";
+ "BLANK LINE"; "BLANK SCREEN";
+ "ERASE"; "END OF LINE"; "END OF SCREEN"; "EOL"; "EOS";
+ "BELL"; "HIGHLIGHT"; "LOWLIGHT"; "RESERVED-VIDEO"; "UNDERLINE";
+ "FOREGROUND-COLOR"; "BACKGROUND-COLOR";
+ "USING"; "VALUE";
+
+ "CLASS"; "ALPHABETIC"; "ALPHABETIC-LOWER"; "ALPHABETIC-UPPER"; "BOOLEAN";
+
+ "CODE";
+
+ "LEFT"; "CENTER"; "RIGHT";
+
+ "DEFAULT"; "NONE";
+
+ "FILLER";
+
+ "FORMAT BIT DATA"; "FORMAT CHARACTER DATA"; "FORMAT NUMERIC DATA";
+
+ "INDICATE";
+
+ "LINAGE"; "WITH FOOTING AT"; "LINES AT TOP"; "TOP";
+ "LINES AT BOTTOM"; "BOTTOM";
+
+ "ON NEXT PAGE";
+
+ "ASCENDING"; "ASCENDING KEY IS"; "DESCENDING"; "DESCENDING KEY IS";
+ "INDEXED"; "INDEXED BY"; "STEP";
+
+ "CAPACITY"; "INITIALIZED";
+
+ "PIC"; "PICTURE"; "LOCALE"; "SIZE"; "A"; "N"; "X"; "Z"; "1"; "*"; "9"; "+"; "-";
+ "CR"; "DB"; "E"; "S"; "V"; "."; "P";
+
+ "OTHER";
+
+ "SOURCE"; "SUM"; "UPON"; "RESET";
+
+ "ON"; "FOR"; "REPORT HEADING"; "RH"; "PAGE HEADING"; "PH"; "CONTROL HEADING"; "CH";
+ "CONTROL FOOTING"; "CF"; "PAGE FOOTING"; "PF"; "REPORT FOOTING"; "RF";
+
+ "BINARY"; "BINARY-CHAR"; "BINARY-SHORT"; "BINARY-LONG"; "BINARY-DOUBLE";
+ "COMPUTATIONAL"; "COMP"; "FLOAT-BINARY-32"; "FLOAT-BINARY-64";
+ "FLOAT-BINARY-128"; "FLOAT-DECIMAL-16"; "FLOAT-DECIMAL-34"; "FLOAT-EXTENDED";
+ "FLOAT-LONG"; "FLOAT-SHORT"; "INDEX"; "OBJECT REFERENCE"; "FACTORY";
+ "ACTIVE-CLASS"; "ONLY"; "PACKED-DECIMAL"; "POINTER"; "FUNCTION-POINTER";
+ "PROGRAM-POINTER"; "BINARY-ENCODING"; "DECIMAL-ENCODING";
+ "HIGH-ORDER-LEFT"; "HIGH-ORDER-RIGHT";
+ "VALIDATE-STATUS"; "VAL-STATUS"; "ERROR"; "CONTENT"; "RELATION";
+ "VALUES"
+ ];;
+
+let keywords_data = StringSet.elements @@ StringSet.of_list keywords_data
+let keywords_proc = StringSet.elements @@ StringSet.of_list (keywords_proc @ keywords_proc_other)
+ *)
+
diff --git a/src/lsp/cobol_lsp/lsp_diagnostics.ml b/src/lsp/cobol_lsp/lsp_diagnostics.ml
new file mode 100644
index 000000000..525d20317
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_diagnostics.ml
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+open Ez_file.V1
+open EzFile.OP
+
+module DIAG = Cobol_common.Diagnostics
+
+module TYPES = struct
+ type diagnostics = Lsp.Types.Diagnostic.t list URIMap.t
+end
+include TYPES
+type t = diagnostics
+
+let pseudo_normalized_uri ~rootdir filename =
+ let filename =
+ let prefix = EzFile.current_dir_name // "" in
+ if EzFile.is_absolute filename
+ then filename
+ else rootdir // match EzString.chop_prefix ~prefix filename with
+ | None -> filename
+ | Some x -> x
+ in
+ Lsp.Uri.of_path filename
+
+let translate_one ~rootdir ~uri (diag: DIAG.t) =
+ let uri, project_srcloc = match uri with
+ | `Force uri ->
+ uri, Cobol_common.Srcloc.lexloc_in ~filename:(Lsp.Uri.to_path uri)
+ | `Main uri ->
+ uri, Cobol_common.Srcloc.as_lexloc (* rely on default projection *)
+ in
+ let uri, range =
+ match Option.map project_srcloc (DIAG.location diag) with
+ | Some (Lexing.{ pos_fname = f; _ }, _ as lexloc) ->
+ pseudo_normalized_uri ~rootdir f, Lsp_position.range_of_lexloc lexloc
+ | None ->
+ uri, Lsp_position.none_range
+ in
+ let diag =
+ Lsp.Types.Diagnostic.create ()
+ ~range
+ ~severity:(match DIAG.severity diag with
+ | Hint -> Lsp.Types.DiagnosticSeverity.Hint
+ | Note | Info -> Information
+ | Warn -> Warning
+ | Error -> Error)
+ ~message:Pretty.(to_string "%t@[%a@]" blast_margin DIAG.pp_msg diag)
+ in
+ URIMap.singleton uri [diag]
+
+let translate ~rootdir ~uri diagnostics =
+ let init = match uri with `Force uri | `Main uri -> URIMap.singleton uri [] in
+ DIAG.Set.fold begin fun diagnostic ->
+ translate_one ~rootdir ~uri diagnostic |>
+ URIMap.union (fun _uri a b -> Some (List.rev_append a b))
+ end diagnostics init
+
+let publish diagnostics : unit =
+ URIMap.iter (fun uri diags -> Lsp_io.send_diagnostics ~uri diags) diagnostics
+
+(* --- *)
+
+let as_notification ?(log = false) diag =
+ let type_ = match DIAG.severity diag with
+ | Hint | Note -> Lsp.Types.MessageType.Log
+ | Info -> Info
+ | Warn -> Warning
+ | Error -> Error
+ in
+ let message =
+ Pretty.(to_string "%t@[%a@]" blast_margin DIAG.pp_msg diag) in
+ if log then
+ let params = Lsp.Types.LogMessageParams.create ~message ~type_ in
+ Lsp.Server_notification.LogMessage params
+ else
+ let params = Lsp.Types.ShowMessageParams.create ~message ~type_ in
+ Lsp.Server_notification.ShowMessage params
diff --git a/src/lsp/cobol_lsp/lsp_diagnostics.mli b/src/lsp/cobol_lsp/lsp_diagnostics.mli
new file mode 100644
index 000000000..3981352cc
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_diagnostics.mli
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+
+module DIAG = Cobol_common.Diagnostics
+
+module TYPES: sig
+ type diagnostics = Lsp.Types.Diagnostic.t list URIMap.t
+end
+include module type of TYPES
+ with type diagnostics = TYPES.diagnostics
+type t = diagnostics
+
+val translate_one
+ : rootdir:string
+ -> uri:[< `Force of Lsp.Uri.t | `Main of Lsp.Uri.t ]
+ -> Cobol_common.Diagnostics.t -> diagnostics
+
+val translate
+ : rootdir:string
+ -> uri:[< `Force of Lsp.Uri.t | `Main of Lsp.Uri.t ]
+ -> Cobol_common.Diagnostics.Set.t -> diagnostics
+
+val publish
+ : diagnostics
+ -> unit
+
+val as_notification
+ : ?log:bool -> Cobol_common.Diagnostics.t -> Lsp.Server_notification.t
diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml
new file mode 100644
index 000000000..c849b38a4
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_document.ml
@@ -0,0 +1,219 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+open Lsp_lookup.TYPES
+open Lsp_project.TYPES
+open Ez_file.V1
+
+module DIAGS = Cobol_common.Diagnostics
+
+module TYPES = struct
+
+ type document =
+ {
+ project: Lsp_project.t;
+ textdoc: Lsp.Text_document.t;
+ copybook: bool;
+ pplog: Cobol_preproc.rev_log;
+ tokens: Cobol_parser.tokens_with_locs Lazy.t;
+ parsed: parsed_data option;
+ (* Used for caching, when loading a cache file as the file is not reparsed,
+ then diagnostics are not sent. *)
+ diags: DIAGS.Set.t;
+ }
+ and parsed_data =
+ {
+ ast: PTREE.compilation_group;
+ cus: CUs.t;
+ (* Extracted info: lazy to only ever retrieve what's relevant upon a first
+ request. *)
+ definitions: name_definitions_in_compilation_unit CUMap.t Lazy.t;
+ references: name_references_in_compilation_unit CUMap.t Lazy.t;
+ }
+
+ (** Raised by {!retrieve_parsed_data}. *)
+ exception Unparseable of Lsp.Types.DocumentUri.t
+ exception Copybook of Lsp.Types.DocumentUri.t
+
+ type cached = (** Persistent representation (for caching) *)
+ {
+ doc_cache_filename: string; (* relative to project rootdir *)
+ doc_cache_checksum: Digest.t; (* checked against file on disk on reload *)
+ doc_cache_langid: string;
+ doc_cache_version: int;
+ doc_cache_pplog: Cobol_preproc.rev_log;
+ doc_cache_tokens: Cobol_parser.tokens_with_locs;
+ doc_cache_parsed: (PTREE.compilation_group * CUs.t) option;
+ doc_cache_diags: DIAGS.Set.serializable;
+ }
+
+end
+include TYPES
+
+type t = document
+let uri { textdoc; _ } = Lsp.Text_document.documentUri textdoc
+
+let parse ~project text =
+ let uri = Lsp.Text_document.documentUri text in
+ let libpath = Lsp_project.libpath_for ~uri project in
+ Cobol_parser.parse_with_tokens
+ (* Recovery policy for the parser: *)
+ ~recovery:(EnableRecovery { silence_benign_recoveries = true })
+ ~source_format:project.source_format
+ ~config:project.cobol_config
+ ~libpath
+ (String { contents = Lsp.Text_document.text text;
+ filename = Lsp.Uri.to_path uri })
+
+let lazy_definitions ast cus =
+ lazy begin cus |>
+ CUs.assoc Lsp_lookup.definitions |>
+ (*this piece for handling renames is temporary*)
+ Lsp_lookup.add_rename_item_definitions ast |>
+ Lsp_lookup.add_paragraph_definitions ast |>
+ Lsp_lookup.add_redefine_definitions ast
+ end
+
+let lazy_references ast cus defs =
+ lazy begin
+ let defs = Lazy.force defs in
+ try
+ List.fold_left
+ (fun map cu ->
+ let cu_name = Lsp_lookup.name_of_compunit cu in
+ let _, cu_defs = CUMap.find_by_name cu_name defs in
+ CUMap.add
+ (CUs.find_by_name cu_name cus)
+ (Lsp_lookup.references cu_defs cu) map )
+ CUMap.empty ast
+ with Not_found -> CUMap.empty
+ end
+
+let analyze ({ project; textdoc; copybook; _ } as doc) =
+ let pplog, tokens, (parsed, diags) =
+ if copybook then
+ [], lazy [], (None, DIAGS.Set.none)
+ else
+ let ptree = parse ~project textdoc in
+ Cobol_parser.preproc_rev_log ptree,
+ Cobol_parser.parsed_tokens ptree,
+ match Cobol_typeck.analyze_compilation_group ptree with
+ | Ok (cus, ast, diags) ->
+ let definitions = lazy_definitions ast cus in
+ let references = lazy_references ast cus definitions in
+ Some { ast; cus; definitions; references}, diags
+ | Error diags ->
+ None, diags (* NB: no token if unrecoverable error (e.g, wrong
+ indicator) *)
+ in
+ { doc with pplog; tokens; diags; parsed }
+
+(** Creates a record for a document that is not yet parsed or analyzed. *)
+let blank ~project ?copybook textdoc =
+ let copybook = match copybook with
+ | Some p -> p
+ | None -> Lsp_project.detect_copybook project
+ ~uri:(Lsp.Text_document.documentUri textdoc)
+ in
+ {
+ project;
+ textdoc;
+ pplog = [];
+ tokens = lazy [];
+ diags = DIAGS.Set.none;
+ parsed = None;
+ copybook;
+ }
+
+let position_encoding = `UTF8
+
+let load ~project ?copybook doc =
+ Lsp.Text_document.make ~position_encoding doc
+ |> blank ~project ?copybook
+ |> analyze
+
+let update { project; textdoc; _ } changes =
+ (* TODO: Make it not reparse everything when a change occurs. *)
+ Lsp.Text_document.apply_content_changes textdoc changes
+ |> blank ~project
+ |> analyze
+
+(** Raises {!Unparseable} in case the document cannot be parsed entierely. *)
+let retrieve_parsed_data: document -> parsed_data = function
+ | { parsed = Some p; _ } -> p
+ | { copybook = false; _ } as doc -> raise @@ Unparseable (uri doc)
+ | { copybook = true; _ } as doc -> raise @@ Copybook (uri doc)
+
+(** Caching utilities *)
+
+let to_cache ({ project; textdoc; pplog; tokens; parsed; diags; _ } as doc) =
+ {
+ doc_cache_filename = Lsp_project.relative_path_for ~uri:(uri doc) project;
+ doc_cache_checksum = Digest.string (Lsp.Text_document.text textdoc);
+ doc_cache_langid = Lsp.Text_document.languageId textdoc;
+ doc_cache_version = Lsp.Text_document.version textdoc;
+ doc_cache_pplog = pplog;
+ doc_cache_tokens = Lazy.force tokens;
+ doc_cache_parsed = Option.map (fun { ast; cus; _ } -> ast, cus) parsed;
+ doc_cache_diags = DIAGS.Set.apply_delayed_formatting diags;
+ }
+
+(* NB: Note this checks against the actual file on disk, which may be different
+ from what a client sends upon opening. *)
+(** Raises {!Failure} in case of bad checksum. *)
+let of_cache ~project
+ { doc_cache_filename = filename;
+ doc_cache_checksum = checksum;
+ doc_cache_langid = languageId;
+ doc_cache_version = version;
+ doc_cache_pplog = pplog;
+ doc_cache_tokens = tokens;
+ doc_cache_parsed = parsed;
+ doc_cache_diags = diags } =
+ let absolute_filename = Lsp_project.absolute_path_for ~filename project in
+ if checksum <> Digest.file absolute_filename then
+ failwith "Bad checksum"
+ else
+ let uri = Lsp.Uri.of_path absolute_filename
+ and text = EzFile.read_file absolute_filename in
+ let doc = Lsp.Types.DidOpenTextDocumentParams.create
+ ~textDocument:(Lsp.Types.TextDocumentItem.create
+ ~languageId ~text ~uri ~version) in
+ let doc = Lsp.Text_document.make ~position_encoding doc |> blank ~project in
+ let parsed =
+ Option.map
+ (fun (ast, cus) ->
+ let definitions = lazy_definitions ast cus in
+ let references = lazy_references ast cus definitions in
+ { ast; cus; definitions; references})
+ parsed
+ in
+ let diags = DIAGS.Set.of_serializable diags in
+ { doc with pplog; tokens = lazy tokens; parsed; diags }
+
+(* --- *)
+
+(** {2 Miscellaneous} *)
+
+let () =
+ Printexc.register_printer begin function
+ | Unparseable uri ->
+ Some (Pretty.to_string "Unable to parse document at %s" @@
+ Lsp.Types.DocumentUri.to_string uri)
+ | Copybook uri ->
+ Some (Pretty.to_string "Not parsing copybook at %s" @@
+ Lsp.Types.DocumentUri.to_string uri)
+ | _ ->
+ None
+ end
diff --git a/src/lsp/cobol_lsp/lsp_imports.ml b/src/lsp/cobol_lsp/lsp_imports.ml
new file mode 100644
index 000000000..bcc36d032
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_imports.ml
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Definitions of module aliases and helper functors *)
+
+module AST = struct
+ include Cobol_ast (* include general/abstract type definitions, *)
+ include Cobol_data.Pictured_ast (* and then restricted/refined types. *)
+end
+
+module PTREE = Cobol_parser.PTree
+module CUs = Cobol_data.Compilation_unit.SET
+module CUMap = Cobol_data.Compilation_unit.MAP
+module URIMap = Map.Make (Lsp.Uri)
diff --git a/src/lsp/cobol_lsp/lsp_io.ml b/src/lsp/cobol_lsp/lsp_io.ml
new file mode 100644
index 000000000..6c13999bb
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_io.ml
@@ -0,0 +1,123 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Simple communication functions for the LSP server to send an receive json
+ RPC messages. *)
+
+(** [send_out msg] returns {!type:unit} and is used to send out a message. This
+ function can be edited later to use other channels than stdin or stdout as
+ IO. *)
+let send_out msg = print_string msg
+
+(** [read_message ()] tries to read a json RPC message from the standard input
+ stream. Returns [Ok packet] upon success, or [Error error_response] if the
+ message is in the wrong format. *)
+let read_message () : (Jsonrpc.Packet.t, Jsonrpc.Response.Error.t) result =
+ let rec read_headers acc =
+ let line = read_line () in
+ match String.trim line with
+ | "" -> Ok acc (* an empty line after the headers *)
+ | line ->
+ try
+ let i = String.index line ':' in
+ if String.get line (i + 1) <> ' ' then raise Not_found;
+ let header_key = String.lowercase_ascii @@ String.sub line 0 i in
+ let header_value =
+ String.lowercase_ascii @@ String.trim @@
+ String.sub line (i + 1) (String.length line - i - 1)
+ in
+ read_headers @@ (header_key, header_value)::acc
+ with _ -> Error (Fmt.str "invalid header: %s" line)
+ in
+ let rec read_len buf i len =
+ if len > 0 then
+ let n = input stdin buf i len in
+ read_len buf (i + n) (len - n)
+ in
+ let headers = read_headers [] in
+ match headers with
+ | Ok headers ->
+ begin match List.assoc_opt "content-type" headers, List.assoc_opt "content-length" headers with
+ | (Some ("utf8" | "utf-8") | None), Some len_str ->
+ let content_length = int_of_string_opt len_str in
+ begin match content_length with
+ | Some len ->
+ let buf = Bytes.make len '\000' in
+ let () = read_len buf 0 len in
+ let str = Bytes.to_string buf in
+ begin try
+ let json = Yojson.Safe.from_string str in
+ Ok (Jsonrpc.Packet.t_of_yojson json)
+ with Yojson.Json_error msg ->
+ let message = Fmt.str "invalid json: %s:\n%s" msg str in
+ Error (Jsonrpc.Response.Error.(make ~code:Code.ParseError ~message ()))
+ end
+ | None ->
+ let message = Fmt.str "not an integer value: %s" len_str in
+ Error (Jsonrpc.Response.Error.(make ~code:Code.ParseError ~message ()))
+ end
+ | Some _, _ ->
+ Error
+ (Jsonrpc.Response.Error.(
+ make ~code:Code.InvalidRequest ~message:"content-type must be 'utf-8'" ()))
+ | _, None ->
+ Error
+ (Jsonrpc.Response.Error.(
+ make ~code:Code.ParseError ~message:"missing content-length header" ()))
+ end
+ | Error message ->
+ Error
+ (Jsonrpc.Response.Error.(make ~code:Code.ParseError ~message ()))
+
+(** [send_json json] sends out a json rpc package. *)
+let send_json json =
+ let str = Yojson.Safe.to_string json in
+ let len = String.length str in
+ let msg = Fmt.str "Content-Length: %d\r\n\r\n%s" len str in
+ send_out msg
+
+(** [send_response response] sends out a json RPC response on standard
+ output. *)
+let send_response response =
+ let json = Jsonrpc.Response.yojson_of_t response in
+ send_json json
+
+(** [send_notification notif] sends out a json RPC notification on standard
+ output. *)
+let send_notification notif =
+ let json = Jsonrpc.Notification.yojson_of_t notif in
+ send_json json
+
+(** [send_diagnostics ~uri diagnostics] sends out a list of diagnostics that
+ pertain to the given URI. *)
+let send_diagnostics ~uri diagnostics =
+ let params = Lsp.Types.PublishDiagnosticsParams.create ~diagnostics ~uri () in
+ let notif = Lsp.Server_notification.PublishDiagnostics params in
+ send_notification (Lsp.Server_notification.to_jsonrpc notif)
+
+(** [pretty_notification ~log ~type_ fmt ...] formats any number of arguments
+ according to the format string [fmt], and sends the result via a json RPC
+ notification for log or direct display (depending on the flag [log], false
+ by default). Also prints the result on stderr (for now). *)
+let pretty_notification ?(log = false) ~type_ fmt =
+ Pretty.string_to begin fun message ->
+ Pretty.error "Notif: %s@." message;
+ let notif =
+ if log
+ then Lsp.(Server_notification.LogMessage
+ (Types.LogMessageParams.create ~message ~type_))
+ else Lsp.(Server_notification.ShowMessage
+ (Types.ShowMessageParams.create ~message ~type_))
+ in
+ send_notification (Lsp.Server_notification.to_jsonrpc notif)
+ end ("%t@["^^fmt^^"@]") Pretty.blast_margin
diff --git a/src/lsp/cobol_lsp/lsp_io.mli b/src/lsp/cobol_lsp/lsp_io.mli
new file mode 100644
index 000000000..d21a2d414
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_io.mli
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** Simple communication functions for the LSP server to send an receive json
+ RPC messages. *)
+
+(** [read_message ()] tries to read a json RPC message from the standard input
+ stream. *)
+val read_message: unit -> (Jsonrpc.Packet.t, Jsonrpc.Response.Error.t) result
+
+(** [send_response response] sends out a json RPC response on standard
+ output. *)
+val send_response: Jsonrpc.Response.t -> unit
+
+(** [send_notification notif] sends out a json RPC notification on standard
+ output. *)
+val send_notification: Jsonrpc.Notification.t -> unit
+
+(** [send_diagnostics ~uri diagnostics] sends out a list of diagnostics that
+ pertain to the given URI. *)
+val send_diagnostics: uri:Lsp.Uri.t -> Lsp.Types.Diagnostic.t list -> unit
+
+(** [pretty_notification ~log ~type_ fmt ...] formats any number of arguments
+ according to the format string [fmt], and sends the result via a json RPC
+ notification. Also prints the result on stderr (for now). *)
+val pretty_notification
+ : ?log:bool
+ -> type_:Lsp.Types.MessageType.t
+ -> ('a, Format.formatter, unit) format -> 'a
diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml
new file mode 100644
index 000000000..cb363d148
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_lookup.ml
@@ -0,0 +1,523 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common (* Srcloc, Visitor *)
+open Cobol_common.Srcloc.INFIX
+open Cobol_data.Types
+open Lsp_imports
+
+module TYPES = struct
+
+ (** Type definitions to help representing and querying (partially) parsed
+ COBOL programs. *)
+
+ open Cobol_common.Srcloc (* with_loc & pp_with_loc *)
+
+ (** Information returned by {!names_at_position}. *)
+ type names_at_position =
+ {
+ qualname_at_position: AST.qualname option;
+ enclosing_compilation_unit_name: string option;
+ }
+
+ type name_definition =
+ {
+ as_paragraph: paragraph_definition option; (* link to AST's paragraph *)
+ as_item: item_definition option;
+ } [@@deriving show]
+ and paragraph_definition =
+ AST.paragraph with_loc [@@deriving show]
+ and item_definition =
+ {
+ item_definition: AST.any_item_descr with_loc;
+ item_redefinitions: AST.name with_loc list;
+ } [@@deriving show]
+
+ type name_definitions_in_compilation_unit =
+ name_definition Cobol_data.Qualmap.t [@@deriving show]
+
+ type name_references_in_compilation_unit =
+ Srcloc.srcloc list Cobol_data.Qualmap.t [@@deriving show]
+
+ type copy_operation = string with_loc (** with loc of {[COPY ...]} *)
+
+end
+open TYPES
+
+(* --- *)
+
+let bare name : AST.qualname = AST.Name name
+let qual name : AST.qualname option -> AST.qualname = function
+ | None -> AST.Name name
+ | Some qn -> AST.Qual (name, qn)
+let simple_name : AST.qualname -> string = function
+ | Qual (n, _) | Name n -> ~&n
+let baseloc_of_qualname: AST.qualname -> srcloc = function
+ | Name name
+ | Qual (name, _) -> ~@name
+
+(* TODO: manipulate positions that are combined with a filename instead of
+ passing `filename` around all the time. *)
+
+(** [lexloc_of_qualname_in ~filename qualname] returns the full location of
+ [qualname], from the first qualifier to the last. This function is
+ temporary and is expected to be replaced once a better way of getting this
+ location is found. *)
+let lexloc_of_qualname_in ~filename (qn: AST.qualname) =
+ let rec end_pos: AST.qualname -> Lexing.position = function
+ | Name n -> Cobol_common.Srcloc.end_pos_in ~filename ~@n
+ | Qual (_, qn) -> end_pos qn
+ in
+ match qn with
+ | Name n -> Cobol_common.Srcloc.lexloc_in ~filename ~@n
+ | Qual (n, qn) -> Cobol_common.Srcloc.start_pos_in ~filename ~@n, end_pos qn
+
+(** [qualname_at_pos ~filename qualname pos] returns the qualname built from all
+ the qualifiers of [qualname] that are after or at position [pos] ion
+ [filename]. This function is temporary and is expected to be replaced once
+ a better way of finding the qualname is implemented. *)
+let rec qualname_at_pos ~filename (qn: AST.qualname) pos =
+ match qn with
+ | Name _ ->
+ qn
+ | Qual (name, qn') ->
+ let lexloc = lexloc_of_qualname_in ~filename qn in
+ if not (Lsp_position.is_after_lexloc pos lexloc) &&
+ not (Lsp_position.is_in_srcloc ~filename pos ~@name)
+ then qualname_at_pos ~filename qn' pos
+ else qn
+
+let name_of_compunit (cu: PTREE.compilation_unit with_loc) =
+ match ~&cu with
+ | Program {program_name = name; _}
+ | Function {function_name = name; _}
+ | ClassDefinition {class_name = name; _}
+ | InterfaceDefinition {interface_name = name; _} -> ~&name
+
+let compilation_unit_by_name (cu_name: AST.name) (ptree: PTREE.compilation_group) =
+ List.find_opt (fun cu -> cu_name = name_of_compunit cu) ptree
+
+(* --- *)
+
+(** [names_at_position pos ptree] seeks the compilation unit name and qualified
+ name at the given position [pos], in compilation group parse-tree
+ [ptree]. *)
+let names_at_position ~uri pos ptree : names_at_position =
+ let filename = Lsp.Uri.to_path uri in
+ let open struct
+
+ type acc =
+ {
+ names: names_at_position;
+ qualifiers: (AST.qualname * int) list; (* qualifiers stack *)
+ qualifiers_for_redef: (AST.qualname * int) list;(* all qualnames can be redefined*)
+ }
+
+ let init =
+ {
+ names = { qualname_at_position = None;
+ enclosing_compilation_unit_name = None };
+ qualifiers = [];
+ qualifiers_for_redef = [];
+ }
+
+ let result acc = acc.names
+
+ let qualify n = function
+ | [] -> bare n
+ | (qn, _) :: _ -> qual n (Some qn)
+
+ let rec pop_qualifiers l = function
+ | [] -> []
+ | (_, l') :: tl when l <= l' -> pop_qualifiers l tl
+ | l -> l
+
+ let push_qualifier n l qualifiers =
+ let qn = qualify n qualifiers in
+ qn, (qn, l) :: qualifiers
+
+ let update_qualifiers n l qualifiers =
+ push_qualifier n l @@ pop_qualifiers l qualifiers
+
+ let reset_qualifiers acc = {acc with qualifiers = []}
+
+ end in
+
+ let srcloc_contains pos loc =
+ Lsp_position.is_in_srcloc ~filename pos loc
+ in
+
+ let on_name n loc ({ names; qualifiers; _ } as acc) =
+ Visitor.do_children @@
+ if srcloc_contains pos loc
+ then { acc with
+ names = { names with
+ qualname_at_position = Some (qualify n qualifiers) } }
+ else acc
+ in
+
+ let on_item n l loc { names; qualifiers; qualifiers_for_redef } =
+ Visitor.do_children @@
+ let qn, qualifiers = update_qualifiers n l qualifiers in
+ let qualifiers_for_redef = (qn, l) :: pop_qualifiers (l + 1) qualifiers_for_redef in
+ { names =
+ if srcloc_contains pos loc
+ then { names with qualname_at_position = Some qn }
+ else names;
+ qualifiers; qualifiers_for_redef}
+ in
+
+ let on_filler l ({qualifiers; qualifiers_for_redef; _} as acc) =
+ Visitor.do_children @@
+ let qualifiers_for_redef = pop_qualifiers (l + 1) qualifiers_for_redef in
+ let qualifiers = pop_qualifiers l qualifiers in
+ { acc with qualifiers_for_redef; qualifiers}
+ in
+
+ let on_group_item name level loc acc =
+ match name with
+ | _ when acc.names.qualname_at_position <> None ->
+ Visitor.skip_children acc
+ | Some { payload = AST.DataFiller; _ } | None ->
+ on_filler level acc
+ | Some { payload = DataName name; _ } ->
+ on_item name level loc acc
+ in
+
+ Cobol_parser.PTree_visitor.fold_compilation_group (object
+ inherit [acc] Cobol_parser.PTree_visitor.folder
+ inherit! [acc] Lsp_position.sieve ~filename ~pos
+
+ method! fold_compilation_unit' cu ({ names; _ } as acc) =
+ if Lsp_position.is_in_srcloc ~filename pos ~@cu then
+ let cu_name = name_of_compunit cu in
+ let names = { names with
+ enclosing_compilation_unit_name = Some cu_name } in
+ Visitor.do_children { acc with names }
+ else
+ Visitor.skip_children acc
+
+ method! fold_qualname qn ({ names; _ } as acc) =
+ if Lsp_position.is_in_lexloc pos (lexloc_of_qualname_in ~filename qn) then
+ let qn = qualname_at_pos ~filename qn pos in
+ let names = { names with qualname_at_position = Some qn } in
+ Visitor.skip_children { acc with names }
+ else
+ Visitor.skip_children acc
+
+ (* Note: we bypass the sieve on the following items, and re-implement (sic)
+ the name qualification mechanism in sections of the DATA DIVISION. *)
+
+ (* TODO: check whether it is worth resetting the qualifiers stack when
+ entering the relevant sections. *)
+
+ method! fold_data_clause clause ({qualifiers_for_redef; names; _} as acc) =
+ Visitor.skip_children @@ match clause with
+ | DataRedefines name when srcloc_contains pos ~@name ->
+ let x = List.find_opt
+ (fun (qn, _) ->
+ simple_name qn = ~&name)
+ qualifiers_for_redef
+ in
+ begin match x with
+ | None -> acc
+ | Some (qn, _) ->
+ {acc with names = {names with qualname_at_position = Some qn }}
+ end
+ | _ -> acc
+
+ method! fold_data_item' { loc; payload = { data_level = l;
+ data_name = n; _ } } =
+ on_group_item n ~&l loc
+
+ method! fold_screen_item' { loc; payload = { screen_level = l;
+ screen_data_name = n; _ } } =
+ on_group_item n l loc
+
+ method! fold_report_group_item' { loc;
+ payload = { report_level = l;
+ report_data_name = n; _ } } =
+ on_group_item n l loc
+
+ method! fold_constant_item' { loc; payload = { constant_level = l; (* 01 *)
+ constant_name = n; _ } } acc =
+ on_group_item n ~&l loc (reset_qualifiers acc) (* CHECKME: should reset qualifiers... *)
+
+ method! fold_rename_item' { loc; payload = { rename_to; _ } } acc =
+ (*rename_item can only be qualified by the data-name of level 01
+ ISO/IEC 1989:2014 P379 13.18.45.2(3) *)
+ on_name rename_to loc {acc with qualifiers = pop_qualifiers 01 acc.qualifiers}
+
+ method! fold_condition_name_item' { loc; payload = { condition_name; _ } } =
+ on_name condition_name loc
+
+ end) ptree init |> result
+
+(* --- *)
+
+(** Name definitions retrieval *)
+
+let def_binding qn map =
+ (* TODO: Qualmap.update? *)
+ try Cobol_data.Qualmap.find qn map
+ with Not_found -> { as_paragraph = None; as_item = None }
+
+let def_paragraph qn para map =
+ let binding = def_binding qn map in
+ Cobol_data.Qualmap.add qn { binding with as_paragraph = Some para } map
+
+let def_item qn item map =
+ let binding = def_binding qn map in
+ Cobol_data.Qualmap.add qn { binding with as_item = Some item } map
+
+let def_redefinition qn redefine_item map =
+ let binding = def_binding qn map in
+ match binding.as_item with
+ | None ->
+ map (* ignore binding *)
+ | Some ({ item_redefinitions = redefs; _ } as item) ->
+ def_item qn { item with item_redefinitions = redefine_item :: redefs } map
+
+
+(** Creates a mapping of item definitions from a type-checked group item. *)
+(*TODO: Make it with QualName so we have better definition finding *)
+let definitions: compilation_unit -> name_definitions_in_compilation_unit =
+ let rec def_group ?cur_qn map { loc; payload = group } =
+ let group_infos = match group with
+ | Cobol_data.Group.Elementary { name; data_item = Data item; _ } ->
+ Some (name, AST.Data item, [])
+ | Constant { name; constant_item_descr = Constant c; _ } ->
+ Some (name, Constant c, [])
+ | Group { name; data_item = Data item; elements = children; _ } ->
+ Some (name, Data item, children)
+ | Renames _ (* TODO (needs _ item_descr) *)
+ | ConditionName _ -> (* TODO: ditto*)
+ None
+ in
+ match group_infos with
+ | Some (group_name, item_definition, children) ->
+ (* TODO: group_name: `string with_loc` instead of just `string` *)
+ let qn = qual (group_name &@ loc) cur_qn in
+ let map = def_item qn { item_definition = item_definition &@ loc;
+ item_redefinitions = [] } map in
+ List.fold_left (def_group ~cur_qn:qn) map children
+ | None -> (* ignore *)
+ map
+ in
+
+ fun { cu_wss; _ } ->
+ List.fold_left def_group Cobol_data.Qualmap.empty cu_wss
+
+
+let update_definitions_based_on_compilation_group_ptree ~f ptree defs =
+ let cus = CUMap.compilation_units defs in
+ List.fold_left begin fun defs cu' ->
+ try
+ let cu = CUs.find_by_name (name_of_compunit cu') cus in
+ CUMap.update cu begin fun cu_defs ->
+ Some (f cu' @@ Option.value cu_defs ~default:Cobol_data.Qualmap.empty)
+ end defs
+ with Not_found -> defs
+ end defs ptree
+
+
+(*TODO: remove this once Cobol_typeck implements Renames*)
+let add_rename_item_definitions ptree defs =
+(*rename_item can only be qualified by the data-name of level 01
+ ISO/IEC 1989:2014 P379 13.18.45.2(3) *)
+ let visitor = object
+ inherit [name_definitions_in_compilation_unit *
+ AST.qualname option] Cobol_parser.PTree_visitor.folder
+
+ method! fold_data_item { data_level; data_name; _ } ((map, _) as acc) =
+ Visitor.do_children @@
+ match data_name with
+ | Some { payload = DataFiller; _ } | None when ~&data_level = 1 ->
+ map, None
+ | Some { payload = DataName name; _ } when ~&data_level = 1 ->
+ map, Some (bare name)
+ | _ ->
+ acc
+
+ method! fold_rename_item' { payload = { rename_to = name; _ } as rename;
+ loc } (map, cur_qn) =
+ Visitor.skip_children @@
+ (def_item (qual name cur_qn)
+ { item_definition = AST.Renames rename &@ loc;
+ item_redefinitions = [] } map,
+ cur_qn)
+ end in
+
+ update_definitions_based_on_compilation_group_ptree ptree defs
+ ~f:begin fun cu' defs ->
+ Cobol_parser.PTree_visitor.fold_compilation_unit' visitor
+ cu' (defs, None) |> fst
+ end
+
+
+let add_paragraph_definitions ptree defs =
+
+ let register_section name s (defs, _section_name) =
+ let qn = bare name in
+ Visitor.do_children (def_paragraph qn s defs, Some qn)
+
+ and register_paragraph name p (defs, section_name) =
+ let qn = qual name section_name in
+ Visitor.do_children (def_paragraph qn p defs, section_name)
+ in
+
+ let visitor = object
+ inherit [name_definitions_in_compilation_unit *
+ AST.qualname option] Cobol_parser.PTree_visitor.folder
+
+ method! fold_environment_division _ = Visitor.skip
+ method! fold_data_division' _ = Visitor.skip
+
+ method! fold_paragraph' p = match ~&p with
+ | { paragraph_name = None; _ } -> Visitor.skip_children
+ | { paragraph_is_section = true;
+ paragraph_name = Some name; _ } -> register_section name p
+ | { paragraph_name = Some name; _ } -> register_paragraph name p
+
+ end in
+ update_definitions_based_on_compilation_group_ptree ptree defs
+ ~f:begin fun cu' defs ->
+ Cobol_parser.PTree_visitor.fold_compilation_unit' visitor
+ cu' (defs, None) |> fst
+ end
+
+
+let add_redefine_definitions ptree defs =
+ let open struct
+ type acc =
+ {
+ defs: name_definitions_in_compilation_unit;
+ qualifiers: (AST.qualname * int) list; (* qualifiers stack *)
+ aux: (AST.qualname * int) list; (* all qualnames can be redefined*)
+ }
+
+ let qualify n = function
+ | [] -> bare n
+ | (qn, _) :: _ -> qual n (Some qn)
+
+ let rec pop_qualifiers l = function
+ | [] -> []
+ | (_, l') :: tl when l <= l' -> pop_qualifiers l tl
+ | l -> l
+
+ let push_qualifier n l qualifiers =
+ let qn = qualify n qualifiers in
+ qn, (qn, l) :: qualifiers
+
+ let update_qualifiers n l qualifiers =
+ push_qualifier n l @@ pop_qualifiers l qualifiers
+
+ let result acc = acc.defs
+
+ end in
+
+ let visitor = object
+ inherit [acc] Cobol_parser.PTree_visitor.folder
+
+ method! fold_environment_division _ = Visitor.skip
+ method! fold_procedure_division _ = Visitor.skip
+
+ method! fold_data_item {data_level; data_name; _} ({qualifiers; aux; _} as acc) =
+ let l = ~&data_level in
+ match data_name with
+ | Some { payload = AST.DataFiller; _ } | None ->
+ Visitor.do_children @@
+ let aux = pop_qualifiers (l + 1) aux in
+ let qualifiers = pop_qualifiers l qualifiers in
+ { acc with aux; qualifiers}
+ | Some { payload = DataName name; _ } ->
+ Visitor.do_children @@
+ let qn, qualifiers = update_qualifiers name l qualifiers in
+ let aux = (qn, l) :: pop_qualifiers (l + 1) aux in
+ { acc with qualifiers; aux}
+
+ method! fold_data_clause clause ({defs; aux; _} as acc) =
+ Visitor.skip_children @@ match clause with
+ | DataRedefines name ->
+ let x = List.find_opt
+ (fun (qn, _) ->
+ simple_name qn = ~&name)
+ aux
+ in
+ begin match x with
+ | None -> acc
+ | Some (qn, _) ->
+ {acc with defs = def_redefinition qn name defs}
+ end
+ | _ -> acc
+
+ end in
+ update_definitions_based_on_compilation_group_ptree ptree defs
+ ~f:begin fun cu' defs ->
+ Cobol_parser.PTree_visitor.fold_compilation_unit' visitor
+ cu' {defs; aux = []; qualifiers = []} |> result
+ end
+
+
+let references_of_qualname qn cu cu_defs =
+
+ let visitor key = object
+ (*[key] is the full qualname of the data*)
+ inherit [srcloc list] Cobol_parser.PTree_visitor.folder
+ method! fold_environment_division _ = Visitor.skip
+ method! fold_qualname qn locs =
+ match Cobol_data.Qualmap.find_full_qualname_opt qn cu_defs with
+ | Some full_qn when AST.compare_qualname full_qn key = 0 ->
+ Visitor.skip_children @@ baseloc_of_qualname qn :: locs
+ | Some _ ->
+ Visitor.do_children locs
+ | None ->
+ Visitor.skip_children locs
+ end in
+
+ let qn = match Cobol_data.Qualmap.find_full_qualname_opt qn cu_defs with
+ | Some qn -> qn
+ | None -> qn
+ in
+ let refs_in_data_div_or_proc_div =
+ Cobol_parser.PTree_visitor.fold_compilation_unit'
+ (visitor qn) cu []
+ and refs_in_redef_clauses = (* redefinitions *)
+ match Cobol_data.Qualmap.find qn cu_defs with
+ | { as_item = Some { item_redefinitions = redefs; _ }; _ } ->
+ List.rev_map (~@) redefs
+ | _ -> []
+ | exception Not_found -> []
+ in
+ refs_in_redef_clauses @ List.rev refs_in_data_div_or_proc_div
+
+let references cu_defs cu =
+ Cobol_data.Qualmap.fold
+ (fun qn _ map ->
+ Cobol_data.Qualmap.add qn (references_of_qualname qn cu cu_defs) map)
+ cu_defs Cobol_data.Qualmap.empty
+
+let copy_at_pos ~filename pos ptree =
+ Cobol_parser.PTree_visitor.fold_compilation_group (object
+ inherit [copy_operation option] Cobol_parser.PTree_visitor.folder
+ method! fold' { loc; _ } = function
+ | Some _ as acc ->
+ Visitor.skip_children acc
+ | None ->
+ match Srcloc.as_copy loc with
+ | Some { loc; _ } as copy
+ when Lsp_position.is_in_srcloc ~filename pos loc ->
+ Visitor.skip_children copy
+ | _ ->
+ Visitor.do_children None
+ end) ptree None
diff --git a/src/lsp/cobol_lsp/lsp_notif.ml b/src/lsp/cobol_lsp/lsp_notif.ml
new file mode 100644
index 000000000..2ae01984d
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_notif.ml
@@ -0,0 +1,42 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_server.TYPES
+
+let on_notification state notif =
+ match state, notif with
+ | ShuttingDown, Lsp.Client_notification.Exit ->
+ Exit (Ok ())
+ | ShuttingDown, _ ->
+ ShuttingDown
+ | NotInitialized _ | Exit _ as state, _ ->
+ state (* spec indicate notif should just be discarded *)
+ | Initialized config, Initialized ->
+ Running (Lsp_server.init ~config)
+ | Running registry, TextDocumentDidOpen params ->
+ Running (Lsp_server.add params registry)
+ | Running registry, TextDocumentDidChange params ->
+ Running (Lsp_server.update params registry)
+ | Running registry, TextDocumentDidClose params ->
+ Running (Lsp_server.remove params registry)
+ | Running _, Exit ->
+ Exit (Error "Received premature 'exit' notification")
+ | _ ->
+ state
+
+let handle notif status =
+ match Lsp.Client_notification.of_jsonrpc notif with
+ | Error str ->
+ Pretty.failwith "LSP@ sever@ could@ not@ decode@ notification:@ %s" str
+ | Ok notif ->
+ on_notification status notif
diff --git a/src/lsp/cobol_lsp/lsp_notif.mli b/src/lsp/cobol_lsp/lsp_notif.mli
new file mode 100644
index 000000000..3a3b4c299
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_notif.mli
@@ -0,0 +1,14 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val handle: Jsonrpc.Notification.t -> (Lsp_server.state as 's) -> 's
diff --git a/src/lsp/cobol_lsp/lsp_position.ml b/src/lsp/cobol_lsp/lsp_position.ml
new file mode 100644
index 000000000..c587ee140
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_position.ml
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module has utility functions to use {!Lsp.Types.Position} and
+ {!Lsp.Types.Range} types with {!Srcloc.lexloc} and {!Srcloc.srcloc}. *)
+
+open Cobol_common
+open Srcloc.TYPES
+open Lsp.Types
+
+(** Range of length [0], at position [0, 0] *)
+let none_range =
+ let none_pos = Position.create ~line:0 ~character:0 in
+ Range.create ~start:none_pos ~end_:none_pos
+
+(** {1 Postions {i w.r.t} lexical locations} *)
+
+(** [range_of_lexloc] creates a representation of the given lexical location
+ that is suitable for the LSP library. *)
+let range_of_lexloc ((start_pos, end_pos): lexloc) =
+ (* NOTE: Line numbers start at 0 in LSP protocol. *)
+ let sl = start_pos.pos_lnum - 1
+ and sc = start_pos.pos_cnum - start_pos.pos_bol
+ and el = end_pos.pos_lnum - 1
+ and ec = end_pos.pos_cnum - end_pos.pos_bol in
+ Range.create
+ ~start:(Position.create ~line:sl ~character:sc)
+ ~end_:(Position.create ~line:el ~character:ec)
+
+(** [is_before_lexloc pos lexloc] holds when [pos] is strictly before [lexloc] *)
+let is_before_lexloc pos lexloc =
+ let Range.{start = {line; character;}; _} = range_of_lexloc lexloc in
+ Position.(pos.line < line || (pos.line = line && pos.character < character))
+
+(** [is_after_lexloc pos lexloc] holds when [pos] is strictly after [lexloc] *)
+let is_after_lexloc pos lexloc =
+ let Range.{end_ = {line; character;}; _} = range_of_lexloc lexloc in
+ Position.(pos.line > line || (pos.line = line && pos.character > character))
+
+(** [is_in_lexloc pos lexloc] holds when [pos] is neither before or after
+ [lexloc] *)
+let is_in_lexloc pos lexloc =
+ (not @@ is_after_lexloc pos lexloc) && (not @@ is_before_lexloc pos lexloc)
+
+(** [contains_lexloc range lexloc] holds when [lexloc] is strictly contained
+ inside [range]. *)
+let contains_lexloc Range.{start; end_} lexloc =
+ is_before_lexloc start lexloc && is_after_lexloc end_ lexloc
+
+(* --- *)
+
+(** {1 Postions {i w.r.t} generalized source locations} *)
+
+(** [range_of_srcloc_in ~filename srcloc] is [range_of_srcloc (Srcloc.lexloc_in
+ ~filename srcloc)] *)
+let range_of_srcloc_in ~filename srcloc =
+ range_of_lexloc (Srcloc.lexloc_in ~filename srcloc)
+
+(** [is_in_srcloc ~filename pos srcloc] is a shorthand for [is_in_lexloc pos
+ (Srcloc.lexloc_in ~filename srcloc)] *)
+let is_in_srcloc ~filename pos srcloc =
+ is_in_lexloc pos (Srcloc.lexloc_in ~filename srcloc)
+
+(* --- *)
+
+class ['x] sieve ~filename ~pos = object
+ method fold': 'n. ('n with_loc, 'x) Cobol_common.Visitor.fold =
+ fun { loc; _ } ->
+ if is_in_srcloc ~filename pos loc
+ then Visitor.do_children
+ else Visitor.skip_children
+end
diff --git a/src/lsp/cobol_lsp/lsp_position.mli b/src/lsp/cobol_lsp/lsp_position.mli
new file mode 100644
index 000000000..9996a587c
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_position.mli
@@ -0,0 +1,61 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module has utility functions to use {!Lsp.Types.Position} and
+ {!Lsp.Types.Range} types with {!Srcloc.lexloc} and {!Srcloc.srcloc}. *)
+
+(** Range of length [0], at position [0, 0] *)
+val none_range: Lsp.Types.Range.t
+
+(** [range_of_lexloc] creates a representation of the given lexical location
+ that is suitable for the LSP library. *)
+val range_of_lexloc: Cobol_common.Srcloc.lexloc -> Lsp.Types.Range.t
+
+(** [is_before_lexloc pos lexloc] holds when [pos] is strictly before
+ [lexloc] *)
+val is_before_lexloc: Lsp.Types.Position.t -> Cobol_common.Srcloc.lexloc -> bool
+
+(** [is_after_lexloc pos lexloc] holds when [pos] is strictly after [lexloc] *)
+val is_after_lexloc: Lsp.Types.Position.t -> Cobol_common.Srcloc.lexloc -> bool
+
+(** [is_in_lexloc pos lexloc] holds when [pos] is neither before or after
+ [lexloc] *)
+val is_in_lexloc: Lsp.Types.Position.t -> Cobol_common.Srcloc.lexloc -> bool
+
+(** [contains_lexloc range lexloc] holds when [lexloc] is strictly contained
+ within [range]. *)
+val contains_lexloc: Lsp.Types.Range.t -> Cobol_common.Srcloc.lexloc -> bool
+
+(* --- *)
+
+val range_of_srcloc_in
+ : filename:string
+ -> Cobol_common.Srcloc.srcloc
+ -> Lsp.Types.Range.t
+
+val is_in_srcloc
+ : filename:string
+ -> Lsp.Types.Position.t
+ -> Cobol_common.Srcloc.srcloc
+ -> bool
+
+(* --- *)
+
+(** [sieve ~filename ~pos] is a folder visitor that skips any localized AST node
+ whose source location does not include the given position. To be used as a
+ mixin component so it overrides [fold'] last. *)
+class ['x] sieve: filename:string -> pos:Lsp.Types.Position.t ->
+ object
+ method fold'
+ : 'n. ('n Cobol_common.Srcloc.with_loc, 'x) Cobol_common.Visitor.fold
+ end
diff --git a/src/lsp/cobol_lsp/lsp_project.ml b/src/lsp/cobol_lsp/lsp_project.ml
new file mode 100644
index 000000000..577c88f7c
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_project.ml
@@ -0,0 +1,322 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** This module contains the functions to parse and get the configuration *)
+
+open Ez_file.V1
+open EzFile.OP
+open Toml.Types
+
+module DIAGS = Cobol_common.Diagnostics
+
+module TABLE =
+ Ephemeron.K1.Make (struct
+ include String (* rootdir *)
+ let hash = Hashtbl.hash
+ end)
+
+module TYPES = struct
+
+ type path =
+ | RelativeToProjectRoot of string
+ | RelativeToFileDir of string
+
+ type rootdir = string (* private *)
+
+ type project = { (* private *)
+ rootdir: rootdir;
+ config_checksum: Digest.t option;
+ cobol_config: Cobol_config.t;
+ source_format: Cobol_config.source_format_spec;
+ libpath: path list;
+ copybook_extensions: string list;
+ copybook_if_no_extension: bool;
+ }
+
+ type layout = {
+ project_config_filename: string;
+ }
+
+end
+include TYPES
+type t = project
+
+let rootdir { rootdir; _ } = rootdir
+let string_of_rootdir = Fun.id
+
+type cached = { (** Persistent representation (for caching) *)
+ cached_config_checksum: Digest.t option;
+ cached_cobol_config: Cobol_config.t;
+ cached_source_format: Cobol_config.source_format_spec;
+ cached_libpath: path list;
+ cached_copybook_extensions: string list;
+ cached_copybook_if_no_extensions: bool;
+}
+
+module M = struct
+ type nonrec t = t
+ let compare { rootdir = d1; _ } { rootdir = d2; _ } = String.compare d1 d2
+end
+
+module SET = struct
+ include Set.Make (M)
+ let for_rootdir ~rootdir s =
+ let p = find_first (fun p -> String.compare p.rootdir rootdir >= 0) s in
+ if p.rootdir = rootdir then p else raise Not_found
+ let mem_rootdir ~rootdir s =
+ try ignore (for_rootdir ~rootdir s); true with Not_found -> false
+end
+
+module MAP = Map.Make (M)
+
+let rootdir_for ~uri ~layout:{ project_config_filename; _ } =
+ let rec try_dir dir =
+ if EzFile.exists (dir // project_config_filename)
+ then Some dir
+ else
+ let new_dir = EzFile.dirname dir in
+ if new_dir = dir
+ then None (* we are at root *)
+ else try_dir new_dir
+ in
+ let filename = Lsp.Uri.to_path uri in
+ let dir = match try_dir (EzFile.dirname filename) with
+ | Some dir -> dir
+ | None -> EzFile.dirname filename
+ in
+ (* Pretty.error "Project directory: %s@." dir; *)
+ dir
+
+let config_from_dialect_name ?(strict = false) dialect =
+ try
+ let dialect = Cobol_config.DIALECT.of_string dialect in
+ Cobol_common.catch_diagnostics
+ (fun diags dialect ->
+ Ok (Cobol_config.from_dialect diags ~strict dialect,
+ DIAGS.Set.none))
+ dialect
+ with Invalid_argument e ->
+ Error (DIAGS.Set.error "Unknown dialect: %s" e)
+
+let default_libpath = [RelativeToProjectRoot "."]
+let default_copybook_extensions = Cobol_preproc.Copybook.copybook_extensions
+let default_copybook_if_no_extension = true
+
+let default ~rootdir = {
+ rootdir;
+ config_checksum = None;
+ cobol_config = Cobol_config.default;
+ source_format = Cobol_config.(SF SFFixed);
+ libpath = default_libpath;
+ copybook_extensions = default_copybook_extensions;
+ copybook_if_no_extension = default_copybook_if_no_extension;
+}
+
+let dialect_key = Table.Key.of_string "dialect"
+and source_format_key = Table.Key.of_string "source-format"
+and strict_key = Table.Key.of_string "strict"
+and dir_key = Table.Key.of_string "dir"
+and file_relative_key = Table.Key.of_string "file-relative"
+and copybook_key = Table.Key.of_string "copybook"
+
+let expected acc ~kind ~key =
+ DIAGS.Acc.error acc
+ "Invalid@ entry@ type@ for@ key@ `%s',@ %s@ expected"
+ (Table.Key.to_string key) kind
+let expected_string = expected ~kind:"string"
+let expected_bool = expected ~kind:"Boolean"
+
+(** [read_config_file file] returns the project configuration from the file
+ [file]. Errors and warnings raised when parsing this file are directly
+ publised via {!Lsp_io}. *)
+let read_config_file ~rootdir config_file =
+ let copybook_entries table =
+ List.fold_left begin fun (libpath, errors) entry ->
+ match Table.find_opt dir_key entry,
+ Table.find_opt file_relative_key entry with
+ | Some TString str, Some TBool true ->
+ RelativeToFileDir str :: libpath, errors
+ | Some TString str, (None | Some TBool false) ->
+ RelativeToProjectRoot str :: libpath, errors
+ | Some TString _, Some _ ->
+ libpath, expected_bool ~key:file_relative_key errors
+ | Some _, _ ->
+ libpath, expected_string ~key:dir_key errors
+ | None, _ ->
+ libpath, errors
+ end (default_libpath, DIAGS.Set.none) table
+ in
+ (* TODO: push notifications directly via {!Lsp_io.pretty_notification} *)
+ let config, diags = match Toml.Parser.from_filename config_file with
+ | `Ok toml ->
+ let config =
+ match Table.find_opt dialect_key toml,
+ Table.find_opt strict_key toml with
+ | Some TString dialect, Some TBool strict ->
+ config_from_dialect_name dialect ~strict
+ | Some TString dialect, None ->
+ config_from_dialect_name dialect
+ | None, (None | Some TBool _) -> (* match on strict so it is not caught
+ in last case *)
+ Ok (Cobol_config.default, DIAGS.Set.none)
+ | Some _, _ ->
+ Error (expected_string ~key:dialect_key DIAGS.Set.none)
+ | _, Some _ ->
+ Error (expected_bool ~key:strict_key DIAGS.Set.none)
+ in
+ let libpath, errors =
+ match Table.find copybook_key toml with
+ | TArray NodeTable tbl ->
+ copybook_entries tbl
+ | exception Not_found ->
+ default_libpath, DIAGS.Set.none
+ | _ ->
+ default_libpath,
+ expected ~key:copybook_key ~kind:"array of tables" DIAGS.Set.none
+ in
+ let source_format, sf_errors =
+ let none = DIAGS.Set.none in
+ match Table.find source_format_key toml with
+ | TString str ->
+ begin match String.uppercase_ascii str with
+ | "FREE" -> Cobol_config.SF SFFree, none
+ | "FIXED" -> SF SFFixed, none
+ | "VARIABLE" -> SF SFVariable, none
+ | "XOPEN" -> SF SFXOpen, none
+ | "XCARD" -> SF SFxCard, none
+ | "CRT" -> SF SFCRT, none
+ | "TERMINAL" -> SF SFTrm, none
+ | "COBOLX" -> SF SFCOBOLX, none
+ | "AUTO" -> Auto, none
+ | _ -> Auto, DIAGS.Set.error "Invalid source format: %s" str
+ end
+ | exception Not_found ->
+ Auto, none
+ | _ ->
+ Auto, expected_string ~key:source_format_key none
+ in
+ let errors = DIAGS.Set.union errors sf_errors in
+ let errors =
+ match config with
+ | Error diags -> DIAGS.Set.union errors diags
+ | Ok _ -> errors
+ in
+ let cobol_config, errors =
+ match config with
+ | Error _ ->
+ Cobol_config.default,
+ DIAGS.Acc.warn errors "Unsing the default configuration"
+ | Ok (config, diags) ->
+ config, DIAGS.Set.union errors diags
+ in
+ {
+ rootdir;
+ config_checksum = Some (Digest.file config_file);
+ cobol_config;
+ source_format;
+ libpath;
+ copybook_extensions = default_copybook_extensions;
+ copybook_if_no_extension = default_copybook_if_no_extension;
+ }, errors
+ | `Error (msg, _) ->
+ default ~rootdir,
+ DIAGS.Set.error "Failed to parse `superbol.toml': %s@\n\
+ Using default configuration" msg
+ | exception e ->
+ default ~rootdir,
+ DIAGS.Set.error "Failed to read `superbol.toml': %a@\n\
+ Using default configuration" Fmt.exn e
+ in
+ Lsp_diagnostics.publish @@
+ Lsp_diagnostics.translate diags ~rootdir
+ ~uri:(`Main (Lsp.Uri.of_path config_file));
+ config
+
+let try_reading_config_file ~layout:{ project_config_filename; _ } ~rootdir =
+ let config_filename = rootdir // project_config_filename in
+ if EzFile.exists config_filename
+ then read_config_file ~rootdir config_filename
+ else default ~rootdir
+
+let table = TABLE.create 1
+
+let in_existing_dir dir ~layout =
+ if EzFile.is_directory dir then
+ let project = try_reading_config_file ~layout ~rootdir:dir in
+ TABLE.add table dir project;
+ project
+ else
+ Fmt.invalid_arg "Expected existing directory: %s" dir
+
+let for_ ~rootdir ~layout =
+ try TABLE.find table rootdir
+ with Not_found ->
+ let project = try_reading_config_file ~layout ~rootdir in
+ TABLE.add table rootdir project;
+ project
+
+let libpath_for ~uri { libpath; _ } =
+ List.map begin function
+ | RelativeToProjectRoot str -> str
+ | RelativeToFileDir str -> Filename.dirname (Lsp.Uri.to_path uri) // str
+ end libpath
+
+(* TODO: add config flags to libpath where some directories may only include
+ copybooks. *)
+let detect_copybook ~uri { copybook_extensions;
+ copybook_if_no_extension; _ } =
+ let path = Lsp.Uri.to_path uri in
+ List.exists (Filename.check_suffix path) copybook_extensions ||
+ (copybook_if_no_extension && Filename.extension path = "")
+
+let to_cache { config_checksum; cobol_config; source_format; libpath;
+ copybook_extensions; copybook_if_no_extension; _ } =
+ {
+ cached_config_checksum = config_checksum;
+ cached_cobol_config = cobol_config;
+ cached_source_format = source_format;
+ cached_libpath = libpath;
+ cached_copybook_extensions = copybook_extensions;
+ cached_copybook_if_no_extensions = copybook_if_no_extension;
+ }
+
+let of_cache ~rootdir ~layout
+ { cached_config_checksum = config_checksum;
+ cached_cobol_config = cobol_config;
+ cached_source_format = source_format;
+ cached_libpath = libpath;
+ cached_copybook_extensions = copybook_extensions;
+ cached_copybook_if_no_extensions = copybook_if_no_extension }
+ =
+ let project
+ = { rootdir; config_checksum; cobol_config; source_format; libpath;
+ copybook_extensions; copybook_if_no_extension } in
+ let config_filename = rootdir // layout.project_config_filename in
+ try match config_checksum with
+ | Some checksum when checksum = Digest.file config_filename ->
+ TABLE.replace table rootdir project;
+ project
+ | _ -> raise Exit
+ with _ -> (* read error or bad checksum (Exit) *)
+ let project = try_reading_config_file ~rootdir ~layout in
+ TABLE.add table rootdir project;
+ project
+
+let relative_path_for ~uri { rootdir; _ } =
+ try Lsp_utils.relative_path ~uri rootdir
+ with Invalid_argument _ -> Lsp.Uri.to_path uri (* if not in project rootdir *)
+
+let absolute_path_for ~filename { rootdir; _ } =
+ if EzFile.is_absolute filename
+ then filename (* in case the file is not within its project directory *)
+ else rootdir // filename
diff --git a/src/lsp/cobol_lsp/lsp_project.mli b/src/lsp/cobol_lsp/lsp_project.mli
new file mode 100644
index 000000000..2e92580ea
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_project.mli
@@ -0,0 +1,93 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module TYPES: sig
+
+ type path =
+ | RelativeToProjectRoot of string
+ | RelativeToFileDir of string
+
+ type rootdir
+
+ type project = private {
+ rootdir: rootdir;
+ config_checksum: Digest.t option;
+ cobol_config: Cobol_config.t;
+ source_format: Cobol_config.source_format_spec;
+ libpath: path list;
+ copybook_extensions: string list;
+ copybook_if_no_extension: bool;
+ }
+
+ type layout = {
+ project_config_filename: string;
+ }
+
+end
+include module type of TYPES
+ with type path = TYPES.path
+ and type rootdir = TYPES.rootdir
+ and type project = TYPES.project
+ and type layout = TYPES.layout
+
+type t = project
+
+(** [for_ ~rootdir ~layout] retrieves a project based on its root directory.
+ This may trigger reading project configuration files if the project was not
+ yet loaded. Any notification about the loading process is published
+ directly via {!Lsp_io.send_diagnostics} or {!Lsp_io.send_notification}. *)
+val for_: rootdir:rootdir -> layout:layout -> t
+
+(** [in_existing_dir dirname ~layout] retrieves a project after checking
+ [dirname] actually refers to an exising directory that can serve as root for
+ the project. The same notes as {!for_} apply, with the addition that
+ {!Invalid_argument} may is raised in case [dirname] is not the name of an
+ existing directory. *)
+val in_existing_dir: string -> layout:layout -> t
+
+(** [rootdir_for ~uri ~layout] locates the project directory (that contains a
+ file with given name [layout.project_config_filename]) for a file at the
+ given URI. Returns the name of the directory that contains the file at URI
+ if no project file is found. *)
+val rootdir_for: uri:Lsp.Uri.t -> layout:layout -> rootdir
+
+(** [libpath_for ~uri project] constructs a list of directory names where
+ copybooks are looked up, for a source file at the given URI, in the given
+ project. *)
+val libpath_for: uri:Lsp.Uri.t -> t -> string list
+
+(** [detect_copybook ~uri project] indicates whether a document at the given URI
+ for [project] should be treated as a copybook. *)
+val detect_copybook: uri:Lsp.Uri.t -> t -> bool
+
+(** Cached representation *)
+
+type cached
+val to_cache: t -> cached
+val of_cache: rootdir:rootdir -> layout:layout -> cached -> t
+
+(** Sets and maps *)
+
+module SET: sig
+ include Set.S with type elt = t
+ val for_rootdir: rootdir:rootdir -> t -> elt
+ val mem_rootdir: rootdir:rootdir -> t -> bool
+end
+module MAP: Map.S with type key = t
+
+(** Miscellaneous *)
+
+val rootdir: t -> rootdir
+val string_of_rootdir: rootdir -> string
+val relative_path_for: uri:Lsp.Uri.t -> t -> string
+val absolute_path_for: filename:string -> t -> string
diff --git a/src/lsp/cobol_lsp/lsp_project_cache.ml b/src/lsp/cobol_lsp/lsp_project_cache.ml
new file mode 100644
index 000000000..11c2fe2cc
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_project_cache.ml
@@ -0,0 +1,141 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+open Ez_file.V1
+open Ez_file.V1.EzFile.OP
+
+module DIAGS = Cobol_common.Diagnostics
+
+module TYPES = struct
+ type config =
+ {
+ cache_relative_filename: string;
+ cache_verbose: bool;
+ }
+end
+include TYPES
+
+(** Internal module used to hold a persistent representation of the set of
+ opened document pertaining to a given project. *)
+module CACHED_DOCS =
+ Set.Make (struct
+ open Lsp_document.TYPES
+ type t = cached
+ let compare { doc_cache_filename = f1; _ } { doc_cache_filename = f2; _ } =
+ String.compare f1 f2
+ end)
+
+type cached_project_record =
+ {
+ cached_project: Lsp_project.cached;
+ cached_docs: CACHED_DOCS.t;
+ }
+
+(* Code: *)
+
+let cache_filename ~config ~rootdir =
+ Lsp_project.string_of_rootdir rootdir // config.cache_relative_filename
+
+let version_tag_length = 40 (* use full commit hash when available *)
+let version_tag =
+ let str = Option.value Version.commit_hash ~default:Version.version in
+ if String.length str >= version_tag_length
+ then String.sub str 0 version_tag_length
+ else str ^ String.make (version_tag_length - String.length str) '_'
+
+let write_project_cache cached_project_record oc =
+ output_string oc version_tag;
+ Marshal.to_channel oc (cached_project_record: cached_project_record)
+ [Closures] (* Still required for Cobol_config.t *)
+
+(** (Internal) Raises {!Failure} whenever the given input channel does not
+ contain a usable project cache structure. *)
+let read_project_cache ic =
+ let version_tag' = really_input_string ic version_tag_length in
+ if version_tag' <> version_tag
+ then Fmt.failwith "Bad version tag: got %s, expected %s\
+ " version_tag' version_tag;
+ (Marshal.from_channel ic: cached_project_record)
+
+(** (Internal) May raise {!Failure} or {!Sys_error}. *)
+let save_project_cache ~config
+ (Lsp_project.{ rootdir; _ } as project) cached_docs =
+ let cached_project_record =
+ {
+ cached_project = Lsp_project.to_cache project;
+ cached_docs;
+ }
+ in
+ let cache_file = cache_filename ~config ~rootdir in
+ EzFile.(make_dir ~p:true (dirname cache_file));
+ (* NB: don't really care if we rewrite the same cache again *)
+ (* if Lsp_utils.is_file cache_file *)
+ (* then (* read, write if commit hash or document changed *) *)
+ (* else *)
+ Lsp_utils.write_to cache_file (write_project_cache cached_project_record);
+ Lsp_io.pretty_notification "Wrote cache at: %s" cache_file ~type_:Info
+
+let save ~config docs =
+ (* Pivot all active projects: associate projects with all their documents, and
+ ignore any project that has none. *)
+ URIMap.fold begin fun _ (Lsp_document.{ project; _ } as doc) ->
+ Lsp_project.MAP.update project begin function
+ | None -> Some (CACHED_DOCS.singleton (Lsp_document.to_cache doc))
+ | Some s -> Some (CACHED_DOCS.add (Lsp_document.to_cache doc) s)
+ end
+ end docs Lsp_project.MAP.empty |>
+ Lsp_project.MAP.iter (save_project_cache ~config)
+
+(** (Internal) *)
+let load_project ~rootdir ~layout ~config { cached_project; cached_docs; _ } =
+ let project = Lsp_project.of_cache ~rootdir ~layout cached_project in
+ let add_doc doc docs = URIMap.add (Lsp_document.uri doc) doc docs in
+ CACHED_DOCS.fold begin fun cached_doc docs ->
+ try
+ let doc = Lsp_document.of_cache ~project cached_doc in
+ if config.cache_verbose then
+ Lsp_io.pretty_notification "Successfully read cache for %s"
+ (Lsp.Uri.to_string @@ Lsp_document.uri doc) ~log:true ~type_:Info;
+ add_doc doc docs
+ with
+ | Failure msg | Sys_error msg ->
+ if config.cache_verbose then
+ Lsp_io.pretty_notification "Failed to read cache for %s: %s"
+ cached_doc.doc_cache_filename msg ~log:true ~type_:Info;
+ docs
+ | e ->
+ Lsp_io.pretty_notification "Failed to read cache for %s: %a"
+ cached_doc.doc_cache_filename Fmt.exn e ~log:true ~type_:Warning;
+ docs
+ end cached_docs URIMap.empty
+
+let load ~rootdir ~layout ~config =
+ let fallback = URIMap.empty in
+ let cache_file = cache_filename ~config ~rootdir in
+ try
+ let cached_project = Lsp_utils.read_from cache_file read_project_cache in
+ let project = load_project ~rootdir ~layout ~config cached_project in
+ Lsp_io.pretty_notification "Successfully read cache for %s"
+ (Lsp_project.string_of_rootdir rootdir) ~log:true ~type_:Info;
+ project
+ with
+ | Failure msg | Sys_error msg ->
+ if config.cache_verbose then
+ Lsp_io.pretty_notification "Failed to read cache file %s: %s"
+ cache_file msg ~log:true ~type_:Info;
+ fallback
+ | e ->
+ Lsp_io.pretty_notification "Failed to read cache file %s: %a"
+ cache_file Fmt.exn e ~log:true ~type_:Warning;
+ fallback
diff --git a/src/lsp/cobol_lsp/lsp_project_cache.mli b/src/lsp/cobol_lsp/lsp_project_cache.mli
new file mode 100644
index 000000000..75312de99
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_project_cache.mli
@@ -0,0 +1,56 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+
+module TYPES: sig
+ type config =
+ {
+ (** Name of cache file, relative to project root directory. *)
+ cache_relative_filename: string;
+ cache_verbose: bool;
+ }
+end
+include module type of TYPES
+ with type config = TYPES.config
+
+(** [save ~config docs] saves the caches of all the given document's
+ projects.
+
+ For any project [p] of which at least one document belongs to [docs], any
+ document of [p] that does not belong to [docs] is removed from [p]'s
+ cache.
+
+ Some notifications about the saving process may be pushed via
+ {!Lsp_io.send_notification}. May raise some IO-related exceptions
+ ({!Sys_error}, {!Failure}). *)
+val save
+ : config: TYPES.config
+ -> Lsp_document.t URIMap.t
+ -> unit
+
+(** [load ~rootdir ~config ~layout] pre-loads cached documents pertaining to a
+ project located in [rootdir], with project directory layout [layout].
+
+ All projects in the returned map belong to the same project. Note this map
+ may actually be empty (for instance in case of missing, out-dated cache
+ files, or cache files for a different version of the library).
+
+ Some notifications about the loading process may be pushed via
+ {!Lsp_io.send_notification}. May raise some IO-related exceptions
+ ({!Sys_error}, {!Failure}). *)
+val load
+ : rootdir:Lsp_project.rootdir
+ -> layout: Lsp_project.layout
+ -> config: TYPES.config
+ -> Lsp_document.t URIMap.t
diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml
new file mode 100644
index 000000000..9de767d0e
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_request.ml
@@ -0,0 +1,379 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Lsp_imports
+open Lsp_project.TYPES
+open Lsp_server.TYPES
+open Lsp_lookup.TYPES
+open Lsp.Types
+open Ez_file.V1
+
+
+(** Some preliminary utilities for manipulating source locations *)
+
+type loc_translator =
+ {
+ location_of_srcloc: srcloc -> Location.t;
+ location_of: 'x. 'x with_loc -> Location.t;
+ }
+
+let loc_translator TextDocumentIdentifier.{ uri } =
+ let filename = Lsp.Uri.to_path uri in
+ let location_of_srcloc loc =
+ let range = Lsp_position.range_of_srcloc_in ~filename loc in
+ Location.create ~uri ~range
+ in
+ {
+ location_of_srcloc;
+ location_of = fun { loc; _ } -> location_of_srcloc loc;
+ }
+
+
+(** Catching cases where we miss some document data *)
+
+let try_with_document_data ?(on_error = None) ~f registry document_id =
+ try
+ let Lsp_document.{ project; textdoc; pplog; tokens; _ } as doc =
+ Lsp_server.find_document document_id registry in
+ f ~project ~textdoc ~pplog ~tokens @@ Lsp_document.retrieve_parsed_data doc
+ with e ->
+ Lsp_io.pretty_notification ~type_:Warning "Caught exception: %a" Fmt.exn e;
+ on_error
+
+(** Handling requests *)
+
+(* Client capabilities are to be used for special request response, for example
+ a definition request can be answered with a LocationLink iff the client
+ supports it.
+
+ NOTE: For now we don't use them because we don't have any special
+ response. *)
+let make_capabilities _ =
+ let sync =
+ TextDocumentSyncOptions.create ()
+ ~openClose:true
+ ~change:Incremental
+ in
+ let semantic =
+ let full = SemanticTokensOptions.create_full ~delta:false () in
+ let legend = SemanticTokensLegend.create
+ ~tokenTypes:Lsp_semantic.tokens_types
+ ~tokenModifiers:Lsp_semantic.tokens_modifiers
+ in
+ SemanticTokensOptions.create ()
+ ~full:(`Full full) ~legend
+ in
+ let hover = HoverOptions.create () in
+ let completion_option = CompletionOptions.create () in
+
+ ServerCapabilities.create ()
+ ~textDocumentSync:(`TextDocumentSyncOptions sync)
+ ~definitionProvider:(`Bool true)
+ ~referencesProvider:(`Bool true)
+ ~documentRangeFormattingProvider: (`Bool true)
+ ~documentFormattingProvider: (`Bool true)
+ ~semanticTokensProvider:(`SemanticTokensOptions semantic)
+ ~hoverProvider:(`HoverOptions hover)
+ ~completionProvider:(completion_option)
+
+let handle_initialize (params: InitializeParams.t) =
+ InitializeResult.create ()
+ ~capabilities:(make_capabilities params.capabilities)
+
+let find_definitions { location_of; _ } cu_name qn defs =
+ let location_of_item { item_definition; _ } =
+ match item_definition.payload with
+ | CondName {condition_name = name; _}
+ | Renames {rename_to = name; _}->
+ location_of name
+ | Constant {constant_name = Some name; _}
+ | Data {data_name = Some name; _}
+ | Screen {screen_data_name = Some name; _}
+ | ReportGroup {report_data_name = Some name; _} ->
+ location_of name
+ | _ -> raise Not_found
+ in
+ try
+ let _cu, cu_defs = CUMap.find_by_name cu_name defs in
+ let { as_item; as_paragraph } = Cobol_data.Qualmap.find qn cu_defs in
+ Option.((to_list @@ map location_of_item as_item) @
+ (to_list @@ map location_of as_paragraph))
+ with Not_found -> []
+
+let lookup_definition_in_doc
+ DefinitionParams.{ textDocument = doc; position; _ }
+ Lsp_document.{ ast = ptree; definitions = defs; _ }
+ =
+ match Lsp_lookup.names_at_position ~uri:doc.uri position ptree with
+ | { qualname_at_position = None; _ }
+ | { enclosing_compilation_unit_name = None; _ } ->
+ None
+ | { qualname_at_position = Some qn;
+ enclosing_compilation_unit_name = Some cu_name } ->
+ let defs = Lazy.force defs in
+ let loc_translator = loc_translator doc in
+ Some (`Location (find_definitions loc_translator cu_name qn defs))
+
+let handle_definition registry (params: DefinitionParams.t) =
+ try_with_document_data registry params.textDocument
+ ~f:(fun ~project:_ ~textdoc:_ ~pplog:_ ~tokens:_ ->
+ lookup_definition_in_doc params)
+
+let lookup_references_in_doc
+ ReferenceParams.{ textDocument = doc; position; context; _ }
+ Lsp_document.{ ast = ptree; definitions = defs; references = refs; _ }
+ =
+ match Lsp_lookup.names_at_position ~uri:doc.uri position ptree with
+ | { enclosing_compilation_unit_name = None; _ } ->
+ None
+ | { qualname_at_position = qn;
+ enclosing_compilation_unit_name = Some cu_name } ->
+ let { location_of_srcloc; _ } as loc_translator = loc_translator doc in
+ let def_locs =
+ match qn with
+ | Some qn when context.includeDeclaration ->
+ find_definitions loc_translator cu_name qn (Lazy.force defs)
+ | Some _ | None ->
+ []
+ in
+ let ref_locs =
+ try
+ match qn with
+ | None -> []
+ | Some qn ->
+ let refs = Lazy.force refs in
+ let _cu, cu_refs = CUMap.find_by_name cu_name refs in
+ List.map location_of_srcloc
+ (Cobol_data.Qualmap.find qn cu_refs)
+ with Not_found -> []
+ in
+ Some (def_locs @ ref_locs)
+
+let handle_references state (params: ReferenceParams.t) =
+ try_with_document_data state params.textDocument
+ ~f:(fun ~project:_ ~textdoc:_ ~pplog:_ ~tokens:_ ->
+ lookup_references_in_doc params)
+
+
+(*Remark:
+ The first line of the text selected to RangeFormatting must be
+ the begin of statement/paragraph/section/division/01 level data declaration,
+ and the text selected must terminate in the same scope.
+ Otherwise, unexpected result.
+*)
+let handle_range_formatting registry params =
+ let open DocumentRangeFormattingParams in
+ let { textDocument = doc; range = {start; end_}; _ } = params in
+ let Lsp_document.{ project; _ } = Lsp_server.find_document doc registry in
+ let range_to_indent =
+ Cobol_indent.Type.{
+ start_line = start.line + 1;
+ end_line = end_.line + 1
+ }
+ in
+ (*the range must contain the whole lines*)
+ let range =
+ (*TODO:find a simple method to get the number of letters of one line
+ (the code below use 1000 as the upperbound) *)
+ Range.{
+ start = Position.create ~line:start.line ~character:0;
+ end_ = Position.create ~line:end_.line ~character:1000;
+ }
+ in
+ let newText =
+ Cobol_indent.indent_range'
+ ~source_format:project.source_format
+ ~indent_config:None
+ ~file:(Lsp.Uri.to_path doc.uri)
+ ~range:(Some range_to_indent)
+ in
+ Some [TextEdit.create ~newText ~range]
+
+let handle_formatting registry params =
+ let DocumentFormattingParams.{ textDocument = doc; _ } = params in
+ let Lsp_document.{ project; textdoc; _ } =
+ Lsp_server.find_document doc registry in
+ let lines = String.split_on_char '\n' (Lsp.Text_document.text textdoc) in
+ let length = List.length lines - 1 in
+ (* TODO: formatting on empty files will break here *)
+ let width = String.length @@ List.hd @@ List.rev lines in
+ let edit_range =
+ Range.create
+ ~start:(Position.create ~character:0 ~line:0)
+ ~end_:(Position.create ~character:width ~line:length)
+ in
+ let path = Lsp.Uri.to_path doc.uri in
+ let newText =
+ Cobol_indent.indent_range'
+ ~source_format:project.source_format
+ ~indent_config:None
+ ~file:path
+ ~range:None
+ in
+ Some [TextEdit.create ~newText ~range:edit_range]
+
+let handle_semantic_tokens_full registry (params: SemanticTokensParams.t) =
+ try_with_document_data registry params.textDocument
+ ~f:begin fun ~project:_ ~textdoc:_ ~pplog:_ ~tokens Lsp_document.{ ast; _ } ->
+ let filename = Lsp.Uri.to_path params.textDocument.uri in
+ let data = Lsp_semantic.data ~filename (Lazy.force tokens) ast in
+ Some (SemanticTokens.create ~data ())
+ end
+
+let handle_hover registry (params: HoverParams.t) =
+ let filename = Lsp.Uri.to_path params.textDocument.uri in
+ let find_hovered_replacement pplog =
+ List.find_opt begin fun Cobol_preproc.{ matched_loc; _ } ->
+ Lsp_position.is_in_lexloc params.position
+ (Cobol_common.Srcloc.lexloc_in ~filename matched_loc)
+ end pplog
+ in
+ let hover_markdown ~loc value =
+ let content = MarkupContent.create ~kind:MarkupKind.Markdown ~value in
+ let range = Lsp_position.range_of_srcloc_in ~filename loc in
+ Some (Hover.create () ~contents:(`MarkupContent content) ~range)
+ in
+ try_with_document_data registry params.textDocument
+ ~f:begin fun ~project ~textdoc:_ ~pplog ~tokens:_ { ast; _ } ->
+ match Lsp_lookup.copy_at_pos ~filename params.position ast with
+ | Some { payload = lib; loc } ->
+ let text = EzFile.read_file lib in
+ (* TODO: grab source-format from preprocessor state? *)
+ let module Config = (val project.cobol_config) in
+ let mdlang = match Config.format#value with
+ | SF (SFFree | SFVariable | SFCOBOLX) -> "cobolfree"
+ | SF _ | Auto -> "cobol"
+ in
+ Pretty.string_to (hover_markdown ~loc) "```%s\n%s\n```" mdlang text
+ | None ->
+ match find_hovered_replacement pplog with
+ | None -> None
+ | Some Cobol_preproc.{ matched_loc = loc; replacement_text; _ } ->
+ Pretty.string_to (hover_markdown ~loc) "``@[%a@]``"
+ Cobol_preproc.Text.pp_text replacement_text
+ end
+
+let handle_completion registry (params:CompletionParams.t) =
+ let open Lsp_completion in
+ try_with_document_data registry params.textDocument
+ ~f:begin fun ~project:_ ~textdoc ~pplog:_ ~tokens:_ { ast; _ } ->
+ let items = completion_items textdoc params.position ast in
+ let completionlist = CompletionList.create ~isIncomplete:false ~items () in
+ Some (`CompletionList completionlist)
+ end
+
+let handle_shutdown registry =
+ try Lsp_server.save_project_caches registry
+ with e -> Pretty.error "Exception caught while saving project caches: %a@.\
+ " Fmt.exn e
+
+let on_request
+ : type r. state -> r Lsp.Client_request.t ->
+ id:Jsonrpc.Id.t -> (r * state, r error) result =
+ fun state client_req ~id:_ ->
+ match state, client_req with
+ | NotInitialized config, Lsp.Client_request.Initialize init_params ->
+ Ok (handle_initialize init_params, Initialized config)
+ | NotInitialized _, _ ->
+ Error (InvalidStatus state)
+ | (ShuttingDown | Initialized _ | Exit _) as state, _ ->
+ Error (InvalidStatus state)
+ | Running registry, _ -> match client_req with
+ | Initialize _ ->
+ Error (InvalidStatus (Running registry))
+ | TextDocumentDefinition def_params ->
+ Ok (handle_definition registry def_params, state)
+ | TextDocumentReferences ref_params ->
+ Ok (handle_references registry ref_params, state)
+ | TextDocumentRangeFormatting params ->
+ Ok (handle_range_formatting registry params, state)
+ | TextDocumentFormatting params ->
+ begin try Ok (handle_formatting registry params, state)
+ with Failure msg -> Error (FormattingError msg) end
+ | SemanticTokensFull semantic_params ->
+ Ok (handle_semantic_tokens_full registry semantic_params, state)
+ | TextDocumentHover hover_params ->
+ Ok (handle_hover registry hover_params, state)
+ | TextDocumentCompletion completion_params ->
+ Ok (handle_completion registry completion_params, state)
+ | Shutdown ->
+ Ok (handle_shutdown registry, ShuttingDown)
+ | TextDocumentDeclaration (* TextDocumentPositionParams.t.t *) _
+ | TextDocumentTypeDefinition (* TypeDefinitionParams.t.t *) _
+ | TextDocumentImplementation (* ImplementationParams.t.t *) _
+ | TextDocumentCodeLens (* CodeLensParams.t.t *) _
+ | TextDocumentCodeLensResolve (* CodeLens.t.t *) _
+ | TextDocumentPrepareCallHierarchy (* CallHierarchyPrepareParams.t.t *) _
+ | TextDocumentPrepareRename (* PrepareRenameParams.t.t *) _
+ | TextDocumentRename (* RenameParams.t.t *) _
+ | TextDocumentLink (* DocumentLinkParams.t.t *) _
+ | TextDocumentLinkResolve (* DocumentLink.t.t *) _
+ | TextDocumentMoniker (* MonikerParams.t.t *) _
+ | DocumentSymbol (* DocumentSymbolParams.t.t *) _
+ | WorkspaceSymbol (* WorkspaceSymbolParams.t.t *) _
+ | DebugEcho (* DebugEcho.Params.t *) _
+ | DebugTextDocumentGet (* DebugTextDocumentGet.Params.t *) _
+ | TextDocumentHighlight (* DocumentHighlightParams.t.t *) _
+ | TextDocumentFoldingRange (* FoldingRangeParams.t.t *) _
+ | SignatureHelp (* SignatureHelpParams.t.t *) _
+ | CodeAction (* CodeActionParams.t.t *) _
+ | CodeActionResolve (* CodeAction.t.t *) _
+ | CompletionItemResolve (* CompletionItem.t.t *) _
+ | WillSaveWaitUntilTextDocument (* WillSaveTextDocumentParams.t.t *) _
+ | TextDocumentOnTypeFormatting (* DocumentOnTypeFormattingParams.t.t *) _
+ | TextDocumentColorPresentation (* ColorPresentationParams.t.t *) _
+ | TextDocumentColor (* DocumentColorParams.t.t *) _
+ | SelectionRange (* SelectionRangeParams.t.t *) _
+ | ExecuteCommand (* ExecuteCommandParams.t.t *) _
+ | SemanticTokensDelta (* SemanticTokensDeltaParams.t.t *) _
+ | SemanticTokensRange (* SemanticTokensRangeParams.t.t *) _
+ | LinkedEditingRange (* LinkedEditingRangeParams.t.t *) _
+ | CallHierarchyIncomingCalls (* CallHierarchyIncomingCallsParams.t.t *) _
+ | CallHierarchyOutgoingCalls (* CallHierarchyOutgoingCallsParams.t.t *) _
+ | WillCreateFiles (* CreateFilesParams.t.t *) _
+ | WillDeleteFiles (* DeleteFilesParams.t.t *) _
+ | WillRenameFiles (* RenameFilesParams.t.t *) _
+ ->
+ Error (UnhandledRequest client_req)
+ | UnknownRequest { meth ; params=_ } ->
+ Error (UnknownRequest meth)
+
+let handle req state =
+ match Lsp.Client_request.of_jsonrpc req with
+ | Ok (E r) ->
+ let response, state =
+ match on_request state r ~id:req.id with
+ | Ok (reply, state) ->
+ let reply_json = Lsp.Client_request.yojson_of_result r reply in
+ Jsonrpc.Response.ok req.id reply_json, state
+ | Error server_error ->
+ let json_error =
+ Lsp_server.jsonrpc_of_error server_error req.method_ in
+ Jsonrpc.Response.error req.id json_error, state
+ | exception e ->
+ Jsonrpc.Response.error req.id @@ Jsonrpc.Response.Error.of_exn e, state
+ in
+ Lsp_io.send_response response;
+ state
+ | Error str ->
+ Pretty.failwith "Could not read request: %s" str
+
+module INTERNAL = struct
+ let lookup_definition = handle_definition
+ let lookup_definition_in_doc = lookup_definition_in_doc
+ let lookup_references = handle_references
+ let lookup_references_in_doc = lookup_references_in_doc
+ let hover = handle_hover
+ let formatting = handle_formatting
+end
diff --git a/src/lsp/cobol_lsp/lsp_request.mli b/src/lsp/cobol_lsp/lsp_request.mli
new file mode 100644
index 000000000..2bd0cbbf5
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_request.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val handle: Jsonrpc.Request.t -> (Lsp_server.state as 's) -> 's
+
+module INTERNAL: sig
+ val lookup_definition
+ : Lsp_server.t
+ -> Lsp.Types.DefinitionParams.t
+ -> [> `Location of Lsp.Types.Location.t list ] option
+ val lookup_definition_in_doc
+ : Lsp.Types.DefinitionParams.t
+ -> Lsp_document.parsed_data
+ -> [> `Location of Lsp.Types.Location.t list ] option
+ val lookup_references
+ : Lsp_server.t
+ -> Lsp.Types.ReferenceParams.t
+ -> Lsp.Types.Location.t list option
+ val lookup_references_in_doc
+ : Lsp.Types.ReferenceParams.t
+ -> Lsp_document.parsed_data
+ -> Lsp.Types.Location.t list option
+ val hover
+ : Lsp_server.t
+ -> Lsp.Types.HoverParams.t
+ -> Lsp.Types.Hover.t option
+ val formatting
+ : Lsp_server.t
+ -> Lsp.Types.DocumentFormattingParams.t
+ -> Lsp.Types.TextEdit.t list option
+end
diff --git a/src/lsp/cobol_lsp/lsp_semantic.ml b/src/lsp/cobol_lsp/lsp_semantic.ml
new file mode 100644
index 000000000..723d52e9e
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_semantic.ml
@@ -0,0 +1,622 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Cobol_common (* Srcloc, Visitor *)
+open Cobol_common.Srcloc.INFIX
+open Cobol_parser.Grammar_tokens
+
+type semantic_token = {
+ line: int;
+ start: int;
+ length: int;
+ token_type: string;
+ token_modifiers: string list;
+}
+
+let tokens_types = [
+ "type";
+ "operator";
+ "variable";
+ "function";
+ "parameter";
+ "keyword";
+ "string";
+ "number";
+ "namespace";
+ "decorator";
+ "modifier";
+ "comment";
+ (* "class"; *)
+ (* "enum"; *)
+ (* "interface"; *)
+ (* "struct"; *)
+ (* "typeParameter"; *)
+ (* "property"; *)
+ (* "enumMember"; *)
+ (* "event"; *)
+ (* "method"; *)
+ (* "macro"; *)
+ (* "regexp"; *)
+]
+
+let tokens_modifiers = [
+ "declaration";
+ "definition";
+ "readonly";
+ "modification";
+ "defaultLibrary";
+(*"static";
+ "deprecated";
+ "abstract";
+ "async";
+ "documentation";*)
+]
+
+let semantic_token lexloc token_type token_modifiers =
+ let range = Lsp_position.range_of_lexloc lexloc in
+ let line = range.start.line in
+ let start = range.start.character in
+ let length = range.end_.character - start in
+ { line; start; length; token_type; token_modifiers }
+
+type token_type =
+ | ProgramName
+ | ParagraphName
+ | ProcName
+ | Parameter
+ | DataDecl
+ | DataLevel
+ | Var
+ | VarModif
+ | ReportName
+ | ExceptionName
+ | MnemonicName
+ | FileName
+
+let semantic_visitor ~filename =
+ let open Cobol_parser.PTree_visitor in
+ let open Cobol_ast.Terms_visitor in
+ let open Cobol_ast.Operands_visitor in
+ let open Cobol_common.Visitor in
+
+ let semantic_token_of lexloc token_type =
+ let semantic_token_of lexloc (token_type, token_modifiers) =
+ semantic_token lexloc token_type token_modifiers
+ in
+ semantic_token_of lexloc @@ match token_type with
+ | ProgramName -> "string", ["definition"; "readonly"]
+ | ParagraphName -> "function", ["definition"]
+ | ProcName -> "function", []
+ | Parameter -> "parameter", []
+ | DataDecl -> "variable", ["declaration"]
+ | DataLevel -> "decorator", []
+ | Var -> "variable", []
+ | VarModif -> "variable", ["modification"]
+ | ReportName
+ | ExceptionName
+ | MnemonicName
+ | FileName -> "variable", ["readonly"]
+ in
+ let add_name' name token_type acc =
+ match Srcloc.lexloc_in ~filename ~@name with
+ | lexloc -> List.cons (semantic_token_of lexloc token_type) acc
+ | exception Invalid_argument _ -> acc
+ in
+ let rec add_qualname (qn:Cobol_ast.qualname) token_type acc =
+ match qn with
+ | Name name ->
+ add_name' name token_type acc
+ | Qual (name, qn) ->
+ add_name' name token_type acc |> add_qualname qn token_type
+ in
+ let add_ident (id:Cobol_ast.ident) token_type acc =
+ match id with
+ | QualIdent {ident_name; _} -> add_qualname ident_name token_type acc
+ | _ -> acc (* TODO *)
+ in
+ let add_ident' id = add_ident ~&id in
+ let add_list add_fun l token_type acc =
+ List.fold_left (fun acc n -> add_fun n token_type acc) acc l
+ in
+ let add_option add_fun v token_type acc =
+ match v with
+ | None -> acc
+ | Some v -> add_fun v token_type acc
+ in
+
+ Cobol_parser.PTree_visitor.fold_compilation_group (object (self)
+ inherit [semantic_token List.t] Cobol_parser.PTree_visitor.folder
+
+ (* program-name *)
+ method! fold_program_unit {program_name; _} acc = acc
+ |> add_name' program_name ProgramName
+ |> Visitor.do_children
+ (* we call do_children, so we must ensure that
+ the fold_name' does nothing,
+ otherwise, there will be token overlap.
+
+ Or we can override this method fold_program_unit to explicitly
+ fold its every child and return Visitor.skip_children x.
+ But by doing that for every method(which we need to override),
+ we have to write a great amount of code... like rewriting
+ the code of Cobol_ast.
+
+ *)
+
+ (*TODO: File/Report section*)
+
+ (* data-name *)
+ method! fold_data_name data_name acc =
+ match data_name with
+ | DataName n -> acc
+ |> add_name' n DataDecl
+ |> Visitor.skip_children
+ | _ ->
+ Visitor.do_children acc
+
+ method! fold_rename_item {rename_level; rename_to;
+ rename_renamed; rename_through } acc = acc
+ |> add_name' rename_to DataDecl
+ (*|> Visitor.do_children*)
+ (* We can remove the code below and return do_children directly*)
+ |> fold_data_level' self rename_level
+ |> fold_qualname self rename_renamed
+ |> fold_qualname_opt self rename_through
+ |> Visitor.skip_children
+
+ method! fold_condition_name_item { condition_name_level;
+ condition_name;
+ condition_name_values;
+ condition_name_alphabet;
+ condition_name_when_false } acc = acc
+ |> add_name' condition_name DataDecl
+ (*|> Visitor.do_children *)
+ |> fold_data_level' self condition_name_level
+ |> fold_list ~fold:fold_condition_name_value self condition_name_values
+ |> fold_name'_opt self condition_name_alphabet
+ |> fold_literal_opt self condition_name_when_false
+ |> Visitor.skip_children
+
+ method! fold_data_clause dc acc =
+ match dc with
+ | DataRedefines name -> acc
+ |> add_name' name Var
+ |> Visitor.skip_children
+ | _ ->
+ Visitor.skip_children acc (*Not implmented*)
+
+ (* data-level *)
+ (* TODO: condition_name ??*)
+ method! fold_data_level' dl acc = acc
+ |> add_name' dl DataLevel
+ |> Visitor.skip_children
+
+ (* paragraph name *)
+ method! fold_paragraph { paragraph_name; paragraph_is_section;
+ paragraph_segment; paragraph_sentences } acc =
+ ignore paragraph_is_section; acc
+ |> add_option add_name' paragraph_name ParagraphName
+ (*|> Visitor.do_children*)
+ |> fold_integer_opt self paragraph_segment
+ |> fold_list ~fold:(fun v -> v#continue_with_statements') self paragraph_sentences
+ |> Visitor.skip_children
+
+ (* procedure using *)
+ method! fold_using_by_reference { using_by_reference;
+ using_by_reference_optional } acc = acc
+ |> add_name' using_by_reference Parameter
+ (*|> Visitor.do_children*)
+ |> fold_bool self using_by_reference_optional
+ |> Visitor.skip_children
+
+ method! fold_using_clause = function
+ | UsingByReference _ ->
+ Visitor.do_children
+ | UsingByValue l -> fun x -> x
+ |> add_list add_name' l Parameter
+ |> Visitor.skip_children
+
+ (* inline call of function *)
+ method! fold_inline_call { call_fun; call_args; call_refmod } acc = acc
+ |> add_name' call_fun ProcName
+ |> fold_list ~fold:fold_effective_arg self call_args
+ |> fold_option ~fold:fold_refmod self call_refmod
+ |> Visitor.skip_children
+
+ (* Statement *)
+ (* distinguish
+ 1 variable
+ 2 variable modified
+ 3 procedure-name
+ 4 report-name/file-name/exception-name/mnemonic-name *)
+ (*TODO: maybe finer analysis*)
+
+ method! fold_accept' {payload = accept_stmt; _} acc =
+ match accept_stmt with
+ | AcceptFromDevice { item; device_item } -> acc
+ |> add_name' device_item MnemonicName
+ (*|> Visitor.do_children*)
+ |> fold_ident' self item
+ |> Visitor.skip_children
+ | AcceptGeneric _
+ | AcceptTemporal _
+ | AcceptMsgCount _
+ | AcceptAtScreen _
+ | AcceptFromEnv _ ->
+ Visitor.do_children acc
+
+ method! fold_allocate' {payload = { allocate_kind;
+ allocate_initialized;
+ allocate_returning }; _ } acc = acc
+ |> fold_allocate_kind self allocate_kind
+ |> fold_bool self allocate_initialized
+ |> add_option add_ident' allocate_returning VarModif
+ |> Visitor.skip_children
+
+ (*TODO: Alter *)
+
+ method! fold_call' {payload = { call_prefix; call_using;
+ call_returning;
+ call_error_handler }; _} acc = acc
+ |> fold_call_prefix self call_prefix
+ |> fold_list ~fold:fold_call_using_clause' self call_using
+ |> add_option add_ident' call_returning VarModif
+ |> fold_option ~fold:fold_call_error_handler self call_error_handler
+ |> Visitor.skip_children
+
+ (*TODO: Cancel *)
+
+ method! fold_close_phrase { close_item; close_format} acc = acc
+ |> add_name' close_item FileName
+ (*|> Visitor.do_children*)
+ |> fold_option ~fold:fold_close_format self close_format
+ |> Visitor.skip_children
+
+ (* Add Compute Divide Multiply Subtract *)
+ method! fold_rounded_ident { rounded_ident; rounded_rounding } acc = acc
+ |> add_ident rounded_ident VarModif
+ |> fold_rounding self rounded_rounding
+ |> Visitor.skip_children
+
+ method! fold_delete' {payload = { delete_targets; delete_retry;
+ delete_on_invalid_key }; _} acc = acc
+ |> add_name' delete_targets FileName
+ (*|> Visitor.do_children*)
+ |> fold_option ~fold:fold_retry_clause self delete_retry
+ |> fold_dual_handler self delete_on_invalid_key
+ |> Visitor.skip_children
+
+ method! fold_display' { payload; _ } acc =
+ Visitor.do_children_and_then acc @@ match payload with
+ | DisplayDevice { upon = Some { payload = DisplayUponName n; _ }; _ } ->
+ add_name' n MnemonicName
+ | _ ->
+ Fun.id
+
+ (*TODO: Exit *)
+
+ method! fold_free' names acc = acc
+ |> add_list add_name' ~&names VarModif
+ |> Visitor.skip_children
+
+ method! fold_generate' name acc = acc
+ |> add_name' ~&name VarModif
+ |> Visitor.skip_children
+
+ method! fold_goto' {payload = goto_target; _} acc = acc
+ |> add_qualname goto_target ProcName
+ |> Visitor.skip_children
+
+ method! fold_goto_depending' {payload = { goto_depending_targets;
+ goto_depending_on }; _} acc = acc
+ |> add_list add_qualname goto_depending_targets ProcName
+ |> fold_ident self goto_depending_on
+ |> Visitor.skip_children
+
+ method! fold_initialize' {payload = { init_items; init_filler; init_category;
+ init_replacings; init_to_default }; _} acc = acc
+ |> add_list add_ident init_items VarModif
+ |> fold_bool self init_filler
+ |> fold_option ~fold:fold_init_category self init_category
+ |> fold_list ~fold:fold_init_replacing self init_replacings
+ |> fold_bool self init_to_default
+ |> Visitor.skip_children
+
+ method! fold_initiate' { payload = names; _} acc = acc
+ |> add_list add_name' names ReportName
+ |> Visitor.skip_children
+
+ method! fold_tallying { tallying_target; tallying_clauses } acc = acc
+ |> add_qualname tallying_target.ident_name VarModif
+ |> fold_list ~fold:fold_tallying_clause' self tallying_clauses
+ |> Visitor.skip_children
+
+ method! fold_inspect' { payload = { inspect_item; inspect_spec }; _} acc = acc
+ |> add_ident inspect_item VarModif
+ |> fold_inspect_spec self inspect_spec
+ |> Visitor.skip_children
+
+ (*TODO: Invoke *)
+
+ method! fold_move' {payload = move_stmt; _} acc =
+ match move_stmt with
+ | MoveSimple { from; to_ } -> acc
+ |> fold_ident_or_literal self from
+ |> add_list add_ident to_ VarModif
+ |> Visitor.skip_children
+ | MoveCorresponding { from; to_ } -> acc
+ |> fold_ident self from
+ |> add_list add_ident to_ VarModif
+ |> Visitor.skip_children
+
+ method! fold_named_file_option {named_file_name;
+ named_file_option} acc = acc
+ |> add_name' named_file_name FileName
+ (*|> Visitor.do_children*)
+ |> fold_option ~fold:fold_file_option self named_file_option
+ |> Visitor.skip_children
+
+ method! fold_perform_target perform_target acc =
+ match perform_target with
+ | PerformOutOfLine { procedure_start; procedure_end } -> acc
+ |> add_qualname procedure_start ProcName
+ |> add_option add_qualname procedure_end ProcName
+ |> Visitor.skip_children
+ | PerformInline _ ->
+ Visitor.do_children acc
+
+ method! fold_varying_phrase { varying_ident; varying_from;
+ varying_by; varying_until } acc = acc
+ |> add_ident varying_ident VarModif
+ |> fold_ident_or_numlit self varying_from
+ |> fold_option ~fold:fold_ident_or_numlit self varying_by
+ |> fold_condition self varying_until
+ |> Visitor.skip_children
+
+ method! fold_raise' {payload = raise_stmt; _} acc =
+ match raise_stmt with
+ | RaiseIdent _ -> Visitor.do_children acc
+ | RaiseException name -> acc
+ |> add_name' name ExceptionName
+ |> Visitor.skip_children
+
+ method! fold_read' {payload = { read_file; read_direction;
+ read_into; read_lock_behavior;
+ read_lock; read_key;
+ read_error_handler }; _} acc = acc
+ |> add_name' read_file FileName
+ |> fold_option ~fold:fold_read_direction self read_direction
+ |> add_option add_ident read_into VarModif
+ |> fold_option ~fold:fold_read_lock_behavior self read_lock_behavior
+ |> fold_option ~fold:fold_bool self read_lock
+ |> fold_option ~fold:fold_qualname self read_key
+ |> fold_option ~fold:fold_read_error_handler self read_error_handler
+ |> Visitor.skip_children
+
+ (* TODO: RELEASE *)
+
+ method! fold_resume' {payload = qn; _} acc = acc
+ |> add_qualname qn ProcName
+ |> Visitor.skip_children
+
+ method! fold_return' {payload = {return_file; return_into;
+ return_at_end}; _} acc = acc
+ |> add_name' return_file FileName
+ |> add_option add_ident' return_into VarModif
+ |> fold_dual_handler self return_at_end
+ |> Visitor.skip_children
+
+ method! fold_write_target write_target acc =
+ match write_target with
+ | WriteTargetName _ -> Visitor.do_children acc
+ | WriteTargetFile name -> acc
+ |> add_name' name FileName
+ |> Visitor.skip_children
+
+ method! fold_search_spec search_spec acc =
+ match search_spec with
+ | SearchSerial { varying; when_clauses } -> acc
+ |> add_option add_ident varying VarModif
+ |> fold_list ~fold:fold_search_when_clause' self when_clauses
+ |> Visitor.skip_children
+ | SearchAll _ -> Visitor.do_children acc
+
+ method! fold_set_switch_spec {set_switch_targets;
+ set_switch_value } acc = acc
+ |> add_list add_ident set_switch_targets MnemonicName (*TODO: ident??*)
+ |> fold_on_off self set_switch_value
+ |> Visitor.skip_children
+
+ method! fold_set_condition_spec { set_condition_targets;
+ set_condition_value } acc = acc
+ |> add_list add_ident set_condition_targets VarModif
+ |> fold_bool self set_condition_value
+ |> Visitor.skip_children
+
+ method! fold_set' {payload = set_stmt;_ } acc =
+ match set_stmt with
+ | SetAmbiguous { targets; set_method; value} -> acc
+ |> add_list add_ident targets VarModif
+ |> fold_set_ambiguous_method self set_method
+ |> fold_expression self value
+ |> Visitor.skip_children
+ | SetSwitch _ (*TODO*)
+ | SetCondition _
+ | SetAttribute _
+ | SetLocale _
+ | SetSavedException ->
+ Visitor.do_children acc
+ | SetSaveLocale { target; locale } -> acc
+ |> add_ident target VarModif
+ |> fold_set_save_locale self locale
+ |> Visitor.skip_children
+ | SetFloatContent { targets; content; sign } -> acc
+ |> add_list add_ident targets VarModif
+ |> fold_float_content self content
+ |> fold_option ~fold:fold_sign self sign
+ |> Visitor.skip_children
+
+ method! fold_start' {payload = {start_file; start_position;
+ start_on_invalid_key }; _} acc = acc
+ |> add_name' start_file FileName
+ (*|> Visitor.do_children*)
+ |> fold_option ~fold:fold_start_position self start_position
+ |> fold_dual_handler self start_on_invalid_key
+ |> Visitor.skip_children
+
+ method! fold_string_stmt' {payload = {string_sources;
+ string_target;
+ string_pointer;
+ string_on_overflow}; _} acc = acc
+ |> add_ident string_target VarModif
+ |> fold_list ~fold:fold_string_source self string_sources
+ |> fold_option ~fold:fold_ident self string_pointer
+ |> fold_dual_handler self string_on_overflow
+ |> Visitor.skip_children
+
+ method! fold_terminate' {payload = names; _} acc = acc
+ |> add_list add_name' names ReportName
+ |> Visitor.skip_children
+
+ method! fold_unlock' {payload = { unlock_file; unlock_record }; _} acc = acc
+ |> add_name' unlock_file FileName
+ (*|> Visitor.do_children*)
+ |> fold_bool self unlock_record
+ |> Visitor.skip_children
+
+ method! fold_unstring_target { unstring_target;
+ unstring_target_delimiter;
+ unstring_target_count} acc = acc
+ |> add_ident unstring_target VarModif
+ |> add_option add_ident unstring_target_delimiter VarModif
+ |> add_option add_ident unstring_target_count VarModif
+ |> Visitor.skip_children
+
+ (*TODO: Validate *)
+ (*TODO: Merge, Sort*)
+
+ (* All qualname not colored yet will be marked as normal variable *)
+ method! fold_qualname qn acc = acc
+ |> add_qualname qn Var
+ |> Visitor.skip_children
+
+ end)
+
+(** [make_non_ambigious tokens] returns tokens that do not need to have more analyzing to get their
+ type. *)
+let make_non_ambigious ~filename tokens = tokens |>
+ List.filter_map
+ (fun { payload; loc } ->
+ try Some (payload, Srcloc.lexloc_in ~filename loc) with _ -> None) |>
+ List.filter_map
+ (fun (token, lexloc) ->
+ match token with
+ | WORD _ | WORD_IN_AREA_A _ -> None
+ | ALPHANUM _ | ALPHANUM_PREFIX _ ->
+ Some (semantic_token lexloc "string" [])
+ | BOOLIT _
+ | HEXLIT _ | NULLIT _
+ | NATLIT _ | SINTLIT _
+ | FIXEDLIT _ | FLOATLIT _
+ | DIGITS _
+ | EIGHTY_EIGHT ->
+ Some (semantic_token lexloc "number" [])
+ | PICTURE_STRING _ ->
+ Some (semantic_token lexloc "type" ["declaration"])
+ (* | EQUAL | PLUS | MINUS *)
+ | AMPERSAND | ASTERISK | COLON | DASH_SIGN | DOUBLE_ASTERISK | DOUBLE_COLON
+ | EQ | GE | GT | LE | LPAR | LT | NE | PLUS_SIGN | RPAR | SLASH ->
+ Some (semantic_token lexloc "operator" [])
+ | PARAGRAPH | STATEMENT | PROGRAM |SECTION | DIVISION ->
+ Some (semantic_token lexloc "namespace" [])
+ | ACCEPT | ACCESS | ADD | ALLOCATE | ALTER | APPLY | ARE | ASSIGN | CALL | CANCEL | CHAIN | CLOSE
+ | COMMIT | COMPUTE | CONTINUE | CONTROL | CONTROLS | COPY | COPY_SELECTION | COUNT | CYCLE
+ | DELETE | DESTROY | DISABLE | DISP | DISPLAY | DISPLAY_1 | DISPLAY_COLUMNS | DISPLAY_FORMAT
+ | DIVIDE | ENABLE | ENSURE_VISIBLE | ENTER | ERASE | ESCAPE | EVALUATE | EXAMINE | EXHIBIT | EXIT
+ | FREE | GENERATE | GET | GO | GOBACK | GO_BACK | GO_FORWARD | GO_HOME | GO_SEARCH | IF | IGNORE
+ | INITIALIZE | INITIATE | INSPECT | INVOKE | LEAVE | LOCK | LOCK_HOLDING | MERGE | MODIFY | MOVE
+ | MULTIPLY | NOTIFY | NOTIFY_CHANGE | OPEN | OUTPUT | OVERRIDE | PARSE | PERFORM | PRINT
+ | PRINT_NO_PROMPT | PRINT_PREVIEW | PROCEED | PURGE | RAISE | READ | RECEIVE | REFRESH
+ | RELEASE | REPLACE | RERUN | RESERVE | RESET | RESUME | RETRY | RETURN | REWRITE | ROLLBACK
+ | SEARCH | SELECT | SELECT_ALL | SEND | SET | SORT | SORT_MERGE | SORT_ORDER | STDCALL | START
+ | STEP | STOP | STRING | SUBTRACT | SUPPRESS | TEST | TERMINATE | TRANSFORM | UNLOCK | UNSTRING
+ | UPDATE | USE | USE_ALT | USE_RETURN | USE_TAB | VALIDATE | VALIDATE_STATUS | WRAP | WRITE
+ | END_ACCEPT | END_ADD | END_CALL | END_COMPUTE | END_DELETE | END_DISPLAY | END_DIVIDE | END_EVALUATE
+ | END_IF | END_MULTIPLY | END_PERFORM | END_READ | END_RETURN | END_REWRITE | END_SEARCH | END_START
+ | END_STRING | END_SUBTRACT | END_UNSTRING | END_WRITE ->
+ Some (semantic_token lexloc "function" ["defaultLibrary";])
+ | _ ->
+ Some (semantic_token lexloc "keyword" []))
+
+let semantic_tbl = Hashtbl.create 16
+let () = List.iteri (fun i elt -> Hashtbl.add semantic_tbl elt i) tokens_types
+let index i = Hashtbl.find semantic_tbl i
+
+let tokens_modifiers_bit_flag = Hashtbl.create 8
+let () =
+ List.iteri (fun i v ->
+ Hashtbl.add tokens_modifiers_bit_flag
+ v (0b1 lsl i))
+ tokens_modifiers
+
+let token_modifiers_flag modifiers =
+ List.fold_left
+ (fun acc modifier ->
+ let modifier_flag = Hashtbl.find tokens_modifiers_bit_flag modifier in
+ acc lor modifier_flag)
+ 0b0
+ modifiers
+
+let data_of_semantic_token semantic_token =
+ let data = Array.make 5 0 in
+ data.(0) <- semantic_token.line;
+ data.(1) <- semantic_token.start;
+ data.(2) <- semantic_token.length;
+ data.(3) <- index semantic_token.token_type;
+ data.(4) <- token_modifiers_flag semantic_token.token_modifiers;
+ data
+
+let data_of_semantic_tokens semantic_tokens =
+ let data = Array.make (5 * List.length semantic_tokens) 0 in
+ ignore @@ List.fold_left
+ (fun (idx, last_line, last_start) semantic_token ->
+ let token_data = data_of_semantic_token semantic_token in
+ let delta_line = token_data.(0) - last_line in
+ let delta_start = if delta_line = 0 then
+ token_data.(1) - last_start
+ else
+ token_data.(1)
+ in
+ data.(5 * idx) <- delta_line;
+ data.(5 * idx + 1) <- delta_start;
+ data.(5 * idx + 2) <- token_data.(2);
+ data.(5 * idx + 3) <- token_data.(3);
+ data.(5 * idx + 4) <- token_data.(4);
+ (idx + 1, semantic_token.line, semantic_token.start))
+ (0, 0, 0)
+ semantic_tokens;
+ data
+
+let sort_semantic_token first second = (* TODO: use Lexing.position, and then a
+ comparison on `pos_cnum` only? *)
+ let cmp = Stdlib.compare first.line second.line in
+ if cmp = 0
+ then Stdlib.compare first.start second.start
+ else cmp
+
+let data ~filename tokens ptree : int array =
+ tokens
+ |> make_non_ambigious ~filename
+ |> semantic_visitor ~filename ptree
+ |> List.fast_sort sort_semantic_token
+ |> data_of_semantic_tokens
diff --git a/src/lsp/cobol_lsp/lsp_server.ml b/src/lsp/cobol_lsp/lsp_server.ml
new file mode 100644
index 000000000..8a413e542
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_server.ml
@@ -0,0 +1,200 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+open Lsp.Types
+
+module DIAGS = Cobol_common.Diagnostics
+
+module TYPES = struct
+
+ type config = {
+ project_layout: Lsp_project.layout;
+ cache_config: Lsp_project_cache.config;
+ }
+
+ type registry = { (* private *)
+ projects: Lsp_project.SET.t;
+ docs: Lsp_document.t URIMap.t;
+ indirect_diags: Lsp_diagnostics.t URIMap.t; (* diagnostics for other URIs
+ mentioned by docs in
+ `docs` *)
+ config: config;
+ }
+
+ type state =
+ | NotInitialized of config (* At startup and until "initialize" request *)
+ | Initialized of config (* After "initialize" and before "initialized" notif *)
+ | Running of registry (* After "initialized" and before "shutdown" *)
+ | ShuttingDown (* From "shuntdown" until "exit" notif *)
+ | Exit of exit_status (* After "exit" notif *)
+
+ and exit_status = (unit, string) result
+
+ type 'a error =
+ | InvalidStatus of state
+ | UnhandledRequest of 'a Lsp.Client_request.t
+ | UnknownRequest of string
+ | FormattingError of string
+
+end
+include TYPES
+
+type t = registry
+
+(* Code: *)
+
+let add_project proj r =
+ let projects = Lsp_project.SET.add proj r.projects in
+ if projects == r.projects then r else { r with projects }
+
+let add_or_replace_doc doc r =
+ let docs = URIMap.add (Lsp_document.uri doc) doc r.docs in
+ if docs == r.docs then r else { r with docs }
+
+(** {2 Handling of diagnostics for non-opened documents} *)
+
+let dispatch_diagnostics (Lsp_document.{ project; diags; _ } as doc) registry =
+ let uri = Lsp_document.uri doc in
+ let rootdir = Lsp_project.rootdir project in
+ let indirect4uri =
+ if diags <> DIAGS.Set.none
+ then URIMap.empty (* stick to the new diagnostics *)
+ else URIMap.filter (fun _ -> URIMap.mem uri) registry.indirect_diags
+ in
+ if URIMap.is_empty indirect4uri then begin
+ let all_diags =
+ Lsp_diagnostics.translate diags ~uri:(`Main uri)
+ ~rootdir:(Lsp_project.string_of_rootdir rootdir)
+ in
+ (* Note here we may publish diagnostics for non-opened documents. LSP
+ protocol does not seem to forbid that (but some editors just ignore
+ those). *)
+ Lsp_diagnostics.publish all_diags;
+ { registry with
+ indirect_diags =
+ (* Register published diagnostics for the other documents in case they
+ are opened in the future. *)
+ URIMap.merge (fun _ _ new_ -> new_) registry.indirect_diags @@
+ URIMap.singleton uri (URIMap.remove uri all_diags) }
+ end else begin (* publish indirect diagnostics for the doc instead *)
+ let all_diags =
+ URIMap.fold begin fun _main_uri ->
+ URIMap.union (fun _ a b -> Some (List.rev_append a b))
+ end indirect4uri URIMap.empty
+ in
+ Lsp_diagnostics.publish all_diags;
+ registry
+ end
+
+(** {2 Management of per-project caches} *)
+
+let save_project_caches { config = { cache_config = config; _ }; docs; _ } =
+ Lsp_project_cache.save ~config docs
+
+let load_project_cache ~rootdir ({ config = { project_layout = layout;
+ cache_config = config; _ };
+ projects; docs = old_docs; _ } as registry) =
+ let new_docs = Lsp_project_cache.load ~config ~layout ~rootdir in
+ let projects = match URIMap.choose_opt new_docs with
+ | Some (_, Lsp_document.{ project = p; _ }) -> Lsp_project.SET.add p projects
+ | None -> projects
+ and docs = URIMap.union (fun _ _old new_ -> Some new_) old_docs new_docs in
+ { registry with projects; docs }
+
+
+(** {2 Registry management} *)
+
+let init ~config : registry =
+ {
+ config;
+ projects = Lsp_project.SET.empty;
+ docs = URIMap.empty;
+ indirect_diags = URIMap.empty;
+ }
+
+let create_or_retrieve_project ~uri registry =
+ let layout = registry.config.project_layout in
+ let rootdir = Lsp_project.rootdir_for ~uri ~layout in
+ try Lsp_project.SET.for_rootdir ~rootdir registry.projects, registry
+ with Not_found ->
+ let project = Lsp_project.for_ ~rootdir ~layout in
+ project, add_project project registry
+
+let add (DidOpenTextDocumentParams.{ textDocument = { uri; text; _ };
+ _ } as doc) ?copybook registry =
+ (* Try first with a lookup for the project in a cache, and then by
+ creating/loading the project. *)
+ let rec aux ~try_cache registry =
+ match URIMap.find_opt uri registry.docs with
+ (* When opening, we need to check that the text we already have (in cache)
+ matches what the client gives us. *)
+ | Some doc when String.equal (Lsp.Text_document.text doc.textdoc) text ->
+ dispatch_diagnostics doc registry
+ | None | Some _ when try_cache ->
+ let registry =
+ let layout = registry.config.project_layout in
+ let rootdir = Lsp_project.rootdir_for ~uri ~layout in
+ if Lsp_project.SET.mem_rootdir ~rootdir registry.projects
+ then registry
+ else load_project_cache ~rootdir registry
+ in
+ aux ~try_cache:false registry (* try again without the cache *)
+ | None | Some _ ->
+ let project, registry = create_or_retrieve_project ~uri registry in
+ let doc = Lsp_document.load ~project ?copybook doc in
+ let registry = dispatch_diagnostics doc registry in
+ add_or_replace_doc doc registry
+ in
+ aux ~try_cache:true registry
+
+let update DidChangeTextDocumentParams.{ textDocument = { uri; _ };
+ contentChanges; _ } registry =
+ try
+ let doc = URIMap.find uri registry.docs in
+ let doc = Lsp_document.update doc contentChanges in
+ let registry = dispatch_diagnostics doc registry in
+ add_or_replace_doc doc registry
+ with Not_found ->
+ Pretty.failwith "Document@ %s@ was@ not@ opened@ before@ changes"
+ (DocumentUri.to_string uri)
+
+let remove DidCloseTextDocumentParams.{ textDocument = { uri } } registry =
+ { registry with docs = URIMap.remove uri registry.docs }
+
+(** Raises {!Not_found} if the document is not currently opened. *)
+let find_document TextDocumentIdentifier.{ uri; _ } { docs; _ } =
+ URIMap.find uri docs
+
+(** {2 Miscellaneous} *)
+
+let jsonrpc_of_error error method_ =
+ let (code: Jsonrpc.Response.Error.Code.t), message = match error with
+ | InvalidStatus NotInitialized _ ->
+ ServerNotInitialized, "Expected 'initialize' request"
+ | InvalidStatus Initialized _ ->
+ InvalidRequest, "Unexpected request during initialization"
+ | InvalidStatus ShuttingDown ->
+ InvalidRequest, "Unexpected request while shutting down"
+ | InvalidStatus Exit _ ->
+ InvalidRequest, "Unexpected request while quitting"
+ | InvalidStatus Running _ ->
+ InvalidRequest, "Unexpected request while running"
+ | UnhandledRequest _ ->
+ RequestFailed, Fmt.str "Unhandled request: %s" method_
+ | UnknownRequest method_ ->
+ MethodNotFound, Fmt.str "Unknown request method: %s" method_
+ | FormattingError msg ->
+ RequestFailed, Fmt.str "Formatting request error: %s" msg
+ in
+ Jsonrpc.Response.Error.make ~code ~message ()
diff --git a/src/lsp/cobol_lsp/lsp_server.mli b/src/lsp/cobol_lsp/lsp_server.mli
new file mode 100644
index 000000000..c57115aa7
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_server.mli
@@ -0,0 +1,81 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Lsp_imports
+
+module TYPES: sig
+
+ type config = {
+ project_layout: Lsp_project.layout;
+ cache_config: Lsp_project_cache.config;
+ }
+
+ type registry = private {
+ projects: Lsp_project.SET.t;
+ docs: Lsp_document.t URIMap.t;
+ indirect_diags: Lsp_diagnostics.t URIMap.t; (* diagnostics for other URIs
+ mentioned by docs in
+ `docs` *)
+ config: config;
+ }
+
+ type state =
+ | NotInitialized of config (* At startup and until "initialize" request *)
+ | Initialized of config (* After "initialize" and before "initialized" notif *)
+ | Running of registry (* After "initialized" and before "shutdown" *)
+ | ShuttingDown (* From "shuntdown" until "exit" notif *)
+ | Exit of exit_status (* After "exit" notif *)
+
+ and exit_status = (unit, string) result
+
+ type 'a error =
+ | InvalidStatus of state
+ | UnhandledRequest of 'a Lsp.Client_request.t
+ | UnknownRequest of string
+ | FormattingError of string
+
+end
+include module type of TYPES
+ with type config = TYPES.config
+ and type registry = TYPES.registry
+ and type state = TYPES.state
+ and type exit_status = TYPES.exit_status
+ and type 'a error = 'a TYPES.error
+
+type t = registry (* alias *)
+
+val init
+ : config:config
+ -> t
+
+(** When given, [copybook] indicates whether the document is a copybook (in
+ which case it is not parsed directly as a normal program). When absent,
+ copybook detection is performed via project configuration (see
+ {!Lsp_project.detect_copybook}). *)
+val add
+ : Lsp.Types.DidOpenTextDocumentParams.t -> ?copybook: bool -> t -> t
+
+val update
+ : Lsp.Types.DidChangeTextDocumentParams.t -> t -> t
+
+val remove
+ : Lsp.Types.DidCloseTextDocumentParams.t -> t -> t
+
+val find_document
+ : Lsp.Types.TextDocumentIdentifier.t -> t -> Lsp_document.t
+
+val jsonrpc_of_error
+ : 'a error -> string -> Jsonrpc.Response.Error.t
+
+val save_project_caches
+ : t -> unit
diff --git a/src/lsp/cobol_lsp/lsp_server_loop.ml b/src/lsp/cobol_lsp/lsp_server_loop.ml
new file mode 100644
index 000000000..9e39aea55
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_server_loop.ml
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** LSP server's main I/O-driven loop *)
+
+open Ez_file.V1
+open Ez_file.V1.EzFile.OP
+
+(** [config ~project_config_filename ~relative_work_dirname] creates an LSP
+ configuration structure for identifying and managing projects.
+
+ - [project_config_filename] is the names of the TOML file that is to be
+ found at the root of each project's directory tree;
+
+ - [relative_work_dirname] is the name of the directory where the LSP should
+ put its working files (caches, etc). *)
+let config ~project_config_filename ~relative_work_dirname =
+ let invalid_dir reason =
+ Fmt.invalid_arg
+ ("relative_work_dirname: "^^reason^^" (got `%s')") relative_work_dirname
+ in
+ if relative_work_dirname = ""
+ then invalid_dir "invalid direcory name";
+ if EzFile.is_absolute relative_work_dirname
+ then invalid_dir "relative direcory name expected";
+ Lsp_server.{
+ cache_config = {
+ cache_relative_filename = relative_work_dirname // "lsp-cache";
+ cache_verbose = true;
+ };
+ project_layout = {
+ project_config_filename;
+ };
+ }
+
+(** Start the lsp server, listening and responding on stdin and stdout. This is
+ blocking (driven by standard input), and shutdown is triggered by a client
+ request. Returns [Ok ()] if the server ran and shut down properly, or
+ [Error error_message] otherwise. *)
+let run ~config =
+ let process_msg = function
+ | Jsonrpc.Packet.Notification n ->
+ Lsp_notif.handle n
+ | Request r ->
+ Lsp_request.handle r
+ | _ ->
+ Fun.id
+ in
+ let rec loop status =
+ let status = match Lsp_io.read_message () with
+ | Error e -> Jsonrpc.Response.Error.raise e
+ | Ok m -> process_msg m status
+ in
+ match status with
+ | Exit code -> code
+ | _ -> loop status
+ in
+ loop (NotInitialized config)
diff --git a/src/lsp/cobol_lsp/lsp_server_loop.mli b/src/lsp/cobol_lsp/lsp_server_loop.mli
new file mode 100644
index 000000000..70a452b2f
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_server_loop.mli
@@ -0,0 +1,21 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val config
+ : project_config_filename: string
+ -> relative_work_dirname: string
+ -> Lsp_server.config
+
+val run
+ : config: Lsp_server.config
+ -> Lsp_server.exit_status
diff --git a/src/lsp/cobol_lsp/lsp_utils.ml b/src/lsp/cobol_lsp/lsp_utils.ml
new file mode 100644
index 000000000..32de99c7d
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_utils.ml
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+open Ez_file.V1
+
+(** [relative_path uri absolute_path] returns the relative path of [uri] {i
+ w.r.t} [absolute_path] if [absolute_path] is a prefix of [uri], and raises
+ {!Invalid_argument} otherwise. *)
+let relative_path ~uri absolute_path =
+ let path = Lsp.Uri.to_path uri in
+ match EzString.chop_prefix ~prefix:absolute_path path with
+ | Some "" -> "."
+ | Some path when path.[0] = FileOS.dir_separator -> EzString.after path 0
+ | Some path -> path
+ | None -> Fmt.invalid_arg "%s is not contained within %s" path absolute_path
+
+let is_file path = EzFile.exists path && not (EzFile.is_directory path)
+
+let read_from path f =
+ let ic = open_in_bin path in
+ match f ic with
+ | v -> close_in ic; v
+ | exception exn -> close_in ic; raise exn
+
+let write_to path f =
+ let oc = open_out_bin path in
+ try
+ f oc;
+ close_out oc;
+ Pretty.error "Wrote %s@." path
+ with e ->
+ Pretty.error "Error when writing %s (removing): %a@." path Fmt.exn e;
+ EzFile.remove path;
+ raise e
diff --git a/src/lsp/cobol_lsp/lsp_utils.mli b/src/lsp/cobol_lsp/lsp_utils.mli
new file mode 100644
index 000000000..4fd275ef7
--- /dev/null
+++ b/src/lsp/cobol_lsp/lsp_utils.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+val relative_path: uri:Lsp.Uri.t -> string -> string
+val is_file: string -> bool
+val read_from: string -> (in_channel -> 'a) -> 'a
+val write_to: string -> (out_channel -> unit) -> unit
diff --git a/src/lsp/cobol_lsp/package.toml b/src/lsp/cobol_lsp/package.toml
new file mode 100644
index 000000000..621084821
--- /dev/null
+++ b/src/lsp/cobol_lsp/package.toml
@@ -0,0 +1,83 @@
+
+# name of package
+name = "cobol_lsp"
+skeleton = "library"
+
+# version if different from project version
+# version = "0.1.0"
+
+# synopsis if different from project synopsis
+# synopsis = ...
+
+# description if different from project description
+# description = ...
+
+# kind is either "library", "program" or "virtual"
+kind = "library"
+
+# authors if different from project authors
+# authors = [ "Me " ]
+
+# name of a file to generate with the current version
+gen-version = "version.ml"
+
+# supported file generators are "ocamllex", "ocamlyacc" and "menhir"
+# default is [ "ocamllex", "ocamlyacc" ]
+# generators = [ "ocamllex", "menhir" ]
+
+# menhir options for the package
+#Example:
+#version = "2.0"
+#parser = { modules = ["parser"]; tokens = "Tokens" }
+#tokens = { modules = ["tokens"]}
+# menhir = ...
+
+# whether all modules should be packed/wrapped (default is true)
+# pack-modules = false
+
+# whether the package can be silently skipped if missing deps (default is false)
+# optional = true
+
+# module name used to pack modules (if pack-modules is true)
+# pack = "Mylib"
+
+# preprocessing options
+# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))"
+preprocess = "pps ppx_deriving.show"
+
+# files to skip while updating at package level
+skip = ["index.mld"]
+
+# package library dependencies
+# [dependencies]
+# ez_file = ">=0.1 <1.3"
+# base-unix = { libname = "unix", version = ">=base" }
+[dependencies]
+cobol_common = "version"
+cobol_config = "version"
+cobol_data = "version"
+cobol_indent = "version"
+cobol_parser = "version"
+cobol_typeck = "version"
+jsonrpc = ">=1.15"
+lsp = ">=1.15 <1.16"
+pretty = "version"
+toml = "7.1.0"
+
+# package tools dependencies
+[tools]
+# ...
+
+# package fields (depends on package skeleton)
+#Examples:
+# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))"
+# dune-libraries = "bigstring"
+# dune-trailer = "(install (..))"
+# opam-trailer = "pin-depends: [..]"
+# no-opam-test = "yes"
+# no-opam-doc = "yes"
+# gen-opam = "some" | "all"
+# dune-stanzas = "(flags (:standard (:include linking.sexp)))"
+# static-clibs = "unix"
+[fields]
+# ...
diff --git a/src/vscode-debugprotocol/version.mlt b/src/lsp/cobol_lsp/version.mlt
similarity index 100%
rename from src/vscode-debugprotocol/version.mlt
rename to src/lsp/cobol_lsp/version.mlt
diff --git a/src/lsp/cobol_parser/README.md b/src/lsp/cobol_parser/README.md
new file mode 100644
index 000000000..b619ca6e5
--- /dev/null
+++ b/src/lsp/cobol_parser/README.md
@@ -0,0 +1,6 @@
+# Cobol_parser package
+
+This package contains all the parsing logic and grammar definitions, as well as some Menhir extensions
+to parse COBOL.
+
+For API documentation, please see [index.mld].
diff --git a/src/lsp/cobol_parser/cobol_parser.ml b/src/lsp/cobol_parser/cobol_parser.ml
new file mode 100644
index 000000000..f1ed7d7ea
--- /dev/null
+++ b/src/lsp/cobol_parser/cobol_parser.ml
@@ -0,0 +1,82 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** {1 Exported modules} *)
+
+(** Parse tree *)
+module PTree = PTree
+module PTree_visitor = PTree_visitor
+
+(** Options to tune the parser engine *)
+include Parser_options
+
+type ('a, 'm) parsed_result = ('a, 'm) Parser_engine.parsed_result =
+ {
+ parsed_input: Cobol_preproc.input;
+ parsed_diags: Cobol_common.Diagnostics.Set.t;
+ parsed_output: ('a, 'm) Parser_options.output;
+ }
+
+type 'm parsed_compilation_group =
+ (PTree.compilation_group option, 'm) parsed_result
+
+(** {1 Exported modules} *)
+(*TODO: remove these extra modules once the parser provides the proper tokens.*)
+module Grammar_contexts = Grammar_contexts
+module Grammar_tokens = Grammar_tokens
+module Text_keywords = Text_keywords
+
+(** {1 Exported functions} *)
+
+type 'x source_handling = ?source_format:Cobol_config.source_format_spec -> 'x
+
+let parse_simple: _ source_handling = Parser_engine.parse_simple
+let parse_with_tokens: _ source_handling = Parser_engine.parse_with_tokens
+let parsed_tokens = Parser_engine.parsed_tokens
+let preproc_rev_log = Parser_engine.preproc_rev_log
+
+(* --- *)
+
+(** {1 Modules and functions exported for testing purposes}
+
+ Signatures of modules below may change unexpectedly. *)
+
+module INTERNAL = struct
+
+ (** {2 COBOL tokens} *)
+ module Tokens = Grammar_tokens
+
+ let pp_token = Text_tokenizer.pp_token
+ let pp_tokens = Text_tokenizer.pp_tokens
+
+ (** {2 COBOL grammar} *)
+ module Grammar (* : Grammar_sig.S *) = Grammar
+
+ (** {2 Parser with dummy source locations, that can be fed directly with a
+ list of tokens} *)
+ module Dummy = struct
+ module Tags: Cobol_ast.Helpers.TAGS = struct
+ let loc = Cobol_common.Srcloc.raw Lexing.(dummy_pos, dummy_pos)
+ end
+
+ let parse_as item toks =
+ let toks = ref toks
+ and dummy_lexer = Lexing.from_string ~with_positions:false "" in
+ item begin fun _ -> match !toks () with
+ | Seq.Nil -> Grammar_tokens.EOF
+ | Cons (x, tl) -> toks := tl; x
+ end dummy_lexer
+
+ let parse_list_as parse lx = parse_as parse (List.to_seq lx)
+ end
+end
diff --git a/src/lsp/cobol_parser/context.ml b/src/lsp/cobol_parser/context.ml
new file mode 100644
index 000000000..4da82f4a6
--- /dev/null
+++ b/src/lsp/cobol_parser/context.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** {1 Context management}
+
+ This module defines syntactical contexts that are used to enable keywords
+ that are context sensitive {i w.r.t} grammar rules. Such rules are
+ annotated using [[@context]] attribules, that describe a context which is:
+
+ - entered {e after} the {e first item} on the rules' right-hand side has
+ been observed.
+ NOTE: for now this item must be a terminal symbol;
+
+ - exited whenever the annotated rule is reduced.
+*)
+
+(** {2 Context types}
+
+ We concretely represent a context [ctx] as the set of keywords that are
+ sensitive to [ctx].
+*)
+
+module TH = Text_lexer.TokenHandles
+
+type context = TH.t
+let pp_context ppf c =
+ Pretty.list ~fopen:"{@[" ~fclose:"@]}" ~fempty:"{}" begin fun ppf h ->
+ Pretty.string ppf (Text_lexer.show_token_of_handle h)
+ end ppf (TH.elements c)
+
+type t = context
+
+(** {2 Context stack} *)
+
+(** The type context stacks as managed by the parser. *)
+type stack = entry list
+
+(** As the set of context-sensitive keywords may not by disjoint between
+ contexts, each element of the stack maintains the difference that a context
+ [ctx] brings {i w.r.t} all contexts that were inserted in the stack before
+ [ctx]. *)
+and entry =
+ {
+ ctx: context;
+ diff: tokens_diff;
+ }
+and tokens_diff = TH.t
+
+(** {3 Usual operations on context stacks} *)
+
+let empty_stack: stack = []
+
+let push: context -> stack -> stack = fun ctx -> function
+ | [] -> [ { ctx; diff = ctx } ]
+ | { diff = top; _ } :: _ as t -> { ctx; diff = TH.diff ctx top } :: t
+
+let top: stack -> context option = function
+ | { ctx; _ } :: _ -> Some ctx
+ | [] -> None
+
+(** {3 Context-specific operations} *)
+
+(** Retrieve the difference between the hidden part of the stack ({i i.e} all
+ its elements, minus the top one), and the top element of the stack (if any),
+ in terms of a set of context-sensitive keywords; returns an empty set if the
+ stack is empty. *)
+let top_tokens: stack -> TH.t = function
+ | [] -> TH.empty
+ | { diff; _ } :: _ -> diff
+
+(** [pop stack] pops the top element [ctx] from [stack]. Retrieves the
+ difference between the hidden part of the stack [stack] ({i i.e} all its
+ elements, minus [ctx]), and [ctx], in terms of a set of context-sensitive
+ keywords. Raises {!Invalid_argument} if the stack is empty. *)
+let pop: stack -> stack * TH.t = function
+ | [] -> Pretty.invalid_arg "Unable to pop on an empty context stack"
+ | { diff; _ } :: tl -> tl, diff
diff --git a/src/lsp/cobol_parser/context.mli b/src/lsp/cobol_parser/context.mli
new file mode 100644
index 000000000..5d6f9c4d9
--- /dev/null
+++ b/src/lsp/cobol_parser/context.mli
@@ -0,0 +1,33 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+(** {2 Context(s)} *)
+
+type context = Grammar_contexts.t
+val pp_context: context Pretty.printer
+
+type t = context
+(** {2 Context stack} *)
+
+type stack
+
+(** {3 Usual operations on context stacks} *)
+
+val empty_stack: stack
+val push: context -> stack -> stack
+val top: stack -> context option
+
+(** {3 Context-specific operations} *)
+
+val top_tokens: stack -> Text_lexer.TokenHandles.t
+val pop: stack -> stack * Text_lexer.TokenHandles.t
diff --git a/src/lsp/cobol_parser/context/dune b/src/lsp/cobol_parser/context/dune
new file mode 100644
index 000000000..f9ef08185
--- /dev/null
+++ b/src/lsp/cobol_parser/context/dune
@@ -0,0 +1,9 @@
+(executable
+ (name gen_context)
+ (modules Gen_context)
+ (libraries unix fmt menhirSdk))
+
+(executable
+ (name gen_contexts)
+ (modules Gen_contexts)
+ (libraries unix fmt menhirSdk))
diff --git a/src/lsp/cobol_parser/context/gen_context.ml b/src/lsp/cobol_parser/context/gen_context.ml
new file mode 100644
index 000000000..44c27fa39
--- /dev/null
+++ b/src/lsp/cobol_parser/context/gen_context.ml
@@ -0,0 +1,109 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+let name = ref ""
+
+let usage () =
+ Printf.eprintf "Usage: %s file.cmly\n" Sys.argv.(0);
+ exit 1
+
+let () =
+ for i = 1 to Array.length Sys.argv - 1 do
+ if !name = ""
+ then name := Sys.argv.(i)
+ else usage ()
+ done;
+ if !name = ""
+ then usage ()
+
+(* --- *)
+
+include MenhirSdk.Cmly_read.Read (struct let filename = !name end)
+
+let pp_pos ppf r =
+ let Lexing.({ pos_lnum = l1; pos_bol = b1; pos_cnum = c1; pos_fname; _ },
+ { pos_lnum = l2; pos_bol = b2; pos_cnum = c2; _ })
+ = Range.(startp r, endp r) in
+ Fmt.pf ppf "%s:%a" pos_fname Fmt.text_loc ((l1, c1 - b1), (l2, c2 - b2))
+
+let context attrs =
+ List.find_opt (Attribute.has_label "context") attrs |>
+ Option.map (fun a -> Attribute.payload a, Attribute.position a)
+
+let nonterminal_context n : (string * Range.t) option =
+ match Nonterminal.kind n with
+ | `REGULAR -> context (Nonterminal.attributes n)
+ | `START -> None
+
+let emit_prelude ppf =
+ List.iter begin fun a ->
+ if Attribute.has_label "header" a ||
+ Attribute.has_label "context.header" a then
+ Format.fprintf ppf "%s\n" (Attribute.payload a)
+ end Grammar.attributes
+
+let emit_nonterminal_contexts ppf =
+ Fmt.pf ppf "\
+ let nonterminal_context: type k. k nonterminal -> _ option = function\n";
+ Nonterminal.iter begin fun n -> match nonterminal_context n with
+ | Some (s, pos) ->
+ if Nonterminal.nullable n then
+ Fmt.epr "%a:@\n\
+ @[<2>** Warning:@ context@ `%s'@ on@ nullable@ \
+ non-terminal@]@." pp_pos pos s;
+ Fmt.pf ppf " | N_%s -> Some %s\n" (Nonterminal.name n) s
+ | None -> ()
+ end;
+ Fmt.pf ppf "\
+ \ | _ -> None\n"
+
+let pp_contexts = Fmt.(list ~sep:(any ";@ ") string)
+
+let emit_contexts_mapping ppf =
+ Fmt.pf ppf "\
+ let contexts_for_state_num: int -> _ list = function\n";
+ Lr1.iter begin fun s ->
+ let contexts =
+ List.filter_map begin fun (prod, i) ->
+ if i == 1
+ then Option.map fst @@ nonterminal_context (Production.lhs prod)
+ else None
+ end (Lr0.items (Lr1.lr0 s))
+ in
+ match List.sort_uniq (String.compare) contexts with
+ | [] -> () (* skip *)
+ | ctxs -> Fmt.pf ppf " | %d -> [%a]\n" (Lr1.to_int s) pp_contexts ctxs
+ end;
+ Fmt.pf ppf "\
+ \ | _ -> []\
+ \n\
+ \nlet contexts: type k. k lr1state -> _ list = fun s ->\
+ \n contexts_for_state_num (number s)\n"
+
+let emit ppf =
+ Fmt.pf ppf
+ "(* Caution: this file was automatically generated from %s; do not edit *)\
+ @\nopen %s\
+ @\nopen MenhirInterpreter\
+ @\n%t\
+ @\n%t\
+ @\n%t\
+ @\n"
+ !name
+ (String.capitalize_ascii (Filename.basename Grammar.basename))
+ emit_prelude
+ emit_nonterminal_contexts
+ emit_contexts_mapping
+
+let () =
+ emit Fmt.stdout
diff --git a/src/lsp/cobol_parser/context/gen_contexts.ml b/src/lsp/cobol_parser/context/gen_contexts.ml
new file mode 100644
index 000000000..d9173b687
--- /dev/null
+++ b/src/lsp/cobol_parser/context/gen_contexts.ml
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+let name = ref ""
+let external_tokens = ref ""
+
+let usage = Fmt.str "Usage: %s [OPTIONS] file.cmly" Sys.argv.(0)
+
+let anon str =
+ if !name = "" then
+ name := str
+ else
+ raise @@ Arg.Bad usage
+
+let () =
+ Arg.parse
+ Arg.[
+ ("--external-tokens", Set_string external_tokens,
+ " Import token type definitions from ");
+ ]
+ anon usage
+
+include MenhirSdk.Cmly_read.Read (struct let filename = !name end)
+
+let tokens_module =
+ match !external_tokens with
+ | "" -> String.capitalize_ascii @@ Filename.basename Grammar.basename
+ | s -> s
+
+let all_ctxts = ref []
+
+let context_list str =
+ String.split_on_char ',' str |>
+ List.filter_map (fun ctxt ->
+ let ctxt = String.trim ctxt in
+ if ctxt <> "" then
+ Some ctxt
+ else
+ None)
+
+let has_contexts attrs =
+ List.find_opt (Attribute.has_label "contexts") attrs |> Option.is_some
+
+let contexts attrs =
+ List.find_opt (Attribute.has_label "contexts") attrs |>
+ Option.fold ~none:[] ~some:(fun attr -> context_list @@ Attribute.payload attr)
+
+let emit_contexts ppf t =
+ match Terminal.kind t with
+ | `ERROR | `EOF | `PSEUDO ->
+ ()
+ | `REGULAR ->
+ let attrs = Terminal.attributes t in
+ if has_contexts attrs then
+ let contexts = contexts (Terminal.attributes t) in
+ Fmt.pf ppf "%s,@ [%a];@\n"
+ (Terminal.name t)
+ Fmt.(list ~sep:(any ";@ ") string) contexts
+
+let emit_specs ppf =
+ Fmt.pf ppf "@[<2>let specs = %s.[@\n" tokens_module;
+ (*So they are in alphabetical order*)
+ let terminals = ref [] in
+ Terminal.iter (fun t -> terminals := t :: !terminals);
+ List.iter (emit_contexts ppf) !terminals;
+ Fmt.pf ppf "@]]@\nin@\n"
+
+let emit_empty_record ppf =
+ Fmt.(list ~sep:(any ";@\n") (fun ppf c -> Fmt.pf ppf " %s = empty" c) ppf) !all_ctxts
+
+let emit_ctxt_funs ppf =
+ Fmt.(list
+ ~sep:(any "@\n")
+ (fun ppf c ->
+ Fmt.pf ppf "let %s t c = { c with %s = add t c.%s } in" c c c)
+ ppf)
+ !all_ctxts
+
+let emit_fold ppf =
+ Fmt.pf ppf "List.fold_left (fun (acc, cstoks, unimpl) (t, add_contexts) ->@\n\
+ \ let h = Text_lexer.handle_of_token t in@\n\
+ \ List.fold_left (fun acc f -> f h acc) acc add_contexts,@\n\
+ \ TH.add h cstoks,@\n\
+ \ if add_contexts = [] then TH.add h unimpl else unimpl)@\n\
+ (empty, TH.empty, TH.empty) specs"
+
+let emit_tokens_contexts ppf =
+ Fmt.pf ppf "let all, sensitive_tokens, sensitive_tokens_unimplemented =@\n\
+ @[<2> let open TH in@\n\
+ let empty =@\n\
+ \ {@\n\
+ %t;@\n\
+ \ }@\n\
+ in@\n\
+ %t@\n\
+ %t\
+ %t@]"
+ emit_empty_record
+ emit_ctxt_funs
+ emit_specs
+ emit_fold
+
+let emit_context_type ppf =
+ let ctxts = ref [] in
+ Terminal.iter (fun t ->
+ let attrs = Terminal.attributes t in
+ if has_contexts attrs then
+ begin
+ ctxts := (contexts attrs) @ !ctxts
+ end);
+ let ctxts = List.sort_uniq (String.compare) !ctxts in
+ all_ctxts := ctxts;
+ Fmt.(list ~sep:(any ";@\n") (fun ppf n -> Fmt.pf ppf " %s: t" n) ppf) ctxts
+
+let emit_prelude ppf =
+ Fmt.pf ppf "module TH = Text_lexer.TokenHandles@\n\
+ type context = TH.t@\n@\n\
+ type t = context@\n\
+ type contexts =@\n\
+ \ {@\n\
+ %t;@\n\
+ \ }@\n"
+ emit_context_type
+
+let emit_context_values ppf =
+ List.iter (fun ctxt ->
+ Fmt.pf ppf "let %s = all.%s@\n" ctxt ctxt)
+ !all_ctxts
+
+let emit ppf =
+ Fmt.pf ppf
+ "(* Caution this file was automatically generated from %s; do not edit *)@\n\
+ %t@\n\
+ %t@\n@\n\
+ %t@\n"
+ !name
+ emit_prelude
+ emit_tokens_contexts
+ emit_context_values
+
+let () =
+ emit Fmt.stdout
+
diff --git a/src/lsp/cobol_parser/contexts.ml b/src/lsp/cobol_parser/contexts.ml
new file mode 100644
index 000000000..ab77caf15
--- /dev/null
+++ b/src/lsp/cobol_parser/contexts.ml
@@ -0,0 +1,55 @@
+(**************************************************************************)
+(* *)
+(* SuperBOL OSS Studio *)
+(* *)
+(* Copyright (c) 2022-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This source code is licensed under the GNU Affero General Public *)
+(* License version 3 found in the LICENSE.md file in the root directory *)
+(* of this source tree. *)
+(* *)
+(**************************************************************************)
+
+module type T = sig
+ type t
+ val accept_stmt: t
+ val allocate_stmt: t
+ val alphabet_clause: t
+ val arithmetic_clause: t
+ val class_specifier: t
+ val column_clause: t
+ val constant: t
+ val currency_clause: t
+ val default_clause: t
+ val dynlen_struct_clause: t
+ val erase_clause: t
+ val exit_stmt: t
+ val factory_paragraph: t
+ val float_binary_clause: t
+ val float_decimal_clause: t
+ val function_specifier: t
+ val interface_specifier: t
+ val intermediate_rounding_clause: t
+ val line_clause: t
+ val lock_mode_clause: t
+ val lock_on_phrase: t
+ val object_computer_paragraph: t
+ val object_paragraph: t
+ val occurs_clause: t
+ val options_paragraph: t
+ val program_id_paragraph: t
+ val read_stmt: t
+ val resume_stmt: t
+ val retry_phrase: t
+ val rounded_phrase: t
+ val screen_descr_entry: t
+ val set_attribute_stmt: t
+ val set_stmt: t
+ val sharing_clause: t
+ val sharing_phrase: t
+ val stop_stmt: t
+ val typedef_clause: t
+ val usage_clause: t
+ val validate_status_clause: t
+end
diff --git a/src/lsp/cobol_parser/dune b/src/lsp/cobol_parser/dune
new file mode 100644
index 000000000..1b0e14325
--- /dev/null
+++ b/src/lsp/cobol_parser/dune
@@ -0,0 +1,93 @@
+; generated by drom from package skeleton 'library'
+
+(library
+ (name cobol_parser)
+ (public_name cobol_parser)
+ (wrapped true)
+ ; use field 'dune-libraries' to add libraries without opam deps
+ (libraries ppx_deriving menhirLib ez_file ebcdic_lib cobol_preproc cobol_common cobol_ast str)
+ ; use field 'dune-flags' to set this value
+ (flags (:standard))
+ ; use field 'dune-stanzas' to add more stanzas here
+ (preprocess (pps ppx_deriving.show))
+
+ )
+
+(ocamllex text_categorizer)
+
+(rule
+ (targets version.ml)
+ (deps (:script version.mlt) package.toml)
+ (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script}))))
+
+(documentation
+ (package cobol_parser))
+
+; use field 'dune-trailer' to add more stuff here
+(menhir (modules grammar_tokens grammar_common grammar)
+ (merge_into grammar)
+ (flags --inspection --cmly --table --strict
+
+ --external-tokens Grammar_tokens
+ --unused-tokens))
+
+
+(menhir (modules grammar_tokens)
+ (flags --inspection --table --only-tokens))
+
+(rule
+ (targets text_keywords.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./keywords/gen_keywords.exe} %{deps}
+ --external-tokens Grammar_tokens))))
+
+(rule
+ (targets grammar_post_actions.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./post/gen_post_actions.exe} %{deps}))))
+
+(rule
+ (targets grammar_recover.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./recover/gen_recover.exe} %{deps}))))
+
+(rule
+ (targets grammar_contexts.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./context/gen_contexts.exe} %{deps}
+ --external-tokens Grammar_tokens))))
+
+(rule
+ (targets grammar_context.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./context/gen_context.exe} %{deps}))))
+
+(rule
+ (targets grammar_printer.ml)
+ (enabled_if (<> %{profile} "release"))
+ (deps grammar.cmly)
+ (mode promote)
+ (action
+ (with-stdout-to %{targets}
+ (run %{exe:./printer/gen_printer.exe} %{deps}))))
+
diff --git a/src/lsp/cobol_parser/grammar.mly b/src/lsp/cobol_parser/grammar.mly
new file mode 100644
index 000000000..15e154143
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar.mly
@@ -0,0 +1,3962 @@
+%{
+(**************************************************************************)
+(* *)
+(* Copyright (c) 2021-2023 OCamlPro SAS *)
+(* *)
+(* All rights reserved. *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License version 2.1, with the special exception on linking *)
+(* described in the LICENSE.md file in the root directory. *)
+(* *)
+(* *)
+(**************************************************************************)
+
+open PTree
+open Grammar_utils
+open Cobol_ast
+open Cobol_common.Srcloc.INFIX
+
+let split_last l =
+ List.(let rl = rev l in hd rl, rev (tl rl))
+
+let with_loc token location_limits =
+ token &@ Grammar_utils.Overlay_manager.join_limits location_limits
+
+let dual_handler_none =
+ { dual_handler_pos = []; dual_handler_neg = [] }
+%}
+
+(* Tokens are listed in `grammar_tokens.mly' *)
+%[@printer.header open Grammar_tokens]
+%[@context.header open Grammar_contexts]
+
+(* --- Post-actions --- *)
+
+(* Post-actions are functions with pre-defined argument and return types, that
+ can be executed whenever a production is reduced. Post-actions always
+ receive as first argument the semantic value that is produced.
+
+ These actions may be specified using attributes attached to a rule as a whole
+ (in which case the action is executed whenever any production defined within
+ the rule is reduced). Alternatively, a post-action may be attached to a
+ single production by means of an attribute to the last item of its producers.
+ When both attributes are given, the latter takes precedence. *)
+
+(* Parameter module specific to post-actions *)
+%[@post.parameter Config: Cobol_config.T]
+
+(* Tag declaration for post-actions.
+
+ For now we only define a single kind of post-actions, that receives an
+ optional source code location in addition to the semantic value (which is
+ implicit in the declaration below), and returns a diagnostics result. With
+ this definition, grammar attributes "[@post.diagnostic ...]" may be used to
+ create diagnostics based on the result of configuration feature
+ verifications. *)
+%[@post.tag diagnostic loc:Cobol_common.Srcloc.srcloc option ->
+ unit Cobol_common.Diagnostics.in_result]
+
+%[@post.tag special_names Cobol_ast.special_names_clause]
+
+%[@post.tag pending string]
+
+(* --- Recovery helpers --- *)
+
+%[@recovery.header
+ open Cobol_common.Srcloc.INFIX
+
+ let dummy_loc =
+ Grammar_utils.Overlay_manager.(join_limits (dummy_limit, dummy_limit))
+
+ let dummy_name = "_" &@ dummy_loc
+
+ let dummy_qualname: Cobol_ast.qualname =
+ Cobol_ast.Name dummy_name
+
+ let dummy_qualident =
+ Cobol_ast.{ ident_name = dummy_qualname;
+ ident_refmod = None;
+ ident_subscripts = [] }
+
+ let dummy_ident =
+ Cobol_ast.QualIdent dummy_qualident
+
+ let dummy_expr =
+ Cobol_ast.Atom (Fig Zero)
+
+ let dummy_picture =
+ PTree.{ picture = "X" &@ dummy_loc;
+ picture_locale = None;
+ picture_depending = None }
+]
+
+%nonassoc lowest
+%nonassoc ELSE
+
+(* Set precedence of statements to be higher than imperative statement *)
+(* This helps resolve conflicts in lists of statements, by prefering shift *)
+%nonassoc ACCEPT
+%nonassoc ADD
+%nonassoc ALLOCATE
+%nonassoc ALTER
+%nonassoc CALL
+%nonassoc CANCEL
+%nonassoc CLOSE
+%nonassoc COMPUTE
+%nonassoc CONTINUE
+%nonassoc DELETE
+%nonassoc DISABLE
+%nonassoc DISPLAY
+%nonassoc DIVIDE
+%nonassoc ENABLE
+%nonassoc ENTER
+%nonassoc EVALUATE
+%nonassoc EXIT
+%nonassoc FREE
+%nonassoc GENERATE
+%nonassoc GO
+%nonassoc GOBACK
+%nonassoc IF
+%nonassoc INITIALIZE
+%nonassoc INITIATE
+%nonassoc INSPECT
+%nonassoc INVOKE
+%nonassoc MERGE
+%nonassoc MOVE
+%nonassoc MULTIPLY
+%nonassoc OPEN
+%nonassoc PERFORM
+%nonassoc PURGE
+%nonassoc RAISE
+%nonassoc READ
+%nonassoc RECEIVE
+%nonassoc RELEASE
+%nonassoc RESUME
+%nonassoc RETURN
+%nonassoc REWRITE
+%nonassoc SEARCH
+%nonassoc SEND
+%nonassoc SET
+%nonassoc SORT
+%nonassoc START
+%nonassoc STOP
+%nonassoc STRING
+%nonassoc SUBTRACT
+%nonassoc SUPPRESS
+%nonassoc TERMINATE
+%nonassoc TRANSFORM
+%nonassoc UNLOCK
+%nonassoc UNSTRING
+%nonassoc VALIDATE
+%nonassoc WRITE
+
+(* Precedence for empty terminators *)
+%nonassoc no_term
+
+(* Precedence higher than no_term so that we can keep shifting *)
+%nonassoc EXCEPTION ON_EXCEPTION NOT_ON_EXCEPTION ON_SIZE_ERROR NOT_ON_SIZE_ERROR OVERFLOW ON_OVERFLOW NOT_ON_OVERFLOW INVALID_KEY NOT_INVALID_KEY AT_END NOT_AT_END AT_EOP END_OF_PAGE NOT_AT_EOP EOP DATA WITH_DATA (*NO_DATA*) END ON NEXT_PAGE
+
+(* Set precedence of terminators to be higher than the absence of terminator *)
+(* Allows to solve conflicts with nested terminated-statements *)
+%nonassoc END_ACCEPT
+%nonassoc END_ADD
+%nonassoc END_CALL
+%nonassoc END_COMPUTE
+%nonassoc END_DELETE
+%nonassoc END_DISPLAY
+%nonassoc END_DIVIDE
+%nonassoc END_EVALUATE
+%nonassoc END_IF
+%nonassoc END_MULTIPLY
+%nonassoc END_READ
+%nonassoc END_RECEIVE
+%nonassoc END_RETURN
+%nonassoc END_REWRITE
+%nonassoc END_SEARCH
+%nonassoc END_START
+%nonassoc END_STRING
+%nonassoc END_SUBTRACT
+%nonassoc END_UNSTRING
+%nonassoc END_WRITE
+%nonassoc below_LINES
+%nonassoc LINES
+%nonassoc WORD TO FROM WHEN USING VALUE OPTIONAL SUM INVALID
+%nonassoc BELL BLINK HIGHLIGHT LOWLIGHT REVERSE_VIDEO UNDERLINE
+%nonassoc FOREGROUND_COLOR BACKGROUND_COLOR
+
+%left OR
+%left AND
+%right AMPERSAND
+%right DOUBLE_COLON AS
+
+%nonassoc OF IN
+%nonassoc below_RPAR
+%nonassoc RPAR
+%nonassoc LPAR
+%nonassoc PLUS_SIGN
+%nonassoc DASH_SIGN
+
+(* Symbol types *)
+
+%type <(statement, string) result> imperative_statement
+
+(* Entry points *)
+
+%start compilation_group
+%start standalone_condition
+
+%%
+
+(* --------------------- DEDICATED UTILITIES -------------------------------- *)
+
+let nel [@recovery []] [@symbol ""] (X) :=
+ | x = X; { [ x ] } %prec lowest
+ | x = X; l = nel(X); { x :: l }
+
+let rnel [@recovery []] [@symbol ""] (X) := ~ = nel (X); < > (* alias *)
+
+let loc_result (X) ==
+ | res = loc (X); { Cobol_common.Srcloc.lift_result res }
+
+let loc (X) ==
+ | x = X; { x &@ Grammar_utils.Overlay_manager.join_limits $sloc }
+
+let ioloc (X) ==
+ | {None}
+ | ~ = loc(X);
+
+(* --------------------- COMPILATION GROUPS AND UNITS ---------------------- *)
+
+let compilation_group :=
+ | option(control_division);
+ ul = ll(loc(compilation_unit));
+ pdo = loc(program_definition_no_end)?; EOF;
+ { match pdo with
+ | None -> ul
+ | Some pd -> ul @ [((Program ~&pd): compilation_unit) &@<- pd] }
+
+(* --- CONTROL DIVISION --- *)
+
+let control_division [@post.diagnostic fun _ -> Config.control_division#verify] :=
+ | CONTROL; DIVISION; ".";
+ option(default_section)
+
+let default_section :=
+ | DEFAULT; SECTION; "."; default_section_clauses
+
+let default_section_clauses :=
+ | option(mr(option(default_accept_clause);
+ option(default_display_clause);
+ "."))
+
+let default_accept_clause :=
+ | ACCEPT; IS?; word_or_terminal
+
+let default_display_clause :=
+ | DISPLAY; IS?; word_or_terminal
+
+let word_or_terminal [@symbol ""] :=
+ | WORD; {}
+ | TERMINAL; {}
+
+(* --- COMPILATION UNIT --- *)
+
+let compilation_unit :=
+ | ~ = program_prototype ;
+ | ~ = program_definition ;
+ | ~ = function_unit ;
+ | ~ = class_definition ;
+ | ~ = interface_definition ;
+
+
+
+program_definition [@cost 0]:
+ | pd = program_definition_no_end
+ pdl = loc(program_definition)* (* COB2002: PROCEDURE DIVISION must be present *)
+ END PROGRAM ep = name "."
+ { match pd.program_level with
+ | ProgramDefinition { kind;
+ has_identification_division;
+ informational_paragraphs;
+ nested_programs = [] } ->
+ { pd with
+ program_level = ProgramDefinition { kind;
+ has_identification_division;
+ informational_paragraphs;
+ nested_programs = pdl };
+ program_end_name = Some ep }
+ | _ -> failwith "Cannot happen as per the grammar." }
+
+program_definition_no_end:
+ | id = bo(identification_division) (* COB85: mandatory *)
+ pid = program_id_paragraph
+ ipo = informational_paragraphs (* Allowed in nested programs ? *)
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(loc(program_procedure_division))
+ { let program_name, program_as, kind = pid in
+ { program_name;
+ program_as;
+ program_level = ProgramDefinition { kind;
+ has_identification_division = id;
+ informational_paragraphs = ipo;
+ nested_programs = [] };
+ program_options = opo;
+ program_env = edo;
+ program_data = ddo;
+ program_proc = pdo;
+ program_end_name = None } }
+(* Note: END PROGRAM is not mandatory on last top-level program
+ if it does not contain nested programs (it may be used though) *)
+
+program_prototype [@cost 999]:
+ | bo(identification_division) (* Note: bo instead of ? to avoid conflict *)
+ pid = program_prototype_id_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(loc(procedure_division))
+ END PROGRAM ep = name "."
+ { let program_name, program_as = pid in
+ { program_name;
+ program_as;
+ program_level = ProgramPrototype;
+ program_options = opo;
+ program_env = edo;
+ program_data = ddo;
+ program_proc = pdo;
+ program_end_name = Some ep } }
+
+function_unit [@cost 999]:
+ | ro(identification_division)
+ fid = function_id_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(procedure_division)
+ END FUNCTION ef = name "."
+ { let name, as_, is_proto = fid in
+ { function_name = name;
+ function_as = as_;
+ function_is_proto = is_proto;
+ function_options = opo;
+ function_env = edo;
+ function_data = ddo;
+ function_proc = pdo;
+ function_end_name = ef } } (* TODO: shoudn't we just check ef == name? *)
+
+class_definition [@cost 999]:
+ | ro(identification_division)
+ cid = class_id_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ fdo = io(factory_definition) (* Note: inline to avoid conflict *)
+ ido = ro(instance_definition)
+ END CLASS ec = name "."
+ { let class_name, class_as, class_final,
+ class_inherits, class_usings = cid in
+ { class_name;
+ class_as;
+ class_final;
+ class_inherits;
+ class_usings;
+ class_options = opo;
+ class_env = edo;
+ class_factory = fdo;
+ class_instance = ido;
+ class_end_name = ec } }
+
+factory_definition:
+ | ro(identification_division)
+ fp = factory_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(object_procedure_division)
+ END FACTORY "."
+ { { factory_implements = fp;
+ factory_options = opo;
+ factory_env = edo;
+ factory_data = ddo;
+ factory_methods = pdo } }
+
+instance_definition:
+ | ro(identification_division)
+ op = object_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(object_procedure_division)
+ END OBJECT "."
+ { { instance_implements = op;
+ instance_options = opo;
+ instance_env = edo;
+ instance_data = ddo;
+ instance_methods = pdo } }
+
+interface_definition [@cost 999]:
+ | ro(identification_division)
+ iid = interface_id_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ pdo = ro(object_procedure_division)
+ END INTERFACE ei = name "."
+ { let interface_name, interface_as,
+ interface_inherits, interface_usings = iid in
+ { interface_name;
+ interface_as;
+ interface_inherits;
+ interface_usings;
+ interface_options = opo;
+ interface_env = edo;
+ interface_methods = pdo;
+ interface_end_name = ei } }
+
+method_definition: (* Note: used in PROCEDURE DIVISION, see below *)
+ | ro(identification_division)
+ mid = method_id_paragraph
+ opo = ro(options_paragraph)
+ edo = ro(loc(environment_division))
+ ddo = ro(loc(data_division))
+ pdo = ro(procedure_division)
+ END METHOD em = name "."
+ { let method_name, method_kind, method_override, method_final = mid in
+ { method_name;
+ method_kind;
+ method_override;
+ method_final;
+ method_options = opo;
+ method_env = edo;
+ method_data = ddo;
+ method_proc = pdo;
+ method_end_name = em } }
+
+
+
+let identification_division :=
+ | IDENTIFICATION; DIVISION; "."
+
+let informational_paragraphs := (* ~COB85, -COB2002 *)
+ | ao = loc(AUTHOR)?;
+ io = loc(INSTALLATION)?;
+ dwo = loc(DATE_WRITTEN)?;
+ dco = loc(DATE_COMPILED)?;
+ so = loc(SECURITY)?;
+ { { author = ao;
+ installation = io;
+ date_written = dwo;
+ date_compiled = dco;
+ security = so } }
+
+let as__strlit_ := ~ = ro (pf (AS, string_literal)); < >
+
+let program_id_paragraph [@context program_id_paragraph] :=
+ | PROGRAM_ID; "."; i = name; slo = as__strlit_;
+ pko = o(IS?; pk = program_kind; PROGRAM?; { pk }); ".";
+ { i, slo, pko }
+
+let program_kind :=
+ | COMMON; {Common} (* Only within a nested program *)
+ | INITIAL; {Initial}
+ | RECURSIVE; {Recursive}
+
+let program_prototype_id_paragraph := (* +COB2002 *)
+ | PROGRAM_ID; "."; i = name; slo = as__strlit_; IS?; PROTOTYPE; ".";
+ { i, slo }
+
+let function_id_paragraph :=
+ | FUNCTION_ID; "."; i = name; slo = as__strlit_;
+ proto = ibo(IS?; PROTOTYPE; {}); "."; (* +COB2002 *)
+ { i, slo, proto }
+
+let class_id_paragraph := (* +COB2002 *)
+ | CLASS_ID; "."; i = name; slo = as__strlit_; f = bo(IS?; FINAL; {});
+ il1 = lo(INHERITS; FROM?; il = names; { il });
+ il2 = lo(USING; il = names; { il }); ".";
+ { i, slo, f, il1, il2 }
+
+let factory_paragraph [@context factory_paragraph] := (* +COB2002 *)
+ | FACTORY; "."; ~ = lo(IMPLEMENTS; ~ = names; "."; < >); < >
+
+let object_paragraph [@context object_paragraph] := (* +COB2002 *)
+ | OBJECT; "."; ~ = lo(IMPLEMENTS; ~ = names; "."; < >); < >
+
+let interface_id_paragraph := (* +COB2002 *)
+ | INTERFACE_ID; "."; i = name; slo = as__strlit_;
+ il1 = lo(INHERITS; FROM?; il = names; { il });
+ il2 = lo(USING; il = names; { il }); ".";
+ { i, slo, il1, il2 }
+
+let method_id_paragraph := (* +COB2002 *)
+ | METHOD_ID; "."; i = name; slo = as__strlit_;
+ o = bo(OVERRIDE); f = bo(IS?; FINAL; {});
+ { i, NamedMethod { as_ = slo }, o, f }
+ | METHOD_ID; "."; pk = property_kind; PROPERTY; i = name;
+ o = bo(OVERRIDE); f = bo(IS?; FINAL; {});
+ { i, PropertyMethod { kind = pk }, o, f }
+
+let options_paragraph [@context options_paragraph] := (* +COB2002 *)
+ | OPTIONS; "."; ~ = lo(sf(rnel(loc(options_clause)),".")); < >
+
+let options_clause :=
+ | ~ = arithmetic_clause; < >
+ | ~ = rounded_clause; < >
+ | ~ = entry_convention_clause; < >
+ | ~ = float_binary_clause; < >
+ | ~ = float_decimal_clause; < >
+ | ~ = intermediate_rounding_clause; < >
+
+let arithmetic_clause [@context arithmetic_clause] :=
+ | ARITHMETIC; IS?; ~ = arithmetic_mode;
+
+let arithmetic_mode :=
+ | NATIVE; {Native}
+ | STANDARD; {Standard} (* ~COB2002 *)
+ | STANDARD_BINARY; {StandardBinary}
+ | STANDARD_DECIMAL; {StandardDecimal}
+
+let rounded_clause [@context rounded_phrase] :=
+ | DEFAULT; ROUNDED; MODE?; IS?; ~ = rounding_mode;
+
+let entry_convention_clause [@context entry_convention_clause] :=
+ | ENTRY_CONVENTION; IS?; COBOL; {EntryConvention COBOL}
+(*| ENTRY_CONVENTION IS i = implementor_name (* none defined in standard *)
+ { EntryConvention i } *)
+
+let float_binary_clause [@context float_binary_clause] :=
+ | FLOAT_BINARY; DEFAULT?; IS?; ~ = endianness_mode;
+
+let float_decimal_clause [@context float_decimal_clause] :=
+ | FLOAT_DECIMAL; DEFAULT?; IS?; ~ = encoding_endianness;
+
+let intermediate_rounding_clause [@context intermediate_rounding_clause] :=
+ | INTERMEDIATE; ROUNDING; IS?; ~ = rounding_mode;
+ (* CHECKME: not all are valid *)
+
+
+(* ------------------------- ENVIRONMENT DIVISION -------------------------- *)
+
+let environment_division :=
+ | ENVIRONMENT; DIVISION; ".";
+ c = ro(configuration_section);
+ io = ro(input_output_section);
+ { { env_configuration = c;
+ env_input_output = io; } }
+
+
+
+(* ------------- ENVIRONMENT DIVISION / CONFIGURATION SECTION -------------- *)
+
+configuration_section:
+ | CONFIGURATION SECTION "."
+ sco = ro(source_computer_paragraph)
+ oco = ro(object_computer_paragraph)
+ sno = ro(special_names_paragraph)
+ ro = ro(repository_paragraph) (* +COB2002 *)
+ { { source_computer_paragraph = sco;
+ object_computer_paragraph = oco;
+ special_names_paragraph = sno;
+ repository_paragraph = ro; } }
+
+
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)
+
+let source_computer_paragraph := (* WITH DEBUGGING MODE removed in COB2002 *)
+ | SOURCE_COMPUTER; "."; "."?; (* COB2002 allows two consecutive dots *)
+ {None}
+ | SOURCE_COMPUTER; "."; i = name; wdm = bo(WITH?; DEBUGGING; MODE; {}); ".";
+ {Some { source_computer_name = i;
+ source_computer_with_debugging_mode = wdm; } }
+
+
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / OBJECT-COMPUTER PARAGRAPH *)
+
+let object_computer_paragraph [@context object_computer_paragraph] :=
+ | OBJECT_COMPUTER; "."; "."?; (* COB2002 allows two consecutive dots *)
+ {None}
+ | OBJECT_COMPUTER; "."; i = name; ocl = rl(loc(object_computer_clause)); ".";
+ {Some { object_computer_name = i; object_computer_clauses = ocl; }}
+
+let object_computer_clause :=
+ | ~ = memory_size_clause; < > (* ~COB85, -COB2002 *)
+ | ~ = character_classification_clause; < > (* +COB2002 *)
+ | ~ = program_collating_sequence_clause; < > (* COB85 != COB2002 *)
+ | ~ = segment_limit_clause; < > (* -COB2002 *)
+
+let memory_size_clause := (* ~COB85, -COB2002 *)
+ | MEMORY; SIZE?; ~ = integer; ~ = memory_size_unit;
+
+let memory_size_unit :=
+ | WORDS; {MemoryWords}
+ | CHARACTERS; {MemoryCharacters}
+ | MODULES; {MemoryModules}
+
+let character_classification_clause := (* +COB2002 *)
+ | CHARACTER?; CLASSIFICATION; cc = character_classification;
+ { let a, n = cc in
+ ComputerCharClassification { alphanumeric = a; national = n } }
+
+let character_classification :=
+ | IS?; l = locale_phrase; lo = ro(locale_phrase); { Some l, lo }
+ | l = cc_alphanumeric; { Some l, None }
+ | l = cc_national; { None, Some l }
+ | la = cc_alphanumeric; ln = cc_national; { Some la, Some ln }
+ | ln = cc_national; la = cc_alphanumeric; { Some la, Some ln }
+
+let cc_alphanumeric := FOR; ALPHANUMERIC; IS?; ~ = locale_phrase; < >
+let cc_national := FOR; NATIONAL; IS?; ~ = locale_phrase; < >
+
+let locale_phrase :=
+ | i = name; { CharClassificationName i }
+ | LOCALE; { CharClassificationLocale }
+ | SYSTEM_DEFAULT; { CharClassificationSystemDefault }
+ | USER_DEFAULT; { CharClassificationUserDefault }
+
+let program_collating_sequence_clause := (* COB85 != COB2002 *)
+ | PROGRAM?; COLLATING?; SEQUENCE; ~ = alphabet_specification;
+
+
+let segment_limit_clause := (* -COB2002 *)
+ | SEGMENT_LIMIT; IS?; ~ = integer;
+
+
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SPECIAL-NAMES PARAGRAPH *)
+
+let special_names_paragraph :=
+ | SPECIAL_NAMES; "."; ~ = rnel(loc(special_names_clause)); "."; < >
+ | SPECIAL_NAMES; "."; "."?; { [] } (* COB2002 allows two consecutive dots *)
+
+let special_names_clause [@post.special_names] :=
+ (* Note: most can be used multiple times *)
+ | ~ = alphabet_name_clause; < >
+ | ~ = class_name_clause; < >
+ | ~ = crt_status_clause; < > (* +COB2002 *)
+ | ~ = currency_sign_clause; < >
+ | ~ = cursor_clause; < > (* +COB2002 *)
+ | ~ = decimal_point_clause; < >
+ | ~ = dynamic_length_structure_clause; < > (* +COB2002 *)
+ | ~ = locale_clause; < > (* +COB2002 *)
+ | ~ = mnemonic_name_clause; < >
+ | ~ = symbolic_characters_clause; < >
+ | ~ = order_table_clause; < > (* +COB2002 *)
+
+let alphabet_name_clause [@context alphabet_clause] :=
+ | ALPHABET; i = name; an = for_alphanumeric_or_national_opt;
+ IS; cs = character_set;
+ { AlphabetName { alphabet_name = i; category = an; characters = cs } }
+
+let character_set :=
+ | LOCALE; %prec lowest { CharSetLocale None } (* +COB2002 *)
+ | LOCALE; i = name; { CharSetLocale (Some i) } (* +COB2002 *)
+ | NATIVE; { CharSetNative }
+ | STANDARD_1; { CharSetStandard_1 } (* Alphanum only *)
+ | STANDARD_2; { CharSetStandard_2 } (* Alphanum only *)
+ | UCS_4; { CharSetUCS_4 } (* +COB2002 *) (* National only *)
+ | UTF_8; { CharSetUTF_8 } (* +COB2002 *) (* National only *)
+ | UTF_16; { CharSetUTF_16 } (* +COB2002 *) (* National only *)
+ | ll = rnel(literal_phrase); { CharSetCharacters ll }
+(*| i = implementor_name { } *) (* the standard does not define any *)
+
+let literal_phrase :=
+ | l = string_or_int_literal;
+ {CharactersRange (SingleCharacter l)}
+ | l1 = string_or_int_literal; THROUGH; l2 = string_or_int_literal;
+ {CharactersRange (CharacterRange { start_item = l1; end_item = l2 })}
+ | l = string_or_int_literal; ll = rnel(pf(ALSO,string_or_int_literal));
+ {CharactersList (l :: ll)}
+
+let class_name_clause :=
+ | CLASS; i = name;
+ an = for_alphanumeric_or_national_opt; IS?; (* +COB2002 *)
+ ll = nel(l = string_or_int_literal; lo = ro(pf(THROUGH,string_or_int_literal));
+ { match lo with
+ | None -> SingleCharacter l
+ | Some l' -> CharacterRange { start_item = l; end_item = l' }});
+ io = ro(pf(IN,name));
+ { ClassName { class_name = i; category = an; characters = ll; source_charset = io } }
+
+let crt_status_clause := (* +COB2002 *)
+ | CRT; STATUS; IS?; ~ = name;
+
+let currency_sign_clause [@context currency_clause] :=
+ | CURRENCY; SIGN?; IS?; l = string_literal; (* not fig const (hex allowed) *)
+ lo = ro(pf(WITH?; PICTURE; IS?; p = loc(PICTURE_STRING); SYMBOL;
+ { p }, string_literal)); (* +COB2002 *)
+ { CurrencySign { sign = l; picture_symbol = lo } } (* not fig const, not hex, 1
+ char *)
+
+let cursor_clause := (* +COB2002 *)
+ | CURSOR; IS?; ~ = name;
+
+let decimal_point_clause :=
+ | DECIMAL_POINT; IS?; COMMA; {DecimalPointIsComma}
+
+let dynamic_length_structure_clause
+ [@context dynlen_struct_clause] := (* +COB2002 *)
+ | DYNAMIC; LENGTH; STRUCTURE?; i = name; IS?; sk = structure_kind;
+ { DynLenStruct { name = i; kind = sk; } }
+
+let structure_kind :=
+ | sn = bo(SIGNED); sh = bo(SHORT); PREFIXED;
+ { DynLenPrefixed { signed = sn; short = sh } }
+ | DELIMITED; {DynLenDelimited}
+ | ~ = name;
+
+let locale_clause := (* +COB2002 *)
+ | LOCALE; i = name; IS?; is = name_or_string;
+ { SpecialNameLocale { locale_name = i; external_name = is } }
+
+(* This requires the implementor to actually define custom system names
+ for switches, devices and features - the standard does not define any *)
+let mnemonic_name_clause :=
+ | i = name; mns = mnemonic_name_suffix;
+ { let (mno, sso) = mns in
+ MnemonicName { implementor_name = i; mnemonic_name = mno; status = sso } }
+
+let mnemonic_name_suffix :=
+ | IS; n = name; { Some n, None }
+ | ss = status_switch; { None, Some ss }
+ | IS; n = name; ss = status_switch; { Some n, Some ss }
+
+let status_switch :=
+ | ON; STATUS?; IS?; i = name; { StatusSwitchOn i }
+ | OFF; STATUS?; IS?; i = name; { StatusSwitchOff i }
+ | (i1, i2) = mr( ON; STATUS?; IS?; i1 = name;
+ OFF; STATUS?; IS?; i2 = name; {i1, i2}
+ | OFF; STATUS?; IS?; i2 = name;
+ ON; STATUS?; IS?; i1 = name; {i1, i2});
+ { StatusSwitch {on_ = i1; off = i2} }
+
+let symbolic_characters_clause :=
+ | SYMBOLIC; CHARACTERS?;
+ an = for_alphanumeric_or_national_opt; (* +COB2002 *)
+ scl = nel(~ = names; or_(IS,ARE)?; ~ = integers; < >);
+ io = ro(pf(IN,name));
+ { SymbolicChars { category = an; characters = scl; source_charset = io } }
+
+let order_table_clause := (* +COB2002 *)
+ | ORDER; TABLE; i = name; IS?; l = string_literal;
+ { OrderTable { ordering_name = i; cultural_ordering = l } }
+
+let for_alphanumeric_or_national_opt :=
+ | (* epsilon *) {Alphanumeric}
+ | FOR?; ALPHANUMERIC; {Alphanumeric}
+ | FOR?; NATIONAL; {National}
+
+
+
+(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / REPOSITORY PARAGRAPH *)
+
+let repository_paragraph := (* +COB2002 *)
+ | REPOSITORY; "."; ~ = ilo(sf(rnel(specifier),".")); < >
+
+let specifier :=
+ | ~ = class_specifier; < >
+ | ~ = interface_specifier; < >
+ | ~ = function_specifier; < >
+ | PROGRAM; i = name; lo = as__strlit_;
+ { ProgramSpecifier { name = i; external_name = lo } }
+ | PROPERTY; i = name; lo = as__strlit_;
+ { PropertySpecifier { name = i; external_name = lo } }
+
+let class_specifier [@context class_specifier] :=
+ | CLASS; i = name; lo = as__strlit_; eo = ro(expands_phrase);
+ { ClassSpecifier { name = i; external_name = lo; expands = eo } }
+
+let interface_specifier [@context interface_specifier] :=
+ | INTERFACE; i = name; lo = as__strlit_; eo = ro(expands_phrase);
+ { InterfaceSpecifier { name = i; external_name = lo; expands = eo } }
+
+let expands_phrase :=
+ | EXPANDS; i = name; USING; il = names;
+ { { expands_name = i; expands_using = il } }
+
+let function_specifier [@context function_specifier] :=
+ | FUNCTION; i = name; lo = as__strlit_;
+ { UserFunctionSpecifier { name = i; external_name = lo } }
+ | FUNCTION; ~ = names; INTRINSIC;
+ | FUNCTION; ALL; INTRINSIC; {IntrinsicFunctionAllSpecifier}
+
+(* -------------- ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION -------------- *)
+
+let input_output_section :=
+ | INPUT_OUTPUT; SECTION; ".";
+ fco = ro(file_control_paragraph); (* COB85: mandatory *)
+ ioco = ro(io_control_paragraph);
+ { { file_control_paragraph = fco;
+ io_control_paragraph = ioco; } }
+
+
+
+(* - ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION / FILE-CONTROL PARAGRAPH -- *)
+
+let file_control_paragraph :=
+ | FILE_CONTROL; "."; ~ = rl(select); < > (* COB85: non-empty list *)
+
+let select :=
+ | SELECT; o = bo(OPTIONAL); i = name;
+ fcl = rnel(loc(select_clause)); ".";
+ { { select_optional = o;
+ select_name = i;
+ select_clauses = fcl } }
+
+let select_clause := (* Note: some can be used multiple times *)
+ | ~ = assign_clause; < >
+ | ~ = access_mode_clause; < >
+ | ~ = alternate_record_key_clause; < >
+ | ~ = collating_sequence_clause; < > (* +COB2002 *)
+ | ~ = file_status_clause; < >
+ | ~ = lock_mode_clause; < > (* +COB2002 *)
+ | ~ = organization_clause; < >
+ | ~ = padding_character_clause; < > (* -COB2002 *)
+ | ~ = record_delimiter_clause; < >
+ | ~ = record_key_clause; < >
+ | ~ = relative_key_clause; < >
+ | ~ = reserve_clause; < >
+ | ~ = sharing_clause; < > (* +COB2002 *)
+
+let assign_clause := (* USING added in COB2002 *)
+ | ASSIGN; TO?; _assign_external_?;
+ il = rnel(name_or_alphanum); io = ro(pf(USING,name));
+ { SelectAssign { to_ = il; using = io } }
+ | ASSIGN; USING; i = name;
+ { SelectAssign { to_ = []; using = Some i; } }
+
+let _assign_external_ [@post.pending fun () -> "EXTERNAL"] :=
+ | EXTERNAL
+
+let access_mode_clause :=
+ | ACCESS; MODE?; IS?; ~ = access_mode;
+
+let access_mode :=
+ | DYNAMIC; {AccessModeDynamic}
+ | RANDOM; {AccessModeRandom}
+ | SEQUENTIAL; {AccessModeSequential}
+
+let alternate_record_key_clause :=
+ | ALTERNATE; RECORD; KEY?; IS?; i = qualname;
+ il = lo(pf(SOURCE; IS?; {}, names));
+ wd = bo(WITH?; DUPLICATES; {});
+ { SelectAlternateRecordKey { key = i; source = il;
+ with_duplicates = wd } }
+
+let collating_sequence_clause := (* +COB2002 *)
+ | COLLATING?; SEQUENCE; ~ = alphabet_specification;
+
+ | COLLATING?; SEQUENCE; OF; il = names; IS; i = name;
+ {SelectCollatingSequenceOfKey { keys = il; alphabet = i } }
+ | COLLATING?; SEQUENCE; OF; il = ntl(name);
+ {let i, il = split_last il in
+ SelectCollatingSequenceOfKey { keys = il; alphabet = i } }
+
+let file_status_clause :=
+ | FILE?; STATUS; IS?; ~ = qualname;
+
+let lock_mode_clause [@context lock_mode_clause] := (* +COB2002 *)
+ | LOCK; MODE?; IS?; lm = lock_mode; wl = with_lock_clause;
+ { SelectLockMode { mode = lm; with_lock = wl } }
+
+let with_lock_clause [@recovery WithLockNone] :=
+ | { WithLockNone }
+ | WITH; LOCK; ON; m = bo(MULTIPLE); or_(RECORD,RECORDS);
+ { WithLock { multiple = m } }
+
+let lock_mode :=
+ | MANUAL; {LockManual}
+ | AUTOMATIC; {LockAutomatic}
+
+let organization_clause :=
+ | io(ORGANIZATION; IS?; {}); ~ = organization;
+
+let organization :=
+ | INDEXED; {OrganizationIndexed}
+ | RELATIVE; {OrganizationRelative}
+ | LINE?; SEQUENTIAL; {OrganizationSequential} (* LINE for microfocus *)
+
+let padding_character_clause := (* -COB2002 *)
+ | PADDING; CHARACTER?; IS?; ~ = qualname_or_alphanum;
+
+
+let record_delimiter_clause :=
+ | RECORD; DELIMITER; IS?; ~ = record_delimiter;
+
+let record_delimiter :=
+ | STANDARD_1; {Standard_1}
+(*| m = mnemonic_name {}*) (* none defined by the standard *)
+
+let record_key_clause :=
+ | RECORD; KEY?; IS?; i = qualname;
+ il = lo(pf(SOURCE; IS?,names));
+ { SelectRecordKey { key = i; source = il } }
+
+let relative_key_clause :=
+ | RELATIVE; KEY?; IS?; ~ = name;
+
+let reserve_clause :=
+ | RESERVE; ~ = integer; or_(AREA,AREAS)?;
+
+let sharing_clause [@context sharing_clause] := (* +COB2002 *) (* Note: identical to sharing_phrase *)
+ | SHARING; WITH?; ~ = sharing_mode;
+
+
+
+(* -- ENVIRONMENT DIVISION / INPUT-OUTPUT SECTION / I-O-CONTROL PARAGRAPH -- *)
+
+let io_control_paragraph :=
+ | I_O_CONTROL; "."; ~ = io_control_entry?; < >
+
+let io_control_entry :=
+ | rcl = rl(loc(rerun_clause)); (* -COB2002 *)
+ sal = rl(loc(same_area_clause));
+ mfl = rl(loc(multiple_file_clause)); (* -COB2002 *)
+ ".";
+ { { io_control_rerun_clauses = rcl;
+ io_control_same_area_clauses = sal;
+ io_control_multiple_file_clauses = mfl; } }
+
+let rerun_clause := (* -COB2002 *)
+ | RERUN; io = ro(pf(ON,name)); EVERY?; rf = rerun_frequency;
+ { { rerun_on = io; rerun_every = rf } }
+
+let rerun_frequency :=
+ | END; OF?; or_(REEL,UNIT); OF?; ~ = name;
+ | i = integer; RECORDS; OF?; id = name; {RerunRecords (i, id)}
+ | ~ = integer; CLOCK_UNITS;
+ | ~ = name;
+
+let same_area_clause :=
+ | SAME; as_ = area_source; AREA?; FOR?; i = name; il = names;
+ { { same_area_source = as_;
+ same_area_file_name = i;
+ same_area_file_names = il } }
+
+let area_source :=
+ | {AreaSourceFile}
+ | RECORD; {AreaSourceRecord}
+ | SORT; {AreaSourceSortMerge}
+ | SORT_MERGE; {AreaSourceSortMerge}
+
+let multiple_file_clause := (* -COB2002 *)
+ | MULTIPLE; FILE; TAPE?; CONTAINS?;
+ ~ = nel(i = name; io = ro(pf(POSITION,integer));
+ { { file_portion_name = i; file_portion_position = io } }); < >
+
+
+
+
+
+(* ----------------------------- DATA DIVISION ----------------------------- *)
+
+(*
+- file section
+ - file description : constant, record, type
+ - sort-merge description : constant, record, type
+- working storage section : constant, 77-level, record, type
+- local storage section : constant, 77-level, record, type
+- linkage section : constant, 77-level, record, type
+- report section
+ - report description : constant, report group
+- screen section : constant, screen
+
++ file description : FD file-name file-clauses* .
++ sort-merge desc : SD file-name record-clause? .
++ report description : RD report-name report-clauses* .
+
+- constant
+- 77-level data description
+- record description (data description with NO TYPEDEF in level 1)
+- type declaration (data description with a TYPEDEF)
+= data description (level-number entry-name? data-clause* )
+
+- report group description (level-number entry-name? report-group-clauses* )
+
+- screen description (level-number screen-name? screen-clauses* )
+
+* 01 constant-name CONSTANT [IS GLOBAL] AS/FROM ... (constant)
+* nn entry_name? type/next-group/line/picture/USAGE/... (report)
+* nn entry_name? REDEFINES/TYPEDEF/ALIGNED/BASED/picture... (data=record/type)
+* nn entry_name? GLOBAL/LINE/COLUMN/FULL/USAGE... (screen)
+
+(*
+record description entry =
+ set of data description entries, first one of level 1
+-> data item with level 1 without TYPEDEF is a record
+ may be described as level-77 entries
+
+type declaration entry =
+ data description entry that contains a TYPEDEF clause
+ lay have hierarchical structure
+
+8.5.1.2, Levels, and in 13.16, Data description entry.
+13.18.58, TYPEDEF clause.
+
+*)
+
+*)
+
+data_division:
+ | DATA DIVISION "."
+ fso = ro(file_section)
+ wsso = ro(working_storage_section)
+ lsso = ro(local_storage_section) (* +COB2002 *)
+ lso = ro(linkage_section)
+ cso = ro(communication_section) (* -COB2002 *)
+ rso = ro(report_section)
+ sso = ro(screen_section) (* +COB2002 *)
+ { { file_section = fso;
+ working_storage_section = wsso;
+ local_storage_section = lsso;
+ linkage_section = lso;
+ communication_section = cso;
+ report_section = rso;
+ screen_section = sso; } }
+
+
+let section(K, L) ==
+ | K; SECTION; "."; ~ = rl(loc(L)); < >
+
+let file_section :=
+ | ~ = section (FILE, file_or_sort_merge_descr_entry); < >
+
+let working_storage_section :=
+ | ~ = section (WORKING_STORAGE, constant_or_data_descr_entry); < >
+
+let local_storage_section := (* +COB2002 *)
+ | ~ = section (LOCAL_STORAGE, constant_or_data_descr_entry); < >
+
+let linkage_section := (* +COB2002 *)
+ | ~ = section (LINKAGE, constant_or_data_descr_entry); < >
+
+let communication_section := (* -COB2002 *)
+ | ~ = section (COMMUNICATION, communication_descr_entry); < >
+
+let report_section :=
+ | ~ = section (REPORT, report_descr_entry); < >
+
+let screen_section := (* +COB2002 *)
+ | ~ = section (SCREEN, constant_or_screen_descr_entry); < >
+
+
+let elementary_level == ~ = DIGITS;
+
+let constant_level :=
+ | EIGHTY_EIGHT; { with_loc 88 $sloc }
+
+
+file_or_sort_merge_descr_entry:
+ | FD i = name
+ fcl = rl(loc(file_descr_clause)) "."
+ cdl = rl(loc(constant_or_data_descr_entry))
+ { { file_name = i;
+ file_items = cdl;
+ file_clauses = FileFD fcl } }
+ | SD i = name
+ scl = rl(loc(sort_merge_file_descr_clause)) "."
+ cdl = rl(loc(constant_or_data_descr_entry))
+ { { file_name = i;
+ file_items = cdl;
+ file_clauses = FileSD scl } }
+
+communication_descr_entry:
+ | CD i = name FOR? in_ = bo(INITIAL) INPUT
+ cl = rl(loc(communication_descr_clause))
+ il = rl(loc(entry_name_clause)) "."
+ cdl = rl(loc(constant_or_data_descr_entry))
+ { { comm_name = i;
+ comm_clauses = cl;
+ comm_items = cdl;
+ comm_direction = CommInput { initial = in_; items = il } } }
+ | CD i = name FOR? in_ = bo(INITIAL) I_O
+ cl = rl(loc(communication_descr_clause)) il = rl(name) "."
+ cdl = rl(loc(constant_or_data_descr_entry))
+ { { comm_name = i;
+ comm_clauses = cl;
+ comm_items = cdl;
+ comm_direction = CommIO { initial = in_; items = il } } }
+ | CD i = name FOR? OUTPUT
+ cl = rl(loc(communication_descr_clause)) "."
+ cdl = rl(loc(constant_or_data_descr_entry))
+ { { comm_name = i;
+ comm_clauses = cl;
+ comm_items = cdl;
+ comm_direction = CommOutput } }
+
+let report_descr_entry :=
+ | RD; i = name; rl = rl(loc(report_descr_clause)); ".";
+ crl = rl(loc(constant_or_report_group_descr_entry));
+ { { report_name = i;
+ report_clauses = rl;
+ report_items = crl } }
+
+let constant_or_data_descr_entry :=
+ | e = constant;
+ { Constant e }
+ | e = data_descr_entry;
+ { Data e } (* including level 77 entries *)
+ | l = loc(elementary_level); dn = name; RENAMES; ri = qualname;
+ to_ = o(THROUGH; ~ = qualname; < >); ".";
+ { Renames { rename_level = l;
+ rename_to = dn;
+ rename_renamed = ri;
+ rename_through = to_ } }
+ | l = constant_level; cn = name;
+ er(VALUE; IS? | VALUES; ARE?); vl = rnel(literal_through_literal);
+ ao = o(IN; ~ = name; < >);
+ wfo = o(WHEN?; SET?; TO?; FALSE; IS?; ~ = literal; < >); ".";
+ { CondName { condition_name_level = l;
+ condition_name = cn;
+ condition_name_values = vl;
+ condition_name_alphabet = ao;
+ condition_name_when_false = wfo; } }
+(* integer ident? cond_value_clause (level 88 entries) *)
+
+literal_through_literal:
+ | l1 = literal
+ { { condition_name_value = l1; condition_name_through = None } }
+ | l1 = literal THROUGH l2 = literal
+ { { condition_name_value = l1; condition_name_through = Some l2 } }
+
+constant_or_report_group_descr_entry:
+ | e = constant
+ { Constant e: report_item_descr }
+ | e = report_group_descr_entry
+ { ReportGroup e }
+
+let constant_or_screen_descr_entry :=
+ | ~ = constant;
+ | s = screen_descr_entry; {Screen s}
+
+let file_descr_clause :=
+ | ~ = external_clause;
+ | global_clause; {FileGlobal}
+ | ~ = format_clause; < > (* +COB2002 *)
+ | ~ = block_contains_clause; < >
+ | ~ = record_clause;
+ | ~ = label_clause; (* -COB2002 *)
+ | ~ = value_of_clause; (* -COB2002 *)
+ | ~ = data_clause; (* -COB2002 *)
+ | ~ = linage_clause;
+ | ~ = code_set_clause;
+ | ~ = report_clause;
+
+let sort_merge_file_descr_clause :=
+ | ~ = record_clause;
+ | ~ = data_clause; (* -COB2002 *)
+ | global_clause; {FileSDGlobal}
+
+communication_descr_clause:
+ | SYMBOLIC? QUEUE IS? i = name { CommSymbolic (CommQueue, i) } (* IN *)
+ | SYMBOLIC? SUB_QUEUE_1 IS? i = name { CommSymbolic (CommSubQueue1, i) } (* IN *)
+ | SYMBOLIC? SUB_QUEUE_2 IS? i = name { CommSymbolic (CommSubQueue2, i) } (* IN *)
+ | SYMBOLIC? SUB_QUEUE_3 IS? i = name { CommSymbolic (CommSubQueue3, i) } (* IN *)
+ | SYMBOLIC? SOURCE IS? i = name { CommSymbolic (CommSource, i) } (* IN *)
+ | SYMBOLIC? TERMINAL IS? i = name { CommSymbolic (CommTerminal, i) } (* I-O *)
+ | io(SYMBOLIC) DESTINATION IS? i = name { CommSymbolic (CommDestination, i) } (* OUT *)
+ | DESTINATION COUNT IS? i = name { CommDestinationCount i } (* OUT *)
+ | DESTINATION TABLE OCCURS
+ i = integer TIMES?
+ il = lo(pf(INDEXED BY? {},nel(name))) { CommDestinationTable (i, il) } (* OUT *)
+ | MESSAGE? COUNT IS? i = name { CommMessageCount i } (* IN *)
+ | MESSAGE DATE IS? i = name { CommMessageDate i } (* IN/I-O *)
+ | MESSAGE TIME IS? i = name { CommMessageTime i } (* IN/I-O *)
+ | TEXT LENGTH IS? i = name { CommTextLength i } (* IN/OUT/I-O *)
+ | STATUS KEY IS? i = name { CommStatusKey i } (* IN/OUT/I-O *)
+ | END KEY IS? i = name { CommEndKey i } (* IN/I-O *)
+ | ERROR KEY IS? i = name { CommErrorKey i } (* OUT *)
+
+let report_descr_clause :=
+ | global_clause; {Global}
+ | ~ = code_clause; < >
+ | ~ = control_clause; < >
+ | ~ = page_limit_clause; < >
+
+
+
+let format_clause := (* +COB2002 *)
+ | FORMAT; BIT; DATA?; {FileFormat Bit}
+ | FORMAT; CHARACTER; DATA?; {FileFormat Character}
+ | FORMAT; NUMERIC; DATA?; {FileFormat Numeric}
+
+let block_contains_clause :=
+ | BLOCK; CONTAINS?; i = integer; io = io(pf(TO,integer));
+ cr = file_block_contents;
+ { FileBlockContains { from = i; to_ = io;
+ characters_or_records = cr; } }
+
+let file_block_contents ==
+ | {FileBlockContainsCharacters}
+ | CHARACTERS; {FileBlockContainsCharacters}
+ | RECORDS; {FileBlockContainsRecords}
+
+record_clause:
+ | RECORD CONTAINS? i = integer CHARACTERS?
+ { FixedLength i }
+ | RECORD CONTAINS? i1 = integer TO i2 = integer CHARACTERS?
+ { FixedOrVariableLength { min_length = i1;
+ max_length = i2 } }
+ | RECORD IS? VARYING IN? SIZE?
+ lengths = from_to_characters_opt
+ depending = ro(depending_phrase)
+ { let min_length, max_length = lengths in
+ VariableLength { min_length; max_length; depending } }
+
+from_to_characters_opt:
+ | CHARACTERS? { None, None }
+ | FROM? i1 = integer CHARACTERS? { Some i1, None }
+ | TO i2 = integer CHARACTERS? { None, Some i2 }
+ | FROM? i1 = integer TO i2 = integer CHARACTERS? { Some i1, Some i2 }
+
+label_clause:
+ | LABEL mr(RECORD IS? | RECORDS ARE? {}) STANDARD { LabelStandard }
+ | LABEL mr(RECORD IS? | RECORDS ARE? {}) OMITTED { LabelOmitted }
+
+value_of_clause:
+ | VALUE OF iil = nel(i = name IS? il = qualname_or_literal
+ { { value_of_valued = i; value_of_value = il; } })
+ { iil }
+
+data_clause:
+ | DATA_RECORD IS? il = names { il }
+ | DATA_RECORDS ARE? il = names { il }
+
+linage_clause:
+ | l = linage_header
+ wfa = ro(pf(WITH? FOOTING AT? {}, qualname_or_integer))
+ lat = io(pf(LINES? AT? TOP {}, qualname_or_integer))
+ lab = ro(pf(LINES? AT? BOTTOM {}, qualname_or_integer))
+ { { file_linage_lines = l;
+ file_linage_with_footing_at = wfa;
+ file_linage_lines_at_top = lat;
+ file_linage_lines_at_bottom = lab; } }
+
+let linage_header :=
+ | LINAGE; IS?; ~ = qualname_or_integer; %prec below_LINES < >
+ | LINAGE; IS?; ~ = qualname_or_integer; LINES; < >
+
+let code_set_clause :=
+ | CODE_SET; ~ = alphabet_specification; < >
+
+let report_clause_prefix == REPORT; IS? | REPORTS; ARE?
+let report_clause :=
+ | report_clause_prefix; ~ = names; < >
+
+let code_clause := CODE; IS?; ~ = ident;
+
+let control_clause_prefix == CONTROL; IS? | CONTROLS; ARE?
+let control_clause :=
+ | control_clause_prefix; il = names; { Control {final = false; controls = il} }
+ | control_clause_prefix; FINAL; il = rl(name); { Control {final = true; controls = il} }
+
+let limit_is_ == LIMIT; IS? | LIMITS; ARE?
+let page_limit_clause :=
+ | PAGE; limit_is_?;
+ lco = page_line_col;
+ ho = ro(pf(HEADING; IS?,integer));
+ fdo = ro(pf(FIRST; DETAIL; IS?,integer));
+ lcho = io(pf(LAST; mr(CH | CONTROL; HEADING); IS?,integer));
+ ldo = ro(pf(LAST; DETAIL; IS?,integer));
+ fo = ro(pf(FOOTING; IS?,integer));
+ { let lo, co = lco in
+ PageLimit { lines = lo;
+ columns = co;
+ heading = ho;
+ first_detail = fdo;
+ last_control_heading = lcho;
+ last_detail = ldo;
+ footing = fo; } }
+
+let page_line_col :=
+ | c = integer; COLUMNS; { None, Some c }
+ | l = integer; or_(LINE,LINES)?; { Some l, None }
+ | l = integer; or_(LINE,LINES); c = integer; COLUMNS; { Some l, Some c }
+
+
+
+
+let constant (* [@context constant] *) :=
+ (* BYTE-LENGTH is sensitive throughout "constant entry" w.r.t ISO/IEC 2014.
+ However, like in GnuCOBOL we restrict the scope to the only places where
+ the keyword is relevant. *)
+ | l = loc(elementary_level);
+ eno = ro(loc(entry_name_clause)); CONSTANT;
+ go = ibo(global_clause);
+ cv = loc(constant_value); ".";
+ { { constant_level = l;
+ constant_name = eno;
+ constant_global = go;
+ constant_value = cv } }
+
+let constant_value :=
+ | AS; ~ = expression; (* or plain ident *)
+ | p = constant_value_length; OF?; n = name;
+ { match p with
+ | `ByteLength -> ConstByteLength n
+ | `Length -> ConstLength n }
+ | FROM; ~ = name;
+
+let constant_value_length [@context constant] :=
+ | AS; BYTE_LENGTH; {`ByteLength}
+ | AS; LENGTH; {`Length}
+
+let data_descr_entry :=
+ | l = loc(elementary_level);
+ eno = ro(loc(entry_name_clause));
+ dcl = rl(loc(data_descr_clause)); ".";
+ { { data_level = l;
+ data_name = eno;
+ data_clauses = dcl } }
+
+let report_group_descr_entry :=
+ | l = elementary_level;
+ eno = ro(loc(entry_name_clause));
+ rcl = rl(loc(report_group_descr_clause)); ".";
+ { { report_level = l;
+ report_data_name = eno;
+ report_group_clauses = rcl } }
+
+let screen_descr_entry [@context screen_descr_entry] :=
+ | l = elementary_level;
+ eno = ro(loc(entry_name_clause));
+ scl = rl(loc(screen_descr_clause)); ".";
+ { { screen_level = l;
+ screen_data_name = eno;
+ screen_clauses = scl } }
+
+let entry_name_clause :=
+ | ~ = name; (* data name / screen name *)
+ | FILLER; {DataFiller}
+
+
+
+data_descr_clause: (* P255 *)
+ | c = redefines_clause { DataRedefines c }
+ | c = typedef_clause { c } (* +COB2002 *)
+ | aligned_clause { DataAligned } (* +COB2002 *)
+ | any_length_clause { DataAnyLength } (* +COB2002 *)
+ | based_clause { DataBased } (* +COB2002 *)
+ | blank_when_zero_clause { DataBlankWhenZero }
+ | constant_record_clause { DataConstantRecord } (* +COB2002 *)
+ | c = dynamic_length_clause { c } (* +COB2002 *)
+ | c = external_clause { DataExternal c }
+ | global_clause { DataGlobal }
+ | c = group_usage_clause { DataGroupUsage c } (* +COB2002 *)
+ | justified_clause { DataJustified }
+ | c = data_occurs_clause { DataOccurs c }
+ | c = loc(picture_clause) { DataPicture c }
+ | c = loc(property_clause) { DataProperty c } (* +COB2002 *)
+ | c = same_as_clause { DataSameAs c } (* +COB2002 *)
+ | c = select_when_clause { DataSelectWhen c } (* +COB2002 *)
+ | c = sign_clause { DataSign c }
+ | c = synchronized_clause { DataSynchronized c }
+ | c = data_type_clause { DataType c } (* +COB2002 *)
+ | c = usage_clause { DataUsage c }
+ | c = validation_clause { DataValidation c } (* +COB2002 *)
+ | c = data_value_clause { DataValue c }
+
+
+report_group_descr_clause: (* P286 *)
+ | c = report_type_clause { ReportType c }
+ | c = next_group_clause { ReportNextGroup c }
+ | c = report_line_clause { ReportLine c }
+ | c = loc(picture_clause) { ReportPicture c }
+ | c = report_screen_usage_clause { ReportUsage c }
+ | c = sign_clause { ReportSign c }
+ | justified_clause { ReportJustified }
+ | c = report_column_clause { c }
+ | blank_when_zero_clause { ReportBlankWhenZero }
+ | c = source_clause { c }
+ | c = sum_clause { c }
+ | c = report_value_clause { c }
+ | c = present_when_clause { ReportPresentWhen c } (* +COB2002 *)
+ | group_indicate_clause { ReportGroupIndicate }
+ | c = report_occurs_clause { c } (* +COB2002 *)
+ | c = varying_clause { ReportVarying c } (* +COB2002 *)
+
+screen_descr_clause: (* P293 *) (* +COB2002 *)
+ | global_clause { ScreenGlobal }
+ | c = screen_line_clause { ScreenLine c }
+ | c = screen_column_clause { ScreenColumn c }
+ | c = blank_clause { ScreenBlank c }
+ | c = erase_clause { ScreenErase c }
+ | c = screen_attribute_clauses { ScreenAttribute c }
+ | c = loc(picture_clause) { ScreenPicture c }
+ | c = source_destination_clauses { ScreenSourceDestination c }
+ | blank_when_zero_clause { ScreenBlankWhenZero }
+ | justified_clause { ScreenJustified }
+ | c = sign_clause { ScreenSign c }
+ | full_clause { ScreenFull }
+ | auto_clause { ScreenAuto }
+ | secure_clause { ScreenSecure }
+ | required_clause { ScreenRequired }
+ | c = screen_occurs_clause { ScreenOccurs c }
+ | c = report_screen_usage_clause { ScreenUsage c }
+
+
+
+(* ---------- Rules common to data, reports and screens ---------- *)
+
+let blank_when_zero_clause := BLANK; WHEN?; ZERO
+
+let justified_clause := JUSTIFIED; RIGHT?
+
+let picture_clause
+ [@recovery dummy_picture]
+ [@symbol ""] :=
+ | PICTURE; IS?; picture = loc(PICTURE_STRING);
+ picture_locale = ro(picture_locale_phrase);
+ picture_depending = ro(depending_phrase);
+ { { picture; picture_locale; picture_depending } }
+
+let picture_locale_phrase
+ [@recovery { locale_name = None; locale_size = "0" }]
+ [@symbol ""] :=
+ | LOCALE; io = pf(IS?, name)?; SIZE; IS?; i = integer;
+ { {locale_name = io; locale_size = i} }
+
+let sign_clause :=
+ | o(SIGN; IS?; {});
+ lt = mr(LEADING; { LeadingSign } | TRAILING; { TrailingSign });
+ sc = bo(SEPARATE; CHARACTER?; {});
+ { { sign_position = lt;
+ sign_separate_character = sc; } }
+
+
+
+(* ---------- Rules common to data, screens and constants ---------- *)
+
+let global_clause := GLOBAL | IS_GLOBAL
+
+
+
+(* ---------- Rules common to data and reports ---------- *)
+
+let key_is :=
+ | ad = sort_direction; KEY?; IS?; il = qualnames;
+ { { sort_key_direction = ad; sort_key_names = il } }
+
+let sort_direction ==
+ | ASCENDING; {SortAscending}
+ | DESCENDING; {SortDescending}
+
+let indexed_by := INDEXED; BY?; ~ = names; < >
+let depending_phrase := DEPENDING; ON?; ~ = loc(reference); < >
+let step_phrase := STEP; ~ = integer; < >
+
+let varying_clause :=
+ | VARYING; ~ = nel(i = name; fe = ro(pf(FROM,expression));
+ be = ro(pf(BY,expression));
+ { { data_varying = i;
+ data_varying_from = fe;
+ data_varying_by = be; } }); < >
+
+
+
+(* ---------- Rules common to reports and screens ---------- *)
+
+let report_screen_usage_clause :=
+ | USAGE; IS?; DISPLAY; { Display }
+ | USAGE; IS?; NATIONAL; { National } (* +COB2002 *)
+
+
+
+(* ---------- Rules specific to data ---------- *)
+
+let redefines_clause := REDEFINES; ~ = name; < >
+let typedef_clause [@context typedef_clause] :=
+ | or_(TYPEDEF,IS_TYPEDEF); s = bo(STRONG); { DataTypedef { strong = s } }
+let aligned_clause := ALIGNED
+let any_length_clause := ANY; LENGTH
+let based_clause := BASED
+let constant_record_clause := CONSTANT; RECORD
+
+let dynamic_length_clause :=
+ | DYNAMIC; LENGTH?; ido = ro(name); io = ro(pf(LIMIT; IS?,integer));
+ { DataDynamicLength { dynamic_length_structure_name = ido; limit_is = io } }
+
+let external_clause :=
+ | or_(EXTERNAL,IS_EXTERNAL); ~ = as__strlit_; < >
+
+let group_usage_clause [@recover GroupUsageBit] :=
+ | GROUP_USAGE; IS?; BIT; {GroupUsageBit}
+ | GROUP_USAGE; IS?; NATIONAL; {GroupUsageNational}
+
+let data_occurs_clause :=
+ | ~ = occurs_fixed_clause; < >
+ | ~ = occurs_depending_clause; < >
+ | ~ = occurs_dynamic_clause; < >
+
+let occurs_fixed_clause [@context occurs_clause] :=
+ | OCCURS; i = integer; TIMES?; kl = rl(key_is); ib = lo(indexed_by);
+ { OccursFixed { times = i; key_is = kl; indexed_by = ib; } }
+
+let occurs_depending_clause [@context occurs_clause] :=
+ | OCCURS; i1 = integer; TO; i2 = integer; TIMES?;
+ d = depending_phrase; kl = rl(key_is); il = lo(indexed_by);
+ { OccursDepending { from = i1; to_ = i2; depending = d;
+ key_is = kl; indexed_by = il; } }
+
+let occurs_dynamic_clause [@context occurs_clause] :=
+ | OCCURS; DYNAMIC; co = ro(capacity_phrase);
+ i1o = ro(pf(FROM,integer)); i2o = ro(pf(TO,integer));
+ i = bo(INITIALIZED); kl = rl(key_is); il = lo(indexed_by);
+ { OccursDynamic { capacity_in = co; from = i1o; to_ = i2o;
+ initialized = i; key_is = kl; indexed_by = il; } }
+
+let capacity_phrase := CAPACITY; IN?; ~ = name; < >
+
+let property_clause :=
+ | PROPERTY;
+ wno = ro(pf(WITH?; NO; {},property_kind));
+ f = bo(IS?; FINAL; {});
+ { { property_with_no = wno; property_is_final = f } }
+
+let property_kind ==
+ | GET; {PropertyGet}
+ | SET; {PropertySet}
+let same_as_clause := SAME; AS; ~ = name; < >
+let select_when_clause :=
+ | SELECT; WHEN; ~ = name;
+ | SELECT; WHEN; OTHER; {SelectWhenOther}
+
+let synchronized_clause :=
+ | SYNCHRONIZED; LEFT; {SynchronizedLeft}
+ | SYNCHRONIZED; RIGHT; {SynchronizedRight}
+ | SYNCHRONIZED; {SynchronizedDefault}
+
+let data_type_clause := TYPE; TO?; ~ = name; < >
+
+let usage_clause :=
+ | USAGE; IS?; ~ = usage; < >
+ | ~ = usage; < > (* COBOL85 *)
+
+usage [@context usage_clause (* ok as none of leftmost terminals are C/S *)]:
+ | BINARY { Binary }
+ | DISPLAY { Display }
+ | INDEX { Index }
+ | PACKED_DECIMAL { PackedDecimal }
+ (* All the following are +COB2002 *)
+ | BIT { Bit }
+ | BINARY_CHAR so = signedness_ { BinaryChar so }
+ | BINARY_SHORT so = signedness_ { BinaryShort so }
+ | BINARY_LONG so = signedness_ { BinaryLong so }
+ | BINARY_DOUBLE so = signedness_ { BinaryDouble so }
+ | FLOAT_EXTENDED { FloatExtended }
+ | FLOAT_LONG { FloatLong }
+ | FLOAT_SHORT { FloatShort }
+ | FLOAT_BINARY_32 eo = endianness_mode_ { FloatBinary32 eo }
+ | FLOAT_BINARY_64 eo = endianness_mode_ { FloatBinary64 eo }
+ | FLOAT_BINARY_128 eo = endianness_mode_ { FloatBinary128 eo }
+ | FLOAT_DECIMAL_16 ee = encoding_endianness_opt { FloatDecimal16 ee }
+ | FLOAT_DECIMAL_34 ee = encoding_endianness_opt { FloatDecimal34 ee }
+ | NATIONAL { National }
+ | OBJECT REFERENCE rk = ro(object_reference_kind) { ObjectReference rk }
+ | FUNCTION_POINTER TO? i = name { FunctionPointer i }
+ | POINTER io = ro(pf(TO?,name)) { Pointer io }
+ | PROGRAM_POINTER io = ro(pf(TO?,name)) { ProgramPointer io }
+
+ | COMP { Binary }
+ | COMP_0 { UsagePending `Comp0 }
+ | COMP_1 { UsagePending `Comp1 }
+ | COMP_2 { FloatLong }
+ | COMP_3 { PackedDecimal }
+ | COMP_4 { Binary }
+ | COMP_5 { UsagePending `Comp5 }
+ | COMP_6 { UsagePending `Comp6 }
+ | COMP_X { UsagePending `CompX }
+ | COMP_N { UsagePending `CompN }
+ | COMP_9 { UsagePending `Comp9 }
+ | COMP_10 { UsagePending `Comp10 }
+ | COMP_15 { UsagePending `Comp15 }
+
+let signedness_ := ~ = ro(signedness); < >
+let signedness ==
+ | SIGNED; { Signed }
+ | UNSIGNED; { Unsigned }
+
+let endianness_mode_ := ~ = ro(endianness_mode); < >
+let endianness_mode :=
+ | HIGH_ORDER_LEFT; { HighOrderLeft }
+ | HIGH_ORDER_RIGHT; { HighOrderRight }
+
+let encoding_mode :=
+ | BINARY_ENCODING; { BinaryEncoding }
+ | DECIMAL_ENCODING; { DecimalEncoding }
+
+let encoding_endianness_opt :=
+ | { { encoding_mode = None; encoding_endianness = None } }
+ | ~ = encoding_endianness; < >
+
+let encoding_endianness :=
+ | ecm = encoding_mode;
+ { {encoding_mode = Some ecm; encoding_endianness = None } }
+ | edm = endianness_mode;
+ { {encoding_mode = None; encoding_endianness = Some edm } }
+ | ecm = encoding_mode; edm = endianness_mode;
+ { {encoding_mode = Some ecm; encoding_endianness = Some edm } }
+ | edm = endianness_mode; ecm = encoding_mode;
+ { {encoding_mode = Some ecm; encoding_endianness = Some edm } }
+
+let object_reference_kind :=
+ | f = bo(FACTORY; OF?; {}); ACTIVE_CLASS;
+ { ActiveClass { factory_of = f } }
+ | f = bo(FACTORY; OF?; {}); i = name; o = bo(ONLY);
+ { Name { class_or_interface_name = i; factory_of = f; only = o; } }
+
+let validation_clause :=
+ | ~ = class_clause;
+ | ~ = default_clause;
+ | ~ = destination_clause;
+ | ~ = invalid_when_clause;
+ | ~ = present_when_clause;
+ | ~ = varying_clause;
+ | ~ = validate_status_clause; < >
+
+let class_clause := CLASS; IS?; ~ = class_; < >
+
+let class_ :=
+ | ALPHABETIC; {Alphabetic}
+ | ALPHABETIC_LOWER; {AlphabeticLower}
+ | ALPHABETIC_UPPER; {AlphabeticUpper}
+ | BOOLEAN; {Boolean}
+ | NUMERIC; {Numeric}
+ | ~ = name;
+
+let default_clause [@context default_clause] :=
+ | DEFAULT; IS?; ~ = ident_or_literal;
+ | DEFAULT; IS?; NONE; {None}
+
+let destination_clause := DESTINATION; IS?; ~ = idents; < >
+let invalid_when_clause := ~ = nel(INVALID; WHEN; ~ = condition; < >); < >
+let validate_status_clause [@context validate_status_clause] :=
+ | VALIDATE_STATUS;
+ IS?; il = ident_or_literal;
+ WHEN?; ene = error_or_no_error;
+ vsl = lo(pf(ON,rnel(validation_stage)));
+ FOR; idl = idents;
+ { ValidateStatus { is_ = il; when_ = ene; on = vsl; for_ = idl; } }
+
+let error_or_no_error :=
+ | ERROR; {ValidateWhenError}
+ | NO; ERROR; {ValidateWhenNoError}
+
+let validation_stage :=
+ | FORMAT; {ValidationStageFormat}
+ | CONTENT; {ValidationStageContent}
+ | RELATION; {ValidationStageRelation}
+
+let data_value_clause_prefix == VALUE; IS? | VALUES; ARE?
+let data_value_clause :=
+ | data_value_clause_prefix; ~ = literal;
+ | data_value_clause_prefix; ~ = nel(ll = rnel(literal); FROM; fl = subscripts;
+ tl = lo(TO; ~ = subscripts; < >);
+ { { table_data_values = ll;
+ table_data_from = fl;
+ table_data_to = tl } });
+
+(* /* *)
+(* cond_value_clause: // for 88 entries *)
+(* | mr(VALUE IS? | VALUES ARE? {}) *)
+(* ll = literal_through_literal+ *)
+(* ao = pf(IN,ident)? *)
+(* wf = pf(WHEN? SET? TO? FALSE IS? {},literal)? *)
+(* {} *)
+(* | or_(VALUE,VALUES) *)
+(* ll = literal_through_literal+ *)
+(* ao = pf(IN,ident)? *)
+(* vi = pf(or_(IS,ARE)?,valid_or_invalid) *)
+(* wc = pf(WHEN,condition)? *)
+(* {} *)
+(* ; *)
+
+(* literal_through_literal: // literal range *)
+(* | l = literal lo = pf(THROUGH,literal)? { (l, lo) } *)
+(* ; *)
+
+(* valid_or_invalid: *)
+(* | VALID { Valid } *)
+(* | INVALID { Invalid } *)
+(* ; *)
+(* */ *)
+
+
+
+(* ---------- Rules specific to reports ---------- *)
+
+report_type_clause:
+ | TYPE IS? DETAIL { Detail }
+ | TYPE IS? mr(RH | REPORT HEADING {}) { ReportHeading }
+ | TYPE IS? mr(RF | REPORT FOOTING {}) { ReportFooting }
+ | TYPE IS? mr(PH | PAGE HEADING {}) { PageHeading }
+ | TYPE IS? mr(PF | PAGE FOOTING {}) { PageFooting }
+ | TYPE IS? mr(CH | CONTROL HEADING {})
+ fo = o(io(or_(ON,FOR))
+ if_ = report_data_name_or_final op = bo(OR PAGE {}) { if_, op })
+ { ControlHeading fo }
+ | TYPE IS? mr(CF | CONTROL FOOTING {})
+ fo = o(io(or_(ON,FOR))
+ if_ = report_data_name_or_final { if_ } )
+ { ControlFooting fo }
+
+next_group_clause:
+ | NEXT GROUP IS? i = integer { ReportNextAbsolute i }
+ | NEXT GROUP IS? or_(PLUS,"+") i = integer { ReportNextRelative i }
+ | NEXT GROUP IS? NEXT PAGE wr = bo(WITH? RESET {}) { ReportNextNextPage wr }
+
+report_line_clause:
+ | line_header pl = rnel(line_position) { pl }
+
+line_header [@context line_clause (*NUMBERS only*)]:
+ | LINE mr(NUMBER IS? | NUMBERS ARE? | or_(IS,ARE)? {}) | LINES ARE {}
+
+line_position:
+ | i = integer %prec lowest { LineAbsolute (i, false) }
+ | i = integer io(ON) NEXT_PAGE { LineAbsolute (i, true) }
+ | or_(PLUS,"+") i = integer { LineRelative i }
+ | ON? NEXT_PAGE { LineOnNextPage }
+
+report_column_clause:
+ | a = column_header or_(IS,ARE)? pl = rnel(column_position)
+ { ReportColumn { alignment = a; position = pl } }
+
+let column_header [@context column_clause (* NUMBERS & CENTER *)] :=
+ | or_(COL,COLUMN); or_(NUMBER,NUMBERS)?; ~ = alignment; < >
+ | COLUMNS; ~ = alignment; < >
+
+let column_position :=
+ | ~ = integer;
+ | or_(PLUS,"+"); ~ = integer;
+
+let alignment :=
+ | LEFT?; {AlignLeft}
+ | CENTER; {AlignRight}
+ | RIGHT; {AlignCenter}
+
+source_clause:
+ | mr(SOURCE IS? | SOURCES ARE? {})
+ el = source_operands rmo = rounded_phrase_opt
+ { ReportSource { source = el; rounding = rmo; } }
+
+(* Not rigorously exact (see P389), but too complicated to parse otherwise *)
+source_operands:
+ | e = expression { [e] }
+ | el = ntl(arithmetic_term) { el }
+
+sum_clause:
+ | sl = nel(sum_phrase)
+ ro = io(pf(RESET ON? {}, report_data_name_or_final))
+ rm = rounded_phrase_opt
+ { ReportSum { sum_of = sl; reset_on = ro; rounding = rm; } }
+
+sum_phrase:
+ | SUM OF? el = sum_operands il = lo(pf(UPON,names)) (* TODO: recov? *)
+ { { sum_operands = el; sum_upon_items = il } }
+
+(* Not sure which expressions are valid here (see P381) *)
+sum_operands:
+ | e = expression { [e] }
+ | el = ntl(arithmetic_term) { el }
+
+let report_data_name_or_final :=
+ | ~ = qualident;
+ | FINAL; {ReportFinal}
+
+let report_value_clause :=
+ | mr(VALUE; IS?| VALUES; ARE?); ~ = literal;
+
+let present_when_clause := PRESENT; WHEN; ~ = condition; < >
+let group_indicate_clause := GROUP; INDICATE?
+
+let report_occurs_clause [@context occurs_clause] :=
+ | OCCURS; from = integer; to_ = io(pf(TO,integer)); TIMES?;
+ depending = ro(depending_phrase);
+ step = ro(step_phrase);
+ { ReportOccurs { from; to_; depending; step } }
+
+
+
+(* ---------- Rules specific to screens ---------- *)
+
+let screen_line_clause :=
+ | LINE; NUMBER?; IS?; ~ = screen_line_column_clause; < >
+
+let screen_column_clause :=
+ | or_(COL,COLUMN); NUMBER?; IS?; ~ = screen_line_column_clause; < >
+
+let screen_line_column_clause :=
+ | ~ = ident_or_integer;
+ | pm = plus_or_minus; ii = ident_or_integer; {Relative (pm, ii)}
+
+let plus_or_minus :=
+ | mr(PLUS | "+"); { Plus }
+ | mr(MINUS | "-"); { Minus }
+
+let blank_clause :=
+ | BLANK; LINE; { Line }
+ | BLANK; SCREEN; { Screen }
+
+let erase_clause [@context erase_clause] :=
+ | ERASE; mr(EOL | END?; OF?; LINE; {}); { EndOfLine }
+ | ERASE; mr(EOS | END?; OF?; SCREEN; {}); { EndOfScreen }
+
+let screen_attribute_clauses :=
+ | ~ = nel(loc(screen_attribute_clause)); < >
+
+screen_attribute_clause:
+ | BELL { Bell }
+ | BLINK { Blink }
+ | HIGHLIGHT { Highlight }
+ | LOWLIGHT { Lowlight }
+ | REVERSE_VIDEO { ReverseVideo }
+ | UNDERLINE { Underline }
+ | FOREGROUND_COLOR IS? i = ident_or_integer { ForegroundColor i }
+ | BACKGROUND_COLOR IS? i = ident_or_integer { BackgroundColor i }
+
+// TODO: not really a list, should disambiguate later
+let source_destination_clauses :=
+ | ~ = nel(loc(source_destination_clause)); < >
+
+source_destination_clause:
+ | FROM ii = ident_or_literal { From ii }
+ | TO i = ident { To i }
+ | USING i = ident { Using i }
+ | VALUE IS? l = literal { Value l }
+
+let full_clause == FULL
+let auto_clause == AUTO
+let secure_clause == SECURE
+let required_clause == REQUIRED
+let screen_occurs_clause := OCCURS; ~ = integer; TIMES?; < >
+
+
+
+
+
+
+(* -------------------- PROCEDURE DIVISION -------------------- *)
+
+procedure_division:
+ | PROCEDURE DIVISION
+ ul = ilo(pf(USING,rnel(loc(using_clause))))
+ ro = ro(returning) (* +COB2002 *)
+ rl = ilo(raising_phrase) "." (* +COB2002 *)
+ dl = lo(declaratives)
+ sl = rl(loc(section_paragraph))
+ { { procedure_using_clauses = ul;
+ procedure_returning = ro;
+ procedure_raising_phrases = rl;
+ procedure_declaratives = dl;
+ procedure_paragraphs = sl } }
+
+program_procedure_division:
+ | PROCEDURE DIVISION
+ ul = ilo(pf(USING,rnel(loc(using_clause))))
+ ro = ro(returning) (* +COB2002 *)
+ rl = ilo(raising_phrase) "." (* +COB2002 *)
+ dl = lo(declaratives)
+ sl = section_paragraphs
+ { { procedure_using_clauses = ul;
+ procedure_returning = ro;
+ procedure_raising_phrases = rl;
+ procedure_declaratives = dl;
+ procedure_paragraphs = sl } }
+
+let object_procedure_division := (* +COB2002 *)
+ | PROCEDURE; DIVISION; "."; ~ = rl(loc(method_definition)); < >
+
+(* COB85: only USING ident+ (in the IPC module, P541) *)
+let using_clause :=
+ | io(BY?; REFERENCE);
+ ~ = nell(o = ibo(OPTIONAL); n = name; { { using_by_reference_optional = o;
+ using_by_reference = n } });
+ %prec lowest
+ | BY?; VALUE; ~ = nell(name); %prec lowest
+
+(* Ambiguous, only class name may have factory *)
+let raising_phrase :=
+ | RAISING; ~ = nel(loc(f = bo(FACTORY; OF?); i = name;
+ { { raising_factory = f; raising = i} })); < >
+ (* exception / interface name / class name *)
+
+let declaratives :=
+ | DECLARATIVES; "."; ~ = rnel(loc(decl_section_paragraph));
+ END; DECLARATIVES; "."; < >
+
+(* Ambigous sections and paragraphs *)
+let decl_section_paragraph :=
+ | i = procedure_name_decl;
+ so = o(SECTION; ~ = ro(integer); "."; ~ = use_statement; < >); ".";
+ sl = rl(loc(sentence));
+ { let io, us = match so with
+ | None -> None, None
+ | Some (io, us) -> io, Some us
+ in
+ { declarative_name = i;
+ declarative_segment = io;
+ declarative_use = us;
+ declarative_sentences = sl } }
+(* segment number from 0 to 99, less than 50 *)
+
+(* Ambigous sections and paragraphs *)
+let section_paragraphs :=
+ | (* Empty *) { [] }
+ | ~ = rnel(loc(section_paragraph)); < >
+ | sl = loc(rnel(loc(sentence)));
+ tl = rl(loc(section_paragraph));
+ { ({ paragraph_name = None;
+ paragraph_is_section = false;
+ paragraph_segment = None;
+ paragraph_sentences = ~&sl } &@<- sl) :: tl }
+
+let section_paragraph :=
+ | i = procedure_name_decl;
+ s = o(SECTION; ~ = ro(integer); < >); ".";
+ sl = rl(loc(sentence));
+ { let is_section, sg = match s with None -> false, None | Some v -> true, v in
+ { paragraph_name = Some i;
+ paragraph_is_section = is_section;
+ paragraph_segment = sg;
+ paragraph_sentences = sl } }
+(* segment number from 0 to 99 *)
+
+let sentence :=
+ (* | ~ = rl(loc(imperative_statement)); "."; < > *)
+ | stmts = rl (loc_result (imperative_statement)); ".";
+ { List.filter_map Result.to_option stmts }
+
+
+
+(*
+procedural statement
+
+declarative statements actions that may be taken during processing of other statements
+ start by USE
+imperative statements unconditional actions
+ unconditional action or conditional delimited by explicit termin
+conditional statements actions depending on a condition
+ conditional phrase not terminated by explicit terminator
+
+imperative-statement = one or more imperative statements ended by separator DOT or
+ by any phrase associated with thet general format
+*)
+
+
+(* An imperative statement specifies an unconditional action to be taken by the
+ * runtime element or is a conditional statement that is delimited by its explicit
+ * scope terminator. *)
+let imperative_statement [@recovery Result.Error "bad statement"] :=
+ | ~ = unconditional_action;
+ | ~ = if_statement_explicit_term;
+
+(* A conditional statement specifies that the truth value of a condition is evaluated
+ * and used to determine subsequent flow of control. Any statement with a conditional
+ * phrase that is not terminated by its explicit scope terminator is a conditional statement. *)
+let if_statement_explicit_term :=
+ | ~ = if_statement; < > (* Conditional *)
+
+let imp_stmts [@recovery []] [@symbol ""] :=
+ | stmts = nell (loc_result (imperative_statement));
+%prec lowest
+ { List.filter_map Result.to_option stmts }
+(* prec annotation needed to solve a conflict involving IF and WRITE *)
+
+
+let oterm_(X) == er(X | {} %prec no_term) (* optional terminators *)
+
+
+
+
+(* ---------- Error handling rules ---------- *)
+
+(* COB85: the negative case must be after the positive case *)
+let handler (X, NOT_X) ==
+ | X; isl = imp_stmts; { { dual_handler_pos = isl; dual_handler_neg = [] } }
+ | NOT_X; isl = imp_stmts; { { dual_handler_pos = []; dual_handler_neg = isl } }
+ | (isl1, isl2) =
+ mr( X; isl1 = imp_stmts; NOT_X; isl2 = imp_stmts; {isl1, isl2}
+ | NOT_X; isl2 = imp_stmts; X; isl1 = imp_stmts; {isl1, isl2});
+ { { dual_handler_pos = isl1; dual_handler_neg = isl2 } }
+
+let handler_opt (X, NOT_X) ==
+ | (* epsilon *) { dual_handler_none }
+ | ~ = handler (X, NOT_X); < >
+
+
+let on_overflow := OVERFLOW | ON_OVERFLOW
+
+
+(* Used by CALL *)
+let overflow_or_exception_handler ==
+ | on_overflow; ~ = imp_stmts; (* &COB85 *)
+ | ~ = handler(on_exception,NOT_ON_EXCEPTION);
+let on_exception := EXCEPTION | ON_EXCEPTION
+
+(* Used by READ *)
+let at_end_or_invalid_key_handler ==
+ | h = handler(at_end,NOT_AT_END); {ReadAtEnd, h}
+ | h = handler(INVALID_KEY,NOT_INVALID_KEY); {ReadInvalidKey, h}
+let at_end := END | AT_END
+
+(* Used by WRITE *)
+let end_of_page_or_invalid_key_handler ==
+ | h = handler(at_eop,NOT_AT_EOP); {WriteAtEndOfPage, h}
+ | h = handler(INVALID_KEY,NOT_INVALID_KEY); {WriteInvalidKey, h}
+let at_eop := EOP | AT_EOP | END_OF_PAGE
+
+
+
+(* ---------- Identifier and literals ---------- *)
+
+
+
+let name [@recovery dummy_name] [@symbol ""] :=
+ | i = loc(WORD); < >
+let names := ~ = rnel(name); < >
+
+let in_of := IN | OF
+
+let qualname [@recovery dummy_qualname] [@symbol ""] :=
+ | n = name; %prec lowest {Name n: qualname}
+ | n = name; in_of; qdn = qualname; {Qual (n, qdn)}
+let qualnames := ~ = rnel(qualname); < >
+let reference == qualname
+
+let refmod ==
+ | "("; leftmost = expression_no_all; ":"; length = ro(expression_no_all); ")";
+ { { leftmost; length_opt = length } }
+
+let literal_int_ident :=
+ | ~ = loc(DIGITS); < >
+ | EIGHTY_EIGHT; { with_loc "88" $sloc }
+
+let procedure_name_decl :=
+ | ~ = loc(WORD_IN_AREA_A); < >
+ | ~ = procedure_name; < >
+
+let procedure_name := (* Can be present in paragraph or section name and level number *)
+ | ~ = name; < >
+ | ~ = literal_int_ident; < >
+
+let qualified_procedure_name :=
+ | qdn = qualname; { qdn }
+ | li = literal_int_ident; { Name li }
+ | pn1 = literal_int_ident; in_of;
+ pn2 = literal_int_ident; { Qual (pn1, Name pn2) }
+
+let argument :=
+ | e = expression_no_all; %prec lowest {ArgExpr e}
+ | OMITTED; {ArgOmitted}
+
+let arguments ==
+ | "("; ")"; { [] }
+ | "("; al = rnel(argument); ")"; { al }
+
+let optional_arguments_list :=
+ | (* Empty *) %prec lowest { [] }
+ | ~ = arguments; < >
+
+let subscript_first [@recovery SubSAll] [@symbol ""] [@cost 0] :=
+ | ALL; {SubSAll}
+ | e = expression_no_all; {SubSExpr e}
+ | i = name; s = sign; offset = integer; {SubSIdx (i, s, offset): subscript}
+
+let subscript_following [@recovery SubSAll] [@symbol ""] [@cost 0] :=
+ | ALL; {SubSAll}
+ | e = expression_par_unop; {SubSExpr e}
+ | i = name; s = sign; offset = integer; {SubSIdx (i, s, offset): subscript}
+
+let subscripts [@recovery []] [@symbol ""] [@cost 0] :=
+ | "("; s = subscript_first; sl = rnel(subscript_following); ")"; { s::sl }
+ | "("; s = subscript_first; ")"; { [s] }
+
+let qualident [@symbol "<(qualified) identifier>"] [@recovery dummy_qualident] :=
+ | ~ = qualident_refmod; < >
+ | ~ = qualident_no_refmod; < >
+
+let qualident_no_refmod :=
+ | qdn = qualname; %prec lowest
+ { { ident_name = qdn; ident_refmod = None; ident_subscripts = [] } }
+ | qdn = qualname; sl = subscripts; %prec lowest
+ { { ident_name = qdn; ident_refmod = None; ident_subscripts = sl } }
+
+let qualident_refmod :=
+ | qdn = qualname; rm = refmod;
+ { { ident_name = qdn; ident_refmod = Some rm; ident_subscripts = [] } }
+ | qdn = qualname; sl = subscripts; rm = refmod;
+ { { ident_name = qdn; ident_refmod = Some rm; ident_subscripts = sl } }
+
+(* Only for functions which name is also a keyword in COBOL *)
+let intrinsic_function_name :=
+ | LENGTH; { "LENGTH" }
+ | RANDOM; { "RANDOM" }
+ | REVERSE; { "REVERSE" }
+ | SIGN; { "SIGN" }
+ | SUM; { "SUM" }
+
+let function_name [@recovery dummy_name] [@symbol ""] :=
+ | ~ = name; < >
+ | ~ = loc(intrinsic_function_name); < >
+
+let function_ident :=
+ | FUNCTION; n = function_name; al = arguments; rm = io(refmod); %prec lowest
+ { { call_fun = n; call_args = al; call_refmod = rm } }
+ | FUNCTION; n = function_name; rm = io(refmod); %prec below_RPAR
+ { { call_fun = n; call_args = []; call_refmod = rm } }
+
+let inline_invocation :=
+ | i = ident; "::"; l = literal; al = optional_arguments_list;
+ { { invoke_class = i; invoke_meth = l; invoke_args = al } }
+
+let object_view :=
+ | i = ident; AS; s = object_view_spec;
+ { { object_view_ident = i; object_view_spec = s } }
+
+let object_view_spec ==
+ | n = name; {ObjViewAmbiguous n: object_view_spec}
+ | ~ = name; ONLY;
+ | FACTORY; OF; ~ = name;
+ | FACTORY; OF; ~ = name; ONLY;
+ | UNIVERSAL; {ObjViewUniversal}
+
+let object_ref :=
+ | EXCEPTION_OBJECT; {ExceptionObject}
+ | NULL; {Null}
+ | SELF; {Self}
+ | n = name; OF; SUPER; {Super (Some n)}
+ | SUPER; {Super None}
+
+let address :=
+ | ADDRESS; OF; i = ident; {DataAddress i}
+ | ADDRESS; OF; PROGRAM; i = ident_or_literal; {ProgAddress i}
+
+let counter :=
+ | k = counter_kind; %prec lowest { { counter_kind = k; counter_name = None } }
+ | k = counter_kind; in_of; n = name; { { counter_kind = k; counter_name = Some n } }
+
+let counter_kind ==
+ | LINAGE_COUNTER; {LineageCounter}
+ | PAGE_COUNTER; {PageCounter}
+ | LINE_COUNTER; {LineCounter}
+
+let ident [@symbol ""] [@recovery dummy_ident] :=
+ | q = qualident_no_refmod; {QualIdent q} (* Works for object property too *)
+ | f = function_ident; {InlineCall f}
+ | i = inline_invocation; {InlineInvoke i}
+ | o = object_view; {ObjectView o}
+ | r = object_ref; {ObjectRef r} (* Includes predefined address (NULL) *)
+ | a = address; {Address a}
+ | c = counter; {Counter c}
+ | q = qualident_refmod; {QualIdent q} (* Works for object property too *)
+
+let idents [@symbol ""] [@recovery []] :=
+ | ~ = rnel(ident); < >
+
+let ident_or_literal
+ [@symbol ""] [@cost 0]
+ [@recovery Cobol_ast.UPCAST.ident_with_literal dummy_ident] :=
+ | i = ident; %prec lowest { UPCAST.ident_with_literal i }
+ | l = literal; { UPCAST.literal_with_ident l }
+
+let figurative_constant [@recovery Zero]
+ [@symbol ""] :=
+ | ~ = figurative_constant_no_all; < >
+ | ALL; l = nonnumeric_literal_no_all; { All l }
+(*ALL symbolic-character (alphanum, national) (defined in SPECIAL-NAMES)*)
+
+let figurative_constant_no_all ==
+ | ZERO; {Zero} (* alphanum, national, boolean, numeric *)
+ | SPACE; {Space} (* alphanum, national *)
+ | QUOTE; {Quote} (* alphanum, national *)
+ | LOW_VALUE; {LowValue} (* alphanum, national *)
+ | HIGH_VALUE; {HighValue} (* alphanum, national *)
+(* | i = ident { Symbolic i } *) (*conflict in ident_or_xxx_literal*)
+
+let integers := ~ = rnel(integer); < >
+let integer [@recovery "0"]
+ [@symbol ""] :=
+ | ~ = DIGITS; < >
+ | ~ = SINTLIT; < >
+ | EIGHTY_EIGHT; {"88"}
+
+let fixedlit [@recovery fixed_zero] [@cost 10]
+ [@symbol ""] :=
+ | (i, _, d) = FIXEDLIT; { Cobol_ast.fixed_of_strings i d }
+
+let floatlit [@recovery floating_zero] [@cost 10]
+ [@symbol ""] :=
+ | (i, _, d, e) = FLOATLIT; { Cobol_ast.floating_of_strings i d e }
+
+let alphanum == (* TODO: attach interpretation (hex, etc) into AST *)
+ | a = ALPHANUM; { fst a }
+ | h = HEXLIT; { h }
+
+let literal [@recovery Integer "0"] [@symbol ""] :=
+ | a = alphanum; {Alphanum a}
+ | n = NATLIT; {National n}
+ | b = BOOLIT; {Boolean b}
+ | i = integer; {Integer i}
+ | f = fixedlit; {Fixed f}
+ | f = floatlit; {Floating f}
+ | f = figurative_constant; {Fig f}
+ | l1 = nonnumeric_literal_no_all; "&";
+ l2 = nonnumeric_literal_no_all; {Concat (l1, l2): literal}
+
+(*
+literal_no_all:
+ | l = elementary_literal { l }
+ | f = figurative_constant_no_all { Figurative (f) }
+ | l1 = nonnumeric_literal_no_all "&"
+ l2 = nonnumeric_literal_no_all { Concat (l1, l2) : literal }
+;
+*)
+
+(* concat : both operands shall be of the same class *)
+(* result of concatenation shall be less than 8191 character positions *)
+(* was 160 in older standard (COB85 ?) *)
+(* note : & should be between spaces *)
+
+
+
+
+let numeric_literal [@symbol ""] :=
+ | i = integer; { Integer i : numlit }
+ | f = fixedlit; { Fixed f }
+ | f = floatlit; { Floating f }
+ | ZERO; { NumFig Zero }
+(* Note: numeric literals do NOT allow figurative constants with ALL *)
+
+
+
+
+let elementary_string_literal ==
+ | a = alphanum; { Alphanum a }
+ | n = NATLIT; { National n : strlit }
+
+let string_literal [@symbol ""] :=
+ | l = elementary_string_literal; { l }
+ | f = figurative_constant; { Fig f }
+ | l1 = string_literal_no_all; "&";
+ l2 = string_literal_no_all; { StrConcat (l1, l2) : strlit }
+
+let string_literal_no_all [@symbol ""] :=
+ | l = elementary_string_literal; { l: strlit }
+ | f = figurative_constant_no_all; { Fig f }
+ | l1 = string_literal_no_all; "&";
+ l2 = string_literal_no_all; { StrConcat (l1, l2) : strlit }
+
+
+
+
+elementary_string_or_int_literal:
+ | a = alphanum { Alphanum a }
+ | n = NATLIT { National n }
+ | i = integer { Integer i }
+
+string_or_int_literal:
+ | l = elementary_string_or_int_literal { l }
+ | f = figurative_constant { Fig f }
+ | l1 = string_literal_no_all "&"
+ l2 = string_literal_no_all { StrConcat (l1, l2) : strlit_or_intlit }
+
+(*
+string_or_int_literal_no_all:
+ | l = elementary_string_or_int_literal { l }
+ | f = figurative_constant_no_all { Figurative (f) }
+ | l1 = string_or_int_literal_no_all "&"
+ l2 = string_or_int_literal_no_all { Concat (l1, l2) : strlit_or_intlit }
+*)
+
+elementary_nonnumeric_literal:
+ | a = alphanum { Alphanum a }
+ | n = NATLIT { National n }
+ | b = BOOLIT { Boolean b }
+
+nonnumeric_literal:
+ | l = elementary_nonnumeric_literal { l }
+ | f = figurative_constant { Fig f }
+ | l1 = nonnumeric_literal_no_all "&"
+ l2 = nonnumeric_literal_no_all { Concat (l1, l2): nonnumlit }
+
+nonnumeric_literal_no_all:
+ | l = elementary_nonnumeric_literal { l }
+ | f = figurative_constant_no_all { Fig f }
+ | l1 = nonnumeric_literal_no_all "&"
+ l2 = nonnumeric_literal_no_all { Concat (l1, l2): nonnumlit }
+
+
+
+
+
+(* Used in many *)
+let qualname_or_literal :=
+ | n = qualname; { UPCAST.qualname_with_literal n }
+ | l = literal; { UPCAST.literal_with_qualdatname l }
+
+(* Used in ADD, DIVIDE, MULTIPLY, PERFORM, SUBTRACT *)
+
+let ident_or_numeric :=
+ | i = ident; { UPCAST.ident_with_numeric i }
+ | l = numeric_literal; { UPCAST.numeric_with_ident l }
+let idents_or_numerics == ~ = rnel(ident_or_numeric); < >
+
+(* Used in CALL *)
+let name_or_string :=
+ | i = name; { Name i }
+ | s = string_literal; { UPCAST.string_with_name s }
+
+let ident_or_string :=
+ | i = ident; %prec below_RPAR { UPCAST.ident_with_string i }
+ | s = string_literal; { UPCAST.string_with_ident s }
+let idents_or_strings == ~ = rnel(ident_or_string); < >
+
+(* UNSTRING *)
+(* These statements explicitly forbid the ALL literal,
+ which (by chance) helps solve some conflicts *)
+
+let ident_or_string_no_all :=
+ | i = ident; { UPCAST.ident_with_string i }
+ | l = string_literal_no_all; { UPCAST.string_with_ident l }
+
+(* INSPECT, STRING, TRANSFORM *)
+
+let ident_or_nonnumeric :=
+ | i = ident; { UPCAST.ident_with_nonnum i }
+ | l = nonnumeric_literal; { UPCAST.nonnum_with_ident l }
+
+(* INSPECT, STRING, TRANSFORM *)
+(* These statements explicitly forbid the ALL literal,
+ which (by chance) helps solve some conflicts *)
+let ident_or_nonnumeric_no_all :=
+ | i = ident; { UPCAST.ident_with_nonnum i }
+ | l = nonnumeric_literal_no_all; { UPCAST.nonnum_with_ident l }
+
+(* Used in ENABLE, DISABLE *)
+let name_or_alphanum :=
+ | i = name; { Name i }
+ | a = alphanum; { Alphanum a }
+
+let qualname_or_alphanum :=
+ | n = qualname; { UPCAST.qualname_with_alphanum n }
+ | a = alphanum; { Alphanum a }
+
+let ident_or_alphanum :=
+ | i = ident; { UPCAST.ident_with_alphanum i }
+ | a = alphanum; { Alphanum a }
+
+(* Used in line_number (ACCEPT, DISPLAY) and PERFORM *)
+let qualname_or_integer :=
+ | n = qualname; { UPCAST.qualname_with_integer n }
+ | i = integer; { Integer i }
+
+let ident_or_integer :=
+ | i = ident; { UPCAST.ident_with_integer i }
+ | ZERO; { NumFig Zero }
+ | i = integer; { Integer i : ident_or_intlit }
+
+(* ---------- Expressions ---------- *)
+
+expression_par_unop: (* arith or boolean *)
+ | e1 = expression_par_unop "+" e2 = expr_term { Binop (e1, BPlus, e2) }
+ | e1 = expression_par_unop "-" e2 = expr_term { Binop (e1, BMinus, e2) }
+ | e = expr_term_par_unop { e }
+ (* but not both ALL literal *)
+ (* when a +/- follows an arith exp or ident, it must be between () *)
+
+expr_term_par_unop:
+ | e1 = expr_term_par_unop o = binop e2 = expr_factor { Binop (e1, o, e2) }
+ | e = expr_factor_par_unop { e }
+
+expr_factor_par_unop:
+ | e1 = expr_unary_par "**" e2 = expr_factor { Binop (e1, BPow, e2) }
+ | e = expr_unary_par { e }
+
+let expr_unary_par == atomic_expression_no_all
+
+let expression [@recovery Atom (Fig Zero)] [@symbol ""] [@cost 0] :=
+ (* arith or boolean *)
+ | e1 = expression; "+"; e2 = expr_term; { Binop (e1, BPlus, e2) }
+ | e1 = expression; "-"; e2 = expr_term; { Binop (e1, BMinus, e2) }
+ | e = expr_term; { e }
+ (* but not both ALL literal *)
+ (* when a +/- follows an arith exp or ident, it must be between () *)
+
+expr_term:
+ | e1 = expr_term o = binop e2 = expr_factor { Binop (e1, o, e2) }
+ | e = expr_factor { e }
+
+expr_factor:
+ | e1 = expr_unary "**" e2 = expr_factor { Binop (e1, BPow, e2) }
+ | e = expr_unary { e }
+
+expr_unary:
+ | e = atomic_expression { e }
+ | o = unop e = atomic_expression { Unop (o, e) }
+
+let atomic_expression [@recovery dummy_expr] [@symbol ""] :=
+ | e = arithmetic_term; { e }
+ | "("; e = expression; ")"; { e } (* arith or boolean *)
+
+arithmetic_term:
+ | i = ident { Atom (UPCAST.ident_with_literal i) } (* numeric or boolean *)
+ | i = integer { Atom (Integer i) }
+ | f = fixedlit { Atom (Fixed f) }
+ | f = floatlit { Atom (Floating f) }
+ | b = BOOLIT { Atom (Boolean b) } (* boolean *)
+ | f = figurative_constant { Atom (Fig f) } (* numeric or boolean (NB: or strlits) *)
+ | a = alphanum { Atom (Alphanum a) } (* NB: quick relaxation for now *)
+
+let expression_no_all [@recovery dummy_expr] [@symbol ""] (* [@cost 0] *):=
+ | e1 = expression_no_all; "+"; e2 = expr_term_no_all; { Binop (e1, BPlus, e2) }
+ | e1 = expression_no_all; "-"; e2 = expr_term_no_all; { Binop (e1, BMinus, e2) }
+ | e = expr_term_no_all; { e }
+ (* but not both ALL literal *)
+ (* when a +/- follows an arith exp or ident, it must be between () *)
+
+expr_term_no_all:
+ | e1 = expr_term_no_all o = binop e2 = expr_factor_no_all { Binop (e1, o, e2) }
+ | e = expr_factor_no_all { e }
+
+expr_factor_no_all:
+ | e1 = expr_unary_no_all "**" e2 = expr_factor_no_all { Binop (e1, BPow, e2) }
+ | e = expr_unary_no_all { e }
+
+let expr_unary_no_all ==
+ | e = atomic_expression_no_all; { e }
+ | o = unop; e = atomic_expression_no_all; { Unop (o, e) }
+
+let atomic_expression_no_all [@recovery dummy_expr] [@symbol ""] :=
+ | e = arithmetic_term_no_all; { e }
+ | "("; e = expression_no_all; ")"; { e } (* arith or boolean *)
+
+arithmetic_term_no_all:
+ | i = ident { Atom (UPCAST.ident_with_literal i) } (* numeric or boolean *)
+ | i = integer { Atom (Integer i) }
+ | f = fixedlit { Atom (Fixed f) }
+ | f = floatlit { Atom (Floating f) }
+ | b = BOOLIT { Atom (Boolean b) } (* boolean *)
+ | a = alphanum { Atom (Alphanum a) } (* NB: quick relaxation for now *)
+ | f = figurative_constant_no_all { Atom (Fig f) } (* numeric or boolean (NB: or strlits) *)
+
+%inline binop:
+ | "*" { BMul }
+ | "/" { BDiv }
+ | B_AND { BAnd }
+ | B_OR { BOr }
+ | B_XOR { BXor }
+
+%inline unop:
+ | "+" { UPlus }
+ | "-" { UMinus }
+ | B_NOT { UNot }
+
+(* ---------- Conditions ---------- *)
+
+
+
+condition:
+ | complex_condition { $1 }
+
+complex_condition:
+ | nonrel_condition { $1 }
+ | flat_relation_condition %prec lowest { $1 }
+ | complex_condition logop complex_condition { Logop ($1, $2, $3) }
+
+%inline logop:
+ | AND { LAnd }
+ | OR { LOr }
+
+%inline flat_relation_condition:
+ | n = ibo(NOT) c = relation_condition
+ suff = io (pair (logop, flat_combination_operand))
+ { expand_relation_condition n c suff }
+
+nonrel_condition:
+ | n = ibo(NOT) e = expression %prec lowest { neg_cond n @@ Expr e }
+ | n = ibo(NOT) c = extended_condition { neg_cond' n c }
+ | n = ibo(NOT) "(" c = complex_condition ")" { neg_cond' n c }
+
+flat_combination_operand:
+ | r = io(relop) e = expression { FlatAmbiguous (r, e) }
+ | NOT e = expression { FlatNotExpr e }
+ | n = ibo(NOT) c = relation_condition { FlatRel (n, c) }
+ | n = ibo(NOT) c = extended_condition { FlatOther (neg_cond' n c) }
+ | n = ibo(NOT) "(" c = complex_condition ")" { FlatOther (neg_cond' n c) }
+ | flat_combination_operand logop flat_combination_operand
+ { FlatComb ($1, $2, $3) }
+
+relation_condition:
+ | expression relop expression { $1, $2, $3 }
+
+extended_condition:
+ | e = expression io(IS) n = bo(NOT) c = class_condition
+ { neg_cond n @@ ClassCond (e, c) } (* exp = ident *)
+ | e = expression io(IS) n = bo(NOT) s = sign_condition
+ { neg_cond n @@ SignCond (e, s) } (* exp = arith exp *)
+ | e = expression io(IS) n = bo(NOT) OMITTED
+ { neg_cond n @@ Omitted e } (* exp = ident *)
+
+relop [@recovery Eq] [@symbol ""]:
+ | io(IS) n = ibo(NOT) GREATER THAN?
+ | io(IS) n = ibo(NOT) ">" { if n then Le else Gt }
+ | io(IS) n = ibo(NOT) LESS THAN?
+ | io(IS) n = ibo(NOT) "<" { if n then Ge else Lt }
+ | io(IS) n = ibo(NOT) EQUAL TO?
+ | io(IS) n = ibo(NOT) "=" { if n then Ne else Eq }
+ | io(IS) n = ibo(NOT) "<>" { if n then Eq else Ne }
+ | io(IS) n = ibo(NOT) GREATER THAN? OR EQUAL TO?
+ | io(IS) n = ibo(NOT) ">=" { if n then Lt else Ge }
+ | io(IS) n = ibo(NOT) LESS THAN? OR EQUAL TO?
+ | io(IS) n = ibo(NOT) "<=" { if n then Gt else Le }
+
+class_condition:
+ | i = name { AlphabetOrClass i }
+ | c = class_condition_no_ident { c }
+
+class_condition_no_ident [@recovery ClassNumeric]:
+ | ALPHABETIC { Alphabetic }
+ | ALPHABETIC_LOWER { AlphabeticLower }
+ | ALPHABETIC_UPPER { AlphabeticUpper }
+ | BOOLEAN { ClassBoolean }
+ | FARTHEST_FROM_ZERO { FarthestFromZero }
+ | FLOAT_INFINITY { FloatInfinity }
+ | FLOAT_NOT_A_NUMBER { FloatNotANumber }
+ | FLOAT_NOT_A_NUMBER_QUIET { FloatNotANumberQuiet }
+ | FLOAT_NOT_A_NUMBER_SIGNALING { FloatNotANumberSignaling }
+ | IN_ARITHMETIC_RANGE { InArithmeticRange }
+ | NEAREST_TO_ZERO { NearestToZero }
+ | NUMERIC { ClassNumeric }
+
+sign_condition:
+ | s = sign_condition_no_zero { s }
+ | ZERO { SgnZero }
+
+sign_condition_no_zero [@recovery SgnPositive]:
+ | POSITIVE { SgnPositive }
+ | NEGATIVE { SgnNegative : signz }
+
+
+
+(* ---------- Rules common to several statements ---------- *)
+
+
+
+(* ACCEPT, DISPLAY *)
+
+let position :=
+ | l = line_number; { LinePosition l }
+ | c = column_number; { ColumnPosition c }
+ | l = line_number; c = column_number; { LineColumnPosition (l, c) }
+ | c = column_number; l = line_number; { LineColumnPosition (l, c) }
+
+let line_number :=
+ | LINE; NUMBER?; ~ = ident_or_integer; < >
+(* integer must be unsigned *)
+
+let column_number :=
+ | or_(COL,COLUMN); NUMBER?; ~ = ident_or_integer; < >
+(* integer must be unsigned *)
+
+
+
+(* ADD, COMPUTE, DIVIDE, MULTIPLY, SUBTRACT *)
+
+let rounded_ident :=
+ | i = ident; rm = rounded_phrase_opt;
+ { { rounded_ident = i; rounded_rounding = rm} }
+let rounded_idents == ~ = rnel(rounded_ident); < >
+
+let rounded_phrase_opt :=
+ | (* epsilon *) {RoundingNotAny} (* = ROUNDED MODE TRUNCATION *)
+ | ~ = rounded_phrase; < >
+
+let rounded_phrase [@context rounded_phrase] :=
+ | ROUNDED; {RoundingDefault} (* use default rounding *)
+ | ROUNDED; MODE; IS?; ~ = rounding_mode;
+
+let rounding_mode :=
+ | AWAY_FROM_ZERO; {AwayFromZero}
+ | NEAREST_AWAY_FROM_ZERO; {NearestAwayFromZero}
+ | NEAREST_EVEN; {NearestEven}
+ | NEAREST_TOWARD_ZERO; {NearestTowardZero}
+ | PROHIBITED; {TowardGreater}
+ | TOWARD_GREATER; {TowardLesser}
+ | TOWARD_LESSER; {Truncation}
+ | TRUNCATION; {Prohibited}
+
+
+
+(* ALLOCATE, CALL, INVOKE, Procedure division header *)
+
+let returning := RETURNING; ~ = loc(ident); < >
+
+
+
+(* CALL, INVOKE *)
+(* Ambiguous & different between standards *)
+(*
+COB85:
+ (BY REFERENCE)? identifier...
+ BY CONTENT identifier...
+COB2002:
+ (BY REFERENCE)? identifier/OMITTED
+ (BY CONTENT)? identifier/literal/expression
+ (BY VALUE)? identifier/literal/expression
+*)
+
+let using_by :=
+ | b = call_using_by?; e = arithmetic_term;
+ { { call_using_by = b;
+ call_using_expr = Some e } } (* COB85: ident, COB2002: exp *)
+ | b = call_using_by?; OMITTED;
+ { { call_using_by = b;
+ call_using_expr = None } } (* +COB2002 *)
+
+let call_using_by [@recovery CallUsingByReference] :=
+ | BY?; REFERENCE; {CallUsingByReference}
+ | BY?; CONTENT; {CallUsingByContent}
+ | BY?; VALUE; {CallUsingByValue} (* +COB2002 *)
+
+
+
+(* DELETE, OPEN, READ, REWRITE, WRITE *)
+
+let retry_phrase [@context retry_phrase] :=
+ | RETRY; ~ = expression; TIMES;
+ | RETRY; FOR; ~ = expression; SECONDS;
+ | RETRY; FOREVER; {RetryForever}
+
+
+
+(* DISABLE, ENABLE *)
+
+let with_key :=
+ | WITH?; KEY; ~ = ident_or_alphanum; < >
+
+let mcs_kind :=
+ | INPUT; TERMINAL?; {MCSInput}
+ | I_O; TERMINAL; {MCSInputOutput}
+ | OUTPUT; {MCSOutput}
+
+let mcs_command :=
+ | io = mcs_kind; i = name; iao = io(with_key);
+ { { mcs_command_kind = io;
+ mcs_command_target = i;
+ mcs_command_key = iao } }
+
+
+(* EXIT, GOBACK *)
+
+let raising_exception := (* COB2002+ *)
+ | RAISING; i = ident; {RaisingIdent i}
+ | RAISING; EXCEPTION; i = name; {RaisingException i}
+ | RAISING; LAST; EXCEPTION; {RaisingLastException}
+ | RAISING; LAST; %prec lowest {RaisingLastException} (* unexplainable conflict using option *)
+
+
+
+(* MERGE, SORT *)
+
+let on_key :=
+ | ON?; d = sort_direction; KEY?; il = qualnames;
+ { { sort_key_direction = d; sort_key_names = il } }
+ (* | ON?; DESCENDING; KEY?; il = qualnames; *)
+ (* { { sort_key_direction = SortDescending; sort_key_names = il } } *)
+
+let collating_sequence_phrase :=
+ | COLLATING?; SEQUENCE; ~ = alphabet_specification; < >
+
+let alphabet_specification :=
+ | IS?; i = name; io = ro(name); { { alphanumeric = Some i; national = io } }
+ | i = cs_alphanumeric; { { alphanumeric = Some i; national = None } }
+ | i = cs_national; { { alphanumeric = None; national = Some i } }
+ | (ia, in_) = mr( ia = cs_alphanumeric; in_ = cs_national; {ia, in_}
+ | in_ = cs_national; ia = cs_alphanumeric; {ia, in_});
+ { { alphanumeric = Some ia; national = Some in_ } }
+
+let cs_alphanumeric := FOR; ALPHANUMERIC; IS?; ~ = name; < >
+let cs_national := FOR; NATIONAL; IS?; ~ = name; < >
+
+let output_or_giving :=
+ | OUTPUT; PROCEDURE; IS?; i = procedure_name; io = ro(pf(THROUGH,procedure_name));
+ { OutputProcedure { procedure_start = i; procedure_end = io } }
+ | GIVING; ~ = names;
+
+
+
+(* OPEN, USE *)
+
+let open_mode :=
+ | INPUT; {OpenInput}
+ | OUTPUT; {OpenOutput}
+ | I_O; {OpenInputOutput}
+ | EXTEND; {OpenExtend}
+
+
+(* PERFORM, SEND *)
+
+let after_or_before :=
+ | AFTER; {After}
+ | BEFORE; {Before}
+
+
+(* READ, REWRITE, WRITE *)
+
+let with_lock :=
+ | /*%prec lowest*/ {None}
+ | io(WITH); LOCK; {Some true}
+ | io(WITH); NO; LOCK; {Some false}
+
+
+(* ---------- Rules specific to a single statement ---------- *)
+
+
+
+(* ACCEPT STATEMENT *)
+
+(* TODO: FROM and TO and USING clauses *)
+%public let unconditional_action := ~ = accept_statement;
+accept_statement [@context accept_stmt]:
+ | ACCEPT i = loc(ident) end_accept
+ { AcceptGeneric i }
+ | ACCEPT i1 = loc(ident) FROM i2 = name end_accept
+ { AcceptFromDevice { item = i1; device_item = i2 } }
+ | ACCEPT i = loc(ident) FROM ddt = date_day_time end_accept
+ { AcceptTemporal { item = i; date_time = ddt } }
+ | ACCEPT i = name MESSAGE? COUNT end_accept (* -COB2002 *)
+ { AcceptMsgCount i }
+ | ACCEPT i = name AT p = position (* +COB2002 *)
+ h = handler_opt(on_exception,NOT_ON_EXCEPTION) end_accept
+ { AcceptAtScreen { item = i;
+ position = Some p;
+ on_exception = h; } }
+ | ACCEPT i = name
+ h = handler(on_exception,NOT_ON_EXCEPTION) end_accept (* +COB2002 *)
+ { AcceptAtScreen { item = i;
+ position = None;
+ on_exception = h; } }
+ | ACCEPT item = loc(ident) (* MF *)
+ FROM ENVIRONMENT env_item = loc(ident_or_nonnumeric_no_all)
+ on_exception = handler_opt(on_exception,NOT_ON_EXCEPTION) end_accept
+ { AcceptFromEnv { item; env_item; on_exception } }
+
+let end_accept := oterm_(END_ACCEPT)
+
+let date_day_time :=
+ | DATE; y = bo(YYYYMMDD); {Date y} (* YYYYMMDD +COB2002 *)
+ | DAY; y = bo(YYYYDDD); {Day y} (* YYYYDDD +COB2002 *)
+ | DAY_OF_WEEK; {DayOfWeek}
+ | TIME; {Time}
+
+
+
+(* ADD STATEMENT *)
+
+%public let unconditional_action := ~ = add_statement; < >
+add_statement:
+ | ADD inl = idents_or_numerics TO irl = rounded_idents
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR) end_add
+ { Add { basic_arith_operands =
+ ArithSimple { sources = inl; targets = irl };
+ basic_arith_on_size_error = h } }
+ | ADD inl = idents_or_numerics TO in_ = ident_or_numeric
+ GIVING irl = rounded_idents
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR) end_add
+ { Add { basic_arith_operands =
+ ArithGiving { sources = inl;
+ to_or_from_item = in_;
+ targets = irl };
+ basic_arith_on_size_error = h } }
+ | ADD inl = idents_or_numerics (* Same as above without 'TO' *)
+ GIVING irl = rounded_idents
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR) end_add
+ { let in_, inl = split_last inl in
+ Add { basic_arith_operands =
+ ArithGiving { sources = inl;
+ to_or_from_item = in_;
+ targets = irl };
+ basic_arith_on_size_error = h } }
+ | ADD CORRESPONDING i = qualname TO ir = rounded_ident
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR) end_add
+ { Add { basic_arith_operands =
+ ArithCorresponding { source = i; target = ir };
+ basic_arith_on_size_error = h } }
+
+let end_add := oterm_(END_ADD)
+
+
+(* ALLOCATE STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = allocate_statement; < >
+let allocate_statement [@context allocate_stmt] :=
+ | ALLOCATE; e = expression; CHARACTERS; ib = bo(INITIALIZED); r = returning;
+ { Allocate { allocate_kind = AllocateCharacters e;
+ allocate_initialized = ib;
+ allocate_returning = Some r } }
+ | ALLOCATE; i = name; ib = bo(INITIALIZED); ro = ro(returning);
+ { Allocate { allocate_kind = AllocateDataItem i;
+ allocate_initialized = ib;
+ allocate_returning = ro } }
+
+
+
+(* ALTER STATEMENT (~COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = alter_statement; < >
+let alter_statement :=
+ | ALTER; ~ = l(loc(i1 = qualified_procedure_name; TO; o(PROCEED; TO);
+ i2 = qualified_procedure_name;
+ { { alter_source = i1; alter_target = i2 } }));
+
+
+
+(* CALL STATEMENT *)
+
+%public let unconditional_action := ~ = call_statement; < >
+let call_statement :=
+ | CALL; cp = call_prefix; ul = lo(pf(USING,rnel(loc(using_by))));
+ ro = ro(returning); oeho = io(overflow_or_exception_handler);
+ oterm_(END_CALL);
+ { Call { call_prefix = cp;
+ call_using = ul;
+ call_returning = ro;
+ call_error_handler = oeho } }
+
+let call_prefix :=
+ | i = ident_or_string;
+ | ian = ident_or_string; AS; in_ = ident_or_nested;
+ { CallProto { called = Some ian; prototype = in_ } }
+ | NESTED;
+ { CallProto { called = None; prototype = CallProtoNested } }
+
+let ident_or_nested :=
+ | ~ = ident;
+ | NESTED; {CallProtoNested}
+
+(* CANCEL STATEMENT (+COB85) *)
+
+%public let unconditional_action := ~ = cancel_statement; < >
+let cancel_statement :=
+ | CANCEL; ~ = idents_or_strings;
+
+
+
+(* CLOSE STATEMENT *)
+
+%public let unconditional_action := ~ = close_statement; < >
+let close_statement :=
+ | CLOSE; ~ = nel(i = name; cf = ro(close_format);
+ { { close_item = i; close_format = cf } });
+
+let close_format :=
+ | or_(REEL,UNIT); ~ = bo(FOR?; REMOVAL);
+ | WITH?; NO; REWIND; {CloseWithNoRewind}
+ | WITH?; LOCK; {CloseWithLock}
+
+
+
+(* COMPUTE STATEMENT *)
+
+%public let unconditional_action := ~ = compute_statement; < >
+let compute_statement :=
+ | COMPUTE; irl = rounded_idents; "="; e = expression;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR);
+ oterm_(END_COMPUTE);
+ { Compute { compute_targets = irl; compute_expr = e;
+ compute_on_size_error = h } }
+(* COB2002: added boolean form with bool_expr and no rounded (and no err) *)
+
+
+(* CONTINUE STATEMENT *)
+
+%public let unconditional_action := ~ = continue_statement; < >
+let continue_statement := CONTINUE; {Continue}
+
+
+
+(* DELETE STATEMENT *)
+
+%public let unconditional_action := ~ = delete_statement; < >
+let delete_statement :=
+ | DELETE; i = name; RECORD?; ro = ro(retry_phrase);
+ h = handler_opt(INVALID_KEY,NOT_INVALID_KEY);
+ oterm_(END_DELETE);
+ { Delete { delete_targets = i; delete_retry = ro;
+ delete_on_invalid_key = h} }
+(* retry: +COB2002 *)
+
+
+
+(* DISABLE STATEMENT (+COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = disable_statement; < >
+let disable_statement :=
+ | DISABLE; ~ = mcs_command;
+
+
+
+(* DISPLAY STATEMENT *)
+
+(* TODO: FROM and USING clauses *)
+%public let unconditional_action := ~ = display_statement;
+let display_statement :=
+ (* Ambiguous case *)
+ | DISPLAY; i = ident_or_literal; end_display;
+ { DisplayDefault i }
+
+ (* Device case (disambiguated) *)
+ | DISPLAY; i = ident_or_literal; d = display_device_disambiguated; end_display;
+ { let ill, io, wna = d in
+ DisplayDevice { displayed_items = i :: ill;
+ upon = io;
+ advancing = wna } }
+
+ (* Screen case (disambiguated) *) (* +COB2002 *)
+ | DISPLAY; i = name; dsd = display_screen_disambiguated; end_display;
+ { DisplayScreen { screen_item = i;
+ position = fst dsd;
+ on_exception = snd dsd; } }
+
+let end_display := oterm_(END_DISPLAY)
+
+let display_device_disambiguated ==
+ | ~ = rnel(ident_or_literal); ~ = ro(loc(upon)); ~ = ibo(with_no_advancing); < >
+ | i = loc(upon); wna = ibo(with_no_advancing); { [], Some i, wna }
+ | with_no_advancing; { [], None, true }
+
+let upon :=
+ | UPON; ~ = name;
+ | UPON; ~ = loc(display_device_mnemonic);
+let display_device_mnemonic ==
+ | ENVIRONMENT_NAME; {DisplayDeviceEnvName}
+ | ENVIRONMENT_VALUE; {DisplayDeviceEnvValue}
+ | ARGUMENT_NUMBER; {DisplayDeviceArgNumber}
+ | COMMAND_LINE; {DisplayDeviceCommandLine}
+let with_no_advancing := io(WITH); NO; ADVANCING
+
+let display_screen_disambiguated ==
+ | AT; p = position; h = handler_opt(on_exception,NOT_ON_EXCEPTION); { Some p, h }
+ | h = handler(on_exception,NOT_ON_EXCEPTION); { None, h }
+
+
+(* DIVIDE STATEMENT *)
+(* Slightly ambiguous: INTO ident ? *)
+(* Also deal with remainder -> single ir TODO *)
+
+%public let unconditional_action := ~ = divide_statement;
+divide_statement:
+ | DIVIDE in_ = ident_or_numeric INTO irl = rounded_idents
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); end_divide
+ { { divide_operands = DivideInto { divisor = in_; dividends = irl };
+ divide_on_size_error = h } }
+ | DIVIDE in1 = ident_or_numeric INTO in2 = ident_or_numeric
+ GIVING irl = rounded_idents ro = ro(pf(REMAINDER,ident))
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); (* no remainder: single ir *)
+ end_divide
+ { { divide_operands = DivideGiving { divisor = in1;
+ dividend = in2;
+ giving = irl;
+ into = true;
+ remainder = ro };
+ divide_on_size_error = h } }
+ | DIVIDE in1 = ident_or_numeric BY in2 = ident_or_numeric
+ GIVING irl = rounded_idents ro = ro(pf(REMAINDER,ident))
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); (* no remainder: single ir *)
+ end_divide
+ { { divide_operands = DivideGiving { dividend = in1;
+ divisor = in2;
+ giving = irl;
+ into = false;
+ remainder = ro };
+ divide_on_size_error = h } }
+
+let end_divide := oterm_(END_DIVIDE)
+
+
+(* ENABLE STATEMENT (+COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = enable_statement; < >
+(* let enable_statement := *)
+(* | ENABLE; io = input_output; i = name; iao = io(with_key); *)
+(* { Enable { enable_kind = io; enable_target = i; enable_key = iao} } *)
+
+let enable_statement :=
+ | ENABLE; ~ = mcs_command;
+
+
+(* ENTER STATEMENT (~COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = enter_statement; < >
+let enter_statement :=
+ | ENTER; i = name; io = ro(name); ".";
+ { Enter { enter_language = i; enter_routine = io} }
+
+
+
+(* EVALUATE STATEMENT (+COB85) *)
+(* COBOL 85 and COBOL 2002 differ significantly *)
+(* Particularly ambiguous, especially the selection subjects/objects *)
+(*
+
+selection subject:
+
+ when ident is numeric or boolean of length 1, it is really
+ considered as an ident and not as an arith/bool expression
+
+selection object:
+
+partial_exp = sequence of cobol words starting with
+ a relational operator,
+ a class condition without identifier,
+ a sign condition without identifier,
+ a sign condition without the arithmetic expression
+
+selection_subject followed by partial_exp = conditional exp
+
+Partial exp = ident/zero is ambiguous, could be
+ NOT? class_condition / sign_condition (partial exp)
+ NOT? expression (ident/zero)
+*)
+
+%public let unconditional_action := ~ = evaluate_statement; < >
+let evaluate_statement :=
+ | EVALUATE; ssl = selection_subjects; wl = nell(when_phrase);
+ isl = when_other; oterm_(END_EVALUATE);
+ { Evaluate { eval_subjects = ssl;
+ eval_branches = wl;
+ eval_otherwise = isl; } }
+
+let selection_subjects :=
+ | ss = selection_subject; { [ss] }
+ | ss = selection_subject; ALSO; ssl = selection_subjects; { ss :: ssl }
+
+let selection_subject :=
+ | c = condition; {Subject c} (* also arith/bool expr *)
+ | TRUE; {SubjectConst true}
+ | FALSE; {SubjectConst false}
+
+let selection_objects :=
+ | so = selection_object; { [so] }
+ | so = selection_object; ALSO; sol = selection_objects; { so :: sol }
+
+let selection_object :=
+ | c = condition; {SelCond c} (* also arith/bool exp*)
+ | ~ = range_expression; < >
+ | ~ = partial_expression; < > (* +COB2002 *)
+ | TRUE; {SelConst true}
+ | FALSE; {SelConst false}
+ | ANY; {SelAny: selection_object}
+
+let range_expression :=
+ | b = ibo(NOT); i1 = expression; THROUGH;
+ i2 = expression; i = ro(pf(IN,name));
+ { SelRange { negated = b; start = i1; stop = i2; alphabet = i } }
+
+let partial_expression :=
+ | o = relop; e = expression;
+ { SelRelation { relation = o; expr = e } } (* relation (general, bool, pointer) *)
+ | IS; n = bo(NOT); c = class_condition;
+ { SelClassCond { negated = n; class_specifier = c } } (* class *) (* exp = ident *)
+ | n = bo(NOT); c = class_condition_no_ident;
+ { SelClassCond { negated = n; class_specifier = c } } (* class *) (* exp = ident *)
+ | IS; n = bo(NOT); s = sign_condition;
+ { SelSignCond { negated = n; sign_specifier = s } } (* sign *) (* exp = arith exp *)
+ | n = bo(NOT); s = sign_condition_no_zero;
+ { SelSignCond { negated = n; sign_specifier = s } } (* sign *) (* exp = arith exp *)
+ | io(IS); n = bo(NOT); OMITTED;
+ { SelOmitted { negated = n } } (* omitted *) (* exp = ident *)
+
+let when_phrase :=
+ | wl = rnel(when_selection_objects); isl = imp_stmts;
+ { {eval_selection = wl; eval_actions = isl} }
+
+let when_selection_objects := WHEN; ~ = selection_objects; < >
+
+let when_other :=
+ | %prec lowest { [] }
+ | WHEN; OTHER; ~ = imp_stmts; < >
+
+
+
+(* EXIT STATEMENT *)
+
+%public let unconditional_action := ~ = exit_statement; < >
+let exit_statement [@context exit_stmt] :=
+ | EXIT; ~ = exit_spec;
+let exit_spec [@recovery ExitSimple] :=
+ | %prec lowest { ExitSimple }
+ | PROGRAM; ro = ro(raising_exception); { ExitProgram ro }
+ | METHOD; ro = ro(raising_exception); { ExitMethod ro } (* COB2002+ *)
+ | FUNCTION; ro = ro(raising_exception); { ExitFunction ro } (* COB2002+ *)
+ | PERFORM; c = bo(CYCLE); { ExitPerform c } (* COB2002+ *)
+ | PARAGRAPH; { ExitParagraph } (* COB2002+ *)
+ | SECTION; { ExitSection } (* COB2002+ *)
+
+
+
+(* FREE STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = free_statement; < >
+let free_statement :=
+ | FREE; ~ = names;
+
+
+(* GENERATE STATEMENT (+COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = generate_statement; < >
+let generate_statement :=
+ | GENERATE; ~ = name;
+
+
+
+(* GO TO STATEMENT *)
+
+%public let unconditional_action := ~ = go_to_statement; < >
+let go_to_statement :=
+ | GO; TO?; i = qualified_procedure_name;
+ { GoTo i }
+ | GO; TO?; il = rnel(qualified_procedure_name);
+ DEPENDING; ON?; i = ident;
+ { GoToDepending { goto_depending_targets = il; goto_depending_on = i; } }
+ | GO; TO?; (* COB85; obsolete; should be sole statement of paragraph *)
+ { LoneGoTo }
+
+
+
+(* GOBACK STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = goback_statement; < >
+let goback_statement :=
+ | GOBACK; ~ = ro(raising_exception);
+
+
+
+(* IF STATEMENT *)
+
+let if_statement :=
+ | IF; c = condition; THEN?; ib = if_body; oterm_(END_IF);
+ { let sn, sno = ib in
+ If {condition = c; then_branch = sn; else_branch = sno} }
+(* COB2002: END IF mandatory on ELSE, NEXT STATEMENT archaic *)
+
+let if_body :=
+ | isl = imp_stmts; %prec lowest { Statements isl, None }
+ | isl = imp_stmts; ep = else_phrase; { Statements isl, Some ep }
+ | NEXT; SENTENCE; %prec lowest { NextSentence, None }
+ | NEXT; SENTENCE; ep = else_phrase; { NextSentence, Some ep }
+
+let else_phrase :=
+ | ELSE; NEXT; SENTENCE; { NextSentence }
+ | ELSE; isl = imp_stmts; { Statements isl }
+
+
+(* INITIALIZE STATEMENT (+COB85) *)
+
+%public let unconditional_action := ~ = initialize_statement; < >
+let initialize_statement :=
+ | INITIALIZE; il = idents;
+ wf = ibo(io(WITH); FILLER); (* +COB2002 *)
+ co = io(category_to_value); (* +COB2002 *)
+ rl = ilo(then_replacing);
+ d = ibo(THEN?; TO?; DEFAULT);
+ { Initialize {
+ init_items = il;
+ init_filler = wf;
+ init_category = co;
+ init_replacings = rl;
+ init_to_default = d; } }
+
+let category_to_value :=
+ | ALL; TO?; VALUE; {InitAll}
+ | ~ = init_data_category; TO?; VALUE;
+
+let then_replacing :=
+ | THEN?; REPLACING;
+ ~ = nel(c = init_data_category; DATA?; BY; il = ident_or_literal;
+ { { init_replacing_category = c;
+ init_replacing_replacement_item = il } }); < >
+
+let init_data_category :=
+ | ALPHABETIC; {InitCategoryAlphabetic}
+ | ALPHANUMERIC; {InitCategoryAlphanumeric}
+ | ALPHANUMERIC_EDITED; {InitCategoryAlphanumericEdited}
+ | BOOLEAN; {InitCategoryBoolean} (* +COB2002 *)
+ | DATA_POINTER; {InitCategoryDataPointer} (* +COB2002 *)
+ | FUNCTION_POINTER; {InitCategoryFunctionPointer}
+ | NATIONAL; {InitCategoryNational} (* +COB2002 *)
+ | NATIONAL_EDITED; {InitCategoryNationalEdited} (* +COB2002 *)
+ | NUMERIC; {InitCategoryNumeric}
+ | NUMERIC_EDITED; {InitCategoryNumericEdited}
+ | OBJECT_REFERENCE; {InitCategoryObjectReference} (* +COB2002 *)
+ | PROGRAM_POINTER; {InitCategoryProgramPointer} (* +COB2002 *)
+
+
+
+(* INITIATE STATEMENT (+COB85) *)
+
+%public let unconditional_action := ~ = initiate_statement; < >
+let initiate_statement :=
+ | INITIATE; ~ = names;
+
+
+
+(* INSPECT STATEMENT *)
+
+%public let unconditional_action := ~ = inspect_statement; < >
+let inspect_statement :=
+ | INSPECT; i = ident; s = inspect_spec;
+ { Inspect { inspect_item = i; inspect_spec = s } }
+
+let inspect_spec :=
+ | TALLYING; tpl = rnell(tallying);
+ { InspectTallying tpl }
+ | REPLACING; rpl = rnel(loc(replacing_phrase));
+ { InspectReplacing rpl }
+ | TALLYING; tpl = rnell(tallying);
+ REPLACING; rpl = rnel(loc(replacing_phrase));
+ { InspectBoth (tpl, rpl) }
+ | CONVERTING;
+ il1 = ident_or_nonnumeric_no_all; TO; il2 = ident_or_nonnumeric;
+ abl = rl(inspect_where);
+ { InspectConverting { converting_from = il1;
+ converting_to = il2;
+ converting_where = abl; } }
+
+let tallying :=
+ | i = qualident; FOR; tfl = rnel(loc(tallying_for));
+ { { tallying_target = i; tallying_clauses = tfl } }
+
+let tallying_for :=
+ | CHARACTERS; l = rl(inspect_where); {TallyingCharacters l}
+ | ALL; l = ident_after_before_list; {TallyingRange (TallyAll, l)}
+ | LEADING; l = ident_after_before_list; {TallyingRange (TallyLeading, l)}
+
+let ident_after_before_list :=
+ | iab = ident_after_before; %prec below_RPAR { [iab] }
+ | iab = ident_after_before; iabl = ident_after_before_list; { iab::iabl }
+
+let ident_after_before :=
+ | il = ident_or_nonnumeric_no_all; ab = rl(inspect_where);
+ { { tallying_item = il; tallying_where = ab } }
+
+let inspect_where :=
+ | AFTER; INITIAL?; i = ident_or_nonnumeric_no_all; {InspectAfter, i}
+ | BEFORE; INITIAL?; i = ident_or_nonnumeric_no_all; {InspectBefore, i}
+
+let replacing_phrase :=
+ | CHARACTERS; BY; il = ident_or_nonnumeric_no_all; abo = rl(inspect_where);
+ { ReplacingCharacters { replacement = il; where = abo } }
+ | ALL; l = rnel(ident_by_after_before); {ReplacingRange (ReplaceAll, l)}
+ | LEADING; l = rnel(ident_by_after_before); {ReplacingRange (ReplaceLeading, l)}
+ | FIRST; l = rnel(ident_by_after_before); {ReplacingRange (ReplaceFirst, l)}
+
+let ident_by_after_before :=
+ | il1 = ident_or_nonnumeric_no_all; BY;
+ il2 = ident_or_nonnumeric_no_all;
+ abo = rl(inspect_where);
+ { {replacing_item = il1; replacing_by = il2; replacing_where = abo} }
+
+
+
+(* INVOKE STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = invoke_statement; < >
+let invoke_statement :=
+ | INVOKE; i = ident; is = ident_or_string;
+ ul = lo(pf(USING,rnel(loc(using_by)))); ro = ro(returning);
+ { Invoke { invoke_target = i;
+ invoke_method = is;
+ invoke_using = ul;
+ invoke_returning = ro } }
+
+
+
+(* MERGE STATEMENT *)
+
+%public let unconditional_action := ~ = merge_statement; < >
+let merge_statement :=
+ | MERGE; i = name; okl = rnel(on_key); cso = ro(collating_sequence_phrase);
+ USING; il = names; og = output_or_giving;
+ { Merge { merge_file = i;
+ merge_keys = okl;
+ merge_collating = cso;
+ merge_using = il;
+ merge_target = og } }
+
+
+
+(* MOVE STATEMENT *)
+
+%public let unconditional_action := ~ = move_statement; < >
+let move_statement :=
+ | MOVE; from = ident_or_literal; TO; to_ = idents;
+ { Move (MoveSimple { from; to_ }) }
+ | MOVE; CORRESPONDING; from = ident; TO; to_ = idents;
+ { Move (MoveCorresponding { from; to_ }) }
+
+
+
+(* MULTIPLY STATEMENT *)
+
+%public let unconditional_action := ~ = multiply_statement;
+let multiply_statement :=
+ | MULTIPLY; in_ = ident_or_numeric; BY; irl = rounded_idents;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR);end_multiply;
+ { { multiply_operands = MultiplyBy { multiplier = in_; multiplicand = irl };
+ multiply_on_size_error = h; } }
+ | MULTIPLY; in1 = ident_or_numeric; BY; in2 = ident_or_numeric;
+ GIVING; irl = rounded_idents;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR);end_multiply;
+ { { multiply_operands = MultiplyGiving { multiplier = in1;
+ multiplicand = in2;
+ targets = irl; };
+ multiply_on_size_error = h; } }
+
+let end_multiply := oterm_(END_MULTIPLY)
+
+(* OPEN STATEMENT (+COB85) *)
+(* COB85 has may restrictions over COB2002 as to accepted syntax *)
+
+%public let unconditional_action := ~ = open_statement; < >
+let open_statement :=
+ | OPEN; ~ = rnel(open_phrase);
+
+let open_phrase :=
+ | om = open_mode;
+ so = ro(sharing_phrase); (* +COB2002 *)
+ ro = ro(retry_phrase); (* +COB2002 *)
+ frl = rnel(file_with_opt);
+ { { open_mode = om; open_sharing = so; open_retry = ro; open_files = frl} }
+
+let sharing_phrase [@context sharing_phrase] :=
+ | SHARING; WITH?; ~ = sharing_mode; < >
+
+let sharing_mode :=
+ | ALL; OTHER?; {SharingAllOther}
+ | NO; OTHER?; {SharingNoOther}
+ | READ; ONLY; {SharingReadOnly}
+
+let file_with_opt :=
+ | i = name; rwo = reversed_or_no_rewind_opt;
+ { { named_file_name = i; named_file_option = rwo } }
+
+let reversed_or_no_rewind_opt :=
+ | {None}
+ | REVERSED; {Some FileOptReversed} (* -COB2002 *)
+ | mr(NO; REWIND | WITH; NO; REWIND); {Some FileOptWithNoRewind}
+
+
+
+(* PERFORM STATEMENT *)
+(* COB85 and COB2002 differ significantly *)
+(* TODO: COB85 first format also takes instructions... *)
+
+%public let unconditional_action := ~ = perform_statement; < >
+let perform_statement :=
+ | PERFORM; i = qualified_procedure_name;
+ io = ro(pf(THROUGH,qualified_procedure_name));
+ po = io(perform_phrase);
+ { Perform { perform_target = PerformOutOfLine { procedure_start = i;
+ procedure_end = io };
+ perform_mode = po } }
+ | PERFORM; po = ro(perform_phrase); isl = imp_stmts; END_PERFORM;
+ { Perform { perform_target = PerformInline isl;
+ perform_mode = po } }
+
+let perform_phrase :=
+ | ~ = ident_or_integer; TIMES;
+ | wt = ro(with_test); UNTIL; until = condition;
+ { PerformUntil { with_test = wt; until } }
+ | wt = ro(with_test); VARYING; v = loc(varying_phrase);
+ vl = l(pf(AFTER,loc(varying_phrase)));
+ { PerformVarying { with_test = wt; varying = v; after = vl } }
+
+let with_test := WITH?; TEST; ~ = after_or_before; < >
+
+let varying_phrase :=
+ | i = ident; FROM; in_ = ident_or_numeric;
+ ino = ro(pf(BY,ident_or_numeric));
+ UNTIL; c = condition;
+ { { varying_ident = i; varying_from = in_;
+ varying_by = ino; varying_until = c } }
+
+
+
+(* PURGE STATEMENT (+COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = purge_statement; < >
+let purge_statement :=
+ | PURGE; ~ = name;
+
+
+
+(* RAISE STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = raise_statement;
+let raise_statement :=
+ | RAISE; EXCEPTION; i = name; { RaiseException i }
+ | RAISE; i = ident; { RaiseIdent i }
+
+
+
+(* READ STATEMENT *)
+(* Very ambiguous: sequential and random cases merged and disambiguated later *)
+(* Also, COB2002 has more options. *)
+
+%public let unconditional_action := ~ = read_statement; < >
+let read_statement [@context read_stmt] :=
+ | READ; i = name; npo = ro(read_direction); RECORD?;
+ io = ro(pf(INTO,ident));
+ lro = ro(lock_or_retry); (* +COB2002 *)
+ wlo = with_lock; (* +COB2002 *)
+ ko = ro(pf(KEY; IS?, qualname));
+ ho = io(at_end_or_invalid_key_handler);
+ oterm_(END_READ);
+ { Read { read_file = i;
+ read_direction = npo;
+ read_into = io;
+ read_lock_behavior = lro;
+ read_lock = wlo;
+ read_key = ko;
+ read_error_handler = ho } }
+
+let read_direction := NEXT; {ReadNext} | PREVIOUS; {ReadPrevious} (* +COB2002 *)
+
+let lock_or_retry :=
+ | ADVANCING; ON?; LOCK; {ReadAdvancingOnLock}
+ | IGNORING; LOCK; {ReadIgnoringLock}
+ | ~ = retry_phrase;
+
+
+
+(* RECEIVE STATEMENT (+COB85, -COB2002) *)
+
+%public let unconditional_action := ~ = receive_statement; < >
+let receive_statement :=
+ | RECEIVE; i1 = name; ms = message_or_segment; INTO; i2 = ident;
+ nd = ilo(pf(NO_DATA,imp_stmts));
+ wd = ilo(pf(with_data,imp_stmts));
+ oterm_(END_RECEIVE);
+ { Receive { receive_name = i1; receive_kind = ms; receive_into = i2;
+ receive_on_no_data = { dual_handler_pos = nd;
+ dual_handler_neg = wd } } }
+
+let message_or_segment := MESSAGE; {MCSMessage} | SEGMENT; {MCSSegment}
+let with_data := DATA | WITH_DATA
+
+
+
+(* RELEASE STATEMENT *)
+
+%public let unconditional_action := ~ = release_statement; < >
+let release_statement :=
+ | RELEASE; i = name; ilo = ro(pf(FROM,ident_or_literal));
+ { Release { release_item = i; release_from = ilo } } (* Literal only in COB2002+ *)
+
+
+
+(* RESUME STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = resume_statement; < >
+let resume_statement [@context resume_stmt] :=
+ | RESUME; AT?; NEXT; STATEMENT; { ResumeNextStatement }
+ | RESUME; AT?; i = qualified_procedure_name; { Resume i }
+
+
+
+(* RETURN STATEMENT *)
+
+%public let unconditional_action := ~ = return_statement; < >
+let return_statement :=
+ | RETURN; i = name; RECORD?; io = ro(pf(INTO,loc(ident)));
+ (* ae = at_end nae = ilo(NOT nae = at_end { nae }) end_return*)
+ isl1 = pf(at_end,imp_stmts);
+ isl2 = ilo(pf(NOT_AT_END,imp_stmts)); oterm_(END_RETURN);
+ { Return { return_file = i; return_into = io;
+ return_at_end = { dual_handler_pos = isl1;
+ dual_handler_neg = isl2 } } }
+
+
+
+(* REWRITE STATEMENT *)
+
+%public let unconditional_action := ~ = rewrite_statement; < >
+let rewrite_statement :=
+ | REWRITE; if_ = write_target; RECORD?; (* RECORD: +COB2002 *)
+ ilo = ro(pf(FROM,ident_or_literal));
+ ro = ro(retry_phrase); (* +COB2002 *)
+ wl = with_lock; (* +COB2002 *)
+ h = handler_opt(INVALID_KEY,NOT_INVALID_KEY);
+ oterm_(END_REWRITE);
+ { Rewrite { rewrite_to = if_;
+ rewrite_from = ilo;
+ rewrite_retry = ro;
+ rewrite_lock = wl;
+ rewrite_invalid_key_handler = h } }
+
+
+
+(* SEARCH STATEMENT *)
+(* TODO: merge when_clause / statements_or_next *)
+
+%public let unconditional_action := ~ = search_statement;
+let search_statement :=
+ | SEARCH; i = qualname;
+ io = ro(pf(VARYING,ident));
+ ae = ilo(pf(at_end,imp_stmts));
+ wcl = nell(loc(when_clause));
+ end_search;
+ { { search_item = i;
+ search_at_end = ae;
+ search_spec = SearchSerial { varying = io; when_clauses = wcl } } }
+ | SEARCH; ALL; i = qualname;
+ ae = ilo(pf(at_end,imp_stmts));
+ WHEN; sc = search_condition; scl = ll(and_clause);
+ sn = statements_or_next;
+ end_search;
+ { { search_item = i;
+ search_at_end = ae;
+ search_spec = SearchAll { conditions = sc :: scl; action = sn } } }
+
+let end_search := oterm_(END_SEARCH)
+
+let when_clause :=
+ | WHEN; c = condition; s = statements_or_next;
+ { { search_when_cond = c; search_when_stmts = s } }
+
+let and_clause :=
+ | AND; ~ = search_condition; < >
+
+let search_condition :=
+ | i = qualident; IS?; or_(EQUAL, "="); TO?; e = expression;
+ { IsEqual { data_item = i; condition = e } }
+ | i = qualident; {Cond i}
+
+let statements_or_next ==
+ | isl = imp_stmts; {Statements isl}
+ | NEXT; SENTENCE; {NextSentence}
+
+
+
+(* SEND STATEMENT (+COB85, -COB2002) *)
+(* Somewhat ambiguous *)
+
+%public let unconditional_action := ~ = send_statement; < >
+let send_statement :=
+ | SEND; i1 = name; FROM; i2 = ident;
+ { Send { send_name = i1;
+ send_operands = SendSimple { from = i2 } } }
+ | SEND; i = name; io = io(pf(FROM,ident)); WITH?; ei = ending_indicator;
+ ao = ro(advancing_phrase); r = bo(REPLACING; LINE);
+ { Send { send_name = i;
+ send_operands = SendWith { from = io;
+ ending_indicator = ei;
+ advancing = ao;
+ replace = r } } }
+
+let ending_indicator :=
+ | i = ident; {EndingIndicator i}
+ | ESI; {EndingIndicatorESI}
+ | EMI; {EndingIndicatorEMI}
+ | EGI; {EndingIndicatorEGI}
+
+let advancing_phrase :=
+ | stage = after_or_before; ADVANCING?; PAGE;
+ { AdvancingPage { stage } }
+ | stage = after_or_before; ADVANCING?; i = ident_or_integer;
+ b = bo(or_(LINE,LINES));
+ { AdvancingLines { stage; lines = i; ambiguous = not b } }
+
+
+
+(* SET STATEMENT *)
+(* Very ambiguous *)
+
+%public let unconditional_action := ~ = set_statement;
+let set_statement [@context set_stmt] :=
+ (* Ambiguous cases (formats 1, 2, 5, 7, 8, 9, 10 and 14) *)
+ | SET; i = ident; TO; la = locale_or_ambiguous;
+ { match la with
+ | `Locale ld ->
+ SetSaveLocale { target = i; locale = ld }
+ | `Expr e ->
+ SetAmbiguous { targets = [i]; value = e;
+ set_method = SetMethodTo } }
+ | SET; i = ident; il = idents; TO; e = expression;
+ { SetAmbiguous { targets = i :: il; set_method = SetMethodTo; value = e } }
+ | SET; il = idents; ud = up_down; e = expression;
+ { SetAmbiguous { targets = il; set_method = ud; value = e } }
+ (* Switch and Condition (formats 3 and 4) *)
+ | SET; sl = rnell(i = ident; TO; oo = on_or_off;
+ { { set_switch_targets = [i]; set_switch_value = oo } });
+ { SetSwitch sl }
+ | SET; sl = rnell(i = ident; il = idents; TO; oo = on_or_off;
+ { { set_switch_targets = i :: il; set_switch_value = oo } });
+ { SetSwitch sl }
+ | SET; cl = rnell(i = ident; TO; tf = boollit;
+ { { set_condition_targets = [i]; set_condition_value = tf } });
+ { SetCondition cl }
+ | SET; cl = rnell(i = ident; il = idents; TO; tf = boollit;
+ { { set_condition_targets = i :: il; set_condition_value = tf } });
+ { SetCondition cl }
+
+ (* The following were added in COB2002 (formats 6, 11, 12, 13, 15) *)
+ | SET; i = name; al = set_attribute_switches;
+ { SetAttribute { name = i; attribute_switches = al } }
+ | SET; LOCALE; ld = locale_or_default; TO; lv = locale_value_or_ident;
+ { SetLocale { target = ld; source = lv } }
+ | SET; LAST; EXCEPTION; TO; OFF;
+ { SetSavedException }
+ | SET; CONTENT; OF?; il = idents; TO; fc = float_content; so = ro(sign);
+ { SetFloatContent { targets = il; content = fc; sign = so } }
+
+let locale_or_ambiguous :=
+ | LOCALE; ld = lc_all_or_default; { `Locale ld }
+ | e = expression; { `Expr e }
+
+let set_attribute_switches [@context set_attribute_stmt] :=
+ | ATTRIBUTE; ~ = rnel(screen_attribute_on_off); < >
+
+let screen_attribute_on_off :=
+ | sa = screen_attribute_name; oo = on_or_off;
+ { { set_attribute = sa; set_attribute_switch_value = oo} }
+
+let up_down :=
+ | UP; BY; {SetMethodUp}
+ | DOWN; BY; {SetMethodDown}
+
+let on_or_off :=
+ | ON; {On}
+ | OFF; {Off}
+
+let boollit :=
+ | TRUE; {true}
+ | FALSE; {false}
+
+let screen_attribute_name :=
+ | BELL; {ScreenBell}
+ | BLINK; {ScreenBlink}
+ | HIGHLIGHT; {ScreenHighlight}
+ | LOWLIGHT; {ScreenLowlight}
+ | REVERSE_VIDEO; {ScreenReverseVideo}
+ | UNDERLINE; {ScreenUnderline}
+
+let locale_category :=
+ | LC_ALL; {LcAll}
+ | LC_COLLATE; {LcCollate}
+ | LC_CTYPE; {LcCtype}
+ | LC_MESSAGES; {LcMessages}
+ | LC_MONETARY; {LcMonetary}
+ | LC_NUMERIC; {LcNumeric}
+ | LC_TIME; {LcTime}
+
+let locale_or_default :=
+ | l = locale_category; {SetLocaleTarget l}
+ | USER_DEFAULT; {SetLocaleTargetUserDefault}
+
+let locale_value_or_ident :=
+ | i = ident; {SetLocaleSource i}
+ | USER_DEFAULT; {SetLocaleSourceUserDefault}
+ | SYSTEM_DEFAULT; {SetLocaleSourceSystemDefault}
+
+let lc_all_or_default :=
+ | LC_ALL; {SetSaveLocaleLcAll}
+ | USER_DEFAULT; {SetSaveLocaleUserDefault}
+
+let float_content :=
+ | FARTHEST_FROM_ZERO; ~ = bo(IN_ARITHMETIC_RANGE);
+ | NEAREST_TO_ZERO; ~ = bo(IN_ARITHMETIC_RANGE);
+ | FLOAT_INFINITY; {FloatInfinity}
+ | FLOAT_NOT_A_NUMBER; {FloatNotANumber}
+ | FLOAT_NOT_A_NUMBER_SIGNALING; {FloatNotANumberSignaling}
+
+let sign :=
+ | POSITIVE; {SgnPositive}
+ | NEGATIVE; {SgnNegative}
+
+
+
+(* SORT STATEMENT *)
+
+%public let unconditional_action := ~ = sort_statement; < >
+let sort_statement :=
+ | SORT; i = qualident;
+ wd = ibo(WITH?; DUPLICATES; IN?; ORDER?);
+ cso = ro(collating_sequence_phrase);
+ { Sort (SortTable { table = i;
+ keys = [];
+ duplicate_in_order = wd;
+ collating = cso }) }
+ | SORT; i = qualident; okl = rnel(on_key);
+ wd = ibo(WITH?; DUPLICATES; IN?; ORDER?);
+ cso = ro(collating_sequence_phrase);
+ { Sort (SortTable { table = i;
+ keys = okl;
+ duplicate_in_order = wd;
+ collating = cso }) }
+ | SORT; i = qualident; okl = rnel(on_key);
+ wd = ibo(WITH?; DUPLICATES; IN?; ORDER?);
+ cso = ro(collating_sequence_phrase);
+ iu = input_or_using;
+ og = output_or_giving;
+ { Sort (SortFile { file = i;
+ keys = okl;
+ duplicate_in_order = wd;
+ collating = cso;
+ source = iu;
+ target = og }) }
+(* COB2002 also has an alternate more restricted form for tables *)
+
+let input_or_using :=
+ | INPUT; PROCEDURE; IS?; i = procedure_name;
+ io = ro(pf(THROUGH,procedure_name));
+ { SortInputProcedure { procedure_start = i; procedure_end = io } }
+ | USING; names = names;
+ { SortUsing names }
+
+
+
+(* START STATEMENT *)
+
+%public let unconditional_action := ~ = start_statement; < >
+let start_statement :=
+ | START; i = name; fpo = io(start_position);
+ h = handler_opt(INVALID_KEY,NOT_INVALID_KEY); oterm_(END_START);
+ { Start { start_file = i; start_position = fpo; start_on_invalid_key = h} }
+
+let start_position ==
+ | FIRST; { StartPositionFirst }
+ | LAST; { StartPositionLast }
+ | KEY; ro = relop; i = qualname;
+ wlo = io(pf(WITH?; LENGTH,expression)); (* arith *)
+ { StartPositionKey { operator = ro; name = i; length = wlo } }
+
+
+
+(* STOP STATEMENT *)
+
+%public let unconditional_action := ~ = stop_statement;
+let stop_statement [@context stop_stmt] :=
+ | STOP; RUN; so = ro(with_status); { StopRun so } (* status: +COB2002 *)
+ | STOP; l = literal; { StopLiteral l } (* ~COB85, -COB2002 *)
+
+let with_status :=
+ | WITH; stop_kind = stop_kind;
+ STATUS?; stop_status = ident_or_literal; { { stop_kind; stop_status } }
+
+let stop_kind :=
+ | ERROR; {StopRunError}
+ | NORMAL; {StopRunNormal}
+
+
+
+(* STRING STATEMENT *)
+
+%public let unconditional_action := ~ = string_statement; < >
+let string_statement :=
+ | STRING; ss = nell(source_string); INTO; i = ident;
+ wp = io(pf(WITH?; POINTER,ident));
+ h = handler_opt(on_overflow,NOT_ON_OVERFLOW); oterm_(END_STRING);
+ { String { string_sources = ss; string_target = i;
+ string_pointer = wp; string_on_overflow = h } }
+
+let source_string :=
+ | i = ident_or_nonnumeric_no_all; db = ro(s_delimited_by);
+ { { string_source = i; string_delimiter = db} }
+
+(* NOTE: This is not perfectly standard, but we can figure out the delimiter for each item
+ * in later analysis *)
+let s_delimited_by :=
+ | DELIMITED; BY?; ~ = ident_or_nonnumeric_no_all;
+ | DELIMITED; BY?; SIZE; {StringDelimiterSize}
+
+
+
+(* SUBTRACT STATEMENT *)
+
+%public let unconditional_action := ~ = subtract_statement; < >
+let subtract_statement :=
+ | SUBTRACT; inl = idents_or_numerics; FROM; irl = rounded_idents;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); end_subtract;
+ { Subtract { basic_arith_operands =
+ ArithSimple { sources = inl; targets = irl };
+ basic_arith_on_size_error = h } }
+ | SUBTRACT; inl = idents_or_numerics; FROM; in_ = ident_or_numeric;
+ GIVING; irl = rounded_idents;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); end_subtract;
+ { Subtract { basic_arith_operands =
+ ArithGiving { sources = inl;
+ to_or_from_item = in_;
+ targets = irl };
+ basic_arith_on_size_error = h } }
+ | SUBTRACT; CORRESPONDING; i = qualname; FROM; ir = rounded_ident;
+ h = handler_opt(ON_SIZE_ERROR,NOT_ON_SIZE_ERROR); end_subtract;
+ { Subtract { basic_arith_operands =
+ ArithCorresponding { source = i; target = ir };
+ basic_arith_on_size_error = h } }
+(* COB85: 1 ON SIZE ERROR, THEN 1 NOT ON SIZE ERROR
+ COB2002: order irrelevant *)
+
+let end_subtract := oterm_(END_SUBTRACT)
+
+
+
+(* SUPPRESS STATEMENT (+COB85) *)
+(* May only be used in USE BEFORE REPORTING *)
+
+%public let unconditional_action := ~ = suppress_statement; < >
+let suppress_statement :=
+ | SUPPRESS; PRINTING?; {Suppress}
+
+
+
+(* TERMINATE STATEMENT (+COB85) *)
+
+%public let unconditional_action := ~ = terminate_statement; < >
+let terminate_statement :=
+ | TERMINATE; ~ = names;
+
+
+
+(* TRANSFORM STATEMENT (GCOS7, MF (via IBM OS/VS), maybe others, and obviously
+ GnuCOBOL) --- TODO: dialect option? *)
+
+%public let unconditional_action := ~ = transform_statement; < >
+let transform_statement :=
+ | TRANSFORM; i = loc(ident); CHARACTERS?;
+ FROM; from = loc(ident_or_nonnumeric_no_all); (* CHECKME: ALL? *)
+ TO; to_ = loc(ident_or_nonnumeric); (* ditto *)
+ { Transform { transform_ident = i;
+ transform_from = from;
+ transform_to = to_ } }
+
+
+
+(* UNLOCK STATEMENT (+COB2014 ?) *)
+
+%public let unconditional_action := ~ = unlock_statement; < >
+let unlock_statement :=
+ | UNLOCK; i = name; ro = bo(or_(RECORD,RECORDS));
+ { Unlock { unlock_file = i; unlock_record = ro } }
+
+
+
+(* UNSTRING STATEMENT *)
+
+%public let unconditional_action := ~ = unstring_statement; < >
+let unstring_statement :=
+ | UNSTRING; i = ident; dbo = unstring_delimiters;
+ INTO; idl = rnel(unstring_target);
+ wp = io(pf(WITH?; POINTER,ident));
+ ti = io(pf(TALLYING; IN?,ident));
+ h = handler_opt(on_overflow,NOT_ON_OVERFLOW); oterm_(END_UNSTRING);
+ { Unstring { unstring_source = i;
+ unstring_delimiters = dbo;
+ unstring_targets = idl;
+ unstring_pointer = wp;
+ unstring_tallying = ti;
+ unstring_on_overflow = h } }
+
+let unstring_delimiters [@recovery []] [@symbol ""] :=
+ | (* empty *) { [] }
+ | DELIMITED; BY?; ao = bo(ALL); il = ident_or_string_no_all;
+ aill = l(OR; ao = bo(ALL); il = ident_or_string_no_all;
+ { { unstring_delimiter_by_all = ao; unstring_delimiter = il } });
+ { { unstring_delimiter_by_all = ao; unstring_delimiter = il } :: aill }
+
+let unstring_target :=
+ | i = ident; i1o = ro(pf(DELIMITER; IN?,ident));
+ i2o = ro(pf(COUNT; IN?,ident));
+ { { unstring_target = i;
+ unstring_target_delimiter = i1o;
+ unstring_target_count = i2o } }
+
+
+
+(* USE STATEMENT *)
+
+(*
+SEQUENTIAL/RELATIVE/INDEXED IO (when USE is present) (P 408, 446, 488)
+ USE AFTER STANDARD {EXCEPTION/ERROR} PROCEDURE ON {fname/IN/OUT/EXT}...
+IPC (P 550)
+ USE GLOBAL? AFTER STANDARD {EXCEPTION/ERROR} PROCEDURE ON {fn/IN/OUT/EXT}...
+ USE GLOBAL? BEFORE REPORTING ident
+REPORT WRITER (P 640)
+ USE AFTER STANDARD {EXCEPTION/ERROR} PROCEDURE ON {fn/OUT/EXT}...
+ USE BEFORE REPORTING ident
+DEBUGGING (P 692)
+ USE FOR DEBUGGING ON {cn/fn/pn/[ALL REFS OF]id/ALL PROCS}...
+*)
+
+let use_statement :=
+ | USE; g = ibo(GLOBAL); io(AFTER); io(STANDARD);
+ or_(EXCEPTION, ERROR); PROCEDURE?; ON?; io = names_or_open_mode;
+ { UseAfterFileException { global = g; trigger = io } }
+ | USE; g = bo(GLOBAL); BEFORE; REPORTING; i = ident;
+ { UseBeforeReporting { global = g; report_group = i } }
+ | USE; FOR?; DEBUGGING; ON?; dt = rnel(debug_target); (* -COB2002 *)
+ { UseForDebugging dt }
+ | USE; io(AFTER); exception_condition;
+ efl = rnel(use_after_exception); (* +COB2002 *)
+ { UseAfterIOException efl }
+ | USE; io(AFTER); exception_object; i = name; (* +COB2002 *)
+ { UseAfterExceptionObject i }
+
+let names_or_open_mode :=
+ | i = names; { UseFileExceptionOnNames i }
+ | om = open_mode; { UseFileExceptionOnOpenMode om }
+
+let exception_condition == EXCEPTION; CONDITION | EC
+let exception_object == EXCEPTION; OBJECT | EO
+
+let use_after_exception :=
+ | i = name; fl = rl(pf(FILE,name));
+ { { use_after_exception = i; use_after_exception_on_files = fl } }
+
+let debug_target :=
+ | all = bo(ALL; REFERENCES?; OF?); procedure = qualified_procedure_name;
+ { UseForDebuggingProcedure { all; procedure } }
+ | ALL; PROCEDURES;
+ { UseForDebuggingAllProcedures }
+
+
+
+(* VALIDATE STATEMENT (+COB2002) *)
+
+%public let unconditional_action := ~ = validate_statement; < >
+let validate_statement :=
+ | VALIDATE; ~ = idents;
+
+
+
+(* WRITE STATEMENT *)
+(* Sequential and random cases are ambiguous -> merged *)
+%public let unconditional_action := ~ = write_statement; < >
+write_statement:
+ | WRITE if_ = write_target
+ fo = ro(pf(FROM,ident_or_literal))
+ ao = ro(advancing_phrase)
+ ro = ro(retry_phrase)
+ wl = with_lock
+ ho = io(end_of_page_or_invalid_key_handler)
+ oterm_(END_WRITE)
+ { Write { write_to = if_;
+ write_from = fo;
+ write_advancing = ao;
+ write_retry = ro;
+ write_lock = wl;
+ write_error_handler = ho } }
+
+let write_target :=
+ | n = qualname; {WriteTargetName n}
+ | FILE; n = name; {WriteTargetFile n}
+
+(* --- Standalone (for testing) --------------------------------------------- *)
+
+standalone_condition: condition EOF { $1 };
+
+(* -------------------------------------------------------------------------- *)
+
+%%
diff --git a/src/lsp/cobol_parser/grammar_common.mly b/src/lsp/cobol_parser/grammar_common.mly
new file mode 120000
index 000000000..7e730907d
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar_common.mly
@@ -0,0 +1 @@
+../cobol_preproc/grammar_common.mly
\ No newline at end of file
diff --git a/src/lsp/cobol_parser/grammar_context.ml b/src/lsp/cobol_parser/grammar_context.ml
new file mode 100644
index 000000000..02c909739
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar_context.ml
@@ -0,0 +1,137 @@
+(* Caution: this file was automatically generated from grammar.cmly; do not edit *)
+open Grammar
+open MenhirInterpreter
+open Grammar_contexts
+
+let nonterminal_context: type k. k nonterminal -> _ option = function
+ | N_validate_status_clause -> Some validate_status_clause
+ | N_usage -> Some usage_clause (* ok as none of leftmost terminals are C/S *)
+ | N_typedef_clause -> Some typedef_clause
+ | N_stop_statement -> Some stop_stmt
+ | N_sharing_phrase -> Some sharing_phrase
+ | N_sharing_clause -> Some sharing_clause
+ | N_set_statement -> Some set_stmt
+ | N_set_attribute_switches -> Some set_attribute_stmt
+ | N_screen_descr_entry -> Some screen_descr_entry
+ | N_rounded_phrase -> Some rounded_phrase
+ | N_rounded_clause -> Some rounded_phrase
+ | N_retry_phrase -> Some retry_phrase
+ | N_resume_statement -> Some resume_stmt
+ | N_report_occurs_clause -> Some occurs_clause
+ | N_read_statement -> Some read_stmt
+ | N_program_id_paragraph -> Some program_id_paragraph
+ | N_options_paragraph -> Some options_paragraph
+ | N_occurs_fixed_clause -> Some occurs_clause
+ | N_occurs_dynamic_clause -> Some occurs_clause
+ | N_occurs_depending_clause -> Some occurs_clause
+ | N_object_paragraph -> Some object_paragraph
+ | N_object_computer_paragraph -> Some object_computer_paragraph
+ | N_lock_mode_clause -> Some lock_mode_clause
+ | N_line_header -> Some line_clause (*NUMBERS only*)
+ | N_intermediate_rounding_clause -> Some intermediate_rounding_clause
+ | N_interface_specifier -> Some interface_specifier
+ | N_function_specifier -> Some function_specifier
+ | N_float_decimal_clause -> Some float_decimal_clause
+ | N_float_binary_clause -> Some float_binary_clause
+ | N_factory_paragraph -> Some factory_paragraph
+ | N_exit_statement -> Some exit_stmt
+ | N_erase_clause -> Some erase_clause
+ | N_entry_convention_clause -> Some entry_convention_clause
+ | N_dynamic_length_structure_clause -> Some dynlen_struct_clause
+ | N_default_clause -> Some default_clause
+ | N_currency_sign_clause -> Some currency_clause
+ | N_constant_value_length -> Some constant
+ | N_column_header -> Some column_clause (* NUMBERS & CENTER *)
+ | N_class_specifier -> Some class_specifier
+ | N_arithmetic_clause -> Some arithmetic_clause
+ | N_alphabet_name_clause -> Some alphabet_clause
+ | N_allocate_statement -> Some allocate_stmt
+ | N_accept_statement -> Some accept_stmt
+ | _ -> None
+
+let contexts_for_state_num: int -> _ list = function
+ | 114 -> [options_paragraph]
+ | 116 -> [intermediate_rounding_clause]
+ | 128 -> [float_decimal_clause]
+ | 141 -> [float_binary_clause]
+ | 145 -> [entry_convention_clause]
+ | 148 -> [rounded_phrase]
+ | 154 -> [arithmetic_clause]
+ | 193 -> [object_computer_paragraph]
+ | 308 -> [dynlen_struct_clause]
+ | 328 -> [currency_clause]
+ | 366 -> [alphabet_clause]
+ | 442 -> [interface_specifier]
+ | 452 -> [function_specifier]
+ | 459 -> [class_specifier]
+ | 488 -> [sharing_clause]
+ | 540 -> [lock_mode_clause]
+ | 1061 -> [validate_status_clause]
+ | 1087 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1092 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1094 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1095 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1108 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1109 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1110 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1113 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1114 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1115 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1116 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1119 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1121 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1126 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1128 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1130 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1131 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1132 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1133 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1134 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1135 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1136 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1137 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1138 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1139 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1140 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1141 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1142 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1143 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1144 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1145 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1151 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1153 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1155 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1157 -> [usage_clause (* ok as none of leftmost terminals are C/S *)]
+ | 1159 -> [typedef_clause]
+ | 1359 -> [occurs_clause]
+ | 1413 -> [typedef_clause]
+ | 1439 -> [default_clause]
+ | 1447 -> [constant]
+ | 1915 -> [occurs_clause]
+ | 1942 -> [line_clause (*NUMBERS only*)]
+ | 1944 -> [line_clause (*NUMBERS only*)]
+ | 1955 -> [column_clause (* NUMBERS & CENTER *)]
+ | 1961 -> [column_clause (* NUMBERS & CENTER *)]
+ | 1966 -> [column_clause (* NUMBERS & CENTER *)]
+ | 1988 -> [rounded_phrase]
+ | 2057 -> [screen_descr_entry]
+ | 2098 -> [erase_clause]
+ | 2355 -> [retry_phrase]
+ | 2449 -> [stop_stmt]
+ | 2518 -> [set_stmt]
+ | 2578 -> [set_attribute_stmt]
+ | 2666 -> [resume_stmt]
+ | 2684 -> [read_stmt]
+ | 2743 -> [sharing_phrase]
+ | 2985 -> [exit_stmt]
+ | 3122 -> [allocate_stmt]
+ | 3136 -> [accept_stmt]
+ | 3856 -> [object_paragraph]
+ | 3862 -> [factory_paragraph]
+ | 3900 -> [program_id_paragraph]
+ | 3973 -> [program_id_paragraph]
+ | _ -> []
+
+let contexts: type k. k lr1state -> _ list = fun s ->
+ contexts_for_state_num (number s)
+
diff --git a/src/lsp/cobol_parser/grammar_contexts.ml b/src/lsp/cobol_parser/grammar_contexts.ml
new file mode 100644
index 000000000..8037d6a67
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar_contexts.ml
@@ -0,0 +1,625 @@
+(* Caution this file was automatically generated from grammar.cmly; do not edit *)
+module TH = Text_lexer.TokenHandles
+type context = TH.t
+
+type t = context
+type contexts =
+ {
+ accept_stmt: t;
+ allocate_stmt: t;
+ alphabet_clause: t;
+ arithmetic_clause: t;
+ class_specifier: t;
+ column_clause: t;
+ constant: t;
+ currency_clause: t;
+ default_clause: t;
+ dynlen_struct_clause: t;
+ entry_convention_clause: t;
+ erase_clause: t;
+ exit_stmt: t;
+ factory_paragraph: t;
+ float_binary_clause: t;
+ float_decimal_clause: t;
+ function_specifier: t;
+ interface_specifier: t;
+ intermediate_rounding_clause: t;
+ line_clause: t;
+ lock_mode_clause: t;
+ object_computer_paragraph: t;
+ object_paragraph: t;
+ occurs_clause: t;
+ options_paragrahp: t;
+ options_paragraph: t;
+ options_pragraph: t;
+ program_id_paragraph: t;
+ read_statement: t;
+ read_stmt: t;
+ resume_stmt: t;
+ retry_phrase: t;
+ rounded_phrase: t;
+ screen_descr_entry: t;
+ screnn_descr_entry: t;
+ set_attribute_stmt: t;
+ set_stmt: t;
+ sharing_clause: t;
+ sharing_phrase: t;
+ stop_stmt: t;
+ typedef_clause: t;
+ usage_clause: t;
+ validate_status_clause: t;
+ }
+
+let all, sensitive_tokens, sensitive_tokens_unimplemented =
+ let open TH in
+ let empty =
+ {
+ accept_stmt = empty;
+ allocate_stmt = empty;
+ alphabet_clause = empty;
+ arithmetic_clause = empty;
+ class_specifier = empty;
+ column_clause = empty;
+ constant = empty;
+ currency_clause = empty;
+ default_clause = empty;
+ dynlen_struct_clause = empty;
+ entry_convention_clause = empty;
+ erase_clause = empty;
+ exit_stmt = empty;
+ factory_paragraph = empty;
+ float_binary_clause = empty;
+ float_decimal_clause = empty;
+ function_specifier = empty;
+ interface_specifier = empty;
+ intermediate_rounding_clause = empty;
+ line_clause = empty;
+ lock_mode_clause = empty;
+ object_computer_paragraph = empty;
+ object_paragraph = empty;
+ occurs_clause = empty;
+ options_paragrahp = empty;
+ options_paragraph = empty;
+ options_pragraph = empty;
+ program_id_paragraph = empty;
+ read_statement = empty;
+ read_stmt = empty;
+ resume_stmt = empty;
+ retry_phrase = empty;
+ rounded_phrase = empty;
+ screen_descr_entry = empty;
+ screnn_descr_entry = empty;
+ set_attribute_stmt = empty;
+ set_stmt = empty;
+ sharing_clause = empty;
+ sharing_phrase = empty;
+ stop_stmt = empty;
+ typedef_clause = empty;
+ usage_clause = empty;
+ validate_status_clause = empty;
+ }
+ in
+ let accept_stmt t c = { c with accept_stmt = add t c.accept_stmt } in
+ let allocate_stmt t c = { c with allocate_stmt = add t c.allocate_stmt } in
+ let alphabet_clause t c = { c with alphabet_clause = add t c.alphabet_clause } in
+ let arithmetic_clause t c = { c with arithmetic_clause = add t c.arithmetic_clause } in
+ let class_specifier t c = { c with class_specifier = add t c.class_specifier } in
+ let column_clause t c = { c with column_clause = add t c.column_clause } in
+ let constant t c = { c with constant = add t c.constant } in
+ let currency_clause t c = { c with currency_clause = add t c.currency_clause } in
+ let default_clause t c = { c with default_clause = add t c.default_clause } in
+ let dynlen_struct_clause t c = { c with dynlen_struct_clause = add t c.dynlen_struct_clause } in
+ let entry_convention_clause t c = { c with entry_convention_clause = add t c.entry_convention_clause } in
+ let erase_clause t c = { c with erase_clause = add t c.erase_clause } in
+ let exit_stmt t c = { c with exit_stmt = add t c.exit_stmt } in
+ let factory_paragraph t c = { c with factory_paragraph = add t c.factory_paragraph } in
+ let float_binary_clause t c = { c with float_binary_clause = add t c.float_binary_clause } in
+ let float_decimal_clause t c = { c with float_decimal_clause = add t c.float_decimal_clause } in
+ let function_specifier t c = { c with function_specifier = add t c.function_specifier } in
+ let interface_specifier t c = { c with interface_specifier = add t c.interface_specifier } in
+ let intermediate_rounding_clause t c = { c with intermediate_rounding_clause = add t c.intermediate_rounding_clause } in
+ let line_clause t c = { c with line_clause = add t c.line_clause } in
+ let lock_mode_clause t c = { c with lock_mode_clause = add t c.lock_mode_clause } in
+ let object_computer_paragraph t c = { c with object_computer_paragraph = add t c.object_computer_paragraph } in
+ let object_paragraph t c = { c with object_paragraph = add t c.object_paragraph } in
+ let occurs_clause t c = { c with occurs_clause = add t c.occurs_clause } in
+ let options_paragrahp t c = { c with options_paragrahp = add t c.options_paragrahp } in
+ let options_paragraph t c = { c with options_paragraph = add t c.options_paragraph } in
+ let options_pragraph t c = { c with options_pragraph = add t c.options_pragraph } in
+ let program_id_paragraph t c = { c with program_id_paragraph = add t c.program_id_paragraph } in
+ let read_statement t c = { c with read_statement = add t c.read_statement } in
+ let read_stmt t c = { c with read_stmt = add t c.read_stmt } in
+ let resume_stmt t c = { c with resume_stmt = add t c.resume_stmt } in
+ let retry_phrase t c = { c with retry_phrase = add t c.retry_phrase } in
+ let rounded_phrase t c = { c with rounded_phrase = add t c.rounded_phrase } in
+ let screen_descr_entry t c = { c with screen_descr_entry = add t c.screen_descr_entry } in
+ let screnn_descr_entry t c = { c with screnn_descr_entry = add t c.screnn_descr_entry } in
+ let set_attribute_stmt t c = { c with set_attribute_stmt = add t c.set_attribute_stmt } in
+ let set_stmt t c = { c with set_stmt = add t c.set_stmt } in
+ let sharing_clause t c = { c with sharing_clause = add t c.sharing_clause } in
+ let sharing_phrase t c = { c with sharing_phrase = add t c.sharing_phrase } in
+ let stop_stmt t c = { c with stop_stmt = add t c.stop_stmt } in
+ let typedef_clause t c = { c with typedef_clause = add t c.typedef_clause } in
+ let usage_clause t c = { c with usage_clause = add t c.usage_clause } in
+ let validate_status_clause t c = { c with validate_status_clause = add t c.validate_status_clause } in
+ let specs = Grammar_tokens.[
+ ACTION, [];
+ ACTIVATING, [];
+ ACTIVE_X, [];
+ ACTUAL, [];
+ ADJUSTABLE_COLUMNS, [];
+ ALIGNMENT, [];
+ ALLOWING, [];
+ ANUM, [];
+ APPLY, [];
+ ARITHMETIC, [options_paragraph];
+ ASCII, [];
+ ATTRIBUTE, [set_stmt];
+ ATTRIBUTES, [];
+ AUTO, [screen_descr_entry];
+ AUTOMATIC, [lock_mode_clause];
+ AUTO_DECIMAL, [];
+ AUTO_SPIN, [];
+ AWAY_FROM_ZERO, [rounded_phrase];
+ BACKGROUND_COLOR, [screen_descr_entry];
+ BACKWARD, [];
+ BAR, [];
+ BELL, [screen_descr_entry; set_attribute_stmt];
+ BINARY_ENCODING, [usage_clause; set_attribute_stmt];
+ BITMAP, [];
+ BITMAP_END, [];
+ BITMAP_HANDLE, [];
+ BITMAP_NUMBER, [];
+ BITMAP_START, [];
+ BITMAP_TIMER, [];
+ BITMAP_TRAILING, [];
+ BITMAP_TRANSPARENT_COLOR, [];
+ BITMAP_WIDTH, [];
+ BLINK, [screen_descr_entry; set_attribute_stmt];
+ BOX, [];
+ BOXED, [];
+ BULK_ADDITION, [];
+ BUSY, [];
+ BUTTONS, [];
+ BYTE, [];
+ BYTE_LENGTH, [constant];
+ C, [];
+ CALENDAR_FONT, [];
+ CANCEL_BUTTON, [];
+ CAPACITY, [occurs_clause];
+ CARD_PUNCH, [];
+ CARD_READER, [];
+ CASSETTE, [];
+ CCOL, [];
+ CELL, [];
+ CELL_COLOR, [];
+ CELL_DATA, [];
+ CELL_FONT, [];
+ CELL_PROTECTION, [];
+ CENTER, [column_clause];
+ CENTERED, [];
+ CENTERED_HEADINGS, [];
+ CENTURY_DATE, [];
+ CHANGED, [];
+ CHECK_BOX, [];
+ CLASSIFICATION, [object_computer_paragraph];
+ CLEAR_SELECTION, [];
+ CLINE, [];
+ CLINES, [];
+ COBOL, [entry_convention_clause];
+ COLORS, [];
+ COLUMN_COLOR, [];
+ COLUMN_DIVIDERS, [];
+ COLUMN_FONT, [];
+ COLUMN_HEADINGS, [];
+ COLUMN_PROTECTION, [];
+ COMBO_BOX, [];
+ CONVERSION, [];
+ COPY_SELECTION, [];
+ CORE_INDEX, [];
+ CSIZE, [];
+ CURRENT, [];
+ CURSOR_COL, [];
+ CURSOR_COLOR, [];
+ CURSOR_FRAME_WIDTH, [];
+ CURSOR_ROW, [];
+ CURSOR_X, [];
+ CURSOR_Y, [];
+ CUSTOM_PRINT_TEMPLATE, [];
+ CYCLE, [];
+ CYL_INDEX, [];
+ CYL_OVERFLOW, [];
+ DASHED, [];
+ DATA_COLUMNS, [];
+ DATA_TYPES, [];
+ DATE_ENTRY, [];
+ DECIMAL_ENCODING, [usage_clause; float_decimal_clause];
+ DEFAULT_BUTTON, [];
+ DISC, [];
+ DISK, [];
+ DISP, [];
+ DISPLAY_COLUMNS, [];
+ DISPLAY_FORMAT, [];
+ DIVIDERS, [];
+ DIVIDER_COLOR, [];
+ DOTDASH, [];
+ DOTTED, [];
+ DRAG_COLOR, [];
+ DROP_DOWN, [];
+ DROP_LIST, [];
+ EBCDIC, [];
+ ELEMENT, [];
+ ENCODING, [];
+ ENCRYPTION, [];
+ END_COLOR, [];
+ END_MODIFY, [];
+ ENGRAVED, [];
+ ENSURE_VISIBLE, [];
+ ENTRY_CONVENTION, [options_paragraph];
+ ENTRY_FIELD, [];
+ ENTRY_REASON, [];
+ EOL, [erase_clause];
+ EOS, [erase_clause];
+ ERASE, [screen_descr_entry];
+ ESCAPE_BUTTON, [];
+ EVENT_LIST, [];
+ EVERY, [];
+ EXCEPTION_VALUE, [];
+ EXPAND, [];
+ EXPANDS, [class_specifier; interface_specifier];
+ EXTENDED_SEARCH, [];
+ EXTERN, [];
+ F, [];
+ FH__FCD, [];
+ FH__KEYDEF, [];
+ FILE_LIMIT, [];
+ FILE_LIMITS, [];
+ FILE_NAME, [];
+ FILE_POS, [];
+ FILL_COLOR, [];
+ FILL_COLOR2, [];
+ FILL_PERCENT, [];
+ FINISH_REASON, [];
+ FIXED_WIDTH, [];
+ FLAT, [];
+ FLAT_BUTTONS, [];
+ FLOAT_BINARY, [options_paragraph];
+ FLOAT_DECIMAL, [options_paragrahp];
+ FLOAT_NOT_A_NUMBER, [];
+ FOREGROUND_COLOR, [screen_descr_entry];
+ FOREVER, [retry_phrase];
+ FRAME, [];
+ FRAMED, [];
+ FULL, [screnn_descr_entry];
+ FULL_HEIGHT, [];
+ GO_BACK, [];
+ GO_FORWARD, [];
+ GO_HOME, [];
+ GO_SEARCH, [];
+ GRAPHICAL, [];
+ GRID, [];
+ GROUP_VALUE, [];
+ HAS_CHILDREN, [];
+ HEADING_COLOR, [];
+ HEADING_DIVIDER_COLOR, [];
+ HEADING_FONT, [];
+ HEAVY, [];
+ HEIGHT_IN_CELLS, [];
+ HEX, [];
+ HIGHLIGHT, [screen_descr_entry];
+ HIGH_COLOR, [];
+ HIGH_ORDER_LEFT, [float_binary_clause;
+ float_decimal_clause];
+ HIGH_ORDER_RIGHT, [float_binary_clause; float_decimal_clause];
+ HOT_TRACK, [];
+ HSCROLL, [];
+ HSCROLL_POS, [];
+ ICON, [];
+ IGNORING, [read_statement];
+ IMPLEMENTS, [factory_paragraph; object_paragraph];
+ INDEPENDENT, [];
+ INITIALIZED, [allocate_stmt; occurs_clause];
+ INSERTION_INDEX, [];
+ INSERT_ROWS, [];
+ INTERMEDIATE, [options_pragraph];
+ INTRINSIC, [function_specifier];
+ ITEM, [];
+ ITEM_TEXT, [];
+ ITEM_TO_ADD, [];
+ ITEM_TO_DELETE, [];
+ ITEM_TO_EMPTY, [];
+ ITEM_VALUE, [];
+ KEYBOARD, [];
+ LABEL_OFFSET, [];
+ LARGE_OFFSET, [];
+ LAST_ROW, [];
+ LAYOUT_DATA, [];
+ LC_ALL, [set_stmt];
+ LC_COLLATE, [set_stmt];
+ LC_CTYPE, [set_stmt];
+ LC_MESSAGES, [set_stmt];
+ LC_MONETARY, [set_stmt];
+ LC_NUMERIC, [set_stmt];
+ LC_TIME, [set_stmt];
+ LEADING_SHIFT, [];
+ LEAVE, [];
+ LEFT_TEXT, [];
+ LINES_AT_ROOT, [];
+ LINE_SEQUENTIAL, [];
+ LIST_BOX, [];
+ LOC, [];
+ LOCATION, [];
+ LOCK_HOLDING, [];
+ LONG_DATE, [];
+ LOWER, [];
+ LOWERED, [];
+ LOWLIGHT, [screen_descr_entry; set_attribute_stmt];
+ LOW_COLOR, [];
+ MAGNETIC_TAPE, [];
+ MANUAL, [lock_mode_clause];
+ MASS_UPDATE, [];
+ MASTER_INDEX, [];
+ MAX_LINES, [];
+ MAX_PROGRESS, [];
+ MAX_TEXT, [];
+ MAX_VAL, [];
+ MEMORY, [];
+ MICROSECOND_TIME, [];
+ MIN_VAL, [];
+ MODULES, [];
+ MULTILINE, [];
+ NAME, [];
+ NAMED, [];
+ NAMESPACE, [];
+ NAMESPACE_PREFIX, [];
+ NAT, [];
+ NAVIGATE_URL, [];
+ NEAREST_AWAY_FROM_ZERO, [intermediate_rounding_clause;
+ rounded_phrase];
+ NEAREST_EVEN, [intermediate_rounding_clause;
+ rounded_phrase];
+ NEAREST_TOWARD_ZERO, [intermediate_rounding_clause;
+ rounded_phrase];
+ NEXT_ITEM, [];
+ NOMINAL, [];
+ NONE, [default_clause];
+ NONNUMERIC, [];
+ NORMAL, [stop_stmt];
+ NOTAB, [];
+ NOTIFY, [];
+ NOTIFY_CHANGE, [];
+ NOTIFY_DBLCLICK, [];
+ NOTIFY_SELCHANGE, [];
+ NO_AUTOSEL, [];
+ NO_AUTO_DEFAULT, [];
+ NO_BOX, [];
+ NO_DIVIDERS, [];
+ NO_F4, [];
+ NO_FOCUS, [];
+ NO_GROUP_TAB, [];
+ NO_KEY_LETTER, [];
+ NO_SEARCH, [];
+ NO_UPDOWN, [];
+ NUMBERS, [column_clause; line_clause];
+ NUM_COL_HEADINGS, [];
+ NUM_ROWS, [];
+ OK_BUTTON, [];
+ ONLY, [sharing_clause; sharing_phrase; usage_clause];
+ OTHERS, [];
+ OVERLAP_LEFT, [];
+ OVERLAP_TOP, [];
+ PAGE, [];
+ PAGE_SETUP, [];
+ PARAGRAPH, [exit_stmt];
+ PARENT, [];
+ PARSE, [];
+ PASCAL, [];
+ PASSWORD, [];
+ PERMANENT, [];
+ PIXEL, [];
+ PLACEMENT, [];
+ POP_UP, [];
+ POS, [];
+ POSITION_SHIFT, [];
+ PREFIXED, [dynlen_struct_clause];
+ PREVIOUS, [read_stmt];
+ PRINT, [];
+ PRINTER, [];
+ PRINTER_1, [];
+ PRINT_NO_PROMPT, [];
+ PRINT_PREVIEW, [];
+ PROCESSING, [];
+ PROGRESS, [];
+ PROHIBITED, [intermediate_rounding_clause; rounded_phrase];
+ PROPERTIES, [];
+ PROTECTED, [];
+ PUSH_BUTTON, [];
+ QUERY_INDEX, [];
+ RADIO_BUTTON, [];
+ RAISED, [];
+ READERS, [];
+ READ_ONLY, [];
+ RECORD_DATA, [];
+ RECORD_OVERFLOW, [];
+ RECORD_TO_ADD, [];
+ RECORD_TO_DELETE, [];
+ RECURSIVE, [program_id_paragraph];
+ REFRESH, [];
+ REGION_COLOR, [];
+ RELATION, [validate_status_clause];
+ REORG_CRITERIA, [];
+ REQUIRED, [screen_descr_entry];
+ REREAD, [];
+ RERUN, [];
+ RESET_GRID, [];
+ RESET_LIST, [];
+ RESET_TABS, [];
+ REVERSE_VIDEO, [screen_descr_entry; set_attribute_stmt];
+ RIGHT_ALIGN, [];
+ RIMMED, [];
+ ROUNDING, [options_paragraph];
+ ROW_COLOR, [];
+ ROW_COLOR_PATTERN, [];
+ ROW_DIVIDERS, [];
+ ROW_FONT, [];
+ ROW_HEADINGS, [];
+ ROW_PROTECTION, [];
+ S, [];
+ SAVE_AS, [];
+ SAVE_AS_NO_PROMPT, [];
+ SCROLL, [];
+ SCROLL_BAR, [];
+ SEARCH_OPTIONS, [];
+ SEARCH_TEXT, [];
+ SECONDS, [retry_phrase];
+ SECURE, [screen_descr_entry];
+ SELECTION_INDEX, [];
+ SELECTION_TEXT, [];
+ SELECT_ALL, [];
+ SELF_ACT, [];
+ SEPARATION, [];
+ SHADING, [];
+ SHADOW, [];
+ SHORT, [dynlen_struct_clause];
+ SHOW_LINES, [];
+ SHOW_NONE, [];
+ SHOW_SEL_ALWAYS, [];
+ SIGNED, [dynlen_struct_clause; usage_clause];
+ SORT_ORDER, [];
+ SPINNER, [];
+ SQUARE, [];
+ STACK, [];
+ STANDARD_BINARY, [arithmetic_clause];
+ STANDARD_DECIMAL, [arithmetic_clause];
+ START_X, [];
+ START_Y, [];
+ STATEMENT, [resume_stmt];
+ STATIC, [];
+ STATIC_LIST, [];
+ STATUS_BAR, [];
+ STATUS_TEXT, [];
+ STDCALL, [];
+ STEP, [occurs_clause];
+ STRONG, [typedef_clause];
+ STRUCTURE, [dynlen_struct_clause];
+ STYLE, [];
+ SYMBOL, [currency_clause];
+ SYSTEM_INFO, [];
+ TAB, [];
+ TAB_TO_ADD, [];
+ TAB_TO_DELETE, [];
+ TAPE, [];
+ TEMPORARY, [];
+ TERMINAL_INFO, [];
+ TERMINATION_VALUE, [];
+ THREEDIMENSIONAL, [];
+ THUMB_POSITION, [];
+ TILED_HEADINGS, [];
+ TIME_OUT, [];
+ TITLE, [];
+ TITLE_POSITION, [];
+ TOP_LEVEL, [];
+ TOWARD_GREATER, [rounded_phrase];
+ TOWARD_LESSER, [rounded_phrase];
+ TRACK, [];
+ TRACKS, [];
+ TRACK_AREA, [];
+ TRACK_LIMIT, [];
+ TRAILING_SHIFT, [];
+ TRANSPARENT, [];
+ TREE_VIEW, [];
+ TRUNCATION, [intermediate_rounding_clause; rounded_phrase];
+ U, [];
+ UCS_4, [alphabet_clause];
+ UNBOUNDED, [];
+ UNDERLINE, [screen_descr_entry; set_attribute_stmt];
+ UNFRAMED, [];
+ UNSIGNED, [usage_clause];
+ UNSORTED, [];
+ UPDATERS, [];
+ UPPER, [];
+ USER, [];
+ USE_ALT, [];
+ USE_RETURN, [];
+ USE_TAB, [];
+ UTF_16, [alphabet_clause];
+ UTF_8, [alphabet_clause];
+ V, [];
+ VALIDATING, [];
+ VALUE_FORMAT, [];
+ VARIABLE, [];
+ VERTICAL, [];
+ VERY_HEAVY, [];
+ VIRTUAL_WIDTH, [];
+ VPADDING, [];
+ VSCROLL, [];
+ VSCROLL_BAR, [];
+ VSCROLL_POS, [];
+ VTOP, [];
+ WEB_BROWSER, [];
+ WIDTH, [];
+ WIDTH_IN_CELLS, [];
+ WRAP, [];
+ WRITERS, [];
+ WRITE_ONLY, [];
+ WRITE_VERIFY, [];
+ X, [];
+ XML_DECLARATION, [];
+ XML_SCHEMA, [];
+ Y, [];
+ YYYYDDD, [accept_stmt];
+ YYYYMMDD, [accept_stmt];
+ ZERO_FILL, [];
+ ]
+ in
+ List.fold_left (fun (acc, cstoks, unimpl) (t, add_contexts) ->
+ let h = Text_lexer.handle_of_token t in
+ List.fold_left (fun acc f -> f h acc) acc add_contexts,
+ TH.add h cstoks,
+ if add_contexts = [] then TH.add h unimpl else unimpl)
+ (empty, TH.empty, TH.empty) specs
+
+let accept_stmt = all.accept_stmt
+let allocate_stmt = all.allocate_stmt
+let alphabet_clause = all.alphabet_clause
+let arithmetic_clause = all.arithmetic_clause
+let class_specifier = all.class_specifier
+let column_clause = all.column_clause
+let constant = all.constant
+let currency_clause = all.currency_clause
+let default_clause = all.default_clause
+let dynlen_struct_clause = all.dynlen_struct_clause
+let entry_convention_clause = all.entry_convention_clause
+let erase_clause = all.erase_clause
+let exit_stmt = all.exit_stmt
+let factory_paragraph = all.factory_paragraph
+let float_binary_clause = all.float_binary_clause
+let float_decimal_clause = all.float_decimal_clause
+let function_specifier = all.function_specifier
+let interface_specifier = all.interface_specifier
+let intermediate_rounding_clause = all.intermediate_rounding_clause
+let line_clause = all.line_clause
+let lock_mode_clause = all.lock_mode_clause
+let object_computer_paragraph = all.object_computer_paragraph
+let object_paragraph = all.object_paragraph
+let occurs_clause = all.occurs_clause
+let options_paragrahp = all.options_paragrahp
+let options_paragraph = all.options_paragraph
+let options_pragraph = all.options_pragraph
+let program_id_paragraph = all.program_id_paragraph
+let read_statement = all.read_statement
+let read_stmt = all.read_stmt
+let resume_stmt = all.resume_stmt
+let retry_phrase = all.retry_phrase
+let rounded_phrase = all.rounded_phrase
+let screen_descr_entry = all.screen_descr_entry
+let screnn_descr_entry = all.screnn_descr_entry
+let set_attribute_stmt = all.set_attribute_stmt
+let set_stmt = all.set_stmt
+let sharing_clause = all.sharing_clause
+let sharing_phrase = all.sharing_phrase
+let stop_stmt = all.stop_stmt
+let typedef_clause = all.typedef_clause
+let usage_clause = all.usage_clause
+let validate_status_clause = all.validate_status_clause
+
diff --git a/src/lsp/cobol_parser/grammar_post_actions.ml b/src/lsp/cobol_parser/grammar_post_actions.ml
new file mode 100644
index 000000000..0cffa25c7
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar_post_actions.ml
@@ -0,0 +1,45 @@
+(* Caution: this file was automatically generated from grammar.cmly; do not edit *)
+[@@@warning "-33"] (* <- do not warn on unused opens *)
+[@@@warning "-27"] (* <- do not warn on unused variabes *)
+
+module Make (Config: Cobol_config.T) =
+struct
+
+ open Grammar
+ open MenhirInterpreter
+
+ type post_action =
+ | Post_diagnostic: (loc:Cobol_common.Srcloc.srcloc option -> unit
+ Cobol_common.Diagnostics.in_result) -> post_action
+ | Post_pending: (string) -> post_action
+ | Post_special_names: (Cobol_ast.special_names_clause) -> post_action
+ | NoPost: post_action
+
+ let post_production_num
+ : type k. int -> k env -> post_action = fun prod_num env ->
+ match top env with
+ | None -> NoPost
+ | Some (Element (state, value, _, _)) ->
+ match incoming_symbol state, prod_num with
+ | N N__assign_external_, 2 ->
+ Post_pending ((fun () -> "EXTERNAL") value)
+ | N N_control_division, 335 ->
+ Post_diagnostic ((fun _ -> Config.control_division#verify) value)
+ | N N_special_names_clause, 2082 -> Post_special_names value
+ | N N_special_names_clause, 2083 -> Post_special_names value
+ | N N_special_names_clause, 2084 -> Post_special_names value
+ | N N_special_names_clause, 2085 -> Post_special_names value
+ | N N_special_names_clause, 2086 -> Post_special_names value
+ | N N_special_names_clause, 2087 -> Post_special_names value
+ | N N_special_names_clause, 2088 -> Post_special_names value
+ | N N_special_names_clause, 2089 -> Post_special_names value
+ | N N_special_names_clause, 2090 -> Post_special_names value
+ | N N_special_names_clause, 2091 -> Post_special_names value
+ | N N_special_names_clause, 2092 -> Post_special_names value
+ | _ -> NoPost
+
+ let post_production
+ : type k. production -> k env -> post_action = fun p ->
+ post_production_num (production_index p)
+
+end
diff --git a/src/lsp/cobol_parser/grammar_printer.ml b/src/lsp/cobol_parser/grammar_printer.ml
new file mode 100644
index 000000000..9b0cb436c
--- /dev/null
+++ b/src/lsp/cobol_parser/grammar_printer.ml
@@ -0,0 +1,6378 @@
+open Grammar
+open Grammar_tokens
+
+let print_symbol = function
+ | MenhirInterpreter.X (MenhirInterpreter.T T_error) -> "error"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ZERO_FILL) -> "ZERO_FILL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ZERO) -> "ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_YYYYMMDD) -> "YYYYMMDD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_YYYYDDD) -> "YYYYDDD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_Y) -> "Y"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_XOR) -> "XOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_XML_SCHEMA) -> "XML_SCHEMA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_XML_DECLARATION) -> "XML_DECLARATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_XML) -> "XML"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_X) -> "X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WRITE_VERIFY) -> "WRITE_VERIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WRITE_ONLY) -> "WRITE_ONLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WRITERS) -> "WRITERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WRITE) -> "WRITE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WRAP) -> "WRAP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WORKING_STORAGE) -> "WORKING_STORAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WORD_IN_AREA_A) -> "WORD_IN_AREA_A"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WORDS) -> "WORDS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WORD) -> "WORD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WITH_DATA) -> "WITH_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WITH) -> "WITH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WINDOW) -> "WINDOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WIDTH_IN_CELLS) -> "WIDTH_IN_CELLS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WIDTH) -> "WIDTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WHEN) -> "WHEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WEB_BROWSER) -> "WEB_BROWSER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_WAIT) -> "WAIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VTOP) -> "VTOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VSCROLL_POS) -> "VSCROLL_POS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VSCROLL_BAR) -> "VSCROLL_BAR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VSCROLL) -> "VSCROLL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VPADDING) -> "VPADDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VOLATILE) -> "VOLATILE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VLR) -> "VLR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VIRTUAL_WIDTH) -> "VIRTUAL_WIDTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VIRTUAL) -> "VIRTUAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VIA) -> "VIA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VERY_HEAVY) -> "VERY_HEAVY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VERTICAL) -> "VERTICAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VARYING) -> "VARYING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VARIANT) -> "VARIANT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VARIABLE) -> "VARIABLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALUE_FORMAT) -> "VALUE_FORMAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALUES) -> "VALUES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALUE) -> "VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALIDATING) -> "VALIDATING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALIDATE_STATUS) -> "VALIDATE_STATUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALIDATE) -> "VALIDATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_VALID) -> "VALID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_V) -> "V"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UTF_8) -> "UTF_8"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UTF_16) -> "UTF_16"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USING) -> "USING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USE_TAB) -> "USE_TAB"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USE_RETURN) -> "USE_RETURN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USE_ALT) -> "USE_ALT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USER_DEFAULT) -> "USER_DEFAULT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USER) -> "USER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USE) -> "USE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_USAGE) -> "USAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UPPER) -> "UPPER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UPON) -> "UPON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UPDATERS) -> "UPDATERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UPDATE) -> "UPDATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UP) -> "UP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNUSED__) -> "UNUSED__"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNTIL) -> "UNTIL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSTRING) -> "UNSTRING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSORTED) -> "UNSORTED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSIGNED_SHORT) -> "UNSIGNED_SHORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSIGNED_LONG) -> "UNSIGNED_LONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSIGNED_INT) -> "UNSIGNED_INT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSIGNED) -> "UNSIGNED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNSEQUAL) -> "UNSEQUAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNLOCK) -> "UNLOCK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNIVERSAL) -> "UNIVERSAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNIT) -> "UNIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNFRAMED) -> "UNFRAMED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNDERLINE) -> "UNDERLINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UNBOUNDED) -> "UNBOUNDED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UFF) -> "UFF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_UCS_4) -> "UCS_4"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_U) -> "U"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TYPEDEF) -> "TYPEDEF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TYPE) -> "TYPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRUNCATION) -> "TRUNCATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRUE) -> "TRUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TREE_VIEW) -> "TREE_VIEW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRANSPARENT) -> "TRANSPARENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRANSFORM) -> "TRANSFORM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRAILING_SIGN) -> "TRAILING_SIGN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRAILING_SHIFT) -> "TRAILING_SHIFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRAILING) -> "TRAILING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRADITIONAL_FONT) -> "TRADITIONAL_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRACK_LIMIT) -> "TRACK_LIMIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRACK_AREA) -> "TRACK_AREA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRACKS) -> "TRACKS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TRACK) -> "TRACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TOWARD_LESSER) -> "TOWARD_LESSER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TOWARD_GREATER) -> "TOWARD_GREATER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TOP_LEVEL) -> "TOP_LEVEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TOP) -> "TOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TO) -> "TO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TITLE_POSITION) -> "TITLE_POSITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TITLE) -> "TITLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TIME_OUT) -> "TIME_OUT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TIMES) -> "TIMES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TIME) -> "TIME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TILED_HEADINGS) -> "TILED_HEADINGS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THUMB_POSITION) -> "THUMB_POSITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THROUGH) -> "THROUGH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THREEDIMENSIONAL) -> "THREEDIMENSIONAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THREADS) -> "THREADS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THREAD) -> "THREAD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THEN) -> "THEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_THAN) -> "THAN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TEXT) -> "TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TEST) -> "TEST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINATION_VALUE) -> "TERMINATION_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINATE) -> "TERMINATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_X) -> "TERMINAL_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_INFO) -> "TERMINAL_INFO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_3) -> "TERMINAL_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_2) -> "TERMINAL_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_1) -> "TERMINAL_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL_0) -> "TERMINAL_0"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TERMINAL) -> "TERMINAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TEMPORARY) -> "TEMPORARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TEMP) -> "TEMP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TAPE) -> "TAPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TALLYING) -> "TALLYING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TAB_TO_DELETE) -> "TAB_TO_DELETE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TAB_TO_ADD) -> "TAB_TO_ADD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TABLE) -> "TABLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_TAB) -> "TAB"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSTEM_OFFSET) -> "SYSTEM_OFFSET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSTEM_INFO) -> "SYSTEM_INFO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSTEM_DEFAULT) -> "SYSTEM_DEFAULT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSTEM) -> "SYSTEM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSOUT_X) -> "SYSOUT_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSOUT_3) -> "SYSOUT_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSOUT_2) -> "SYSOUT_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSOUT_1) -> "SYSOUT_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSOUT_0) -> "SYSOUT_0"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSIN_X) -> "SYSIN_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSIN_3) -> "SYSIN_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSIN_2) -> "SYSIN_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSIN_1) -> "SYSIN_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYSIN_0) -> "SYSIN_0"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYNCHRONIZED) -> "SYNCHRONIZED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYMBOLIC) -> "SYMBOLIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SYMBOL) -> "SYMBOL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SWITCH) -> "SWITCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUPPRESS) -> "SUPPRESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUPER) -> "SUPER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUM) -> "SUM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUB_SCHEMA) -> "SUB_SCHEMA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUB_QUEUE_3) -> "SUB_QUEUE_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUB_QUEUE_2) -> "SUB_QUEUE_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUB_QUEUE_1) -> "SUB_QUEUE_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUBWINDOW) -> "SUBWINDOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SUBTRACT) -> "SUBTRACT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STYLE) -> "STYLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STRUCTURE) -> "STRUCTURE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STRONG) -> "STRONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STRING) -> "STRING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STOP) -> "STOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STEP) -> "STEP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STDCALL) -> "STDCALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATUS_TEXT) -> "STATUS_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATUS_BAR) -> "STATUS_BAR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATUS) -> "STATUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATION) -> "STATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATIC_LIST) -> "STATIC_LIST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATIC) -> "STATIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STATEMENT) -> "STATEMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_START_Y) -> "START_Y"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_START_X) -> "START_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_START) -> "START"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STANDARD_DECIMAL) -> "STANDARD_DECIMAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STANDARD_BINARY) -> "STANDARD_BINARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STANDARD_2) -> "STANDARD_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STANDARD_1) -> "STANDARD_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STANDARD) -> "STANDARD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_STACK) -> "STACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SSF) -> "SSF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SQUARE) -> "SQUARE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SPINNER) -> "SPINNER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SPECIAL_NAMES) -> "SPECIAL_NAMES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SPACE_FILL) -> "SPACE_FILL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SPACE) -> "SPACE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SOURCE_COMPUTER) -> "SOURCE_COMPUTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SOURCES) -> "SOURCES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SOURCE) -> "SOURCE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SORT_ORDER) -> "SORT_ORDER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SORT_MERGE) -> "SORT_MERGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SORT) -> "SORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SMALL_FONT) -> "SMALL_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SLASH) -> "/"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIZE) -> "SIZE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SINTLIT) -> "SINTLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIGNED_SHORT) -> "SIGNED_SHORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIGNED_LONG) -> "SIGNED_LONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIGNED_INT) -> "SIGNED_INT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIGNED) -> "SIGNED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SIGN) -> "SIGN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHOW_SEL_ALWAYS) -> "SHOW_SEL_ALWAYS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHOW_NONE) -> "SHOW_NONE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHOW_LINES) -> "SHOW_LINES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHORT_DATE) -> "SHORT_DATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHORT) -> "SHORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHARING) -> "SHARING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHADOW) -> "SHADOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SHADING) -> "SHADING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SET) -> "SET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEQUENTIAL) -> "SEQUENTIAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEQUENCE) -> "SEQUENCE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEPARATION) -> "SEPARATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEPARATE) -> "SEPARATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SENTENCE) -> "SENTENCE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEND) -> "SEND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELF_ACT) -> "SELF_ACT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELF) -> "SELF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELECT_ALL) -> "SELECT_ALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELECTION_TEXT) -> "SELECTION_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELECTION_INDEX) -> "SELECTION_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELECTION) -> "SELECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SELECT) -> "SELECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEGMENT_LIMIT) -> "SEGMENT_LIMIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEGMENT) -> "SEGMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SECURITY) -> "SECURITY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SECURE) -> "SECURE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SECTION) -> "SECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SECONDS) -> "SECONDS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SECONDARY) -> "SECONDARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEARCH_TEXT) -> "SEARCH_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEARCH_OPTIONS) -> "SEARCH_OPTIONS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SEARCH) -> "SEARCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SD) -> "SD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SCROLL_BAR) -> "SCROLL_BAR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SCROLL) -> "SCROLL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SCREEN) -> "SCREEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SAVE_AS_NO_PROMPT) -> "SAVE_AS_NO_PROMPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SAVE_AS) -> "SAVE_AS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SARF) -> "SARF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_SAME) -> "SAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_S) -> "S"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RUN) -> "RUN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RPAR) -> ")"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_PROTECTION) -> "ROW_PROTECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_HEADINGS) -> "ROW_HEADINGS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_FONT) -> "ROW_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_DIVIDERS) -> "ROW_DIVIDERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_COLOR_PATTERN) -> "ROW_COLOR_PATTERN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROW_COLOR) -> "ROW_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROUNDING) -> "ROUNDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROUNDED) -> "ROUNDED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ROLLBACK) -> "ROLLBACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RIMMED) -> "RIMMED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RIGHT_JUSTIFY) -> "RIGHT_JUSTIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RIGHT_ALIGN) -> "RIGHT_ALIGN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RIGHT) -> "RIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RH) -> "RH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RF) -> "RF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REWRITE) -> "REWRITE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REWIND) -> "REWIND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REVERSE_VIDEO) -> "REVERSE_VIDEO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REVERSED) -> "REVERSED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REVERSE) -> "REVERSE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RETURNING) -> "RETURNING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RETURN) -> "RETURN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RETRY) -> "RETRY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RETENTION) -> "RETENTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESUME) -> "RESUME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESET_TABS) -> "RESET_TABS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESET_LIST) -> "RESET_LIST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESET_GRID) -> "RESET_GRID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESET) -> "RESET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RESERVE) -> "RESERVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RERUN) -> "RERUN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REREAD) -> "REREAD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REQUIRED) -> "REQUIRED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPOSITORY) -> "REPOSITORY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPORTS) -> "REPORTS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPORTING) -> "REPORTING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPORT) -> "REPORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPLACING) -> "REPLACING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPLACE) -> "REPLACE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REPEATED) -> "REPEATED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REORG_CRITERIA) -> "REORG_CRITERIA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RENAMES) -> "RENAMES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REMOVAL) -> "REMOVAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REMARKS) -> "REMARKS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REMAINDER) -> "REMAINDER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RELEASE) -> "RELEASE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RELATIVE) -> "RELATIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RELATION) -> "RELATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REGION_COLOR) -> "REGION_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REFRESH) -> "REFRESH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REFERENCES) -> "REFERENCES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REFERENCE) -> "REFERENCE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REEL) -> "REEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_REDEFINES) -> "REDEFINES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECURSIVE) -> "RECURSIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORD_TO_DELETE) -> "RECORD_TO_DELETE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORD_TO_ADD) -> "RECORD_TO_ADD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORD_OVERFLOW) -> "RECORD_OVERFLOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORD_DATA) -> "RECORD_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORDS) -> "RECORDS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORDING) -> "RECORDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECORD) -> "RECORD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECEIVED) -> "RECEIVED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RECEIVE) -> "RECEIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_READ_ONLY) -> "READ_ONLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_READERS) -> "READERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_READ) -> "READ"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RD) -> "RD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RANDOM) -> "RANDOM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RAISING) -> "RAISING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RAISED) -> "RAISED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RAISE) -> "RAISE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_RADIO_BUTTON) -> "RADIO_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_QUOTE) -> "QUOTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_QUEUED) -> "QUEUED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_QUEUE) -> "QUEUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_QUERY_INDEX) -> "QUERY_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PUSH_BUTTON) -> "PUSH_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PURGE) -> "PURGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROTOTYPE) -> "PROTOTYPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROTECTED) -> "PROTECTED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROPERTY) -> "PROPERTY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROPERTIES) -> "PROPERTIES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROMPT) -> "PROMPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROHIBITED) -> "PROHIBITED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROGRESS) -> "PROGRESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROGRAM_POINTER) -> "PROGRAM_POINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROGRAM_ID) -> "PROGRAM_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROGRAM) -> "PROGRAM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCESS_AREA) -> "PROCESS_AREA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCESSING) -> "PROCESSING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCEED) -> "PROCEED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCEDURE_POINTER) -> "PROCEDURE_POINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCEDURES) -> "PROCEDURES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PROCEDURE) -> "PROCEDURE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRIORITY) -> "PRIORITY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINT_PREVIEW) -> "PRINT_PREVIEW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINT_NO_PROMPT) -> "PRINT_NO_PROMPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINTING) -> "PRINTING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINTER_1) -> "PRINTER_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINTER) -> "PRINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRINT) -> "PRINT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRIMARY) -> "PRIMARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PREVIOUS) -> "PREVIOUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PRESENT) -> "PRESENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PREFIXED) -> "PREFIXED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POSITIVE) -> "POSITIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POSITION_SHIFT) -> "POSITION_SHIFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POSITION) -> "POSITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POS) -> "POS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POP_UP) -> "POP_UP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_POINTER) -> "POINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PLUS_SIGN) -> "+"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PLUS) -> "PLUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PLACEMENT) -> "PLACEMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PIXEL) -> "PIXEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PICTURE_STRING) -> "PICTURE_STRING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PICTURE) -> "PICTURE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PHYSICAL) -> "PHYSICAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PH) -> "PH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PF) -> "PF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PERMANENT) -> "PERMANENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PERIOD) -> "."
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PERFORM) -> "PERFORM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PASSWORD) -> "PASSWORD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PASCAL) -> "PASCAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PARSE) -> "PARSE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PARENT) -> "PARENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PARAGRAPH) -> "PARAGRAPH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PAGE_SETUP) -> "PAGE_SETUP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PAGE_COUNTER) -> "PAGE_COUNTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PAGED) -> "PAGED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PAGE) -> "PAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PADDING) -> "PADDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_PACKED_DECIMAL) -> "PACKED_DECIMAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERRIDING) -> "OVERRIDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERRIDE) -> "OVERRIDE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERLINE) -> "OVERLINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERLAP_TOP) -> "OVERLAP_TOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERLAP_LEFT) -> "OVERLAP_LEFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OVERFLOW) -> "OVERFLOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OUTPUT) -> "OUTPUT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OTHERS) -> "OTHERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OTHER) -> "OTHER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ORGANIZATION) -> "ORGANIZATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ORDER) -> "ORDER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OR) -> "OR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OPTIONS) -> "OPTIONS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OPTIONAL) -> "OPTIONAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OPERATIONAL) -> "OPERATIONAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OPEN) -> "OPEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ON_SIZE_ERROR) -> "ON_SIZE_ERROR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ON_OVERFLOW) -> "ON_OVERFLOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ON_EXCEPTION) -> "ON_EXCEPTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ONLY) -> "ONLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ON) -> "ON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OMITTED) -> "OMITTED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OK_BUTTON) -> "OK_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OFF) -> "OFF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OF) -> "OF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OCCURS) -> "OCCURS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OBJECT_REFERENCE) -> "OBJECT_REFERENCE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OBJECT_PROGRAM) -> "OBJECT_PROGRAM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OBJECT_COMPUTER) -> "OBJECT_COMPUTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_OBJECT) -> "OBJECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUM_ROWS) -> "NUM_ROWS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUM_COL_HEADINGS) -> "NUM_COL_HEADINGS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUMERIC_EDITED) -> "NUMERIC_EDITED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUMERIC) -> "NUMERIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUMBERS) -> "NUMBERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NUMBER) -> "NUMBER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NULLS) -> "NULLS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NULLIT) -> "NULLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NULL) -> "NULL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_UPDOWN) -> "NO_UPDOWN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_SEARCH) -> "NO_SEARCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_KEY_LETTER) -> "NO_KEY_LETTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_GROUP_TAB) -> "NO_GROUP_TAB"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_FOCUS) -> "NO_FOCUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_F4) -> "NO_F4"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_ECHO) -> "NO_ECHO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_DIVIDERS) -> "NO_DIVIDERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_DATA) -> "NO_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_BOX) -> "NO_BOX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_AUTO_DEFAULT) -> "NO_AUTO_DEFAULT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO_AUTOSEL) -> "NO_AUTOSEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_ON_SIZE_ERROR) -> "NOT_ON_SIZE_ERROR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_ON_OVERFLOW) -> "NOT_ON_OVERFLOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_ON_EXCEPTION) -> "NOT_ON_EXCEPTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_INVALID_KEY) -> "NOT_INVALID_KEY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_AT_EOP) -> "NOT_AT_EOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT_AT_END) -> "NOT_AT_END"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTIFY_SELCHANGE) -> "NOTIFY_SELCHANGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTIFY_DBLCLICK) -> "NOTIFY_DBLCLICK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTIFY_CHANGE) -> "NOTIFY_CHANGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTIFY) -> "NOTIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTHING) -> "NOTHING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOTAB) -> "NOTAB"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOT) -> "NOT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NORMAL) -> "NORMAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NONNUMERIC) -> "NONNUMERIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NONE) -> "NONE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NOMINAL) -> "NOMINAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NO) -> "NO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEXT_PAGE) -> "NEXT_PAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEXT_ITEM) -> "NEXT_ITEM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEXT) -> "NEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEW) -> "NEW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NESTED) -> "NESTED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEGATIVE) -> "NEGATIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEAREST_TO_ZERO) -> "NEAREST_TO_ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEAREST_TOWARD_ZERO) -> "NEAREST_TOWARD_ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEAREST_EVEN) -> "NEAREST_EVEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NEAREST_AWAY_FROM_ZERO) -> "NEAREST_AWAY_FROM_ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NE) -> "<>"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAVIGATE_URL) -> "NAVIGATE_URL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NATLIT) -> "NATLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NATIVE) -> "NATIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NATIONAL_EDITED) -> "NATIONAL_EDITED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NATIONAL) -> "NATIONAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAT) -> "NAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAMESPACE_PREFIX) -> "NAMESPACE_PREFIX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAMESPACE) -> "NAMESPACE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAMED) -> "NAMED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_NAME) -> "NAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MULTIPLY) -> "MULTIPLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MULTIPLE) -> "MULTIPLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MULTILINE) -> "MULTILINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MOVE) -> "MOVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MODULES) -> "MODULES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MODIFY) -> "MODIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MODE) -> "MODE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MIN_VAL) -> "MIN_VAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MINUS) -> "MINUS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MICROSECOND_TIME) -> "MICROSECOND_TIME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_METHOD_ID) -> "METHOD_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_METHOD) -> "METHOD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MESSAGE_TAG) -> "MESSAGE_TAG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MESSAGE) -> "MESSAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MERGE) -> "MERGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MENU) -> "MENU"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MEMORY) -> "MEMORY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MEDIUM_FONT) -> "MEDIUM_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MAX_VAL) -> "MAX_VAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MAX_TEXT) -> "MAX_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MAX_PROGRESS) -> "MAX_PROGRESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MAX_LINES) -> "MAX_LINES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MASTER_INDEX) -> "MASTER_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MASS_UPDATE) -> "MASS_UPDATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MANUAL) -> "MANUAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_MAGNETIC_TAPE) -> "MAGNETIC_TAPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LT) -> "<"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LPAR) -> "("
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOW_VALUE) -> "LOW_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOW_COLOR) -> "LOW_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOWLIGHT) -> "LOWLIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOWERED) -> "LOWERED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOWER) -> "LOWER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LONG_DATE) -> "LONG_DATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCK_HOLDING) -> "LOCK_HOLDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCKS) -> "LOCKS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCK) -> "LOCK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCATION) -> "LOCATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCAL_STORAGE) -> "LOCAL_STORAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOCALE) -> "LOCALE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LOC) -> "LOC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LM_RESIZE) -> "LM_RESIZE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LIST_BOX) -> "LIST_BOX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINKAGE) -> "LINKAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINE_SEQUENTIAL) -> "LINE_SEQUENTIAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINE_COUNTER) -> "LINE_COUNTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINES_PER_PAGE) -> "LINES_PER_PAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINES_AT_ROOT) -> "LINES_AT_ROOT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINES) -> "LINES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINE) -> "LINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINAGE_COUNTER) -> "LINAGE_COUNTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LINAGE) -> "LINAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LIMITS) -> "LIMITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LIMIT) -> "LIMIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LIKE) -> "LIKE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LIBRARY) -> "LIBRARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LESS) -> "LESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LENGTH) -> "LENGTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEFT_TEXT) -> "LEFT_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEFT_JUSTIFY) -> "LEFT_JUSTIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEFTLINE) -> "LEFTLINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEFT) -> "LEFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEAVE) -> "LEAVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEADING_SHIFT) -> "LEADING_SHIFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LEADING) -> "LEADING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LE) -> "<="
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_TIME) -> "LC_TIME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_NUMERIC) -> "LC_NUMERIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_MONETARY) -> "LC_MONETARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_MESSAGES) -> "LC_MESSAGES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_CTYPE) -> "LC_CTYPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_COLLATE) -> "LC_COLLATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LC_ALL) -> "LC_ALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LAYOUT_MANAGER) -> "LAYOUT_MANAGER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LAYOUT_DATA) -> "LAYOUT_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LAST_ROW) -> "LAST_ROW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LAST) -> "LAST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LARGE_OFFSET) -> "LARGE_OFFSET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LARGE_FONT) -> "LARGE_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LABEL_OFFSET) -> "LABEL_OFFSET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_LABEL) -> "LABEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_KEY_LOCATION) -> "KEY_LOCATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_KEYED) -> "KEYED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_KEYBOARD) -> "KEYBOARD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_KEY) -> "KEY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_KEPT) -> "KEPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_JUSTIFIED) -> "JUSTIFIED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_JSON) -> "JSON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_I_O_CONTROL) -> "I_O_CONTROL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_I_O) -> "I_O"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM_VALUE) -> "ITEM_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM_TO_EMPTY) -> "ITEM_TO_EMPTY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM_TO_DELETE) -> "ITEM_TO_DELETE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM_TO_ADD) -> "ITEM_TO_ADD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM_TEXT) -> "ITEM_TEXT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ITEM) -> "ITEM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IS_TYPEDEF) -> "IS_TYPEDEF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IS_GLOBAL) -> "IS_GLOBAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IS_EXTERNAL) -> "IS_EXTERNAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IS) -> "IS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IN_ARITHMETIC_RANGE) -> "IN_ARITHMETIC_RANGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INVOKING) -> "INVOKING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INVOKE) -> "INVOKE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INVALID_KEY) -> "INVALID_KEY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INVALID) -> "INVALID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTRINSIC) -> "INTRINSIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTO) -> "INTO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTERVENING_) -> "INTERVENING_"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTERMEDIATE) -> "INTERMEDIATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTERFACE_ID) -> "INTERFACE_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INTERFACE) -> "INTERFACE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INSTALLATION) -> "INSTALLATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INSPECT) -> "INSPECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INSERT_ROWS) -> "INSERT_ROWS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INSERTION_INDEX) -> "INSERTION_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INQUIRE) -> "INQUIRE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INPUT_OUTPUT) -> "INPUT_OUTPUT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INPUT) -> "INPUT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INITIATE) -> "INITIATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INITIALIZED) -> "INITIALIZED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INITIALIZE) -> "INITIALIZE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INITIAL) -> "INITIAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INHERITS) -> "INHERITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDICATE) -> "INDICATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDEX_2) -> "INDEX_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDEX_1) -> "INDEX_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDEXED) -> "INDEXED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDEX) -> "INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_INDEPENDENT) -> "INDEPENDENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IN) -> "IN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IMPLEMENTS) -> "IMPLEMENTS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IGNORING) -> "IGNORING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IGNORE) -> "IGNORE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IF) -> "IF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IDS_II) -> "IDS_II"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IDENTIFIED) -> "IDENTIFIED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_IDENTIFICATION) -> "IDENTIFICATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ID) -> "ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ICON) -> "ICON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HSCROLL_POS) -> "HSCROLL_POS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HSCROLL) -> "HSCROLL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HOT_TRACK) -> "HOT_TRACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIGH_VALUE) -> "HIGH_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIGH_ORDER_RIGHT) -> "HIGH_ORDER_RIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIGH_ORDER_LEFT) -> "HIGH_ORDER_LEFT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIGH_COLOR) -> "HIGH_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIGHLIGHT) -> "HIGHLIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HIDDEN_DATA) -> "HIDDEN_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEXLIT) -> "HEXLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEX) -> "HEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEIGHT_IN_CELLS) -> "HEIGHT_IN_CELLS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEAVY) -> "HEAVY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEADING_FONT) -> "HEADING_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEADING_DIVIDER_COLOR) -> "HEADING_DIVIDER_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEADING_COLOR) -> "HEADING_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HEADING) -> "HEADING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HAS_CHILDREN) -> "HAS_CHILDREN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_HANDLE) -> "HANDLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GT) -> ">"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GROUP_VALUE) -> "GROUP_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GROUP_USAGE) -> "GROUP_USAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GROUP) -> "GROUP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GRID) -> "GRID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GREATER) -> "GREATER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GRAPHICAL) -> "GRAPHICAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GO_SEARCH) -> "GO_SEARCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GO_HOME) -> "GO_HOME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GO_FORWARD) -> "GO_FORWARD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GO_BACK) -> "GO_BACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GOBACK) -> "GOBACK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GO) -> "GO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GLOBAL) -> "GLOBAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GIVING) -> "GIVING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GET) -> "GET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GENERATE) -> "GENERATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GE) -> ">="
+ | MenhirInterpreter.X (MenhirInterpreter.T T_GCOS) -> "GCOS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FUNCTION_POINTER) -> "FUNCTION_POINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FUNCTION_ID) -> "FUNCTION_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FUNCTION) -> "FUNCTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FULL_HEIGHT) -> "FULL_HEIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FULL) -> "FULL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FROM) -> "FROM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FREE) -> "FREE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FRAMED) -> "FRAMED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FRAME) -> "FRAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FORMAT) -> "FORMAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FOREVER) -> "FOREVER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FOREGROUND_COLOR) -> "FOREGROUND_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FOR) -> "FOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FOOTING) -> "FOOTING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FONT) -> "FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLR) -> "FLR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_SHORT) -> "FLOAT_SHORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_NOT_A_NUMBER_SIGNALING) -> "FLOAT_NOT_A_NUMBER_SIGNALING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_NOT_A_NUMBER_QUIET) -> "FLOAT_NOT_A_NUMBER_QUIET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_NOT_A_NUMBER) -> "FLOAT_NOT_A_NUMBER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_LONG) -> "FLOAT_LONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_INFINITY) -> "FLOAT_INFINITY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_EXTENDED) -> "FLOAT_EXTENDED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_DECIMAL_34) -> "FLOAT_DECIMAL_34"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_DECIMAL_16) -> "FLOAT_DECIMAL_16"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_DECIMAL) -> "FLOAT_DECIMAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_BINARY_64) -> "FLOAT_BINARY_64"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_BINARY_32) -> "FLOAT_BINARY_32"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_BINARY_128) -> "FLOAT_BINARY_128"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT_BINARY) -> "FLOAT_BINARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOATLIT) -> "FLOATLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOATING) -> "FLOATING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLOAT) -> "FLOAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLAT_BUTTONS) -> "FLAT_BUTTONS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FLAT) -> "FLAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FIXED_WIDTH) -> "FIXED_WIDTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FIXED_FONT) -> "FIXED_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FIXEDLIT) -> "FIXEDLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FIXED) -> "FIXED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FIRST) -> "FIRST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FINISH_REASON) -> "FINISH_REASON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FINALLY) -> "FINALLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FINAL) -> "FINAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILL_PERCENT) -> "FILL_PERCENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILL_COLOR2) -> "FILL_COLOR2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILL_COLOR) -> "FILL_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILLER) -> "FILLER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_POS) -> "FILE_POS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_NAME) -> "FILE_NAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_LIMITS) -> "FILE_LIMITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_LIMIT) -> "FILE_LIMIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_ID) -> "FILE_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE_CONTROL) -> "FILE_CONTROL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILES) -> "FILES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FILE) -> "FILE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FH__KEYDEF) -> "FH__KEYDEF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FH__FCD) -> "FH__FCD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FD) -> "FD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FARTHEST_FROM_ZERO) -> "FARTHEST_FROM_ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FALSE) -> "FALSE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_FACTORY) -> "FACTORY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_F) -> "F"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXTERNAL_FORM) -> "EXTERNAL_FORM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXTERNAL) -> "EXTERNAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXTERN) -> "EXTERN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXTENDED_SEARCH) -> "EXTENDED_SEARCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXTEND) -> "EXTEND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXPANDS) -> "EXPANDS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXPAND) -> "EXPAND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXIT) -> "EXIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXHIBIT) -> "EXHIBIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXCLUSIVE_OR) -> "EXCLUSIVE_OR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXCLUSIVE) -> "EXCLUSIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXCEPTION_VALUE) -> "EXCEPTION_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXCEPTION_OBJECT) -> "EXCEPTION_OBJECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXCEPTION) -> "EXCEPTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EXAMINE) -> "EXAMINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EVERY) -> "EVERY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EVENT_LIST) -> "EVENT_LIST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EVENT) -> "EVENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EVALUATE) -> "EVALUATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ESI) -> "ESI"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ESCAPE_BUTTON) -> "ESCAPE_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ESCAPE) -> "ESCAPE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ERROR) -> "ERROR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ERASE) -> "ERASE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EQUAL) -> "EQUAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EQ) -> "="
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EOS) -> "EOS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EOP) -> "EOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EOL) -> "EOL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EOF) -> "EOF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EO) -> "EO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENVIRONMENT_VALUE) -> "ENVIRONMENT_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENVIRONMENT_NAME) -> "ENVIRONMENT_NAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENVIRONMENT) -> "ENVIRONMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENTRY_REASON) -> "ENTRY_REASON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENTRY_FIELD) -> "ENTRY_FIELD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENTRY_CONVENTION) -> "ENTRY_CONVENTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENTRY) -> "ENTRY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENTER) -> "ENTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENSURE_VISIBLE) -> "ENSURE_VISIBLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENGRAVED) -> "ENGRAVED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_XML) -> "END_XML"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_WRITE) -> "END_WRITE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_UNSTRING) -> "END_UNSTRING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_SUBTRACT) -> "END_SUBTRACT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_STRING) -> "END_STRING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_START) -> "END_START"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_SEND) -> "END_SEND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_SEARCH) -> "END_SEARCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_REWRITE) -> "END_REWRITE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_RETURN) -> "END_RETURN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_RECEIVE) -> "END_RECEIVE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_READ) -> "END_READ"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_PERFORM) -> "END_PERFORM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_OF_PAGE) -> "END_OF_PAGE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_MULTIPLY) -> "END_MULTIPLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_MODIFY) -> "END_MODIFY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_JSON) -> "END_JSON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_IF) -> "END_IF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_EVALUATE) -> "END_EVALUATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_DIVIDE) -> "END_DIVIDE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_DISPLAY) -> "END_DISPLAY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_DELETE) -> "END_DELETE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_COMPUTE) -> "END_COMPUTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_COLOR) -> "END_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_CHAIN) -> "END_CHAIN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_CALL) -> "END_CALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_ADD) -> "END_ADD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END_ACCEPT) -> "END_ACCEPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENDING) -> "ENDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_END) -> "END"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENCRYPTION) -> "ENCRYPTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENCODING) -> "ENCODING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ENABLE) -> "ENABLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EMI) -> "EMI"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ELSE) -> "ELSE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ELEMENT) -> "ELEMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EIGHTY_EIGHT) -> "EIGHTY_EIGHT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EGI) -> "EGI"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EDITING) -> "EDITING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ECHO) -> "ECHO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EC) -> "EC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_EBCDIC) -> "EBCDIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DYNAMIC) -> "DYNAMIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DUPLICATES) -> "DUPLICATES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DROP_LIST) -> "DROP_LIST"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DROP_DOWN) -> "DROP_DOWN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DRAG_COLOR) -> "DRAG_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOWN) -> "DOWN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOUBLE_COLON) -> "::"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOUBLE_ASTERISK) -> "**"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOUBLE) -> "DOUBLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOTTED) -> "DOTTED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DOTDASH) -> "DOTDASH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DIVISION) -> "DIVISION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DIVIDER_COLOR) -> "DIVIDER_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DIVIDERS) -> "DIVIDERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DIVIDE) -> "DIVIDE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_FORMAT) -> "DISPLAY_FORMAT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_COLUMNS) -> "DISPLAY_COLUMNS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_4) -> "DISPLAY_4"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_3) -> "DISPLAY_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_2) -> "DISPLAY_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY_1) -> "DISPLAY_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISPLAY) -> "DISPLAY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISP) -> "DISP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISK) -> "DISK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISCONNECT) -> "DISCONNECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISC) -> "DISC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DISABLE) -> "DISABLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DIGITS) -> "DIGITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DETAIL) -> "DETAIL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DESTROY) -> "DESTROY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DESTINATION) -> "DESTINATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DESCENDING) -> "DESCENDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEPENDING) -> "DEPENDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DELIMITER) -> "DELIMITER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DELIMITED) -> "DELIMITED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DELETE) -> "DELETE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEFINITION) -> "DEFINITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEFAULT_FONT) -> "DEFAULT_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEFAULT_BUTTON) -> "DEFAULT_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEFAULT) -> "DEFAULT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DECLARATIVES) -> "DECLARATIVES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DECIMAL_POINT) -> "DECIMAL_POINT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DECIMAL_ENCODING) -> "DECIMAL_ENCODING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_SUB_3) -> "DEBUG_SUB_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_SUB_2) -> "DEBUG_SUB_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_SUB_1) -> "DEBUG_SUB_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_NAME) -> "DEBUG_NAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_LINE) -> "DEBUG_LINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_ITEM) -> "DEBUG_ITEM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUG_CONTENTS) -> "DEBUG_CONTENTS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DEBUGGING) -> "DEBUGGING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DAY_OF_WEEK) -> "DAY_OF_WEEK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DAY) -> "DAY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATE_WRITTEN) -> "DATE_WRITTEN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATE_MODIFIED) -> "DATE_MODIFIED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATE_ENTRY) -> "DATE_ENTRY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATE_COMPILED) -> "DATE_COMPILED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATE) -> "DATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA_TYPES) -> "DATA_TYPES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA_RECORDS) -> "DATA_RECORDS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA_RECORD) -> "DATA_RECORD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA_POINTER) -> "DATA_POINTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA_COLUMNS) -> "DATA_COLUMNS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DATA) -> "DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DASH_SIGN) -> "-"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_DASHED) -> "DASHED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CYL_OVERFLOW) -> "CYL_OVERFLOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CYL_INDEX) -> "CYL_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CYCLE) -> "CYCLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CUSTOM_PRINT_TEMPLATE) -> "CUSTOM_PRINT_TEMPLATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_Y) -> "CURSOR_Y"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_X) -> "CURSOR_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_ROW) -> "CURSOR_ROW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_FRAME_WIDTH) -> "CURSOR_FRAME_WIDTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_COLOR) -> "CURSOR_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR_COL) -> "CURSOR_COL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURSOR) -> "CURSOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURRENT) -> "CURRENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CURRENCY) -> "CURRENCY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CS_GENERAL) -> "CS_GENERAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CS_BASIC) -> "CS_BASIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CSIZE) -> "CSIZE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CRT_UNDER) -> "CRT_UNDER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CRT) -> "CRT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COUNT) -> "COUNT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CORRESPONDING) -> "CORRESPONDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CORE_INDEX) -> "CORE_INDEX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COPY_SELECTION) -> "COPY_SELECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COPY) -> "COPY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONVERTING) -> "CONVERTING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONVERSION) -> "CONVERSION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONTROLS) -> "CONTROLS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONTROL) -> "CONTROL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONTINUE) -> "CONTINUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONTENT) -> "CONTENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONTAINS) -> "CONTAINS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONSTANT) -> "CONSTANT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONSOLE_3) -> "CONSOLE_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONSOLE_2) -> "CONSOLE_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONSOLE_1) -> "CONSOLE_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONSOLE_0) -> "CONSOLE_0"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONNECT) -> "CONNECT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONFIGURATION) -> "CONFIGURATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CONDITION) -> "CONDITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_X) -> "COMP_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_N) -> "COMP_N"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_9) -> "COMP_9"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_7) -> "COMP_7"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_6) -> "COMP_6"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_5) -> "COMP_5"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_4) -> "COMP_4"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_3) -> "COMP_3"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_2) -> "COMP_2"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_15) -> "COMP_15"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_14) -> "COMP_14"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_13) -> "COMP_13"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_12) -> "COMP_12"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_11) -> "COMP_11"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_10) -> "COMP_10"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_1) -> "COMP_1"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP_0) -> "COMP_0"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTE) -> "COMPUTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTATIONAL_7) -> "COMPUTATIONAL_7"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTATIONAL_14) -> "COMPUTATIONAL_14"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTATIONAL_13) -> "COMPUTATIONAL_13"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTATIONAL_12) -> "COMPUTATIONAL_12"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPUTATIONAL_11) -> "COMPUTATIONAL_11"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPLEMENTARY) -> "COMPLEMENTARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMPLE) -> "COMPLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMP) -> "COMP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMMUNICATION) -> "COMMUNICATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMMON) -> "COMMON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMMIT) -> "COMMIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMMAND_LINE) -> "COMMAND_LINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMMA) -> "COMMA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COMBO_BOX) -> "COMBO_BOX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN_PROTECTION) -> "COLUMN_PROTECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN_HEADINGS) -> "COLUMN_HEADINGS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN_FONT) -> "COLUMN_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN_DIVIDERS) -> "COLUMN_DIVIDERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN_COLOR) -> "COLUMN_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMNS) -> "COLUMNS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLUMN) -> "COLUMN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLORS) -> "COLORS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLOR) -> "COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLON) -> ":"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COLLATING) -> "COLLATING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COL) -> "COL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CODE_SET) -> "CODE_SET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CODE) -> "CODE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_COBOL) -> "COBOL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLOSE) -> "CLOSE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLOCK_UNITS) -> "CLOCK_UNITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLINES) -> "CLINES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLINE) -> "CLINE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLEAR_SELECTION) -> "CLEAR_SELECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLASS_ID) -> "CLASS_ID"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLASSIFICATION) -> "CLASSIFICATION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CLASS) -> "CLASS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHECK_BOX) -> "CHECK_BOX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHECKPOINT_FILE) -> "CHECKPOINT_FILE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHECK) -> "CHECK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHARACTERS) -> "CHARACTERS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHARACTER) -> "CHARACTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHANGED) -> "CHANGED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHAINING) -> "CHAINING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CHAIN) -> "CHAIN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CH) -> "CH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CF) -> "CF"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CENTURY_DATE) -> "CENTURY_DATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CENTERED_HEADINGS) -> "CENTERED_HEADINGS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CENTERED) -> "CENTERED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CENTER) -> "CENTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CELL_PROTECTION) -> "CELL_PROTECTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CELL_FONT) -> "CELL_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CELL_DATA) -> "CELL_DATA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CELL_COLOR) -> "CELL_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CELL) -> "CELL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CD) -> "CD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CCOL) -> "CCOL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CATALOGUE_NAME) -> "CATALOGUE_NAME"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CATALOGUED) -> "CATALOGUED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CASSETTE) -> "CASSETTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CARD_READER) -> "CARD_READER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CARD_PUNCH) -> "CARD_PUNCH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CAPACITY) -> "CAPACITY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CANCEL_BUTTON) -> "CANCEL_BUTTON"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CANCEL) -> "CANCEL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CALL) -> "CALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_CALENDAR_FONT) -> "CALENDAR_FONT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_C) -> "C"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_XOR) -> "B_XOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_SHIFT_RC) -> "B_SHIFT_RC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_SHIFT_R) -> "B_SHIFT_R"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_SHIFT_LC) -> "B_SHIFT_LC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_SHIFT_L) -> "B_SHIFT_L"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_OR) -> "B_OR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_NOT) -> "B_NOT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_EXOR) -> "B_EXOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_B_AND) -> "B_AND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BYTE_LENGTH) -> "BYTE_LENGTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BYTES) -> "BYTES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BYTE) -> "BYTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BY) -> "BY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BUTTONS) -> "BUTTONS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BUSY) -> "BUSY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BULK_ADDITION) -> "BULK_ADDITION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BSN) -> "BSN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BOXED) -> "BOXED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BOX) -> "BOX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BOTTOM) -> "BOTTOM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BOOLIT) -> "BOOLIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BOOLEAN) -> "BOOLEAN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BLOCK) -> "BLOCK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BLINK) -> "BLINK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BLANK) -> "BLANK"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITS) -> "BITS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_WIDTH) -> "BITMAP_WIDTH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_TRANSPARENT_COLOR) -> "BITMAP_TRANSPARENT_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_TRAILING) -> "BITMAP_TRAILING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_TIMER) -> "BITMAP_TIMER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_START) -> "BITMAP_START"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_NUMBER) -> "BITMAP_NUMBER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_HANDLE) -> "BITMAP_HANDLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP_END) -> "BITMAP_END"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BITMAP) -> "BITMAP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BIT) -> "BIT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_SHORT) -> "BINARY_SHORT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_SEQUENTIAL) -> "BINARY_SEQUENTIAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_LONG) -> "BINARY_LONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_ENCODING) -> "BINARY_ENCODING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_DOUBLE) -> "BINARY_DOUBLE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_C_LONG) -> "BINARY_C_LONG"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY_CHAR) -> "BINARY_CHAR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BINARY) -> "BINARY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BELL) -> "BELL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BEGINNING) -> "BEGINNING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BEFORE) -> "BEFORE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BECOMES) -> "BECOMES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BASED) -> "BASED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BAR) -> "BAR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BACKWARD) -> "BACKWARD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BACKGROUND_STANDARD) -> "BACKGROUND_STANDARD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BACKGROUND_LOW) -> "BACKGROUND_LOW"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BACKGROUND_HIGH) -> "BACKGROUND_HIGH"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_BACKGROUND_COLOR) -> "BACKGROUND_COLOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AWAY_FROM_ZERO) -> "AWAY_FROM_ZERO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AUTO_SPIN) -> "AUTO_SPIN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AUTO_DECIMAL) -> "AUTO_DECIMAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AUTOMATIC) -> "AUTOMATIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AUTO) -> "AUTO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AUTHOR) -> "AUTHOR"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AT_EOP) -> "AT_EOP"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AT_END) -> "AT_END"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ATTRIBUTES) -> "ATTRIBUTES"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ATTRIBUTE) -> "ATTRIBUTE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AT) -> "AT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ASTERISK) -> "*"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ASSIGN) -> "ASSIGN"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ASCII) -> "ASCII"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ASCENDING) -> "ASCENDING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ASA) -> "ASA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AS) -> "AS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ARITHMETIC) -> "ARITHMETIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ARGUMENT_VALUE) -> "ARGUMENT_VALUE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ARGUMENT_NUMBER) -> "ARGUMENT_NUMBER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AREAS) -> "AREAS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AREA) -> "AREA"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ARE) -> "ARE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_APPLY) -> "APPLY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ANYCASE) -> "ANYCASE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ANY) -> "ANY"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ANUM) -> "ANUM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ANSI) -> "ANSI"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AND) -> "AND"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AMPERSAND) -> "&"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALTERNATE) -> "ALTERNATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALTERING) -> "ALTERING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALTER) -> "ALTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALSO) -> "ALSO"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHANUM_PREFIX) -> "ALPHANUM_PREFIX"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHANUMERIC_EDITED) -> "ALPHANUMERIC_EDITED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHANUMERIC) -> "ALPHANUMERIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHANUM) -> "ALPHANUM"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHABETIC_UPPER) -> "ALPHABETIC_UPPER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHABETIC_LOWER) -> "ALPHABETIC_LOWER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHABETIC) -> "ALPHABETIC"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALPHABET) -> "ALPHABET"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALLOWING) -> "ALLOWING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALLOCATE) -> "ALLOCATE"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALL) -> "ALL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALIGNMENT) -> "ALIGNMENT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALIGNED) -> "ALIGNED"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ALIAS) -> "ALIAS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_AFTER) -> "AFTER"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ADVANCING) -> "ADVANCING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ADJUSTABLE_COLUMNS) -> "ADJUSTABLE_COLUMNS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ADDRESS) -> "ADDRESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ADD) -> "ADD"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACTUAL) -> "ACTUAL"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACTIVE_X) -> "ACTIVE_X"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACTIVE_CLASS) -> "ACTIVE_CLASS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACTIVATING) -> "ACTIVATING"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACTION) -> "ACTION"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACCESS) -> "ACCESS"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ACCEPT) -> "ACCEPT"
+ | MenhirInterpreter.X (MenhirInterpreter.T T_ABSENT) -> "ABSENT"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_write_target) -> "write_target"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_write_statement) -> "write_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_working_storage_section) -> "working_storage_section"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_word_or_terminal) -> ""
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_test) -> "with_test"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_status) -> "with_status"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_no_advancing) -> "with_no_advancing"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_lock_clause) -> "with_lock_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_lock) -> "with_lock"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_key) -> "with_key"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_with_data) -> "with_data"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_when_selection_objects) -> "when_selection_objects"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_when_phrase) -> "when_phrase"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_when_other) -> "when_other"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_when_clause) -> "when_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_varying_phrase) -> "varying_phrase"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_varying_clause) -> "varying_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_value_of_clause) -> "value_of_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_validation_stage) -> "validation_stage"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_validation_clause) -> "validation_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_validate_status_clause) -> "validate_status_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_validate_statement) -> "validate_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_using_clause) -> "using_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_using_by) -> "using_by"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_use_statement) -> "use_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_use_after_exception) -> "use_after_exception"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_usage_clause) -> "usage_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_usage) -> "usage"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_upon) -> "upon"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_up_down) -> "up_down"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_unstring_target) -> "unstring_target"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_unstring_statement) -> "unstring_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_unstring_delimiters) -> ""
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_unlock_statement) -> "unlock_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_unconditional_action) -> "unconditional_action"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_typedef_clause) -> "typedef_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_transform_statement) -> "transform_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_then_replacing) -> "then_replacing"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_terminate_statement) -> "terminate_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_tallying_for) -> "tallying_for"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_tallying) -> "tallying"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_synchronized_clause) -> "synchronized_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_symbolic_characters_clause) -> "symbolic_characters_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_suppress_statement) -> "suppress_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_sum_phrase) -> "sum_phrase"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_sum_operands) -> "sum_operands"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_sum_clause) -> "sum_clause"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_subtract_statement) -> "subtract_statement"
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_subscripts) -> ""
+ | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_subscript_following) -> "