From d879fd4b657d364999ef42ce44ec12244ca63826 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Fri, 21 Jun 2024 16:21:53 +0200 Subject: [PATCH 01/37] Add a skeleton for SQL preprocessor --- .drom | 102 ++++----- .github/workflows/workflow.yml | 2 +- Makefile | 2 +- drom.toml | 4 + dune-project | 14 ++ opam/sql_preproc.opam | 55 +++++ opam/superbol_free_lib.opam | 1 + src/lsp/cobol_common/version.mlt | 9 +- src/lsp/cobol_config/version.mlt | 9 +- src/lsp/cobol_data/version.mlt | 9 +- src/lsp/cobol_indent/version.mlt | 9 +- src/lsp/cobol_indent_old/version.mlt | 9 +- src/lsp/cobol_lsp/version.mlt | 9 +- src/lsp/cobol_parser/version.mlt | 9 +- src/lsp/cobol_preproc/version.mlt | 9 +- src/lsp/cobol_ptree/version.mlt | 9 +- src/lsp/cobol_typeck/version.mlt | 9 +- src/lsp/cobol_unit/version.mlt | 9 +- src/lsp/ebcdic_lib/ebcdic_version.mlt | 9 +- src/lsp/ezr_toml/version.mlt | 9 +- src/lsp/ppx_cobcflags/version.mlt | 9 +- src/lsp/pretty/version.mlt | 9 +- src/lsp/sql_preproc/dune | 26 +++ src/lsp/sql_preproc/generate.ml | 161 +++++++++++++ src/lsp/sql_preproc/generate.mli | 13 ++ src/lsp/sql_preproc/index.mld | 7 + src/lsp/sql_preproc/main.ml | 66 ++++++ src/lsp/sql_preproc/main.mli | 19 ++ src/lsp/sql_preproc/misc.ml | 102 +++++++++ src/lsp/sql_preproc/misc.mli | 26 +++ src/lsp/sql_preproc/package.toml | 74 ++++++ src/lsp/sql_preproc/parse.ml | 214 ++++++++++++++++++ src/lsp/sql_preproc/parse.mli | 15 ++ src/lsp/sql_preproc/types.ml | 55 +++++ src/lsp/sql_preproc/version.mlt | 35 +++ src/lsp/superbol_free_lib/command_sql.ml | 63 ++++++ src/lsp/superbol_free_lib/dune | 2 +- src/lsp/superbol_free_lib/main.ml | 1 + src/lsp/superbol_free_lib/package.toml | 1 + src/lsp/superbol_free_lib/version.mlt | 9 +- src/lsp/superbol_preprocs/version.mlt | 9 +- src/lsp/superbol_project/version.mlt | 9 +- src/vendor/ez_toml/version.mlt | 9 +- .../src-bindings/interop/version.mlt | 9 +- .../src-bindings/node/version.mlt | 9 +- .../src-bindings/polka/version.mlt | 9 +- .../src-bindings/vscode/version.mlt | 9 +- .../vscode_languageclient/version.mlt | 9 +- .../superbol-vscode-platform/version.mlt | 9 +- src/vscode/vscode-debugadapter/version.mlt | 9 +- src/vscode/vscode-debugprotocol/version.mlt | 9 +- src/vscode/vscode-json/version.mlt | 9 +- 52 files changed, 1201 insertions(+), 111 deletions(-) create mode 100644 opam/sql_preproc.opam create mode 100644 src/lsp/sql_preproc/dune create mode 100644 src/lsp/sql_preproc/generate.ml create mode 100644 src/lsp/sql_preproc/generate.mli create mode 100644 src/lsp/sql_preproc/index.mld create mode 100644 src/lsp/sql_preproc/main.ml create mode 100644 src/lsp/sql_preproc/main.mli create mode 100644 src/lsp/sql_preproc/misc.ml create mode 100644 src/lsp/sql_preproc/misc.mli create mode 100644 src/lsp/sql_preproc/package.toml create mode 100644 src/lsp/sql_preproc/parse.ml create mode 100644 src/lsp/sql_preproc/parse.mli create mode 100644 src/lsp/sql_preproc/types.ml create mode 100644 src/lsp/sql_preproc/version.mlt create mode 100644 src/lsp/superbol_free_lib/command_sql.ml diff --git a/.drom b/.drom index 037dc0090..cc7b6c7de 100644 --- a/.drom +++ b/.drom @@ -5,13 +5,12 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -8cea4e6583257460088512aeb1ad1f3c:. +deca758843ebc9039cb64ad0a60504d3:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -5714f81b8a12cefeab3bd452453832b5:.github/workflows/workflow.yml -aedabb02434649b101d3db2436821c08:.github/workflows/workflow.yml +be866787b33695ca0fbe400819670f9b:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore @@ -26,7 +25,7 @@ aedabb02434649b101d3db2436821c08:.github/workflows/workflow.yml # begin context for Makefile # file Makefile -6df00a262065dfd93e0cc8a2ce00a3ec:Makefile +7e856d11a4bdf169eea5c0fbb9f1d940:Makefile # end context for Makefile # begin context for README.md @@ -76,8 +75,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project -a2652ac66ab141a8ae971d7005691f7a:dune-project -76e255f66748a08d469bf9271cd41de8:dune-project +f7cff5bb555d519a20fc74a74fa9f63d:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -181,10 +179,10 @@ b12cc17cc4ed0083355236058d5a523d:opam/pretty.opam 46a86088dd35038c08807fbc8617a944:opam/sql_ast.opam # end context for opam/sql_ast.opam -# begin context for opam/sql_parser.opam -# file opam/sql_parser.opam -9905287d499b35a41caddb08b96975f7:opam/sql_parser.opam -# end context for opam/sql_parser.opam +# begin context for opam/sql_preproc.opam +# file opam/sql_preproc.opam +c9c81bc1948a1ef51d4b4e93998dfeba:opam/sql_preproc.opam +# end context for opam/sql_preproc.opam # begin context for opam/superbol-free.opam # file opam/superbol-free.opam @@ -203,7 +201,7 @@ a06ba5cab76e86a552dab9b790cf95dd:opam/superbol-vscode-platform.opam # begin context for opam/superbol_free_lib.opam # file opam/superbol_free_lib.opam -8b03e05538fc3628684f8ad4e0ceac15:opam/superbol_free_lib.opam +b3fed8631b6c12ad16581c6e5ef0307b:opam/superbol_free_lib.opam # end context for opam/superbol_free_lib.opam # begin context for opam/superbol_preprocs.opam @@ -293,7 +291,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_common/version.mlt # file src/lsp/cobol_common/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_common/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_common/version.mlt # end context for src/lsp/cobol_common/version.mlt # begin context for src/lsp/cobol_config/dune @@ -303,7 +301,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_config/version.mlt # file src/lsp/cobol_config/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_config/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_config/version.mlt # end context for src/lsp/cobol_config/version.mlt # begin context for src/lsp/cobol_data/dune @@ -313,7 +311,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_data/version.mlt # file src/lsp/cobol_data/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_data/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_data/version.mlt # end context for src/lsp/cobol_data/version.mlt # begin context for src/lsp/cobol_indent/dune @@ -323,7 +321,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_indent/version.mlt # file src/lsp/cobol_indent/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_indent/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_indent/version.mlt # end context for src/lsp/cobol_indent/version.mlt # begin context for src/lsp/cobol_indent_old/dune @@ -333,7 +331,7 @@ a98a08d36a2f65127f60832515b6ab47:src/lsp/cobol_indent_old/dune # begin context for src/lsp/cobol_indent_old/version.mlt # file src/lsp/cobol_indent_old/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_indent_old/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_indent_old/version.mlt # end context for src/lsp/cobol_indent_old/version.mlt # begin context for src/lsp/cobol_lsp/dune @@ -343,7 +341,7 @@ a98a08d36a2f65127f60832515b6ab47:src/lsp/cobol_indent_old/dune # begin context for src/lsp/cobol_lsp/version.mlt # file src/lsp/cobol_lsp/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_lsp/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_lsp/version.mlt # end context for src/lsp/cobol_lsp/version.mlt # begin context for src/lsp/cobol_parser/dune @@ -353,7 +351,7 @@ a98a08d36a2f65127f60832515b6ab47:src/lsp/cobol_indent_old/dune # begin context for src/lsp/cobol_parser/version.mlt # file src/lsp/cobol_parser/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_parser/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_parser/version.mlt # end context for src/lsp/cobol_parser/version.mlt # begin context for src/lsp/cobol_preproc/dune @@ -363,7 +361,7 @@ e31b22f1d241d75db90f170f9c6fd95d:src/lsp/cobol_preproc/dune # begin context for src/lsp/cobol_preproc/version.mlt # file src/lsp/cobol_preproc/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_preproc/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_preproc/version.mlt # end context for src/lsp/cobol_preproc/version.mlt # begin context for src/lsp/cobol_ptree/dune @@ -373,7 +371,7 @@ e31b22f1d241d75db90f170f9c6fd95d:src/lsp/cobol_preproc/dune # begin context for src/lsp/cobol_ptree/version.mlt # file src/lsp/cobol_ptree/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_ptree/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_ptree/version.mlt # end context for src/lsp/cobol_ptree/version.mlt # begin context for src/lsp/cobol_typeck/dune @@ -383,7 +381,7 @@ ef30db283bff57bd7bfea9b29e9178fd:src/lsp/cobol_typeck/dune # begin context for src/lsp/cobol_typeck/version.mlt # file src/lsp/cobol_typeck/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_typeck/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_typeck/version.mlt # end context for src/lsp/cobol_typeck/version.mlt # begin context for src/lsp/cobol_unit/dune @@ -393,7 +391,7 @@ d2c167a61ac9aa89964577228ccb49fa:src/lsp/cobol_unit/dune # begin context for src/lsp/cobol_unit/version.mlt # file src/lsp/cobol_unit/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/cobol_unit/version.mlt +32d077864212af27904137e71df668a7:src/lsp/cobol_unit/version.mlt # end context for src/lsp/cobol_unit/version.mlt # begin context for src/lsp/ebcdic_lib/dune @@ -403,7 +401,7 @@ d2c167a61ac9aa89964577228ccb49fa:src/lsp/cobol_unit/dune # begin context for src/lsp/ebcdic_lib/ebcdic_version.mlt # file src/lsp/ebcdic_lib/ebcdic_version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/ebcdic_lib/ebcdic_version.mlt +32d077864212af27904137e71df668a7:src/lsp/ebcdic_lib/ebcdic_version.mlt # end context for src/lsp/ebcdic_lib/ebcdic_version.mlt # begin context for src/lsp/ezr_toml/dune @@ -413,7 +411,7 @@ eab335ce600887c59f1baf9b0983d0ac:src/lsp/ezr_toml/dune # begin context for src/lsp/ezr_toml/version.mlt # file src/lsp/ezr_toml/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/ezr_toml/version.mlt +32d077864212af27904137e71df668a7:src/lsp/ezr_toml/version.mlt # end context for src/lsp/ezr_toml/version.mlt # begin context for src/lsp/ppx_cobcflags/dune @@ -423,7 +421,7 @@ eab335ce600887c59f1baf9b0983d0ac:src/lsp/ezr_toml/dune # begin context for src/lsp/ppx_cobcflags/version.mlt # file src/lsp/ppx_cobcflags/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/ppx_cobcflags/version.mlt +32d077864212af27904137e71df668a7:src/lsp/ppx_cobcflags/version.mlt # end context for src/lsp/ppx_cobcflags/version.mlt # begin context for src/lsp/pretty/dune @@ -433,7 +431,7 @@ eab335ce600887c59f1baf9b0983d0ac:src/lsp/ezr_toml/dune # begin context for src/lsp/pretty/version.mlt # file src/lsp/pretty/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/pretty/version.mlt +32d077864212af27904137e71df668a7:src/lsp/pretty/version.mlt # end context for src/lsp/pretty/version.mlt # begin context for src/lsp/sql_ast/dune @@ -441,20 +439,20 @@ eab335ce600887c59f1baf9b0983d0ac:src/lsp/ezr_toml/dune e0c73ea039315b0cfa5b4a7ac54a1484:src/lsp/sql_ast/dune # end context for src/lsp/sql_ast/dune -# begin context for src/lsp/sql_ast/version.mlt -# file src/lsp/sql_ast/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/sql_ast/version.mlt -# end context for src/lsp/sql_ast/version.mlt +# begin context for src/lsp/sql_preproc/dune +# file src/lsp/sql_preproc/dune +bef6369614c527afeb0a16e1cee85f3e:src/lsp/sql_preproc/dune +# end context for src/lsp/sql_preproc/dune -# begin context for src/lsp/sql_parser/dune -# file src/lsp/sql_parser/dune -2408ff5956afa93ae2f3302928555c8e:src/lsp/sql_parser/dune -# end context for src/lsp/sql_parser/dune +# begin context for src/lsp/sql_preproc/index.mld +# file src/lsp/sql_preproc/index.mld +463623160e481efaf9123695b0a1db58:src/lsp/sql_preproc/index.mld +# end context for src/lsp/sql_preproc/index.mld -# begin context for src/lsp/sql_parser/version.mlt -# file src/lsp/sql_parser/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/sql_parser/version.mlt -# end context for src/lsp/sql_parser/version.mlt +# begin context for src/lsp/sql_preproc/version.mlt +# file src/lsp/sql_preproc/version.mlt +32d077864212af27904137e71df668a7:src/lsp/sql_preproc/version.mlt +# end context for src/lsp/sql_preproc/version.mlt # begin context for src/lsp/superbol-free/dune # file src/lsp/superbol-free/dune @@ -468,12 +466,12 @@ e0c73ea039315b0cfa5b4a7ac54a1484:src/lsp/sql_ast/dune # begin context for src/lsp/superbol_free_lib/dune # file src/lsp/superbol_free_lib/dune -a8a051709a43fba5b6ab54b66b77cbcf:src/lsp/superbol_free_lib/dune +ef5dde01e364ecef0f87af4d4a869a37: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 -835b44bd66a7d58831f72da5fd0822ba:src/lsp/superbol_free_lib/version.mlt +32d077864212af27904137e71df668a7:src/lsp/superbol_free_lib/version.mlt # end context for src/lsp/superbol_free_lib/version.mlt # begin context for src/lsp/superbol_preprocs/dune @@ -483,7 +481,7 @@ a8a051709a43fba5b6ab54b66b77cbcf:src/lsp/superbol_free_lib/dune # begin context for src/lsp/superbol_preprocs/version.mlt # file src/lsp/superbol_preprocs/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/superbol_preprocs/version.mlt +32d077864212af27904137e71df668a7:src/lsp/superbol_preprocs/version.mlt # end context for src/lsp/superbol_preprocs/version.mlt # begin context for src/lsp/superbol_project/dune @@ -493,7 +491,7 @@ a8a051709a43fba5b6ab54b66b77cbcf:src/lsp/superbol_free_lib/dune # begin context for src/lsp/superbol_project/version.mlt # file src/lsp/superbol_project/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/lsp/superbol_project/version.mlt +32d077864212af27904137e71df668a7:src/lsp/superbol_project/version.mlt # end context for src/lsp/superbol_project/version.mlt # begin context for src/superbol-studio-oss/dune @@ -518,7 +516,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/ez_toml/version.mlt # file src/vendor/ez_toml/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/ez_toml/version.mlt +32d077864212af27904137e71df668a7:src/vendor/ez_toml/version.mlt # end context for src/vendor/ez_toml/version.mlt # begin context for src/vendor/vscode-ocaml-platform/src-bindings/interop/dune @@ -528,7 +526,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt # file src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt +32d077864212af27904137e71df668a7:src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt # end context for src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt # begin context for src/vendor/vscode-ocaml-platform/src-bindings/node/dune @@ -538,7 +536,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt # file src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt +32d077864212af27904137e71df668a7:src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt # end context for src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt # begin context for src/vendor/vscode-ocaml-platform/src-bindings/polka/dune @@ -548,7 +546,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt # file src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt +32d077864212af27904137e71df668a7:src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt # end context for src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt # begin context for src/vendor/vscode-ocaml-platform/src-bindings/vscode/dune @@ -558,7 +556,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt # file src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt +32d077864212af27904137e71df668a7:src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt # end context for src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt # begin context for src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/dune @@ -568,7 +566,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt # file src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt +32d077864212af27904137e71df668a7:src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt # end context for src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt # begin context for src/vscode/superbol-vscode-platform/dune @@ -578,7 +576,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vscode/superbol-vscode-platform/version.mlt # file src/vscode/superbol-vscode-platform/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vscode/superbol-vscode-platform/version.mlt +32d077864212af27904137e71df668a7: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 @@ -588,7 +586,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vscode/vscode-debugadapter/version.mlt # file src/vscode/vscode-debugadapter/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vscode/vscode-debugadapter/version.mlt +32d077864212af27904137e71df668a7:src/vscode/vscode-debugadapter/version.mlt # end context for src/vscode/vscode-debugadapter/version.mlt # begin context for src/vscode/vscode-debugprotocol/dune @@ -598,7 +596,7 @@ c5cd7b2d0a3de0d33ec14e3d433c1cae:src/vendor/ez_toml/index.mld # begin context for src/vscode/vscode-debugprotocol/version.mlt # file src/vscode/vscode-debugprotocol/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vscode/vscode-debugprotocol/version.mlt +32d077864212af27904137e71df668a7:src/vscode/vscode-debugprotocol/version.mlt # end context for src/vscode/vscode-debugprotocol/version.mlt # begin context for src/vscode/vscode-json/dune @@ -613,5 +611,5 @@ c57e4311cc67d76a32541e4dc3132913:src/vscode/vscode-json/dune # begin context for src/vscode/vscode-json/version.mlt # file src/vscode/vscode-json/version.mlt -835b44bd66a7d58831f72da5fd0822ba:src/vscode/vscode-json/version.mlt +32d077864212af27904137e71df668a7:src/vscode/vscode-json/version.mlt # end context for src/vscode/vscode-json/version.mlt diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index d5fda1042..650e9e0a6 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -61,7 +61,7 @@ jobs: - run: opam pin add . -y --no-action - - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser + - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser sql_preproc # if: steps.cache-opam.outputs.cache-hit != 'true' - run: opam install -y opam/*.opam --deps-only --with-test diff --git a/Makefile b/Makefile index db186cd63..1d7a981a4 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,7 @@ ifeq ($(TARGET_PLAT)_$(BUILD_STATIC_EXECS),linux_true) ./scripts/static-build.sh else ${DUNE} build ${DUNE_ARGS} ${DUNE_CROSS_ARGS} @install - ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser + ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser sql_preproc endif ./scripts/after.sh build diff --git a/drom.toml b/drom.toml index 701cb5169..47faab0d7 100644 --- a/drom.toml +++ b/drom.toml @@ -228,6 +228,10 @@ dir = "src/vendor/ez_toml" dir = "src/lsp/ezr_toml" # edit 'src/lsp/ezr_toml/package.toml' for package-specific options +[[package]] +dir = "src/lsp/sql_preproc" +# edit 'src/lsp/ezr_toml/package.toml' for package-specific options + [[package]] dir = "src/lsp/sql_ast" # edit 'src/lsp/sql_ast/package.toml' for package-specific options diff --git a/dune-project b/dune-project index 1d7891a04..f4a53e317 100644 --- a/dune-project +++ b/dune-project @@ -186,6 +186,7 @@ (ocaml (>= 4.14.0)) (vscode-json (= version)) (superbol_preprocs (= version)) + (sql_preproc (= version)) (lwt ( >= 5 )) (ez_toml (= version)) (ez_file ( >= 0.3 )) @@ -458,6 +459,19 @@ ) ) +(package + (name sql_preproc) + (synopsis "SuperBOL Studio OSS Project") + (description "SuperBOL Studio OSS is a new platform for COBOL") + (depends + (ocaml (>= 4.14.0)) + (ppx_deriving ( >= 5.2.1 )) + (ez_file ( >= 0.3 )) + (cobol_indent (= version)) + odoc + ) + ) + (package (name sql_ast) (synopsis "SuperBOL Studio OSS Project") diff --git a/opam/sql_preproc.opam b/opam/sql_preproc.opam new file mode 100644 index 000000000..4d51cc899 --- /dev/null +++ b/opam/sql_preproc.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: "sql_preproc" +version: "0.1.3" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +homepage: "https://ocamlpro.github.io/superbol-studio-oss" +doc: "https://ocamlpro.github.io/superbol-studio-oss/sphinx" +bug-reports: "https://github.com/ocamlpro/superbol-studio-oss/issues" +dev-repo: "git+https://github.com/ocamlpro/superbol-studio-oss.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.14.0"} + "dune" {>= "2.8.0"} + "ppx_deriving" {>= "5.2.1"} + "ez_file" {>= "0.3"} + "cobol_indent" {= version} + "odoc" {with-doc} +] +# 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 index f02bf7eb0..a43992c64 100644 --- a/opam/superbol_free_lib.opam +++ b/opam/superbol_free_lib.opam @@ -49,6 +49,7 @@ depends: [ "dune" {>= "2.8.0"} "vscode-json" {= version} "superbol_preprocs" {= version} + "sql_preproc" {= version} "lwt" {>= "5"} "ez_toml" {= version} "ez_file" {>= "0.3"} diff --git a/src/lsp/cobol_common/version.mlt b/src/lsp/cobol_common/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_common/version.mlt +++ b/src/lsp/cobol_common/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_config/version.mlt b/src/lsp/cobol_config/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_config/version.mlt +++ b/src/lsp/cobol_config/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_data/version.mlt b/src/lsp/cobol_data/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_data/version.mlt +++ b/src/lsp/cobol_data/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_indent/version.mlt b/src/lsp/cobol_indent/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_indent/version.mlt +++ b/src/lsp/cobol_indent/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_indent_old/version.mlt b/src/lsp/cobol_indent_old/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_indent_old/version.mlt +++ b/src/lsp/cobol_indent_old/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_lsp/version.mlt b/src/lsp/cobol_lsp/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_lsp/version.mlt +++ b/src/lsp/cobol_lsp/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_parser/version.mlt b/src/lsp/cobol_parser/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_parser/version.mlt +++ b/src/lsp/cobol_parser/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_preproc/version.mlt b/src/lsp/cobol_preproc/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_preproc/version.mlt +++ b/src/lsp/cobol_preproc/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_ptree/version.mlt b/src/lsp/cobol_ptree/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_ptree/version.mlt +++ b/src/lsp/cobol_ptree/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_typeck/version.mlt b/src/lsp/cobol_typeck/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_typeck/version.mlt +++ b/src/lsp/cobol_typeck/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/cobol_unit/version.mlt b/src/lsp/cobol_unit/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/cobol_unit/version.mlt +++ b/src/lsp/cobol_unit/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/ebcdic_lib/ebcdic_version.mlt b/src/lsp/ebcdic_lib/ebcdic_version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/ebcdic_lib/ebcdic_version.mlt +++ b/src/lsp/ebcdic_lib/ebcdic_version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/ezr_toml/version.mlt b/src/lsp/ezr_toml/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/ezr_toml/version.mlt +++ b/src/lsp/ezr_toml/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/ppx_cobcflags/version.mlt b/src/lsp/ppx_cobcflags/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/ppx_cobcflags/version.mlt +++ b/src/lsp/ppx_cobcflags/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/pretty/version.mlt b/src/lsp/pretty/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/pretty/version.mlt +++ b/src/lsp/pretty/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/sql_preproc/dune b/src/lsp/sql_preproc/dune new file mode 100644 index 000000000..2ad4c1046 --- /dev/null +++ b/src/lsp/sql_preproc/dune @@ -0,0 +1,26 @@ +; generated by drom from package skeleton 'library' + +(library + (name sql_preproc) + (public_name sql_preproc) + (wrapped true) + ; use field 'dune-libraries' to add libraries without opam deps + (libraries ppx_deriving ez_file cobol_indent ) + ; 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 sql_preproc)) + +; use field 'dune-trailer' to add more stuff here + diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml new file mode 100644 index 000000000..138eaf083 --- /dev/null +++ b/src/lsp/sql_preproc/generate.ml @@ -0,0 +1,161 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat +open Types + +let working_storage_section = + {| *> SQL addition in working storage section: + 01 MY-SQL-STUFF PIC X(9). +|} + +let linkage_section = + {| *> SQL addition in linkage section: + 01 SOME-ARG PIC X(9). +|} + +let begin_procedure_division ~ctxt:_ ~loc:_ = + (* We might want to add something at the begining of PROCEDURE DIVISION ? *) + () + +let end_procedure_division ~ctxt:_ ~loc:_ = + (* We might want to add something before the end of PROCEDURE DIVISION ? *) + () + +let generate ~filename ~contents sql_statements = + + (* split lines and numerotate them *) + let lines = EzString.split contents '\n' in + let lines = List.mapi (fun i line -> (filename, i+1, line)) lines in + + (* The result will be stored in this buffer: *) + + let b = Buffer.create 1000 in + + let ctxt = { b ; + main_filename = filename ; + } in + let final_loc = { filename; line = -1; char = 0 } in + + let rec output lines statements = + match statements with + | [] -> + List.iter (fun (_,_,line) -> + Printf.bprintf ctxt.b "%s\n" line + ) lines + | (begin_loc, stmt) :: statements -> + match begin_loc with + | None -> + List.iter (fun (_,_,line) -> + Printf.bprintf ctxt.b "%s\n" line + ) lines ; + begin + match stmt with + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:final_loc + | _ -> () + end + | Some begin_loc -> + output_statement lines begin_loc stmt statements + + and output_statement cur_lines begin_loc stmt statements = + match cur_lines with + | [] -> assert false + | (filename,i,line) :: lines -> + if filename <> begin_loc.filename || i < begin_loc.line then begin + Printf.bprintf ctxt.b "%s\n" line; + output_statement lines begin_loc stmt statements + end + else + match stmt with + | LINKAGE_SECTION { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b linkage_section; + output lines statements + end else begin + Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; + Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; + Buffer.add_string ctxt.b linkage_section; + output cur_lines statements + end + | WORKING_STORAGE { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b working_storage_section ; + output lines statements + end else begin + Printf.bprintf ctxt.b " *> Add missing WORKING-STORAGE SECTION\n"; + Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; + Buffer.add_string ctxt.b working_storage_section; + output cur_lines statements + end + | EXEC_SQL { end_loc ; with_dot ; cmd ; tokens } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + (* TO BE DONE generate ~loc:begin_loc cmd ~line:i + ~ctxt cmd params *) + ignore (cmd, tokens); + + Misc.add_dot ~with_dot b; + output lines statements + end else + output_statement lines begin_loc + stmt statements; + | PROCEDURE_DIVISION_DOT { end_loc } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + (* for now, just put it back *) + Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; + output lines statements + end else + output_statement lines begin_loc + stmt statements; + | IS_SQLVAR { end_loc } -> + if i = begin_loc.line then begin + let before_macro = String.sub line 0 begin_loc.char in + Printf.bprintf ctxt.b "%s%s" before_macro + "SOME STRING THAT REPLACE IS SQLVAR"; + if begin_loc.line <> end_loc.line then + Printf.bprintf ctxt.b "\n "; + end; + if i = end_loc.line then + let len = String.length line in + (* This code won't work with tabulations, because + the end_loc.char is wrong in such a case *) + let after_macro = + String.sub line (end_loc.char+1) (len-end_loc.char-1) in + Printf.bprintf ctxt.b "%s\n" after_macro ; + output lines statements + else + output_statement lines begin_loc stmt statements + | BEGIN_PROCEDURE_DIVISION { enabled } -> + if !enabled then + begin_procedure_division ~ctxt ~loc:begin_loc + else + Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; + output cur_lines statements + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:begin_loc; + output cur_lines statements + | COPY { end_loc ; filename ; contents } -> + Printf.bprintf ctxt.b " *> INLINED: %s\n" line; + if i = end_loc.line then begin + let copylines = EzString.split contents '\n' in + let copylines = List.mapi (fun i line -> + (filename, i+1, line)) copylines in + let lines = copylines @ lines in + output lines statements + end else + output_statement lines begin_loc + stmt statements; + in + output lines sql_statements; + Buffer.contents b diff --git a/src/lsp/sql_preproc/generate.mli b/src/lsp/sql_preproc/generate.mli new file mode 100644 index 000000000..da965beac --- /dev/null +++ b/src/lsp/sql_preproc/generate.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +val generate : + filename:string -> + contents:string -> (Types.loc option * Types.statements) list -> string diff --git a/src/lsp/sql_preproc/index.mld b/src/lsp/sql_preproc/index.mld new file mode 100644 index 000000000..0dd84b1cb --- /dev/null +++ b/src/lsp/sql_preproc/index.mld @@ -0,0 +1,7 @@ +{1 Library sql_preproc} + +SuperBOL Studio OSS is a new platform for COBOL + + +The entry point of this library is the module: {!Sql_preproc}. + diff --git a/src/lsp/sql_preproc/main.ml b/src/lsp/sql_preproc/main.ml new file mode 100644 index 000000000..daeb6c01a --- /dev/null +++ b/src/lsp/sql_preproc/main.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat +open Ez_file.V1 +open Cobol_indent.Types +open Types + +(* Known limitations: + + * We do not correctly handle continuation lines in the middle of + EXEC SQL commands ; + + * tabulations in margin in fixed format breaks the computation of + indentation ; + +*) + +let preproc ~filename + ?(sql_in_copybooks = false) + ?(copy_path = []) + ?(copy_exts = []) + ?(contents = EzFile.read_file filename) + ~source_format () = + let scanner_config = Cobol_indent.Config.load ~source_format ~filename in + + if scanner_config.verbosity > 0 then + Printf.eprintf "Parsing file %S...\n%!" filename; + + let scanner_config = { scanner_config with scan_for_indent = false } in + + let copy_exts = match copy_exts with + | [] -> [ ".cpy" ] + | _ -> copy_exts + in + let copy_path = Filename.dirname filename :: copy_path in + let copy_path = lazy ( List.map (fun dir -> + let files = match Sys.readdir dir with + | exception _ -> [||] + | files -> files + in + let map = ref StringMap.empty in + Array.iter (fun file -> + map := StringMap.add (String.lowercase_ascii file) file !map + ) files; + dir, !map + ) copy_path ) in + + let config = { scanner_config ; + sql_in_copybooks ; + copy_path ; + copy_exts ; + verbosity = scanner_config.verbosity } in + + let sql_statements = Parse.parse ~config ~filename ~contents in + + let contents = Generate.generate ~filename ~contents sql_statements in + + contents diff --git a/src/lsp/sql_preproc/main.mli b/src/lsp/sql_preproc/main.mli new file mode 100644 index 000000000..0dcf78f73 --- /dev/null +++ b/src/lsp/sql_preproc/main.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +val preproc : + filename:string -> + ?sql_in_copybooks:bool -> + ?copy_path:string list -> + ?copy_exts:string list -> + ?contents:string -> + source_format:Cobol_indent.Types.source_format -> + unit -> + string diff --git a/src/lsp/sql_preproc/misc.ml b/src/lsp/sql_preproc/misc.ml new file mode 100644 index 000000000..88fb580f6 --- /dev/null +++ b/src/lsp/sql_preproc/misc.ml @@ -0,0 +1,102 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat +open Cobol_indent.Types +open Types + +let loc_of_edit ~filename e = + { filename ; + line = e.tok_edit.edit.lnum ; + char = e.tok_indent + e.tok_edit.edit.offset_orig ; + } + +let error ?loc fmt = + Printf.kprintf (fun s -> + Printf.eprintf "Error"; + begin match loc with + | None -> () + | Some loc -> + Printf.eprintf " at %s:%d" loc.filename loc.line + end; + Printf.eprintf ": %s\n%!" s; + Printf.eprintf "Aborting.\n%!"; + exit 2 + ) fmt + +let warning ?loc fmt = + Printf.kprintf (fun s -> + Printf.eprintf "Warning"; + begin match loc with + | None -> () + | Some loc -> + Printf.eprintf " at %s:%d" loc.filename loc.line + end; + Printf.eprintf ": %s\n%!" s; + ) fmt + + +let string_of_token = function + | IDENT tok -> tok + | CHARS tok -> tok + | INTEGER tok -> tok + | NUMBER tok -> tok + + | DOT -> "." + | LPAREN -> "(" + | RPAREN -> ")" + | EQUALEQUAL -> "==" + | COMMA -> "," + | SEMI -> ";" + | COLON -> ":" + | EQUAL -> "=" + | MINUS -> "-" + | PLUS -> "+" + | GT -> ">" + | LT -> "<" + | GTE -> ">=" + | LTE -> "<=" + | DIV -> "/" + | MUL -> "*" + | DOLLAR -> "$" + | AMPER -> "&" + | SHARP -> "#" + + | tok -> + try + Hashtbl.find Cobol_indent.Lexer.keyword2string tok + with Not_found -> + failwith ( Cobol_indent.Misc.string_of_token tok ) + +let add_dot ~with_dot b = + if with_dot then + Printf.bprintf b " .\n" + +let resolve_copy ~config file = + + let rec iter_exts exts = + match exts with + | [] -> + raise Not_found + | ext :: exts -> + let file = String.lowercase_ascii (file ^ ext) in + match iter_paths file (Lazy.force config.copy_path) with + | exception Not_found -> iter_exts exts + | filename -> filename + + and iter_paths file path = + match path with + | [] -> raise Not_found + | (dir, map) :: path -> + match StringMap.find file map with + | exception Not_found -> iter_paths file path + | file -> Filename.concat dir file + in + iter_exts config.copy_exts diff --git a/src/lsp/sql_preproc/misc.mli b/src/lsp/sql_preproc/misc.mli new file mode 100644 index 000000000..ab171c649 --- /dev/null +++ b/src/lsp/sql_preproc/misc.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat + +val error : + ?loc:Types.loc -> ('a, unit, string, 'b) format4 -> 'a + +val warning : + ?loc:Types.loc -> + ('a, unit, string, unit) format4 -> 'a + +val loc_of_edit : filename:string -> Cobol_indent.Types.token_descr -> Types.loc + +val string_of_token : Cobol_indent.Types.token -> string + +val add_dot : with_dot:bool -> Buffer.t -> unit + +val resolve_copy : config:Types.config -> string -> string diff --git a/src/lsp/sql_preproc/package.toml b/src/lsp/sql_preproc/package.toml new file mode 100644 index 000000000..4c5dbff4a --- /dev/null +++ b/src/lsp/sql_preproc/package.toml @@ -0,0 +1,74 @@ + +# name of package +name = "sql_preproc" +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 = [] + +# package library dependencies +# [dependencies] +# ez_file = ">=0.1 <1.3" +# base-unix = { libname = "unix", version = ">=base" } +[dependencies] +ppx_deriving = ">=5.2.1" +ez_file = "0.3" +cobol_indent = "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] diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml new file mode 100644 index 000000000..954aeca55 --- /dev/null +++ b/src/lsp/sql_preproc/parse.ml @@ -0,0 +1,214 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open Ez_file.V1 + +open Cobol_indent.Types +open Types + +let rec find_dot tokens = + match tokens with + | [] -> Misc.error "Found end of file while looking for ending dot" + | (DOT, e) :: tokens -> (e, tokens) + | _ :: tokens -> find_dot tokens + +let parse ~config ~filename ~contents = + + let program_id = ref None in + let sql_statements = ref [] in + let procedure_division_found = ref None in + let working_storage_found = ref false in + let linkage_section_found = ref false in + + let sql_add_statement ?loc tokens = + sql_statements := (loc, tokens) :: + !sql_statements + in + + + let rec iter tokens = + match tokens with + | [] -> () + | (PROGRAM_ID, loc) :: (DOT, _) :: (IDENT name, _) :: tokens -> + begin match !program_id with + | None -> + program_id := Some name; + | Some _ -> + Misc.error ~loc + "multiple programs in the same file are not supported" + end; + iter tokens + + | (IDENT "IS", loc) :: (IDENT "SQLVAR", end_loc) :: tokens -> + sql_add_statement ~loc (IS_SQLVAR { end_loc }); + iter tokens + + | (PROCEDURE, loc) :: (DIVISION, _) :: tokens -> + let (end_loc, tokens) = find_dot tokens in + if not !working_storage_found then + sql_add_statement ~loc (WORKING_STORAGE { defined = false }); + if not !linkage_section_found then + sql_add_statement ~loc (LINKAGE_SECTION { defined = false }); + sql_add_statement ~loc (PROCEDURE_DIVISION_DOT + { end_loc }); + assert (!procedure_division_found = None ); + let ok = ref true in + sql_add_statement ~loc:{ loc with line = loc.line+1 } + (BEGIN_PROCEDURE_DIVISION { enabled = ok ; }); + + procedure_division_found := Some ok ; + linkage_section_found := false ; + working_storage_found := false ; + iter tokens + + | (IDENTIFICATION, loc) :: (DIVISION, _) :: tokens -> + begin + match !procedure_division_found with + | None -> () + | Some _ -> + sql_add_statement ~loc END_PROCEDURE_DIVISION; + procedure_division_found := None + end; + linkage_section_found := false ; + working_storage_found := false ; + iter tokens + + | (END, loc) :: (PROGRAM, _) :: tokens -> + begin + match !procedure_division_found with + | None -> () + | Some _ -> + sql_add_statement ~loc END_PROCEDURE_DIVISION; + procedure_division_found := None + end; + iter tokens + + | (END, loc) :: (DECLARATIVES, _) :: (DOT, _) :: tokens -> + begin + match !procedure_division_found with + | None -> () + | Some enabled -> + (* we disable the previous location where we found PROCEDURE + DIVISON, because we don't want to insert code before the + DECLARATIVES, but always after *) + enabled := false; + let enabled = ref true in + procedure_division_found := Some enabled; + sql_add_statement ~loc:{ loc with line = loc.line+1 } + (BEGIN_PROCEDURE_DIVISION { enabled }); + procedure_division_found := None + end; + iter tokens + + | (WORKING_STORAGE, _loc) :: (SECTION, _) :: (DOT, loc) :: tokens -> + working_storage_found := true ; + sql_add_statement ~loc (WORKING_STORAGE { defined = true }); + iter tokens + + | (LINKAGE, _loc) :: (SECTION, _) :: (DOT, loc) :: tokens -> + if not !working_storage_found then begin + sql_add_statement ~loc (WORKING_STORAGE { defined = false }); + working_storage_found := true ; + end; + linkage_section_found := true ; + if config.verbosity > 1 then + Printf.eprintf "LINKAGE SECTION found at %d\n%!" loc.line; + sql_add_statement ~loc (LINKAGE_SECTION { defined = true }); + iter tokens + + | (COPY, loc) :: (tok, _) :: (DOT, end_loc) :: tokens + when config.sql_in_copybooks -> + let file = Misc.string_of_token tok in + begin + match Misc.resolve_copy ~config file with + | exception Not_found -> + Misc.warning ~loc "Could not locate copybook %S" file; + iter tokens + | filename -> + let contents = EzFile.read_file filename in + sql_add_statement ~loc (COPY { end_loc ; filename ; contents }); + tokenize_file ~filename ~contents tokens + end + | (EXEC, loc) :: (IDENT "SQL", _) :: tokens -> + if config.verbosity > 1 then + Printf.eprintf "EXEC SQL found at line %d\n%!" loc.line; + begin match tokens with + | ( + (IDENT _ + | RETURN + | READ | FILE | WRITE | REWRITE | DELETE | SET + | RECEIVE | SEND | START ) + as tok + , _) :: tokens -> + let cmd = Misc.string_of_token tok in + iter_sql loc cmd [] tokens + | (tok, loc) :: _ -> + Misc.error ~loc "SQL syntax error on token %S for command" + (Misc.string_of_token tok) + | [] -> + Misc.error ~loc "SQL syntax error on end of file" + end + | _ :: tokens -> iter tokens + + and iter_sql loc cmd params tokens = + match tokens with + | (END_EXEC, end_loc) :: tokens -> + (* TODO: check if there is a ending DOT on the same line. If + yes, we need to output also a DOT at the end of the + translation. *) + + let end_loc, with_dot, tokens = match tokens with + | (DOT, end_loc) :: tokens -> end_loc, true, tokens + | tokens -> end_loc, false, tokens + in + if config.verbosity > 1 then + Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; + + let params = List.rev params in + sql_add_statement ~loc + (EXEC_SQL { end_loc ; with_dot ; cmd ; tokens = params }); + iter tokens + | [] -> failwith "missing END-EXEC." + | (tok, _) :: tokens -> + let tok = Misc.string_of_token tok in + iter_sql loc cmd ( tok :: params) tokens + + and tokenize_file ~filename ~contents tokens = + let { Cobol_indent.Scanner.toks = new_tokens ; _ } = + Cobol_indent.Scanner.tokenize ~filename + ~config:config.scanner_config ~contents in + + let tokens = List.rev_append + (List.rev_map + (fun (tok, e) -> + (tok, Misc.loc_of_edit ~filename e)) new_tokens) + tokens + in + + iter tokens + + in + + tokenize_file ~filename ~contents []; + + + (* Only fail if no PROCEDURE DIVISION was found for a main program, not for a copybook... + + if not !procedure_division_found then + error "PROCEDURE DIVISION. not found"; + *) + begin + match !procedure_division_found with + | None -> () + | Some _ -> + sql_add_statement END_PROCEDURE_DIVISION + end; + + List.rev !sql_statements diff --git a/src/lsp/sql_preproc/parse.mli b/src/lsp/sql_preproc/parse.mli new file mode 100644 index 000000000..a230e8a8b --- /dev/null +++ b/src/lsp/sql_preproc/parse.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +val parse : + config:Types.config -> + filename:string -> + contents:string -> + (Types.loc option * Types.statements) list diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml new file mode 100644 index 000000000..76a6266b3 --- /dev/null +++ b/src/lsp/sql_preproc/types.ml @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat + +type error = + | Failure of string + +exception Error of error + +type loc = { filename : string ; + line : int ; + char : int } + +(* These statements show how we could keep information and modify the + corresponding places in the code *) + +type statements = + | PROCEDURE_DIVISION_DOT of { end_loc : loc } + | WORKING_STORAGE of { defined: bool } + | LINKAGE_SECTION of { defined: bool } + | EXEC_SQL of { end_loc : loc ; + with_dot : bool ; + cmd : string ; + tokens : string list ; + } + | BEGIN_PROCEDURE_DIVISION of { enabled : bool ref } + | END_PROCEDURE_DIVISION + | COPY of { end_loc : loc ; filename : string ; contents : string } + | IS_SQLVAR of { end_loc : loc } + + +type handle = { + mutable handle_abend : string ; +} + +type gen_context = { + b : Buffer.t ; + main_filename : string ; +} + +type config = { + scanner_config: Cobol_indent.Types.config ; + sql_in_copybooks : bool; + copy_path : ( string * string StringMap.t) list Lazy.t ; + copy_exts : string list ; + verbosity : int ; +} diff --git a/src/lsp/sql_preproc/version.mlt b/src/lsp/sql_preproc/version.mlt new file mode 100644 index 000000000..c4b5410bf --- /dev/null +++ b/src/lsp/sql_preproc/version.mlt @@ -0,0 +1,35 @@ +#!/usr/bin/env ocaml +;; +#load "unix.cma" + +let query cmd = + let chan = Unix.open_process_in cmd in + try + let out = input_line chan in + if Unix.close_process_in chan = Unix.WEXITED 0 then + Some out + else None + with End_of_file -> None + +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") +let version = "0.1.3" + +let string_option = function + | None -> "None" + | Some s -> Printf.sprintf "Some %S" s + +let () = + Format.printf "@["; + Format.printf "let version = %S@," version; + Format.printf + "let commit_hash = %s@," (string_option commit_hash); + Format.printf + "let commit_date = %s@," (string_option commit_date); + Format.printf "@]@."; + () diff --git a/src/lsp/superbol_free_lib/command_sql.ml b/src/lsp/superbol_free_lib/command_sql.ml new file mode 100644 index 000000000..2055a829a --- /dev/null +++ b/src/lsp/superbol_free_lib/command_sql.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +(** `parse` jcl command *) + +open Ezcmd.V2 +open EZCMD.TYPES + +open Common_args + +let parse + ~sql_in_copybooks + ~copy_exts + common files = + let { preproc_options = { source_format; libpath = copy_path ; _ } ; _ } = common in + let source_format = Cobol_indent.Config.source_format source_format in + List.iter (fun filename -> + let contents = + Sql_preproc.Main.preproc + ~sql_in_copybooks + ~copy_path + ~copy_exts + ~filename + ~source_format () + in + Printf.printf "%s%!" contents) files + +let preproc_cmd = + let sql_in_copybooks = ref false in + let copy_exts = ref [] in + let files = ref [] in + let common, common_args = Common_args.get () in + EZCMD.sub + "sql preproc" + (fun () -> + let common = common () in + Printexc.record_backtrace true; + parse + ~sql_in_copybooks:!sql_in_copybooks + ~copy_exts:!copy_exts + common !files) + ~args: + ( common_args @ [ + + [], Arg.Anons (fun l -> files := l), + EZCMD.info ~docv:"FILE" "COBOL files to preproc" ; + + [ "copybooks" ], Arg.Set sql_in_copybooks, + EZCMD.info "Preprocess copybooks also (without REPLACING)"; + + [ "ext" ], Arg.String (fun s -> copy_exts := !copy_exts @ ["." ^ s]), + EZCMD.info ~docv:"EXT" + "Add .EXT as an extension to find copybooks (default is cpy)" ; + + ]) + ~doc:"Preprocess SQL EXECs" diff --git a/src/lsp/superbol_free_lib/dune b/src/lsp/superbol_free_lib/dune index c8c75727e..b1db1b636 100644 --- a/src/lsp/superbol_free_lib/dune +++ b/src/lsp/superbol_free_lib/dune @@ -5,7 +5,7 @@ (public_name superbol_free_lib) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries vscode-json superbol_preprocs lwt ez_toml ez_file ez_cmdliner ez_api.encoding cobol_typeck cobol_parser cobol_lsp cobol_indent cobol_common ) + (libraries vscode-json superbol_preprocs sql_preproc lwt ez_toml ez_file ez_cmdliner ez_api.encoding cobol_typeck cobol_parser cobol_lsp cobol_indent cobol_common ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/superbol_free_lib/main.ml b/src/lsp/superbol_free_lib/main.ml index f7609bf2f..b2974fb69 100644 --- a/src/lsp/superbol_free_lib/main.ml +++ b/src/lsp/superbol_free_lib/main.ml @@ -20,6 +20,7 @@ open Ez_file.V1 open EzFile.OP let public_subcommands = [ + Command_sql.preproc_cmd ; Command_pp.cmd ; Command_lsp.cmd; Command_texi2rst.cmd ; diff --git a/src/lsp/superbol_free_lib/package.toml b/src/lsp/superbol_free_lib/package.toml index 7dda81c01..ae1ab23c7 100644 --- a/src/lsp/superbol_free_lib/package.toml +++ b/src/lsp/superbol_free_lib/package.toml @@ -64,6 +64,7 @@ ez_cmdliner = "0.3.0" vscode-json = "version" ez_api = { version = "2.0", libname = "ez_api.encoding" } ez_toml = "version" +sql_preproc = "version" # We only depend on `lwt` via `ez_api` (and we don't even use any bit # of `lwt` at all). But we still need to add the following constraint diff --git a/src/lsp/superbol_free_lib/version.mlt b/src/lsp/superbol_free_lib/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/superbol_free_lib/version.mlt +++ b/src/lsp/superbol_free_lib/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/superbol_preprocs/version.mlt b/src/lsp/superbol_preprocs/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/superbol_preprocs/version.mlt +++ b/src/lsp/superbol_preprocs/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/superbol_project/version.mlt b/src/lsp/superbol_project/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/superbol_project/version.mlt +++ b/src/lsp/superbol_project/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/ez_toml/version.mlt b/src/vendor/ez_toml/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/ez_toml/version.mlt +++ b/src/vendor/ez_toml/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt b/src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt +++ b/src/vendor/vscode-ocaml-platform/src-bindings/interop/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt b/src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt +++ b/src/vendor/vscode-ocaml-platform/src-bindings/node/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt b/src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt +++ b/src/vendor/vscode-ocaml-platform/src-bindings/polka/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt b/src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode_languageclient/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vscode/superbol-vscode-platform/version.mlt b/src/vscode/superbol-vscode-platform/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vscode/superbol-vscode-platform/version.mlt +++ b/src/vscode/superbol-vscode-platform/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vscode/vscode-debugadapter/version.mlt b/src/vscode/vscode-debugadapter/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vscode/vscode-debugadapter/version.mlt +++ b/src/vscode/vscode-debugadapter/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vscode/vscode-debugprotocol/version.mlt b/src/vscode/vscode-debugprotocol/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vscode/vscode-debugprotocol/version.mlt +++ b/src/vscode/vscode-debugprotocol/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/vscode/vscode-json/version.mlt b/src/vscode/vscode-json/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/vscode/vscode-json/version.mlt +++ b/src/vscode/vscode-json/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function From 951de5501907a4b987f55e06f089f8d1495d2a58 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Wed, 26 Jun 2024 17:08:05 +0200 Subject: [PATCH 02/37] SQL is parsed --- .drom | 6 +++--- opam/sql_preproc.opam | 1 + src/lsp/sql_parser/lexer.mll | 4 ++++ src/lsp/sql_parser/sql_parser.ml | 2 ++ src/lsp/sql_preproc/dune | 2 +- src/lsp/sql_preproc/package.toml | 1 + src/lsp/sql_preproc/parse.ml | 18 +++++++++++++++--- src/lsp/sql_preproc/types.ml | 2 +- test/testsuite/sql/sql_preproc_test/test_1.cbl | 6 ++++++ test/testsuite/sql/sql_preproc_test/test_2.cbl | 6 ++++++ 10 files changed, 40 insertions(+), 8 deletions(-) create mode 100644 test/testsuite/sql/sql_preproc_test/test_1.cbl create mode 100644 test/testsuite/sql/sql_preproc_test/test_2.cbl diff --git a/.drom b/.drom index cc7b6c7de..d4fd82311 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -deca758843ebc9039cb64ad0a60504d3:. +257dce4e763b249fbb5f176ab7b3bc4b:. # end context for . # begin context for .github/workflows/workflow.yml @@ -181,7 +181,7 @@ b12cc17cc4ed0083355236058d5a523d:opam/pretty.opam # begin context for opam/sql_preproc.opam # file opam/sql_preproc.opam -c9c81bc1948a1ef51d4b4e93998dfeba:opam/sql_preproc.opam +28bc6879c35cc4c8a698da6732d0bde5:opam/sql_preproc.opam # end context for opam/sql_preproc.opam # begin context for opam/superbol-free.opam @@ -441,7 +441,7 @@ e0c73ea039315b0cfa5b4a7ac54a1484:src/lsp/sql_ast/dune # begin context for src/lsp/sql_preproc/dune # file src/lsp/sql_preproc/dune -bef6369614c527afeb0a16e1cee85f3e:src/lsp/sql_preproc/dune +bf6281d3f3bc094d4301dbec509a2918:src/lsp/sql_preproc/dune # end context for src/lsp/sql_preproc/dune # begin context for src/lsp/sql_preproc/index.mld diff --git a/opam/sql_preproc.opam b/opam/sql_preproc.opam index 4d51cc899..9ac49db89 100644 --- a/opam/sql_preproc.opam +++ b/opam/sql_preproc.opam @@ -47,6 +47,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "superbol_preprocs" {= version} "ppx_deriving" {>= "5.2.1"} "ez_file" {>= "0.3"} "cobol_indent" {= version} diff --git a/src/lsp/sql_parser/lexer.mll b/src/lsp/sql_parser/lexer.mll index 09728e7da..0aea19d09 100644 --- a/src/lsp/sql_parser/lexer.mll +++ b/src/lsp/sql_parser/lexer.mll @@ -162,6 +162,10 @@ rule token = parse { RPAR } | '*' { STAR } + | ' ' + { token lexbuf } + | _ as c + { failwith (Printf.sprintf "unexpected character: %C" c) } (* | _ as s { TOKEN s } *) | eof diff --git a/src/lsp/sql_parser/sql_parser.ml b/src/lsp/sql_parser/sql_parser.ml index 18955dee3..7c2103636 100644 --- a/src/lsp/sql_parser/sql_parser.ml +++ b/src/lsp/sql_parser/sql_parser.ml @@ -68,3 +68,5 @@ let parse text = let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) ast + + let parseString str = Grammar.main Lexer.token str \ No newline at end of file diff --git a/src/lsp/sql_preproc/dune b/src/lsp/sql_preproc/dune index 2ad4c1046..1d5646b50 100644 --- a/src/lsp/sql_preproc/dune +++ b/src/lsp/sql_preproc/dune @@ -5,7 +5,7 @@ (public_name sql_preproc) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries ppx_deriving ez_file cobol_indent ) + (libraries superbol_preprocs ppx_deriving ez_file cobol_indent ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/sql_preproc/package.toml b/src/lsp/sql_preproc/package.toml index 4c5dbff4a..d6ec98ee0 100644 --- a/src/lsp/sql_preproc/package.toml +++ b/src/lsp/sql_preproc/package.toml @@ -56,6 +56,7 @@ preprocess = "pps ppx_deriving.show" ppx_deriving = ">=5.2.1" ez_file = "0.3" cobol_indent = "version" +superbol_preprocs = "version" # package tools dependencies [tools] diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 954aeca55..ffbcf6ac8 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -140,7 +140,10 @@ let parse ~config ~filename ~contents = if config.verbosity > 1 then Printf.eprintf "EXEC SQL found at line %d\n%!" loc.line; begin match tokens with - | ( + | (tok, loc) :: _ -> + let cmd = Misc.string_of_token tok in + iter_sql loc cmd [] tokens +(* | ( (IDENT _ | RETURN | READ | FILE | WRITE | REWRITE | DELETE | SET @@ -151,7 +154,7 @@ let parse ~config ~filename ~contents = iter_sql loc cmd [] tokens | (tok, loc) :: _ -> Misc.error ~loc "SQL syntax error on token %S for command" - (Misc.string_of_token tok) + (Misc.string_of_token tok) *) | [] -> Misc.error ~loc "SQL syntax error on end of file" end @@ -172,8 +175,17 @@ let parse ~config ~filename ~contents = Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; let params = List.rev params in + let sqlStr = "EXEC SQL "^ (String.concat " " params) ^ " END-EXEC" in + Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; + + let sql = Sql_parser.parseString (Lexing.from_string sqlStr) + in + Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; + sql_add_statement ~loc - (EXEC_SQL { end_loc ; with_dot ; cmd ; tokens = params }); + (EXEC_SQL { end_loc ; with_dot ; cmd ; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." | (tok, _) :: tokens -> diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml index 76a6266b3..46f60a3d9 100644 --- a/src/lsp/sql_preproc/types.ml +++ b/src/lsp/sql_preproc/types.ml @@ -29,7 +29,7 @@ type statements = | EXEC_SQL of { end_loc : loc ; with_dot : bool ; cmd : string ; - tokens : string list ; + tokens : Sql_ast.esql_instuction ; } | BEGIN_PROCEDURE_DIVISION of { enabled : bool ref } | END_PROCEDURE_DIVISION diff --git a/test/testsuite/sql/sql_preproc_test/test_1.cbl b/test/testsuite/sql/sql_preproc_test/test_1.cbl new file mode 100644 index 000000000..d3ff757f3 --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/test_1.cbl @@ -0,0 +1,6 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. test_1. + PROCEDURE DIVISION. + + EXEC SQL INCLUDE SQLCA END-EXEC. + STOP RUN. \ No newline at end of file diff --git a/test/testsuite/sql/sql_preproc_test/test_2.cbl b/test/testsuite/sql/sql_preproc_test/test_2.cbl new file mode 100644 index 000000000..e68694040 --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/test_2.cbl @@ -0,0 +1,6 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. test_2. + PROCEDURE DIVISION. + + EXEC SQL AT CONN1 CREATE TABLE TAB1 (FLD1 INT) END-EXEC. + STOP RUN. \ No newline at end of file From f25b81b4951c9bc7ddb4aa8919d72bfe6652f1d3 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Thu, 27 Jun 2024 14:27:22 +0200 Subject: [PATCH 03/37] try to copy --- src/lsp/sql_preproc/generate.ml | 19 ++++++++++++++----- src/lsp/sql_preproc/parse.ml | 10 +++++----- src/lsp/sql_preproc/types.ml | 1 - 3 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 138eaf083..f1a23db4f 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -10,6 +10,7 @@ open EzCompat open Types +open Sql_ast let working_storage_section = {| *> SQL addition in working storage section: @@ -44,6 +45,16 @@ let generate ~filename ~contents sql_statements = } in let final_loc = { filename; line = -1; char = 0 } in + +let _generatesql ~loc ~line ~ctxt esql_instuction = + match esql_instuction with + | Include sqlvar -> + let before_macro = String.sub line 0 loc.char in + Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro + sqlvar.payload; + | _ -> ignore(loc, line, ctxt, esql_instuction) + in + let rec output lines statements = match statements with | [] -> @@ -97,13 +108,11 @@ let generate ~filename ~contents sql_statements = Buffer.add_string ctxt.b working_storage_section; output cur_lines statements end - | EXEC_SQL { end_loc ; with_dot ; cmd ; tokens } -> + | EXEC_SQL { end_loc ; with_dot ; tokens } -> Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; if i = end_loc.line then begin - (* TO BE DONE generate ~loc:begin_loc cmd ~line:i - ~ctxt cmd params *) - ignore (cmd, tokens); - + (* generatesql ~loc:begin_loc ~line:line ~ctxt tokens; *) + ignore (tokens); Misc.add_dot ~with_dot b; output lines statements end else diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index ffbcf6ac8..bd01b2a8a 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -176,16 +176,16 @@ let parse ~config ~filename ~contents = let params = List.rev params in let sqlStr = "EXEC SQL "^ (String.concat " " params) ^ " END-EXEC" in - Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; +(* Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in - Format.fprintf Format.std_formatter "\nAST\n"; +(* Format.fprintf Format.std_formatter "\nAST\n"; Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; - + *) sql_add_statement ~loc - (EXEC_SQL { end_loc ; with_dot ; cmd ; tokens = sql }); + (EXEC_SQL { end_loc ; with_dot ; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." | (tok, _) :: tokens -> diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml index 46f60a3d9..0d25078f8 100644 --- a/src/lsp/sql_preproc/types.ml +++ b/src/lsp/sql_preproc/types.ml @@ -28,7 +28,6 @@ type statements = | LINKAGE_SECTION of { defined: bool } | EXEC_SQL of { end_loc : loc ; with_dot : bool ; - cmd : string ; tokens : Sql_ast.esql_instuction ; } | BEGIN_PROCEDURE_DIVISION of { enabled : bool ref } From 7fc993314dca7fb0ddd78fd30301cdd5875e7dce Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Fri, 28 Jun 2024 13:53:03 +0200 Subject: [PATCH 04/37] Add CONNECT and CONNECT RESET --- sphinx/commands.rst | 41 +++ src/lsp/sql_parser/grammar.mly | 1 + src/lsp/sql_preproc/generate.ml | 307 +++++++++++------- src/lsp/sql_preproc/parse.ml | 21 +- .../sql/sql_preproc_test/connect1.cbl | 77 +++++ .../sql/sql_preproc_test/connect2.cbl | 194 +++++++++++ .../sql/sql_preproc_test/include_1.cbl | 13 + .../sql/sql_preproc_test/include_2.cbl | 15 + .../testsuite/sql/sql_preproc_test/test_1.cbl | 6 - 9 files changed, 541 insertions(+), 134 deletions(-) create mode 100644 test/testsuite/sql/sql_preproc_test/connect1.cbl create mode 100644 test/testsuite/sql/sql_preproc_test/connect2.cbl create mode 100644 test/testsuite/sql/sql_preproc_test/include_1.cbl create mode 100644 test/testsuite/sql/sql_preproc_test/include_2.cbl delete mode 100644 test/testsuite/sql/sql_preproc_test/test_1.cbl diff --git a/sphinx/commands.rst b/sphinx/commands.rst index 966966694..360a1bf8f 100644 --- a/sphinx/commands.rst +++ b/sphinx/commands.rst @@ -40,6 +40,9 @@ Overview of sub-commands:: snapshot Manage environment snapshots + sql preproc + Preprocess SQL EXECs + switch Print current switch @@ -526,6 +529,44 @@ Where options are: * :code:`--save ID` Create snapshot ID from state +main.exe sql preproc +~~~~~~~~~~~~~~~~~~~~~~ + +Preprocess SQL EXECs + + +**USAGE** +:: + + main.exe sql preproc FILE [OPTIONS] + +Where options are: + + +* :code:`FILE` COBOL files to preproc + +* :code:`-D VAR=VAL` Define a pre-processor variable VAR, with value VAL + +* :code:`-I DIRECTORY` Add DIRECTORY to library search path + +* :code:`--conf CONF_FILE` Set the configuration file to be used + +* :code:`--copybooks` Preprocess copybooks also (without REPLACING) + +* :code:`--dialect DIALECT` or :code:`--std DIALECT` Set the dialect to bu used (overriden by `--conf` if used) + +* :code:`--ext EXT` Add .EXT as an extension to find copybooks (default is cpy) + +* :code:`--free` Shorthand for `--source-format FREE` + +* :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. + + main.exe switch ~~~~~~~~~~~~~~~~~ diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 0277a346a..172626037 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -62,6 +62,7 @@ let main := | EXEC; SQL; stm = esql; END_EXEC; EOF; {stm} let cobol_var_id := +| COLON; c=loc(WORD); {c} | c = loc(COBOL_VAR); {c} let cobol_var := diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index f1a23db4f..441950ee3 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -30,141 +30,214 @@ let end_procedure_division ~ctxt:_ ~loc:_ = (* We might want to add something before the end of PROCEDURE DIVISION ? *) () -let generate ~filename ~contents sql_statements = +(*TODO*) +let getsize _lit = 64 + +let getssomeize = function + | Some lit -> Some (getsize lit) + | None -> None + +let strlit lit = Format.asprintf "%a" Printer.pp_lit lit +let strlitopt = function + | Some lit -> Some (strlit lit) + | None -> None + + +let generate ~filename ~contents sql_statements = (* split lines and numerotate them *) let lines = EzString.split contents '\n' in - let lines = List.mapi (fun i line -> (filename, i+1, line)) lines in + let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in (* The result will be stored in this buffer: *) - let b = Buffer.create 1000 in - let ctxt = { b ; - main_filename = filename ; - } in + let ctxt = { b; main_filename = filename } in let final_loc = { filename; line = -1; char = 0 } in - -let _generatesql ~loc ~line ~ctxt esql_instuction = + let generatesql_connect ?(data_source = "x\"00\"") ?(data_source_tl = 0) + ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) + ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) ?(d_username = "x\"00\"") + ?(username_tl = 0) ?(d_password = "x\"00\"") ?(password_tl = 0) () = + " CALL STATIC \"GIXSQLConnect\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE " ^ data_source + ^ "\n BY VALUE " + ^ string_of_int data_source_tl + ^ "\n BY REFERENCE " ^ d_connection_id + ^ "\n BY VALUE " + ^ string_of_int connection_id_tl + ^ "\n BY REFERENCE " ^ d_dbname + ^ "\n BY VALUE " ^ string_of_int dbname_tl + ^ "\n BY REFERENCE " ^ d_username + ^ "\n BY VALUE " ^ string_of_int username_tl + ^ "\n BY REFERENCE " ^ d_password + ^ "\n BY VALUE " ^ string_of_int password_tl + ^ "\n END-CALL" + in + + let generatesql_connect_reset ?(d_connection_id = "x\"00\"") + ?(connection_id_tl = 0) () = + " CALL STATIC \"GIXSQLConnectReset\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE " ^ d_connection_id + ^ "\n BY VALUE " + ^ string_of_int connection_id_tl + ^ "\n END-CALL" + in + + let generatesql ~loc ~line ~ctxt esql_instuction = match esql_instuction with - | Include sqlvar -> + | Include sqlvar -> let before_macro = String.sub line 0 loc.char in - Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro - sqlvar.payload; - | _ -> ignore(loc, line, ctxt, esql_instuction) - in + Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload + | Connect cs -> begin + match cs with + | Connect_reset lit -> begin + match lit with + | Some lit -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect_reset ~d_connection_id:(strlit lit) ()) + | None -> Printf.bprintf ctxt.b "%s" (generatesql_connect_reset ()) + end + | Connect_to_idby + { dbname; db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:(strlit db_data_source) + ~data_source_tl:(getsize db_data_source) + ?d_connection_id:(strlitopt db_conn_id) + ?connection_id_tl:(getssomeize db_conn_id) + ~d_dbname:(strlit dbname) ~dbname_tl:(getsize dbname) + ~d_username:(strlit username) ~username_tl:(getsize username) + ~d_password:(strlit password) ~password_tl:(getsize password) () ) + | Connect_to { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:(strlit db_data_source) + ~data_source_tl:(getsize db_data_source) + ?d_connection_id:(strlitopt db_conn_id) + ?connection_id_tl:(getssomeize db_conn_id) + ~d_username:(strlit username) ~username_tl:(getsize username) + ?d_password:(strlitopt password) + ?password_tl:(getssomeize password) () ) + | Connect_using { db_data_source } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:(strlit db_data_source) + ~data_source_tl:(getsize db_data_source) () ) + | Connect_user { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ?data_source:(strlitopt db_data_source) + ?data_source_tl:(getssomeize db_data_source) + ?d_connection_id:(strlitopt db_conn_id) + ?connection_id_tl:(getssomeize db_conn_id) + ~d_username:(strlit username) ~username_tl:(getsize username) + ~d_password:(strlit password) ~password_tl:(getsize password) () ) + end + | _ -> ignore (loc, line, ctxt, esql_instuction) + in let rec output lines statements = match statements with | [] -> - List.iter (fun (_,_,line) -> - Printf.bprintf ctxt.b "%s\n" line - ) lines - | (begin_loc, stmt) :: statements -> - match begin_loc with - | None -> - List.iter (fun (_,_,line) -> - Printf.bprintf ctxt.b "%s\n" line - ) lines ; - begin - match stmt with - | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:final_loc - | _ -> () - end - | Some begin_loc -> - output_statement lines begin_loc stmt statements - + List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines + | (begin_loc, stmt) :: statements -> ( + match begin_loc with + | None -> + List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines; + begin + match stmt with + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:final_loc + | _ -> () + end + | Some begin_loc -> output_statement lines begin_loc stmt statements ) and output_statement cur_lines begin_loc stmt statements = match cur_lines with | [] -> assert false - | (filename,i,line) :: lines -> - if filename <> begin_loc.filename || i < begin_loc.line then begin - Printf.bprintf ctxt.b "%s\n" line; - output_statement lines begin_loc stmt statements - end - else - match stmt with - | LINKAGE_SECTION { defined } -> - if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b linkage_section; - output lines statements - end else begin - Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; - Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; - Buffer.add_string ctxt.b linkage_section; - output cur_lines statements - end - | WORKING_STORAGE { defined } -> - if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b working_storage_section ; - output lines statements - end else begin - Printf.bprintf ctxt.b " *> Add missing WORKING-STORAGE SECTION\n"; - Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; - Buffer.add_string ctxt.b working_storage_section; - output cur_lines statements - end - | EXEC_SQL { end_loc ; with_dot ; tokens } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; - if i = end_loc.line then begin - (* generatesql ~loc:begin_loc ~line:line ~ctxt tokens; *) - ignore (tokens); - Misc.add_dot ~with_dot b; - output lines statements - end else - output_statement lines begin_loc - stmt statements; - | PROCEDURE_DIVISION_DOT { end_loc } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; - if i = end_loc.line then begin - (* for now, just put it back *) - Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; - output lines statements - end else - output_statement lines begin_loc - stmt statements; - | IS_SQLVAR { end_loc } -> - if i = begin_loc.line then begin - let before_macro = String.sub line 0 begin_loc.char in - Printf.bprintf ctxt.b "%s%s" before_macro - "SOME STRING THAT REPLACE IS SQLVAR"; - if begin_loc.line <> end_loc.line then - Printf.bprintf ctxt.b "\n "; - end; - if i = end_loc.line then - let len = String.length line in - (* This code won't work with tabulations, because - the end_loc.char is wrong in such a case *) - let after_macro = - String.sub line (end_loc.char+1) (len-end_loc.char-1) in - Printf.bprintf ctxt.b "%s\n" after_macro ; - output lines statements - else - output_statement lines begin_loc stmt statements - | BEGIN_PROCEDURE_DIVISION { enabled } -> - if !enabled then - begin_procedure_division ~ctxt ~loc:begin_loc - else - Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; - output cur_lines statements - | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:begin_loc; - output cur_lines statements - | COPY { end_loc ; filename ; contents } -> - Printf.bprintf ctxt.b " *> INLINED: %s\n" line; - if i = end_loc.line then begin - let copylines = EzString.split contents '\n' in - let copylines = List.mapi (fun i line -> - (filename, i+1, line)) copylines in - let lines = copylines @ lines in - output lines statements - end else - output_statement lines begin_loc - stmt statements; + | (filename, i, line) :: lines -> ( + if filename <> begin_loc.filename || i < begin_loc.line then begin + Printf.bprintf ctxt.b "%s\n" line; + output_statement lines begin_loc stmt statements + end else + match stmt with + | LINKAGE_SECTION { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b linkage_section; + output lines statements + end else begin + Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; + Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; + Buffer.add_string ctxt.b linkage_section; + output cur_lines statements + end + | WORKING_STORAGE { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b working_storage_section; + output lines statements + end else begin + Printf.bprintf ctxt.b + " *> Add missing WORKING-STORAGE SECTION\n"; + Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; + Buffer.add_string ctxt.b working_storage_section; + output cur_lines statements + end + | EXEC_SQL { end_loc; with_dot; tokens } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + generatesql ~loc:begin_loc ~line ~ctxt tokens; + (* ignore (tokens); *) + Misc.add_dot ~with_dot b; + output lines statements + end else + output_statement lines begin_loc stmt statements + | PROCEDURE_DIVISION_DOT { end_loc } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + (* for now, just put it back *) + Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; + output lines statements + end else + output_statement lines begin_loc stmt statements + | IS_SQLVAR { end_loc } -> + if i = begin_loc.line then begin + let before_macro = String.sub line 0 begin_loc.char in + Printf.bprintf ctxt.b "%s%s" before_macro + "SOME STRING THAT REPLACE IS SQLVAR"; + if begin_loc.line <> end_loc.line then + Printf.bprintf ctxt.b "\n " + end; + if i = end_loc.line then ( + let len = String.length line in + (* This code won't work with tabulations, because + the end_loc.char is wrong in such a case *) + let after_macro = + String.sub line (end_loc.char + 1) (len - end_loc.char - 1) + in + Printf.bprintf ctxt.b "%s\n" after_macro; + output lines statements + ) else + output_statement lines begin_loc stmt statements + | BEGIN_PROCEDURE_DIVISION { enabled } -> + if !enabled then + begin_procedure_division ~ctxt ~loc:begin_loc + else + Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; + output cur_lines statements + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:begin_loc; + output cur_lines statements + | COPY { end_loc; filename; contents } -> + Printf.bprintf ctxt.b " *> INLINED: %s\n" line; + if i = end_loc.line then begin + let copylines = EzString.split contents '\n' in + let copylines = + List.mapi (fun i line -> (filename, i + 1, line)) copylines + in + let lines = copylines @ lines in + output lines statements + end else + output_statement lines begin_loc stmt statements ) in output lines sql_statements; Buffer.contents b diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index bd01b2a8a..38a39e902 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -140,9 +140,8 @@ let parse ~config ~filename ~contents = if config.verbosity > 1 then Printf.eprintf "EXEC SQL found at line %d\n%!" loc.line; begin match tokens with - | (tok, loc) :: _ -> - let cmd = Misc.string_of_token tok in - iter_sql loc cmd [] tokens + | (_, _loc) :: _ -> + iter_sql loc [] tokens (* | ( (IDENT _ | RETURN @@ -160,7 +159,7 @@ let parse ~config ~filename ~contents = end | _ :: tokens -> iter tokens - and iter_sql loc cmd params tokens = + and iter_sql loc params tokens = match tokens with | (END_EXEC, end_loc) :: tokens -> (* TODO: check if there is a ending DOT on the same line. If @@ -175,22 +174,22 @@ let parse ~config ~filename ~contents = Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; let params = List.rev params in - let sqlStr = "EXEC SQL "^ (String.concat " " params) ^ " END-EXEC" in -(* Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) + let sqlStr = "EXEC SQL " ^ (String.concat " " params) ^ " END-EXEC" in + Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in -(* Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; - *) + Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; + sql_add_statement ~loc (EXEC_SQL { end_loc ; with_dot ; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." | (tok, _) :: tokens -> let tok = Misc.string_of_token tok in - iter_sql loc cmd ( tok :: params) tokens + iter_sql loc ( tok :: params) tokens and tokenize_file ~filename ~contents tokens = let { Cobol_indent.Scanner.toks = new_tokens ; _ } = diff --git a/test/testsuite/sql/sql_preproc_test/connect1.cbl b/test/testsuite/sql/sql_preproc_test/connect1.cbl new file mode 100644 index 000000000..250e72b55 --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/connect1.cbl @@ -0,0 +1,77 @@ + IDENTIFICATION DIVISION. + + PROGRAM-ID. connect1. + + + ENVIRONMENT DIVISION. + + CONFIGURATION SECTION. + SOURCE-COMPUTER. IBM-AT. + OBJECT-COMPUTER. IBM-AT. + + INPUT-OUTPUT SECTION. + FILE-CONTROL. + + DATA DIVISION. + + FILE SECTION. + + WORKING-STORAGE SECTION. + 01 DATASRC PIC X(64). + 01 DBUSR PIC X(64). + 01 DBPWD PIC X(64). + + 01 T1 PIC 9(3) VALUE 0. + + EXEC SQL + INCLUDE SQLCA + END-EXEC. + + PROCEDURE DIVISION. + + 000-CONNECT. + DISPLAY "DATASRC" UPON ENVIRONMENT-NAME. + ACCEPT DATASRC FROM ENVIRONMENT-VALUE. + DISPLAY "DATASRC_USR" UPON ENVIRONMENT-NAME. + ACCEPT DBUSR FROM ENVIRONMENT-VALUE. + DISPLAY "DATASRC_PWD" UPON ENVIRONMENT-NAME. + ACCEPT DBPWD FROM ENVIRONMENT-VALUE. + + DISPLAY '***************************************'. + DISPLAY " DATASRC : " DATASRC. + DISPLAY " DB : " DBUSR. + DISPLAY " USER : " DBPWD. + DISPLAY '***************************************'. + + EXEC SQL + CONNECT TO :DATASRC USER :DBUSR USING :DBPWD + END-EXEC. + + DISPLAY 'CONNECT SQLCODE: ' SQLCODE + + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + 100-MAIN. + + * EXEC SQL + * START TRANSACTION + * END-EXEC. + + * EXEC SQL + * SELECT COUNT(*) INTO :T1 FROM EMPTABLE + * END-EXEC. + + * DISPLAY 'SELECT SQLCODE : ' SQLCODE. + * + * IF SQLCODE <> 0 THEN + * GO TO 100-EXIT + * END-IF. + + * DISPLAY 'RES: ' T1. + + EXEC SQL CONNECT RESET END-EXEC. + + 100-EXIT. + * STOP RUN. \ No newline at end of file diff --git a/test/testsuite/sql/sql_preproc_test/connect2.cbl b/test/testsuite/sql/sql_preproc_test/connect2.cbl new file mode 100644 index 000000000..72c30b7ad --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/connect2.cbl @@ -0,0 +1,194 @@ + IDENTIFICATION DIVISION. + + PROGRAM-ID. connect2. + + + ENVIRONMENT DIVISION. + + CONFIGURATION SECTION. + SOURCE-COMPUTER. IBM-AT. + OBJECT-COMPUTER. IBM-AT. + + INPUT-OUTPUT SECTION. + FILE-CONTROL. + + DATA DIVISION. + + FILE SECTION. + + WORKING-STORAGE SECTION. + + 01 DATASRC PIC X(64). + 01 DATASRC-FULL PIC X(64). + 01 DBS PIC X(64). + 01 DBUSR PIC X(64). + 01 DBPWD PIC X(64). + 01 DBUSRPWD PIC X(128). + 01 DBNAME PIC X(64). + + 01 T1 PIC 9(4). + + EXEC SQL + INCLUDE SQLCA + END-EXEC. + + PROCEDURE DIVISION. + + 000-CONNECT. + DISPLAY "DATASRC_FULL" UPON ENVIRONMENT-NAME. + ACCEPT DATASRC-FULL FROM ENVIRONMENT-VALUE. + + DISPLAY "DATASRC" UPON ENVIRONMENT-NAME. + ACCEPT DATASRC FROM ENVIRONMENT-VALUE. + + DISPLAY "DBUSR" UPON ENVIRONMENT-NAME. + ACCEPT DBUSR FROM ENVIRONMENT-VALUE. + + DISPLAY "DBPWD" UPON ENVIRONMENT-NAME. + ACCEPT DBPWD FROM ENVIRONMENT-VALUE. + + DISPLAY "DBNAME" UPON ENVIRONMENT-NAME. + ACCEPT DBNAME FROM ENVIRONMENT-VALUE. + + DISPLAY "DBUSRPWD" UPON ENVIRONMENT-NAME. + ACCEPT DBUSRPWD FROM ENVIRONMENT-VALUE. + + 100-MAIN. + + MOVE 'CONN1' TO DBS + + * mode 1 (anonymous) + + EXEC SQL + CONNECT TO :DATASRC USER :DBUSR USING :DBPWD + END-EXEC. + DISPLAY 'CONNECT 1A SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET END-EXEC. + + * mode 2 (anonymous) + + EXEC SQL + CONNECT TO :DATASRC USER :DBUSRPWD + END-EXEC. + DISPLAY 'CONNECT 2A SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET END-EXEC. + + * mode 3 (anonymous) + + EXEC SQL + CONNECT :DBUSR + IDENTIFIED BY :DBPWD + USING :DATASRC + END-EXEC. + DISPLAY 'CONNECT 3A SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET END-EXEC. + + * mode 4 (anonymous) - Unsupported - emit a preproc warning + + EXEC SQL + CONNECT :DBUSR IDENTIFIED BY :DBPWD + END-EXEC. + DISPLAY 'CONNECT 4A SQLCODE: ' SQLCODE. + + * we ignore the error for mode 4 + * IF SQLCODE <> 0 THEN + * GO TO 100-EXIT + * END-IF. + + * mode 5 (anonymous) + + EXEC SQL + CONNECT USING :DATASRC-FULL + END-EXEC. + DISPLAY 'CONNECT 5A SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + * mode 6 (anonymous) + + EXEC SQL + CONNECT TO :DBNAME + USER :DBUSR + USING :DATASRC + IDENTIFIED BY :DBPWD + END-EXEC. + DISPLAY 'CONNECT 6A SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + * mode 1 (named) + + EXEC SQL + CONNECT TO :DATASRC AS :DBS USER :DBUSR USING :DBPWD + END-EXEC. + DISPLAY 'CONNECT 1N SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET :DBS END-EXEC. + + * mode 2 (named) + + EXEC SQL + CONNECT TO :DATASRC AS :DBS USER :DBUSRPWD + END-EXEC. + DISPLAY 'CONNECT 2N SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET :DBS END-EXEC. + + * mode 3 (named) + + EXEC SQL + CONNECT :DBUSR + IDENTIFIED BY :DBPWD + AT :DBS + USING :DATASRC + END-EXEC. + DISPLAY 'CONNECT 3N SQLCODE: ' SQLCODE. + IF SQLCODE <> 0 THEN + GO TO 100-EXIT + END-IF. + + EXEC SQL CONNECT RESET :DBS END-EXEC. + + * mode 4 (named) - Unsupported - emit a preproc warning + + EXEC SQL + CONNECT :DBUSR IDENTIFIED BY :DBPWD + AT :DBS + END-EXEC. + DISPLAY 'CONNECT 4N SQLCODE: ' SQLCODE. + + * we ignore the error for mode 4 + * IF SQLCODE <> 0 THEN + * GO TO 100-EXIT + * END-IF. + + * last step, we need to "force" the error code, otherwise the test will fail + + MOVE 0 TO RETURN-CODE. + + * mode 5 and 6 do not support named connections + + 100-EXIT. + * STOP RUN. + + 200-END. diff --git a/test/testsuite/sql/sql_preproc_test/include_1.cbl b/test/testsuite/sql/sql_preproc_test/include_1.cbl new file mode 100644 index 000000000..379cee201 --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/include_1.cbl @@ -0,0 +1,13 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. test_1. + DATA DIVISION. + + FILE SECTION. + + WORKING-STORAGE SECTION. + + EXEC SQL INCLUDE SQLCA END-EXEC. + + PROCEDURE DIVISION. + + STOP RUN. \ No newline at end of file diff --git a/test/testsuite/sql/sql_preproc_test/include_2.cbl b/test/testsuite/sql/sql_preproc_test/include_2.cbl new file mode 100644 index 000000000..3c846e4e2 --- /dev/null +++ b/test/testsuite/sql/sql_preproc_test/include_2.cbl @@ -0,0 +1,15 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. test_1. + DATA DIVISION. + + FILE SECTION. + + WORKING-STORAGE SECTION. + + EXEC SQL + INCLUDE SQLCA + END-EXEC. + + PROCEDURE DIVISION. + + STOP RUN. \ No newline at end of file diff --git a/test/testsuite/sql/sql_preproc_test/test_1.cbl b/test/testsuite/sql/sql_preproc_test/test_1.cbl deleted file mode 100644 index d3ff757f3..000000000 --- a/test/testsuite/sql/sql_preproc_test/test_1.cbl +++ /dev/null @@ -1,6 +0,0 @@ - IDENTIFICATION DIVISION. - PROGRAM-ID. test_1. - PROCEDURE DIVISION. - - EXEC SQL INCLUDE SQLCA END-EXEC. - STOP RUN. \ No newline at end of file From e46a5b6907928f084da6e3e985ac146bdb8794f1 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Wed, 10 Jul 2024 17:23:04 +0200 Subject: [PATCH 05/37] light integration of typeck, size seems correctly calculated --- .drom | 32 ++- .github/workflows/workflow.yml | 2 +- Makefile | 2 +- dune-project | 5 +- opam/sql_parser.opam | 2 +- opam/sql_preproc.opam | 2 + src/lsp/sql_ast/sql_ast.ml | 66 +++---- src/lsp/sql_ast/version.mlt | 9 +- src/lsp/sql_parser/dune | 2 +- src/lsp/sql_parser/grammar.mly | 26 +-- src/lsp/sql_parser/version.mlt | 9 +- src/lsp/sql_preproc/dune | 2 +- src/lsp/sql_preproc/generate.ml | 239 +++++++++++++++++------ src/lsp/sql_preproc/generate.mli | 5 +- src/lsp/sql_preproc/main.ml | 58 +++--- src/lsp/sql_preproc/main.mli | 1 + src/lsp/sql_preproc/package.toml | 2 + src/lsp/sql_preproc/parse.ml | 135 ++++++------- src/lsp/sql_preproc/sql_typeck.ml | 55 ++++++ src/lsp/sql_preproc/transform.ml | 35 ++++ src/lsp/sql_preproc/transform.mli | 14 ++ src/lsp/superbol_free_lib/command_sql.ml | 105 ++++++---- 22 files changed, 548 insertions(+), 260 deletions(-) create mode 100644 src/lsp/sql_preproc/sql_typeck.ml create mode 100644 src/lsp/sql_preproc/transform.ml create mode 100644 src/lsp/sql_preproc/transform.mli diff --git a/.drom b/.drom index d4fd82311..5a2bd4038 100644 --- a/.drom +++ b/.drom @@ -5,12 +5,12 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -257dce4e763b249fbb5f176ab7b3bc4b:. +82cc9b1697cebf84b1a3ace5a773a880:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -be866787b33695ca0fbe400819670f9b:.github/workflows/workflow.yml +73b824a03b4a4f5c15db8791f70c6bc6:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore @@ -25,7 +25,7 @@ be866787b33695ca0fbe400819670f9b:.github/workflows/workflow.yml # begin context for Makefile # file Makefile -7e856d11a4bdf169eea5c0fbb9f1d940:Makefile +733eba914659eea2902e186f7980b526:Makefile # end context for Makefile # begin context for README.md @@ -75,7 +75,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project -f7cff5bb555d519a20fc74a74fa9f63d:dune-project +88791e8b7737ee4fe8117869ed1f141f:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -179,9 +179,14 @@ b12cc17cc4ed0083355236058d5a523d:opam/pretty.opam 46a86088dd35038c08807fbc8617a944:opam/sql_ast.opam # end context for opam/sql_ast.opam +# begin context for opam/sql_parser.opam +# file opam/sql_parser.opam +86d31f6fcc96cc7cdf635491d2586ea9:opam/sql_parser.opam +# end context for opam/sql_parser.opam + # begin context for opam/sql_preproc.opam # file opam/sql_preproc.opam -28bc6879c35cc4c8a698da6732d0bde5:opam/sql_preproc.opam +71904574a5ea8c45065594c6f5f0f92f:opam/sql_preproc.opam # end context for opam/sql_preproc.opam # begin context for opam/superbol-free.opam @@ -439,9 +444,24 @@ eab335ce600887c59f1baf9b0983d0ac:src/lsp/ezr_toml/dune e0c73ea039315b0cfa5b4a7ac54a1484:src/lsp/sql_ast/dune # end context for src/lsp/sql_ast/dune +# begin context for src/lsp/sql_ast/version.mlt +# file src/lsp/sql_ast/version.mlt +32d077864212af27904137e71df668a7:src/lsp/sql_ast/version.mlt +# end context for src/lsp/sql_ast/version.mlt + +# begin context for src/lsp/sql_parser/dune +# file src/lsp/sql_parser/dune +db6a28cb47529fc304fd32289b947207:src/lsp/sql_parser/dune +# end context for src/lsp/sql_parser/dune + +# begin context for src/lsp/sql_parser/version.mlt +# file src/lsp/sql_parser/version.mlt +32d077864212af27904137e71df668a7:src/lsp/sql_parser/version.mlt +# end context for src/lsp/sql_parser/version.mlt + # begin context for src/lsp/sql_preproc/dune # file src/lsp/sql_preproc/dune -bf6281d3f3bc094d4301dbec509a2918:src/lsp/sql_preproc/dune +0ba9e49a0d53de4b8076614f39543fd4:src/lsp/sql_preproc/dune # end context for src/lsp/sql_preproc/dune # begin context for src/lsp/sql_preproc/index.mld diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 650e9e0a6..91e705cf2 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -61,7 +61,7 @@ jobs: - run: opam pin add . -y --no-action - - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser sql_preproc + - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_preproc sql_ast sql_parser # if: steps.cache-opam.outputs.cache-hit != 'true' - run: opam install -y opam/*.opam --deps-only --with-test diff --git a/Makefile b/Makefile index 1d7a981a4..b01a6c378 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,7 @@ ifeq ($(TARGET_PLAT)_$(BUILD_STATIC_EXECS),linux_true) ./scripts/static-build.sh else ${DUNE} build ${DUNE_ARGS} ${DUNE_CROSS_ARGS} @install - ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser sql_preproc + ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_preproc sql_ast sql_parser endif ./scripts/after.sh build diff --git a/dune-project b/dune-project index f4a53e317..aa6bf6c7c 100644 --- a/dune-project +++ b/dune-project @@ -465,8 +465,11 @@ (description "SuperBOL Studio OSS is a new platform for COBOL") (depends (ocaml (>= 4.14.0)) + (superbol_preprocs (= version)) (ppx_deriving ( >= 5.2.1 )) (ez_file ( >= 0.3 )) + (cobol_unit (= version)) + (cobol_typeck (= version)) (cobol_indent (= version)) odoc ) @@ -500,7 +503,7 @@ (cobol_parser (= version)) (cobol_common (= version)) (ppx_deriving ( >= 5.2.1 )) - (menhir ( = 20230415 )) + (menhir ( >= 20230415 )) odoc ) ) diff --git a/opam/sql_parser.opam b/opam/sql_parser.opam index 366ec56be..6acb1f3bb 100644 --- a/opam/sql_parser.opam +++ b/opam/sql_parser.opam @@ -55,7 +55,7 @@ depends: [ "cobol_parser" {= version} "cobol_common" {= version} "ppx_deriving" {>= "5.2.1"} - "menhir" {= "20230415"} + "menhir" {>= "20230415"} "odoc" {with-doc} ] # Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/sql_preproc.opam b/opam/sql_preproc.opam index 9ac49db89..aac275da4 100644 --- a/opam/sql_preproc.opam +++ b/opam/sql_preproc.opam @@ -50,6 +50,8 @@ depends: [ "superbol_preprocs" {= version} "ppx_deriving" {>= "5.2.1"} "ez_file" {>= "0.3"} + "cobol_unit" {= version} + "cobol_typeck" {= version} "cobol_indent" {= version} "odoc" {with-doc} ] diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index 5fbde687f..f2d61a980 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -20,8 +20,8 @@ type sqlVarToken = string with_loc [@@deriving ord] type cobolVarId = string with_loc [@@deriving ord] type cobol_var = - | NotNull of cobolVarId - | NullIndicator of cobolVarId * cobolVarId + | CobVarNotNull of cobolVarId + | CobVarNullIndicator of cobolVarId * cobolVarId [@@deriving ord] type variable = @@ -125,28 +125,28 @@ and rb_args = and connect_syntax = | Connect_to_idby of { - dbname : literal; - db_conn_id : literal option; - username : literal; - db_data_source : literal; - password : literal + dbname : cobolVarId; + db_conn_id : variable option; + username : cobolVarId; + db_data_source : cobolVarId; + password : cobolVarId } | Connect_to of { - db_data_source : literal; - db_conn_id : literal option; - username : literal; - password : literal option + db_data_source : cobolVarId; + db_conn_id : variable option; + username : cobolVarId; + password : cobolVarId option } - | Connect_using of { db_data_source : literal } + | Connect_using of { db_data_source : cobolVarId } | Connect_user of { - username : literal; - password : literal; - db_conn_id : literal option; - db_data_source : literal option + username : cobolVarId; + password : cobolVarId; + db_conn_id : variable option; + db_data_source : cobolVarId option } - | Connect_reset of literal option + | Connect_reset of cobolVarId option (*WHENEVER*) and sql_type = @@ -460,8 +460,8 @@ module Printer = struct and pp_cob_lst fmt x = list_comma fmt (x, pp_cob_var) and pp_cob_var fmt = function - | NotNull c -> Format.fprintf fmt ":%s" c.payload - | NullIndicator (c, ni) -> Format.fprintf fmt ":%s:%s" c.payload ni.payload + | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload + | CobVarNullIndicator (c, ni) -> Format.fprintf fmt ":%s:%s" c.payload ni.payload and pp_some_rb_work_or_tran fmt = function | Some p -> pp_rb_work_or_tran fmt p @@ -477,23 +477,28 @@ module Printer = struct Format.fprintf fmt "TO SAVEPOINT %s" variable.payload | None -> Format.fprintf fmt "" + and pp_some_cob_var fmt (x, s) = + match x with + | Some v -> Format.fprintf fmt "%s %s" s v.payload + | None -> Format.fprintf fmt "" + and pp_connect fmt c = match c with | Connect_to_idby { dbname; db_conn_id; username; db_data_source; password } -> - Format.fprintf fmt "TO %a %a USER %a USING %a IDENTIFIED BY %a" pp_lit - dbname pp_some_lit (db_conn_id, "AS") pp_lit username pp_lit - db_data_source pp_lit password + Format.fprintf fmt "TO %s %a USER %s USING %s IDENTIFIED BY %s" + dbname.payload pp_some_var (db_conn_id, "AS") username.payload + db_data_source.payload password.payload | Connect_to { db_data_source; db_conn_id; username; password } -> - Format.fprintf fmt "TO %a %a USER %a %a" pp_lit db_data_source pp_some_lit - (db_conn_id, "AS") pp_lit username pp_some_lit (password, "USING") + Format.fprintf fmt "TO %s %a USER %s %a" db_data_source.payload pp_some_var + (db_conn_id, "AS") username.payload pp_some_cob_var (password, "USING") | Connect_using { db_data_source } -> - Format.fprintf fmt "USING %a" pp_lit db_data_source + Format.fprintf fmt "USING %s" db_data_source.payload | Connect_user { username; password; db_conn_id; db_data_source } -> - Format.fprintf fmt "%a IDENTIFIED BY %a %a %a" pp_lit username pp_lit - password pp_some_lit (db_conn_id, "AT") pp_some_lit + Format.fprintf fmt "%s IDENTIFIED BY %s %a %a" username.payload + password.payload pp_some_var (db_conn_id, "AT") pp_some_cob_var (db_data_source, "USING") - | Connect_reset name -> Format.fprintf fmt "RESET %a" pp_some_lit (name, "") + | Connect_reset name -> Format.fprintf fmt "RESET%a" pp_some_cob_var (name, "") and pp_whenever_condtion fmt = function | Not_found_whenever -> Format.fprintf fmt "NOT FOUND" @@ -588,11 +593,6 @@ module Printer = struct | SqlVar v -> Format.fprintf fmt "%s" v.payload | CobolVar c -> pp_cob_var fmt c - and pp_some_lit fmt (x, s) = - match x with - | Some v -> Format.fprintf fmt "%s %a" s pp_lit v - | None -> Format.fprintf fmt "" - and pp_list_lit fmt x = list_comma fmt (x, pp_lit) and pp_lit fmt = function diff --git a/src/lsp/sql_ast/version.mlt b/src/lsp/sql_ast/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/sql_ast/version.mlt +++ b/src/lsp/sql_ast/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/sql_parser/dune b/src/lsp/sql_parser/dune index 5538d58a6..0cf23d02a 100644 --- a/src/lsp/sql_parser/dune +++ b/src/lsp/sql_parser/dune @@ -25,7 +25,7 @@ ; use field 'dune-trailer' to add more stuff here (menhir (modules grammar) - (flags --explain + (flags --inspection --cmly --table --strict --unused-tokens)) diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 172626037..77e81ef16 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -66,8 +66,8 @@ let cobol_var_id := | c = loc(COBOL_VAR); {c} let cobol_var := -| c = cobol_var_id; {NotNull c} -| c = loc(COBOL_VAR); ni=loc(COBOL_VAR); {NullIndicator(c, ni)} +| c = cobol_var_id; {CobVarNotNull c} +| c = loc(COBOL_VAR); ni=loc(COBOL_VAR); {CobVarNullIndicator(c, ni)} let sql_var_name := | s = loc(WORD); {s} @@ -75,7 +75,7 @@ let sql_var_name := let simpl_var := | s = sql_var_name; {SqlVar s} -| s = cobol_var_id; {CobolVar(NotNull s)} +| s = cobol_var_id; {CobolVar(CobVarNotNull s)} let variable := | s = sql_var_name; {SqlVar s} @@ -224,8 +224,8 @@ EXEC SQL CONNECT TO :dbname [ AS :db_conn_id ] USER :username USING :db_data_source IDENTIFIED BY :password *) -| TO; dbname= literalVar; db_conn_id=option(as_var); USER; username= literalVar; - USING; db_data_source= literalVar; IDENTIFIED; BY; password= literalVar; +| TO; dbname= cobol_var_id; db_conn_id=option(as_var); USER; username= cobol_var_id; + USING; db_data_source= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; { Connect_to_idby {dbname; db_conn_id; username; db_data_source; password} } (* @@ -233,29 +233,29 @@ EXEC SQL CONNECT TO :db_data_source [ AS :db_conn_id ] USER :username.:opt_password [ USING password ]; -> Supporté si il n'y as pas de opt_passwod *) -| TO; db_data_source= literalVar; db_conn_id=option(as_var); USER; username= literalVar; +| TO; db_data_source= cobol_var_id; db_conn_id=option(as_var); USER; username= cobol_var_id; password = option(using_var); { Connect_to {db_data_source; db_conn_id; username; password} } (* EXEC SQL CONNECT USING :db_data_source (credentials must be embedded to be able to connect) *) -| USING; db_data_source= literalVar; {Connect_using{db_data_source}} +| USING; db_data_source= cobol_var_id; {Connect_using{db_data_source}} (* EXEC SQL CONNECT :username IDENTIFIED BY :password [ AT :db_conn_id ] [ USING :db_data_source] (mode 4 is unsupported) *) -| username= literalVar; IDENTIFIED; BY; password= literalVar; +| username= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; db_conn_id = option(at_var); db_data_source= option(using_var); {Connect_user{username; password; db_conn_id; db_data_source}} -| RESET; name=option( literalVar); +| RESET; name=option( cobol_var_id); {Connect_reset name } -let at_var:= AT; p= literalVar; {p} +let at_var:= AT; p= simpl_var; {p} -let using_var:= USING; p= literalVar; {p} +let using_var:= USING; p= cobol_var_id; {p} -let as_var:= AS; v= literalVar; {v} +let as_var:= AS; v= simpl_var; {v} let whenever_condition := | NOT; FOUND; {Not_found_whenever} @@ -438,7 +438,7 @@ let sql_token_not_first := | EQUAL; {SqlInstr "=" } | COMMA; {SqlInstr "," } | DOT ; {SqlInstr "." } -| t = cobol_var_id; {SqlVarToken( CobolVar(NotNull t)) } +| t = cobol_var_id; {SqlVarToken( CobolVar(CobVarNotNull t)) } let sql_token := diff --git a/src/lsp/sql_parser/version.mlt b/src/lsp/sql_parser/version.mlt index 3380b87d3..c4b5410bf 100644 --- a/src/lsp/sql_parser/version.mlt +++ b/src/lsp/sql_parser/version.mlt @@ -11,8 +11,13 @@ let query cmd = else None with End_of_file -> None -let commit_hash = query "git show -s --pretty=format:%H" -let commit_date = query "git show -s --pretty=format:%ci" +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") let version = "0.1.3" let string_option = function diff --git a/src/lsp/sql_preproc/dune b/src/lsp/sql_preproc/dune index 1d5646b50..abe124279 100644 --- a/src/lsp/sql_preproc/dune +++ b/src/lsp/sql_preproc/dune @@ -5,7 +5,7 @@ (public_name sql_preproc) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries superbol_preprocs ppx_deriving ez_file cobol_indent ) + (libraries superbol_preprocs ppx_deriving ez_file cobol_unit cobol_typeck cobol_indent ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 441950ee3..9e0881d81 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -12,11 +12,6 @@ open EzCompat open Types open Sql_ast -let working_storage_section = - {| *> SQL addition in working storage section: - 01 MY-SQL-STUFF PIC X(9). -|} - let linkage_section = {| *> SQL addition in linkage section: 01 SOME-ARG PIC X(9). @@ -30,24 +25,70 @@ let end_procedure_division ~ctxt:_ ~loc:_ = (* We might want to add something before the end of PROCEDURE DIVISION ? *) () -(*TODO*) -let getsize _lit = 64 +(* let strlit lit = Format.asprintf "%a" Printer.pp_lit lit *) -let getssomeize = function - | Some lit -> Some (getsize lit) - | None -> None +(* let strlitopt = function + | Some lit -> Some (strlit lit) + | None -> None *) -let strlit lit = Format.asprintf "%a" Printer.pp_lit lit +let cob_var_id_opt (cob_var:cobolVarId option) = + match cob_var with +| Some cob -> Some (cob.payload) +| None -> None -let strlitopt = function - | Some lit -> Some (strlit lit) + +let cob_var_opt = function + | Some var -> ( + match var with + | CobVarNotNull cobolVarId -> Some cobolVarId.payload + | CobVarNullIndicator (var, _) -> Some var.payload ) + | None -> None + +let var_opt = function + | Some var -> ( + match var with + | SqlVar sqlVarToken -> Some sqlVarToken.payload + | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) | None -> None - -let generate ~filename ~contents sql_statements = +let generate ~filename ~contents ~cobol_unit sql_statements = + (*TODO get function*) + let get_length str = Sql_typeck.get_size cobol_unit str in + + let get_some_length var = + match var_opt var with + | Some x -> Some (get_length x) + | None -> None + in + + let get_some_cob_var_length (cob_var:cobolVarId option) = + match cob_var with + | Some x -> Some (get_length x.payload) + | None -> None + in + + + let get_type _str = 16 in + let get_scale _str = 0 in + let get_flags _str = 0 in + let get_ind_addr _str = 0 in + + let working_storage_section, _cobol_unit = + Transform.transform cobol_unit sql_statements + in + (* split lines and numerotate them *) let lines = EzString.split contents '\n' in let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in + (*string to add at the end of every sql processed*) + let error_treatment = ref "" in + let print_error_treatement ctxt = + if !error_treatment <> "" then ( + Printf.bprintf ctxt.b " EVALUATE TRUE\n"; + Printf.bprintf ctxt.b "%s\n" !error_treatment; + Printf.bprintf ctxt.b " END-EVALUATE\n" + ) + in (* The result will be stored in this buffer: *) let b = Buffer.create 1000 in @@ -86,52 +127,133 @@ let generate ~filename ~contents sql_statements = ^ "\n END-CALL" in + let generate_whenever_continuation = function + | Continue -> "CONTINUE" + | Perform sqlVarToken -> "PERFORM " ^ sqlVarToken.payload + | Goto sqlVarToken -> "GOTO " ^ sqlVarToken.payload + in + + let generate_whenever c k = + match c with + | Not_found_whenever -> + " WHEN SQLCODE = 100\n " + ^ generate_whenever_continuation k + ^ "\n" + | SqlError_whenever -> + " WHEN SQLCODE < 0\n " + ^ generate_whenever_continuation k + ^ "\n" + | SqlWarning_whenever -> + " WHEN SQLCODE < 0\n " + ^ generate_whenever_continuation k + ^ "\n" + in + + let get_name_cobol_var (cobol_var : cobol_var) = + match cobol_var with + | CobVarNotNull c -> c.payload + | CobVarNullIndicator (c, n) -> c.payload ^ n.payload + in + + let rec generate_select_into_rec vars = + match vars with + | h :: t -> + let h = get_name_cobol_var h in + " CALL STATIC \"GIXSQLSetResultParams\" USING\n\ + \ BY VALUE " + ^ string_of_int (get_type h) + ^ "\n BY VALUE " + ^ string_of_int (get_length h) + ^ "\n BY VALUE " + ^ string_of_int (get_scale h) + ^ "\n BY VALUE " + ^ string_of_int (get_flags h) + ^ "\n BY REFERENCE " ^ h ^ "\n BY REFERENCE " + ^ string_of_int (get_ind_addr h) + ^ "\n END-CALL\n" ^ generate_select_into_rec t + | [] -> "" + in + let generate_select_into_one vars = + " CALL STATIC \"GIXSQLExecSelectIntoOne\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE x\"00\"\n\ + \ BY VALUE 0\n\ + \ BY REFERENCE SQ0001\n\ + \ BY VALUE 0\n\ + \ BY VALUE 5\n" + ^ string_of_int (List.length vars) + ^ "\n END-CALL\n" + in + + let generate_select_into vars = + " CALL STATIC \"GIXSQLStartSQL\"\n END-CALL" + ^ generate_select_into_rec vars + ^ generate_select_into_one vars + ^ " CALL STATIC \"GIXSQLEndSQL\"\n END-CALL\n" + in + let generatesql ~loc ~line ~ctxt esql_instuction = match esql_instuction with | Include sqlvar -> let before_macro = String.sub line 0 loc.char in - Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload - | Connect cs -> begin - match cs with - | Connect_reset lit -> begin - match lit with - | Some lit -> + Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload; + print_error_treatement ctxt + | Connect cs -> + begin + match cs with + | Connect_reset lit -> begin + match lit with + | Some lit -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect_reset ~d_connection_id:lit.payload ()) + | None -> Printf.bprintf ctxt.b "%s" (generatesql_connect_reset ()) + end + | Connect_to_idby + { dbname; db_conn_id; db_data_source; username; password } -> Printf.bprintf ctxt.b "%s" - (generatesql_connect_reset ~d_connection_id:(strlit lit) ()) - | None -> Printf.bprintf ctxt.b "%s" (generatesql_connect_reset ()) - end - | Connect_to_idby - { dbname; db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:(strlit db_data_source) - ~data_source_tl:(getsize db_data_source) - ?d_connection_id:(strlitopt db_conn_id) - ?connection_id_tl:(getssomeize db_conn_id) - ~d_dbname:(strlit dbname) ~dbname_tl:(getsize dbname) - ~d_username:(strlit username) ~username_tl:(getsize username) - ~d_password:(strlit password) ~password_tl:(getsize password) () ) - | Connect_to { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:(strlit db_data_source) - ~data_source_tl:(getsize db_data_source) - ?d_connection_id:(strlitopt db_conn_id) - ?connection_id_tl:(getssomeize db_conn_id) - ~d_username:(strlit username) ~username_tl:(getsize username) - ?d_password:(strlitopt password) - ?password_tl:(getssomeize password) () ) - | Connect_using { db_data_source } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:(strlit db_data_source) - ~data_source_tl:(getsize db_data_source) () ) - | Connect_user { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ?data_source:(strlitopt db_data_source) - ?data_source_tl:(getssomeize db_data_source) - ?d_connection_id:(strlitopt db_conn_id) - ?connection_id_tl:(getssomeize db_conn_id) - ~d_username:(strlit username) ~username_tl:(getsize username) - ~d_password:(strlit password) ~password_tl:(getsize password) () ) - end + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_dbname:dbname.payload + ~dbname_tl:(get_length dbname.payload) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () ) + | Connect_to { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ?d_password:(cob_var_id_opt password) + ?password_tl:(get_some_cob_var_length password) () ) + | Connect_using { db_data_source } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + () ) + | Connect_user { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ?data_source:(cob_var_id_opt db_data_source) + ?data_source_tl:(get_some_cob_var_length db_data_source) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () ) + end; + print_error_treatement ctxt + | Whenever (c, k) -> + error_treatment := generate_whenever c k ^ !error_treatment + | SelectInto { vars; _ } -> + Printf.bprintf ctxt.b "%s" (generate_select_into vars) | _ -> ignore (loc, line, ctxt, esql_instuction) in @@ -139,7 +261,7 @@ let generate ~filename ~contents sql_statements = match statements with | [] -> List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines - | (begin_loc, stmt) :: statements -> ( + | (begin_loc, stmt) :: statements -> begin match begin_loc with | None -> List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines; @@ -149,7 +271,8 @@ let generate ~filename ~contents sql_statements = end_procedure_division ~ctxt ~loc:final_loc | _ -> () end - | Some begin_loc -> output_statement lines begin_loc stmt statements ) + | Some begin_loc -> output_statement lines begin_loc stmt statements + end and output_statement cur_lines begin_loc stmt statements = match cur_lines with | [] -> assert false diff --git a/src/lsp/sql_preproc/generate.mli b/src/lsp/sql_preproc/generate.mli index da965beac..c85c14211 100644 --- a/src/lsp/sql_preproc/generate.mli +++ b/src/lsp/sql_preproc/generate.mli @@ -10,4 +10,7 @@ val generate : filename:string -> - contents:string -> (Types.loc option * Types.statements) list -> string + contents:string -> + cobol_unit:Cobol_unit.Types.cobol_unit -> + (Types.loc option * Types.statements) list -> + string diff --git a/src/lsp/sql_preproc/main.ml b/src/lsp/sql_preproc/main.ml index daeb6c01a..61446f3bf 100644 --- a/src/lsp/sql_preproc/main.ml +++ b/src/lsp/sql_preproc/main.ml @@ -20,15 +20,11 @@ open Types * tabulations in margin in fixed format breaks the computation of indentation ; - *) -let preproc ~filename - ?(sql_in_copybooks = false) - ?(copy_path = []) - ?(copy_exts = []) - ?(contents = EzFile.read_file filename) - ~source_format () = +let preproc ~filename ?(sql_in_copybooks = false) ?(copy_path = []) + ?(copy_exts = []) ?(contents = EzFile.read_file filename) ~source_format + ~cobol_unit () = let scanner_config = Cobol_indent.Config.load ~source_format ~filename in if scanner_config.verbosity > 0 then @@ -36,31 +32,43 @@ let preproc ~filename let scanner_config = { scanner_config with scan_for_indent = false } in - let copy_exts = match copy_exts with + let copy_exts = + match copy_exts with | [] -> [ ".cpy" ] | _ -> copy_exts in let copy_path = Filename.dirname filename :: copy_path in - let copy_path = lazy ( List.map (fun dir -> - let files = match Sys.readdir dir with - | exception _ -> [||] - | files -> files - in - let map = ref StringMap.empty in - Array.iter (fun file -> - map := StringMap.add (String.lowercase_ascii file) file !map - ) files; - dir, !map - ) copy_path ) in + let copy_path = + lazy + (List.map + (fun dir -> + let files = + match Sys.readdir dir with + | exception _ -> [||] + | files -> files + in + let map = ref StringMap.empty in + Array.iter + (fun file -> + map := StringMap.add (String.lowercase_ascii file) file !map ) + files; + (dir, !map) ) + copy_path ) + in - let config = { scanner_config ; - sql_in_copybooks ; - copy_path ; - copy_exts ; - verbosity = scanner_config.verbosity } in + let config = + { scanner_config; + sql_in_copybooks; + copy_path; + copy_exts; + verbosity = scanner_config.verbosity + } + in let sql_statements = Parse.parse ~config ~filename ~contents in - let contents = Generate.generate ~filename ~contents sql_statements in + let contents = + Generate.generate ~filename ~contents ~cobol_unit sql_statements + in contents diff --git a/src/lsp/sql_preproc/main.mli b/src/lsp/sql_preproc/main.mli index 0dcf78f73..02eeef4c1 100644 --- a/src/lsp/sql_preproc/main.mli +++ b/src/lsp/sql_preproc/main.mli @@ -15,5 +15,6 @@ val preproc : ?copy_exts:string list -> ?contents:string -> source_format:Cobol_indent.Types.source_format -> + cobol_unit:Cobol_unit.Types.cobol_unit -> unit -> string diff --git a/src/lsp/sql_preproc/package.toml b/src/lsp/sql_preproc/package.toml index d6ec98ee0..45ea02359 100644 --- a/src/lsp/sql_preproc/package.toml +++ b/src/lsp/sql_preproc/package.toml @@ -56,6 +56,8 @@ preprocess = "pps ppx_deriving.show" ppx_deriving = ">=5.2.1" ez_file = "0.3" cobol_indent = "version" +cobol_typeck = "version" +cobol_unit = "version" superbol_preprocs = "version" # package tools dependencies diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 38a39e902..10827eb6f 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -9,7 +9,6 @@ (**************************************************************************) open Ez_file.V1 - open Cobol_indent.Types open Types @@ -20,54 +19,52 @@ let rec find_dot tokens = | _ :: tokens -> find_dot tokens let parse ~config ~filename ~contents = - let program_id = ref None in let sql_statements = ref [] in +(* let var_statements = ref [] in *) let procedure_division_found = ref None in let working_storage_found = ref false in let linkage_section_found = ref false in let sql_add_statement ?loc tokens = - sql_statements := (loc, tokens) :: - !sql_statements + sql_statements := (loc, tokens) :: !sql_statements in - let rec iter tokens = match tokens with | [] -> () | (PROGRAM_ID, loc) :: (DOT, _) :: (IDENT name, _) :: tokens -> - begin match !program_id with - | None -> - program_id := Some name; + begin + match !program_id with + | None -> program_id := Some name | Some _ -> - Misc.error ~loc - "multiple programs in the same file are not supported" + Misc.error ~loc "multiple programs in the same file are not supported" end; iter tokens - + (*TODO: Other case gestion (ex: 01 NUM1 PIC 99V99.)*) +(* | (NUMBER priority, loc) :: (IDENT name, _ ) :: (IDENT "PIC", _ ) :: (IDENT var_type, _ ) :: (LPAREN, _ ) :: (IDENT size, _ ) :: (RPAREN, _ ) :: tokens -> + var_add_statement ~loc (priority, name, var_type, size); + iter tokens *) | (IDENT "IS", loc) :: (IDENT "SQLVAR", end_loc) :: tokens -> sql_add_statement ~loc (IS_SQLVAR { end_loc }); iter tokens - | (PROCEDURE, loc) :: (DIVISION, _) :: tokens -> - let (end_loc, tokens) = find_dot tokens in + let end_loc, tokens = find_dot tokens in if not !working_storage_found then sql_add_statement ~loc (WORKING_STORAGE { defined = false }); if not !linkage_section_found then sql_add_statement ~loc (LINKAGE_SECTION { defined = false }); - sql_add_statement ~loc (PROCEDURE_DIVISION_DOT - { end_loc }); - assert (!procedure_division_found = None ); + sql_add_statement ~loc (PROCEDURE_DIVISION_DOT { end_loc }); + assert (!procedure_division_found = None); let ok = ref true in - sql_add_statement ~loc:{ loc with line = loc.line+1 } - (BEGIN_PROCEDURE_DIVISION { enabled = ok ; }); + sql_add_statement + ~loc:{ loc with line = loc.line + 1 } + (BEGIN_PROCEDURE_DIVISION { enabled = ok }); - procedure_division_found := Some ok ; - linkage_section_found := false ; - working_storage_found := false ; + procedure_division_found := Some ok; + linkage_section_found := false; + working_storage_found := false; iter tokens - | (IDENTIFICATION, loc) :: (DIVISION, _) :: tokens -> begin match !procedure_division_found with @@ -76,10 +73,9 @@ let parse ~config ~filename ~contents = sql_add_statement ~loc END_PROCEDURE_DIVISION; procedure_division_found := None end; - linkage_section_found := false ; - working_storage_found := false ; + linkage_section_found := false; + working_storage_found := false; iter tokens - | (END, loc) :: (PROGRAM, _) :: tokens -> begin match !procedure_division_found with @@ -89,7 +85,6 @@ let parse ~config ~filename ~contents = procedure_division_found := None end; iter tokens - | (END, loc) :: (DECLARATIVES, _) :: (DOT, _) :: tokens -> begin match !procedure_division_found with @@ -101,28 +96,26 @@ let parse ~config ~filename ~contents = enabled := false; let enabled = ref true in procedure_division_found := Some enabled; - sql_add_statement ~loc:{ loc with line = loc.line+1 } + sql_add_statement + ~loc:{ loc with line = loc.line + 1 } (BEGIN_PROCEDURE_DIVISION { enabled }); procedure_division_found := None end; iter tokens - | (WORKING_STORAGE, _loc) :: (SECTION, _) :: (DOT, loc) :: tokens -> - working_storage_found := true ; + working_storage_found := true; sql_add_statement ~loc (WORKING_STORAGE { defined = true }); iter tokens - | (LINKAGE, _loc) :: (SECTION, _) :: (DOT, loc) :: tokens -> if not !working_storage_found then begin sql_add_statement ~loc (WORKING_STORAGE { defined = false }); - working_storage_found := true ; + working_storage_found := true end; - linkage_section_found := true ; + linkage_section_found := true; if config.verbosity > 1 then Printf.eprintf "LINKAGE SECTION found at %d\n%!" loc.line; sql_add_statement ~loc (LINKAGE_SECTION { defined = true }); iter tokens - | (COPY, loc) :: (tok, _) :: (DOT, end_loc) :: tokens when config.sql_in_copybooks -> let file = Misc.string_of_token tok in @@ -133,83 +126,66 @@ let parse ~config ~filename ~contents = iter tokens | filename -> let contents = EzFile.read_file filename in - sql_add_statement ~loc (COPY { end_loc ; filename ; contents }); + sql_add_statement ~loc (COPY { end_loc; filename; contents }); tokenize_file ~filename ~contents tokens end | (EXEC, loc) :: (IDENT "SQL", _) :: tokens -> if config.verbosity > 1 then Printf.eprintf "EXEC SQL found at line %d\n%!" loc.line; - begin match tokens with - | (_, _loc) :: _ -> - iter_sql loc [] tokens -(* | ( - (IDENT _ - | RETURN - | READ | FILE | WRITE | REWRITE | DELETE | SET - | RECEIVE | SEND | START ) - as tok - , _) :: tokens -> - let cmd = Misc.string_of_token tok in - iter_sql loc cmd [] tokens - | (tok, loc) :: _ -> - Misc.error ~loc "SQL syntax error on token %S for command" - (Misc.string_of_token tok) *) - | [] -> - Misc.error ~loc "SQL syntax error on end of file" + begin + match tokens with + | (_, _loc) :: _ -> iter_sql loc [] tokens + | [] -> Misc.error ~loc "SQL syntax error on end of file" end | _ :: tokens -> iter tokens - and iter_sql loc params tokens = match tokens with - | (END_EXEC, end_loc) :: tokens -> + | (END_EXEC, end_loc) :: tokens -> (* TODO: check if there is a ending DOT on the same line. If yes, we need to output also a DOT at the end of the translation. *) - - let end_loc, with_dot, tokens = match tokens with - | (DOT, end_loc) :: tokens -> end_loc, true, tokens - | tokens -> end_loc, false, tokens + let end_loc, with_dot, tokens = + match tokens with + | (DOT, end_loc) :: tokens -> (end_loc, true, tokens) + | tokens -> (end_loc, false, tokens) in if config.verbosity > 1 then Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; let params = List.rev params in - let sqlStr = "EXEC SQL " ^ (String.concat " " params) ^ " END-EXEC" in - Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; - - let sql = Sql_parser.parseString (Lexing.from_string sqlStr) - in - Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; - - sql_add_statement ~loc - (EXEC_SQL { end_loc ; with_dot ; tokens = sql }); + let sqlStr = "EXEC SQL " ^ String.concat " " params ^ " END-EXEC" in + (* Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; + *) + let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in + (* Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; + *) + sql_add_statement ~loc (EXEC_SQL { end_loc; with_dot; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." | (tok, _) :: tokens -> let tok = Misc.string_of_token tok in - iter_sql loc ( tok :: params) tokens - + iter_sql loc (tok :: params) tokens and tokenize_file ~filename ~contents tokens = - let { Cobol_indent.Scanner.toks = new_tokens ; _ } = - Cobol_indent.Scanner.tokenize ~filename - ~config:config.scanner_config ~contents in + let { Cobol_indent.Scanner.toks = new_tokens; _ } = + Cobol_indent.Scanner.tokenize ~filename ~config:config.scanner_config + ~contents + in - let tokens = List.rev_append + let tokens = + List.rev_append (List.rev_map - (fun (tok, e) -> - (tok, Misc.loc_of_edit ~filename e)) new_tokens) + (fun (tok, e) -> (tok, Misc.loc_of_edit ~filename e)) + new_tokens ) tokens in iter tokens - in tokenize_file ~filename ~contents []; - (* Only fail if no PROCEDURE DIVISION was found for a main program, not for a copybook... if not !procedure_division_found then @@ -218,8 +194,7 @@ let parse ~config ~filename ~contents = begin match !procedure_division_found with | None -> () - | Some _ -> - sql_add_statement END_PROCEDURE_DIVISION + | Some _ -> sql_add_statement END_PROCEDURE_DIVISION end; List.rev !sql_statements diff --git a/src/lsp/sql_preproc/sql_typeck.ml b/src/lsp/sql_preproc/sql_typeck.ml new file mode 100644 index 000000000..de03250c7 --- /dev/null +++ b/src/lsp/sql_preproc/sql_typeck.ml @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open Cobol_data.Types + +let get_x_info (cu:Cobol_unit.Types.cobol_unit) name_str = + (* May raise Not_found | Cobol_unit.Qualmap.Ambiguous _ *) + try + Cobol_unit.Qualmap.find + (Cobol_unit.Qual.name + (Cobol_common.Srcloc.flagit name_str Cobol_common.Srcloc.dummy) ) + cu.unit_data.data_items.named + with + | Not_found -> Pretty.out " \"%s\" not found " name_str; failwith "Var not found" + | Cobol_unit.Qualmap.Ambiguous _ -> Pretty.out " \"%s\" not found. qualname nel lazy_t found" name_str; failwith "Var not found" + + + +let get_size cu name = + let x_info = get_x_info cu name + in + match x_info with + | Data_field { def = { payload = { field_size; _ }; _ }; _ } -> + let size = Cobol_data.Memory.(as_bits field_size / 8) in + Pretty.out "Size of \"%s\" is %u Bytes@." name size; + size + | _ -> 0 + + +let print_name (cu:Cobol_unit.Types.cobol_unit) = + let x_info = get_x_info cu "VBFLD" + in + match x_info with + | Data_field { def = { payload = { field_layout; field_size; _ }; _ }; _ } -> + Pretty.out "Size of VBFLD is %u Bytes@." + Cobol_data.Memory.(as_bits field_size / 8); + begin + match field_layout with + | Elementary_field { usage = Display picture; _ } -> ( + Pretty.out "PIC is %a@." Cobol_data.Picture.pp picture; + match picture.category with + | FixedNum { digits = _; scale = _; with_sign = _; _ } -> () + | _ -> () ) + | Elementary_field _ + | Struct_field _ -> + () + end + | _ -> () diff --git a/src/lsp/sql_preproc/transform.ml b/src/lsp/sql_preproc/transform.ml new file mode 100644 index 000000000..05ea734f5 --- /dev/null +++ b/src/lsp/sql_preproc/transform.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open Sql_ast +open Types + +let num = ref 0 + +let transform_stm (_, stm) = + match stm with + | EXEC_SQL { tokens; _ } -> ( + match tokens with + | SelectInto { select; select_options; _ } -> + let s = Format.asprintf "SELECT %a%a" Printer.pp_select_lst select Printer.pp_select_options_lst select_options in + let size = String.length s in + num:=!num+1; + " 01 SQ"^string_of_int !num^".\n\ + \ 02 FILLER PIC X("^string_of_int size^") VALUE \"" ^ s ^ "\".\n\ + \ 02 FILLER PIC X(1) VALUE X\"00\".\n" + | _ -> "" ) + | _ -> "" + +let rec transform cobol_unit sql_statements = + match sql_statements with + | h :: t -> + let (sql, _) = transform cobol_unit t in + (transform_stm h ^ sql, cobol_unit) + | [] -> ("", cobol_unit) diff --git a/src/lsp/sql_preproc/transform.mli b/src/lsp/sql_preproc/transform.mli new file mode 100644 index 000000000..066f2a563 --- /dev/null +++ b/src/lsp/sql_preproc/transform.mli @@ -0,0 +1,14 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +val transform : + Cobol_unit.Types.cobol_unit -> + (Types.loc option * Types.statements) list -> + (string * Cobol_unit.Types.cobol_unit) diff --git a/src/lsp/superbol_free_lib/command_sql.ml b/src/lsp/superbol_free_lib/command_sql.ml index 2055a829a..3369d914f 100644 --- a/src/lsp/superbol_free_lib/command_sql.ml +++ b/src/lsp/superbol_free_lib/command_sql.ml @@ -8,56 +8,93 @@ (* *) (**************************************************************************) -(** `parse` jcl command *) +(** `parse` sql command *) open Ezcmd.V2 open EZCMD.TYPES - open Common_args -let parse - ~sql_in_copybooks - ~copy_exts - common files = - let { preproc_options = { source_format; libpath = copy_path ; _ } ; _ } = common in +let typeck_file { preproc_options; parser_options } filename = + Cobol_preproc.Input.from ~filename + ~f: + begin + fun input -> + input + |> Cobol_preproc.preprocessor ~options:preproc_options + |> Cobol_parser.parse_simple ~options:parser_options + |> Cobol_parser.Outputs.result_only + |> (* ignoe diagnostics *) + Cobol_typeck.compilation_group ~config:parser_options.config + |> Cobol_typeck.Results.result_only + |> fun checked_group -> + (* in group: *) + let cu' = Cobol_unit.Collections.SET.choose checked_group.group in + let cu = cu'.payload in + cu + (* let x_info = + (* May raise Not_found | Cobol_unit.Qualmap.Ambiguous _ *) + Cobol_unit.Qualmap.find + (Cobol_unit.Qual.name ( Cobol_common.Srcloc.flagit "VBFLD" Cobol_common.Srcloc.dummy)) + cu.unit_data.data_items.named + in + match x_info with + | Data_field { def = { payload = { field_layout; field_size; _ } ; _ } ; _ } -> + Pretty.out "Size of VBFLD is %u Bytes@." + Cobol_data.Memory.(as_bits field_size / 8); + begin match field_layout with + | Elementary_field { usage = Display picture; _ } -> + Pretty.out "PIC is %a@." + Cobol_data.Picture.pp picture; + (match picture.category with + | FixedNum { digits = _; scale = _; with_sign = _; _ } -> () + | _ -> ()) + | Elementary_field _ + | Struct_field _ -> + () + end + | _ -> () + *) + end + +let parse ~sql_in_copybooks ~copy_exts common files = + let { preproc_options = { source_format; libpath = copy_path; _ }; _ } = + common + in let source_format = Cobol_indent.Config.source_format source_format in - List.iter (fun filename -> + List.iter + (fun filename -> + let common, _ = Common_args.get () in + let cobol_unit = typeck_file (common ()) filename in + (*TODO appel a typeck ici*) let contents = - Sql_preproc.Main.preproc - ~sql_in_copybooks - ~copy_path - ~copy_exts - ~filename - ~source_format () + Sql_preproc.Main.preproc ~sql_in_copybooks ~copy_path ~copy_exts + ~filename ~source_format () ~cobol_unit in - Printf.printf "%s%!" contents) files + Printf.printf "%s%!" contents ) + files let preproc_cmd = let sql_in_copybooks = ref false in let copy_exts = ref [] in let files = ref [] in let common, common_args = Common_args.get () in - EZCMD.sub - "sql preproc" + EZCMD.sub "sql preproc" (fun () -> - let common = common () in + let common = common () in Printexc.record_backtrace true; - parse - ~sql_in_copybooks:!sql_in_copybooks - ~copy_exts:!copy_exts - common !files) + parse ~sql_in_copybooks:!sql_in_copybooks ~copy_exts:!copy_exts common + !files ) ~args: - ( common_args @ [ - - [], Arg.Anons (fun l -> files := l), - EZCMD.info ~docv:"FILE" "COBOL files to preproc" ; - - [ "copybooks" ], Arg.Set sql_in_copybooks, - EZCMD.info "Preprocess copybooks also (without REPLACING)"; - - [ "ext" ], Arg.String (fun s -> copy_exts := !copy_exts @ ["." ^ s]), + ( common_args + @ [ ( [], + Arg.Anons (fun l -> files := l), + EZCMD.info ~docv:"FILE" "COBOL files to preproc" ); + ( [ "copybooks" ], + Arg.Set sql_in_copybooks, + EZCMD.info "Preprocess copybooks also (without REPLACING)" ); + ( [ "ext" ], + Arg.String (fun s -> copy_exts := !copy_exts @ [ "." ^ s ]), EZCMD.info ~docv:"EXT" - "Add .EXT as an extension to find copybooks (default is cpy)" ; - - ]) + "Add .EXT as an extension to find copybooks (default is cpy)" ) + ] ) ~doc:"Preprocess SQL EXECs" From cdad87565186f2e8f7957bf8c777a2a52c3925f8 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Thu, 11 Jul 2024 11:39:29 +0200 Subject: [PATCH 06/37] typoS --- src/lsp/sql_ast/sql_ast.ml | 62 +++++++++++++++----------------- src/lsp/sql_parser/grammar.mly | 2 +- src/lsp/sql_parser/sql_parser.ml | 2 +- src/lsp/sql_preproc/generate.ml | 30 +++++++--------- 4 files changed, 44 insertions(+), 52 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index f2d61a980..a23395b80 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -67,8 +67,7 @@ and esql_instuction = | Commit of rb_work_or_tran option * bool | Savepoint of variable | SelectInto of - { - vars : cobol_var list; + { vars : cobol_var list; select : sql_select; select_options : sql_select_option list } @@ -77,8 +76,7 @@ and esql_instuction = | Prepare of sqlVarToken * sql_instruction | ExecuteImmediate of sql_instruction | ExecuteIntoUsing of - { - executed_string : sqlVarToken; + { executed_string : sqlVarToken; opt_into_hostref_list : cobol_var list option; opt_using_hostref_list : cobol_var list option } @@ -93,8 +91,7 @@ and esql_instuction = | Ignore of sql_instruction and try_block = - { - try_instruction : esql_instuction; + { try_instruction : esql_instuction; try_exceptions : sql_exception list } @@ -124,29 +121,26 @@ and rb_args = and connect_syntax = | Connect_to_idby of - { - dbname : cobolVarId; + { dbname : cobolVarId; db_conn_id : variable option; username : cobolVarId; db_data_source : cobolVarId; password : cobolVarId } | Connect_to of - { - db_data_source : cobolVarId; + { db_data_source : cobolVarId; db_conn_id : variable option; username : cobolVarId; password : cobolVarId option } | Connect_using of { db_data_source : cobolVarId } | Connect_user of - { - username : cobolVarId; + { username : cobolVarId; password : cobolVarId; db_conn_id : variable option; db_data_source : cobolVarId option } - | Connect_reset of cobolVarId option + | Connect_reset of variable option (*WHENEVER*) and sql_type = @@ -380,12 +374,10 @@ module Printer = struct | _ -> Format.fprintf fmt "(%a)" pp_list_lit l ) and pp_where_arg fmt = function - | Some WhereCurrentOf swhere -> - Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload - | Some UpdateSql sql -> - pp_sql fmt sql - | None -> - () + | Some (WhereCurrentOf swhere) -> + Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload + | Some (UpdateSql sql) -> pp_sql fmt sql + | None -> () and pp_sql_update_aux fmt (var, op) = Format.fprintf fmt "%s = %a" var.payload pp_sql_op op @@ -461,7 +453,10 @@ module Printer = struct and pp_cob_var fmt = function | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload - | CobVarNullIndicator (c, ni) -> Format.fprintf fmt ":%s:%s" c.payload ni.payload + | CobVarNullIndicator (c, ni) -> + Format.fprintf fmt ":%s:%s" c.payload ni.payload + + and pp_cob_var_id fmt c = Format.fprintf fmt ":%s" c.payload and pp_some_rb_work_or_tran fmt = function | Some p -> pp_rb_work_or_tran fmt p @@ -477,28 +472,29 @@ module Printer = struct Format.fprintf fmt "TO SAVEPOINT %s" variable.payload | None -> Format.fprintf fmt "" - and pp_some_cob_var fmt (x, s) = - match x with - | Some v -> Format.fprintf fmt "%s %s" s v.payload - | None -> Format.fprintf fmt "" + and pp_some_cob_var fmt (x, s) = + match x with + | Some v -> Format.fprintf fmt "%s %a" s pp_cob_var_id v + | None -> Format.fprintf fmt "" and pp_connect fmt c = match c with | Connect_to_idby { dbname; db_conn_id; username; db_data_source; password } -> - Format.fprintf fmt "TO %s %a USER %s USING %s IDENTIFIED BY %s" - dbname.payload pp_some_var (db_conn_id, "AS") username.payload - db_data_source.payload password.payload + Format.fprintf fmt "TO %a %a USER %a USING %a IDENTIFIED BY %a" + pp_cob_var_id dbname pp_some_var (db_conn_id, "AS") pp_cob_var_id + username pp_cob_var_id db_data_source pp_cob_var_id password | Connect_to { db_data_source; db_conn_id; username; password } -> - Format.fprintf fmt "TO %s %a USER %s %a" db_data_source.payload pp_some_var - (db_conn_id, "AS") username.payload pp_some_cob_var (password, "USING") + Format.fprintf fmt "TO %a %a USER %a %a" pp_cob_var_id db_data_source + pp_some_var (db_conn_id, "AS") pp_cob_var_id username pp_some_cob_var + (password, "USING") | Connect_using { db_data_source } -> - Format.fprintf fmt "USING %s" db_data_source.payload + Format.fprintf fmt "USING %a" pp_cob_var_id db_data_source | Connect_user { username; password; db_conn_id; db_data_source } -> - Format.fprintf fmt "%s IDENTIFIED BY %s %a %a" username.payload - password.payload pp_some_var (db_conn_id, "AT") pp_some_cob_var + Format.fprintf fmt "%a IDENTIFIED BY %a %a %a" pp_cob_var_id username + pp_cob_var_id password pp_some_var (db_conn_id, "AT") pp_some_cob_var (db_data_source, "USING") - | Connect_reset name -> Format.fprintf fmt "RESET%a" pp_some_cob_var (name, "") + | Connect_reset name -> Format.fprintf fmt "RESET%a" pp_some_var (name, "") and pp_whenever_condtion fmt = function | Not_found_whenever -> Format.fprintf fmt "NOT FOUND" diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 77e81ef16..61cb8db61 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -248,7 +248,7 @@ EXEC SQL CONNECT :username IDENTIFIED BY :password | username= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; db_conn_id = option(at_var); db_data_source= option(using_var); {Connect_user{username; password; db_conn_id; db_data_source}} -| RESET; name=option( cobol_var_id); +| RESET; name=option( simpl_var); {Connect_reset name } let at_var:= AT; p= simpl_var; {p} diff --git a/src/lsp/sql_parser/sql_parser.ml b/src/lsp/sql_parser/sql_parser.ml index 7c2103636..ec41e8d29 100644 --- a/src/lsp/sql_parser/sql_parser.ml +++ b/src/lsp/sql_parser/sql_parser.ml @@ -66,7 +66,7 @@ let parse text = |> fst |> List.rev in let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in - (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) + (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) ast let parseString str = Grammar.main Lexer.token str \ No newline at end of file diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 9e0881d81..843edc1a4 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -28,14 +28,13 @@ let end_procedure_division ~ctxt:_ ~loc:_ = (* let strlit lit = Format.asprintf "%a" Printer.pp_lit lit *) (* let strlitopt = function - | Some lit -> Some (strlit lit) - | None -> None *) + | Some lit -> Some (strlit lit) + | None -> None *) -let cob_var_id_opt (cob_var:cobolVarId option) = +let cob_var_id_opt (cob_var : cobolVarId option) = match cob_var with -| Some cob -> Some (cob.payload) -| None -> None - + | Some cob -> Some cob.payload + | None -> None let cob_var_opt = function | Some var -> ( @@ -61,13 +60,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | None -> None in - let get_some_cob_var_length (cob_var:cobolVarId option) = + let get_some_cob_var_length (cob_var : cobolVarId option) = match cob_var with | Some x -> Some (get_length x.payload) | None -> None in - let get_type _str = 16 in let get_scale _str = 0 in let get_flags _str = 0 in @@ -201,13 +199,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | Connect cs -> begin match cs with - | Connect_reset lit -> begin - match lit with - | Some lit -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect_reset ~d_connection_id:lit.payload ()) - | None -> Printf.bprintf ctxt.b "%s" (generatesql_connect_reset ()) - end + | Connect_reset lit -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect_reset ?d_connection_id:(var_opt lit) ()) | Connect_to_idby { dbname; db_conn_id; db_data_source; username; password } -> Printf.bprintf ctxt.b "%s" @@ -231,7 +225,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ~d_username:username.payload ~username_tl:(get_length username.payload) ?d_password:(cob_var_id_opt password) - ?password_tl:(get_some_cob_var_length password) () ) + ?password_tl:(get_some_cob_var_length password) + () ) | Connect_using { db_data_source } -> Printf.bprintf ctxt.b "%s" (generatesql_connect ~data_source:db_data_source.payload @@ -239,7 +234,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = () ) | Connect_user { db_conn_id; db_data_source; username; password } -> Printf.bprintf ctxt.b "%s" - (generatesql_connect ?data_source:(cob_var_id_opt db_data_source) + (generatesql_connect + ?data_source:(cob_var_id_opt db_data_source) ?data_source_tl:(get_some_cob_var_length db_data_source) ?d_connection_id:(var_opt db_conn_id) ?connection_id_tl:(get_some_length db_conn_id) From 9a91b6a9eaabac178b8406fa62a9ba1c550e5169 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Fri, 26 Jul 2024 10:44:28 +0200 Subject: [PATCH 07/37] refactoring --- src/lsp/sql_parser/sql_parser.ml | 2 +- src/lsp/sql_preproc/data_gestion.ml | 88 +++ src/lsp/sql_preproc/data_gestion.mli | 25 + src/lsp/sql_preproc/generate.ml | 630 +++++++++++------- src/lsp/sql_preproc/generated_type.ml | 125 ++++ src/lsp/sql_preproc/old_generate.ml | 386 +++++++++++ .../{transform.mli => old_generate.mli} | 8 +- src/lsp/sql_preproc/parse.ml | 33 +- src/lsp/sql_preproc/sql_typeck.ml | 73 +- src/lsp/sql_preproc/transform.ml | 35 - src/lsp/sql_preproc/types.ml | 7 +- 11 files changed, 1084 insertions(+), 328 deletions(-) create mode 100644 src/lsp/sql_preproc/data_gestion.ml create mode 100644 src/lsp/sql_preproc/data_gestion.mli create mode 100644 src/lsp/sql_preproc/generated_type.ml create mode 100644 src/lsp/sql_preproc/old_generate.ml rename src/lsp/sql_preproc/{transform.mli => old_generate.mli} (87%) delete mode 100644 src/lsp/sql_preproc/transform.ml diff --git a/src/lsp/sql_parser/sql_parser.ml b/src/lsp/sql_parser/sql_parser.ml index ec41e8d29..7b4e1c347 100644 --- a/src/lsp/sql_parser/sql_parser.ml +++ b/src/lsp/sql_parser/sql_parser.ml @@ -66,7 +66,7 @@ let parse text = |> fst |> List.rev in let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in - (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) + (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) ast let parseString str = Grammar.main Lexer.token str \ No newline at end of file diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml new file mode 100644 index 000000000..8e8f7aa96 --- /dev/null +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -0,0 +1,88 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open Sql_ast +open Types +module StringMap = Map.Make (String) + +type variable_information = + { length : int; + vartype : int; + scale : int; + flags : int; + ind_addr : int + } + +type t = variable_information StringMap.t + +let add_var ~map ~name ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) + ?(ind_addr = 0) () = + StringMap.add name { length; vartype; scale; flags; ind_addr } map + +let num = ref 0 + +let transform_stm map (_, stm) = + let create_new_var content = + (*TODO: a function that cut (with &) the resquest if too long*) + let size = String.length content in + num := !num + 1; + let name = "SQ" ^ string_of_int !num in + ( " 01 " ^ name ^ ".\n 02 FILLER PIC X(" + ^ string_of_int size ^ ") VALUE \"" ^ content + ^ "\".\n 02 FILLER PIC X(1) VALUE X\"00\".\n", + add_var ~map ~name:("SQ" ^ string_of_int !num) ?length:(Some size) () ) + in + match stm with + | EXEC_SQL { tokens; _ } -> ( + match tokens with + | SelectInto { select; select_options; _ } -> + create_new_var + (Format.asprintf "SELECT %a%a" Printer.pp_select_lst select + Printer.pp_select_options_lst select_options ) + | Begin -> create_new_var ("BEGIN") + | _ -> ("", map) ) + | DECLARATION { declaration; _ } -> ( + match declaration with + | SQL_type_is { importance; name; sql_type; sql_type_size } -> begin + match sql_type with + | "BINARY" + | "CHAR" -> + let map = + add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () + in + ( " " ^ importance ^ " " ^ name ^ " PIC X(" ^ sql_type_size + ^ ").\n", + map ) + | "VARBINARY" + | "VARCHAR" -> + let map = + add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () + in + ( " " ^ importance ^ " " ^ name ^ ".\n 49 " ^ name + ^ "-LEN PIC 9(8) COMP-5.\n 49 " ^ name ^ "-ARR PIC X(" + ^ sql_type_size ^ ").\n", + map ) + | _ -> failwith "Unknow type." + end ) + | _ -> ("", map) + +let transform sql_statements = + let rec transform_rec map sql_statements = + match sql_statements with + | h :: t -> + let smt, map = transform_stm map h in + let sql, map = transform_rec map t in + (smt ^ sql, map) + | [] -> ("", map) + in + let init_map = StringMap.empty in + transform_rec init_map sql_statements + +let find_opt map str = StringMap.find_opt str map diff --git a/src/lsp/sql_preproc/data_gestion.mli b/src/lsp/sql_preproc/data_gestion.mli new file mode 100644 index 000000000..8646b2cde --- /dev/null +++ b/src/lsp/sql_preproc/data_gestion.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +type t + +type variable_information = + { length : int; + vartype : int; + scale : int; + flags : int; + ind_addr : int + } + +val transform : + (Types.loc option * Types.statements) list -> + (string * t) + +val find_opt : t -> string -> variable_information option diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 843edc1a4..be0bd2781 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -12,139 +12,207 @@ open EzCompat open Types open Sql_ast -let linkage_section = - {| *> SQL addition in linkage section: - 01 SOME-ARG PIC X(9). -|} - -let begin_procedure_division ~ctxt:_ ~loc:_ = - (* We might want to add something at the begining of PROCEDURE DIVISION ? *) - () +let generate ~filename ~contents ~cobol_unit sql_statements = + let linkage_section = Generated_type.Added { content = "" } in + let begin_procedure_division ~loc:_ = + (* We might want to add something at the begining of PROCEDURE DIVISION ? *) + [ Generated_type.Added { content = "" } ] + in -let end_procedure_division ~ctxt:_ ~loc:_ = - (* We might want to add something before the end of PROCEDURE DIVISION ? *) - () + let end_procedure_division ~loc:_ = + (* TODO CURSOR DIVISION*) + [ Generated_type.Added { content = "" } ] + in + (* split lines and numerotate them *) + let lines = EzString.split contents '\n' in + let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in -(* let strlit lit = Format.asprintf "%a" Printer.pp_lit lit *) + (*string to add at the end of every sql processed*) -(* let strlitopt = function - | Some lit -> Some (strlit lit) - | None -> None *) + (* The result will be stored in this buffer: *) + let final_loc = { filename; line = -1; char = 0 } in -let cob_var_id_opt (cob_var : cobolVarId option) = - match cob_var with - | Some cob -> Some cob.payload - | None -> None + let error_treatment = ref [] in + let old_statements = ref [] in + let num = ref 0 in -let cob_var_opt = function - | Some var -> ( - match var with - | CobVarNotNull cobolVarId -> Some cobolVarId.payload - | CobVarNullIndicator (var, _) -> Some var.payload ) - | None -> None + (*GET FUNCTION*) + (*TODOOOO*) + let working_storage_section, new_var_map = + let ws, nvm = Data_gestion.transform sql_statements in + ( [ Generated_type.Added + { content = " *> Begin generated WORKING-STORAGE SECTION" }; + Generated_type.Added { content = ws }; + Generated_type.Added + { content = " *> End genererated WORKING-STORAGE SECTION" } + ], + nvm ) + in -let var_opt = function - | Some var -> ( - match var with - | SqlVar sqlVarToken -> Some sqlVarToken.payload - | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) - | None -> None + let cob_var_id_opt (cob_var : cobolVarId option) = + match cob_var with + | Some cob -> Some cob.payload + | None -> None + in -let generate ~filename ~contents ~cobol_unit sql_statements = - (*TODO get function*) - let get_length str = Sql_typeck.get_size cobol_unit str in + let cob_var_opt = function + | Some var -> ( + match var with + | CobVarNotNull cobolVarId -> Some cobolVarId.payload + | CobVarNullIndicator (var, _) -> Some var.payload ) + | None -> None + in - let get_some_length var = - match var_opt var with - | Some x -> Some (get_length x) + let var_opt = function + | Some var -> ( + match var with + | SqlVar sqlVarToken -> Some ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"") + | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) | None -> None in + let get_length str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.length + | None -> Sql_typeck.get_length cobol_unit str + in + let get_some_cob_var_length (cob_var : cobolVarId option) = match cob_var with | Some x -> Some (get_length x.payload) | None -> None in - let get_type _str = 16 in - let get_scale _str = 0 in - let get_flags _str = 0 in - let get_ind_addr _str = 0 in - - let working_storage_section, _cobol_unit = - Transform.transform cobol_unit sql_statements + let get_some_length var = + match var with + | Some (CobolVar (CobVarNotNull cobol_var)) -> + get_some_cob_var_length (Some cobol_var) + | _ -> None in - (* split lines and numerotate them *) - let lines = EzString.split contents '\n' in - let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in - (*string to add at the end of every sql processed*) - let error_treatment = ref "" in - let print_error_treatement ctxt = - if !error_treatment <> "" then ( - Printf.bprintf ctxt.b " EVALUATE TRUE\n"; - Printf.bprintf ctxt.b "%s\n" !error_treatment; - Printf.bprintf ctxt.b " END-EVALUATE\n" - ) + let get_type str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.vartype + | None -> Sql_typeck.get_type cobol_unit str in - - (* The result will be stored in this buffer: *) - let b = Buffer.create 1000 in - - let ctxt = { b; main_filename = filename } in - let final_loc = { filename; line = -1; char = 0 } in - - let generatesql_connect ?(data_source = "x\"00\"") ?(data_source_tl = 0) - ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) - ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) ?(d_username = "x\"00\"") - ?(username_tl = 0) ?(d_password = "x\"00\"") ?(password_tl = 0) () = - " CALL STATIC \"GIXSQLConnect\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE " ^ data_source - ^ "\n BY VALUE " - ^ string_of_int data_source_tl - ^ "\n BY REFERENCE " ^ d_connection_id - ^ "\n BY VALUE " - ^ string_of_int connection_id_tl - ^ "\n BY REFERENCE " ^ d_dbname - ^ "\n BY VALUE " ^ string_of_int dbname_tl - ^ "\n BY REFERENCE " ^ d_username - ^ "\n BY VALUE " ^ string_of_int username_tl - ^ "\n BY REFERENCE " ^ d_password - ^ "\n BY VALUE " ^ string_of_int password_tl - ^ "\n END-CALL" + let get_scale str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.scale + | None -> Sql_typeck.get_scale cobol_unit str + in + let get_flags str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.flags + | None -> Sql_typeck.get_flags cobol_unit str + in + let get_ind_addr str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.ind_addr + | None -> Sql_typeck.get_ind_addr cobol_unit str in - let generatesql_connect_reset ?(d_connection_id = "x\"00\"") + (*GENERATE FUNCTION*) + let generatesql_connect_reset ~prefix ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) () = - " CALL STATIC \"GIXSQLConnectReset\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE " ^ d_connection_id - ^ "\n BY VALUE " - ^ string_of_int connection_id_tl - ^ "\n END-CALL" + let fun_name = "GIXSQLConnectReset" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = d_connection_id }; + Generated_type.Value { prefix; var = string_of_int connection_id_tl } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generatesql_connect_aux ~prefix ?(data_source = "x\"00\"") + ?(data_source_tl = 0) ?(d_connection_id = "x\"00\"") + ?(connection_id_tl = 0) ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) + ?(d_username = "x\"00\"") ?(username_tl = 0) ?(d_password = "x\"00\"") + ?(password_tl = 0) () = + let fun_name = "GIXSQLConnect" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = data_source }; + Generated_type.Value { prefix; var = string_of_int data_source_tl }; + Generated_type.Reference { prefix; var = d_connection_id }; + Generated_type.Value { prefix; var = string_of_int connection_id_tl }; + Generated_type.Reference { prefix; var = d_dbname }; + Generated_type.Value { prefix; var = string_of_int dbname_tl }; + Generated_type.Reference { prefix; var = d_username }; + Generated_type.Value { prefix; var = string_of_int username_tl }; + Generated_type.Reference { prefix; var = d_password }; + Generated_type.Value { prefix; var = string_of_int password_tl } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_whenever_continuation = function - | Continue -> "CONTINUE" - | Perform sqlVarToken -> "PERFORM " ^ sqlVarToken.payload - | Goto sqlVarToken -> "GOTO " ^ sqlVarToken.payload + let generatesql_connect cs prefix = + match cs with + | Connect_reset lit -> + [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) + ?connection_id_tl:(get_some_length lit) () + ] + | Connect_to_idby { dbname; db_conn_id; db_data_source; username; password } + -> + [ generatesql_connect_aux ~prefix ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_dbname:dbname.payload + ~dbname_tl:(get_length dbname.payload) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () + ] + | Connect_to { db_conn_id; db_data_source; username; password } -> + [ generatesql_connect_aux ~prefix ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ?d_password:(cob_var_id_opt password) + ?password_tl:(get_some_cob_var_length password) + () + ] + | Connect_using { db_data_source } -> + [ generatesql_connect_aux ~prefix ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + () + ] + | Connect_user { db_conn_id; db_data_source; username; password } -> + [ generatesql_connect_aux ~prefix + ?data_source:(cob_var_id_opt db_data_source) + ?data_source_tl:(get_some_cob_var_length db_data_source) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () + ] in - let generate_whenever c k = - match c with - | Not_found_whenever -> - " WHEN SQLCODE = 100\n " - ^ generate_whenever_continuation k - ^ "\n" - | SqlError_whenever -> - " WHEN SQLCODE < 0\n " - ^ generate_whenever_continuation k - ^ "\n" - | SqlWarning_whenever -> - " WHEN SQLCODE < 0\n " - ^ generate_whenever_continuation k - ^ "\n" + let generate_whenever ~prefix c k = + let condition = + match c with + | Sql_ast.Not_found_whenever -> Generated_type.Not_found_whenever + | Sql_ast.SqlError_whenever -> Generated_type.SqlError_whenever + | Sql_ast.SqlWarning_whenever -> Generated_type.SqlWarning_whenever + in + let continuation = + match k with + | Sql_ast.Continue -> Generated_type.Continue + | Sql_ast.Perform x -> Generated_type.Perform x.payload + | Sql_ast.Goto x -> Generated_type.Goto x.payload + in + Generated_type.Error_treatment { prefix; condition; continuation } in let get_name_cobol_var (cobol_var : cobol_var) = @@ -153,119 +221,147 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | CobVarNullIndicator (c, n) -> c.payload ^ n.payload in - let rec generate_select_into_rec vars = - match vars with - | h :: t -> - let h = get_name_cobol_var h in - " CALL STATIC \"GIXSQLSetResultParams\" USING\n\ - \ BY VALUE " - ^ string_of_int (get_type h) - ^ "\n BY VALUE " - ^ string_of_int (get_length h) - ^ "\n BY VALUE " - ^ string_of_int (get_scale h) - ^ "\n BY VALUE " - ^ string_of_int (get_flags h) - ^ "\n BY REFERENCE " ^ h ^ "\n BY REFERENCE " - ^ string_of_int (get_ind_addr h) - ^ "\n END-CALL\n" ^ generate_select_into_rec t - | [] -> "" + let generate_select_into_rec prefix arg = + let h = get_name_cobol_var arg in + let fun_name = "GIXSQLSetResultParams" in + let ref_value = + [ Generated_type.Value { prefix; var = string_of_int (get_type h) }; + Generated_type.Value { prefix; var = string_of_int (get_length h) }; + Generated_type.Value { prefix; var = string_of_int (get_scale h) }; + Generated_type.Value { prefix; var = string_of_int (get_flags h) }; + Generated_type.Reference { prefix; var = h }; + Generated_type.Reference + { prefix; var = string_of_int (get_ind_addr h) } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into_one vars = - " CALL STATIC \"GIXSQLExecSelectIntoOne\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE x\"00\"\n\ - \ BY VALUE 0\n\ - \ BY REFERENCE SQ0001\n\ - \ BY VALUE 0\n\ - \ BY VALUE 5\n" - ^ string_of_int (List.length vars) - ^ "\n END-CALL\n" + + let generate_select_into_one prefix vars = + let size = string_of_int (List.length vars) in + let fun_name = "GIXSQLExecSelectIntoOne" in + let ref_value = + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num + in + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = var_name }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Value { prefix; var = size } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generate_select_into prefix vars = + let startSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLStartSQL"; ref_value = [] } + in + let selects_into_vars = List.map (generate_select_into_rec prefix) vars in + let selects_into = generate_select_into_one prefix vars in + let endSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLEndSQL"; ref_value = [] } + in + let trans_stm = + (startSql :: selects_into_vars) @ (selects_into :: [ endSql ]) + in + trans_stm in - let generate_select_into vars = - " CALL STATIC \"GIXSQLStartSQL\"\n END-CALL" - ^ generate_select_into_rec vars - ^ generate_select_into_one vars - ^ " CALL STATIC \"GIXSQLEndSQL\"\n END-CALL\n" + let generate_declare prefix = + let startSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLStartSQL"; ref_value = [] } + in + let fun_name = "GIXSQLExec" in + let ref_value = + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = var_name } + ] + in + let declare = Generated_type.CallStatic { prefix; fun_name; ref_value } in + + let endSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLEndSQL"; ref_value = [] } + in + let trans_stm = startSql :: declare :: [ endSql ] in + trans_stm in - let generatesql ~loc ~line ~ctxt esql_instuction = + let generatesql ~loc ~line esql_instuction = + let prefix = String.sub line 0 loc.char in match esql_instuction with | Include sqlvar -> - let before_macro = String.sub line 0 loc.char in - Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload; - print_error_treatement ctxt - | Connect cs -> - begin - match cs with - | Connect_reset lit -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect_reset ?d_connection_id:(var_opt lit) ()) - | Connect_to_idby - { dbname; db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_dbname:dbname.payload - ~dbname_tl:(get_length dbname.payload) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ~d_password:password.payload - ~password_tl:(get_length password.payload) - () ) - | Connect_to { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ?d_password:(cob_var_id_opt password) - ?password_tl:(get_some_cob_var_length password) - () ) - | Connect_using { db_data_source } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - () ) - | Connect_user { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect - ?data_source:(cob_var_id_opt db_data_source) - ?data_source_tl:(get_some_cob_var_length db_data_source) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ~d_password:password.payload - ~password_tl:(get_length password.payload) - () ) - end; - print_error_treatement ctxt + (* let prefix = String.sub line 0 loc.char in *) + [ Generated_type.Copy { prefix; file_name = sqlvar.payload } ] + | Connect cs -> generatesql_connect cs prefix + | Disconnect lit -> + [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) () ] | Whenever (c, k) -> - error_treatment := generate_whenever c k ^ !error_treatment - | SelectInto { vars; _ } -> - Printf.bprintf ctxt.b "%s" (generate_select_into vars) - | _ -> ignore (loc, line, ctxt, esql_instuction) + error_treatment := generate_whenever ~prefix c k :: !error_treatment; + [] + | SelectInto { vars; _ } -> generate_select_into prefix vars + | Begin -> generate_declare prefix + | BeginDeclare + | EndDeclare -> + [] (*do nothing*) + | StartTransaction + | DisconnectAll + | At (_, _) + | Sql _ + | Exeption _ + | Rollback (_, _) + | Commit (_, _) + | Savepoint _ + | DeclareTable (_, _) + | DeclareCursor _ + | Prepare (_, _) + | ExecuteImmediate _ + | ExecuteIntoUsing _ + | Open (_, _) + | Close _ + | Fetch (_, _) + | Insert (_, _) + | Delete _ + | Update (_, _, _) + | Ignore _ -> + (*TODO*) + [] in let rec output lines statements = match statements with | [] -> - List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines + List.map + (fun (_, _, line) -> Generated_type.NoChange { content = line }) + lines | (begin_loc, stmt) :: statements -> begin match begin_loc with | None -> - List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines; + let res = + List.map + (fun (_, _, line) -> Generated_type.NoChange { content = line }) + lines + in begin match stmt with | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:final_loc - | _ -> () + res @ end_procedure_division ~loc:final_loc + | _ -> res end | Some begin_loc -> output_statement lines begin_loc stmt statements end @@ -274,89 +370,111 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | [] -> assert false | (filename, i, line) :: lines -> ( if filename <> begin_loc.filename || i < begin_loc.line then begin - Printf.bprintf ctxt.b "%s\n" line; - output_statement lines begin_loc stmt statements + Generated_type.NoChange { content = line } + :: output_statement lines begin_loc stmt statements end else match stmt with | LINKAGE_SECTION { defined } -> if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b linkage_section; - output lines statements + Generated_type.NoChange { content = line } + :: ([ linkage_section ] @ output lines statements) end else begin - Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; - Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; - Buffer.add_string ctxt.b linkage_section; - output cur_lines statements + Generated_type.Added + { content = " *> Add missing LINKAGE SECTION" } + :: Generated_type.Added { content = " LINKAGE SECTION." } + :: ([ linkage_section ] @ output cur_lines statements) end | WORKING_STORAGE { defined } -> if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b working_storage_section; - output lines statements + Generated_type.NoChange { content = line } + :: (working_storage_section @ output lines statements) end else begin - Printf.bprintf ctxt.b - " *> Add missing WORKING-STORAGE SECTION\n"; - Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; - Buffer.add_string ctxt.b working_storage_section; - output cur_lines statements + Generated_type.Added + { content = " *> Add missing WORKING-STORAGE SECTION" } + :: Generated_type.Added + { content = " WORKING-STORAGE SECTION." } + :: (working_storage_section @ output cur_lines statements) end | EXEC_SQL { end_loc; with_dot; tokens } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + let with_dot = + match tokens with + | BeginDeclare + | EndDeclare -> + false + | _ -> with_dot + in + old_statements := line :: !old_statements; if i = end_loc.line then begin - generatesql ~loc:begin_loc ~line ~ctxt tokens; - (* ignore (tokens); *) - Misc.add_dot ~with_dot b; - output lines statements + let trans_stm = generatesql ~loc:begin_loc ~line tokens in + let error_treatment = !error_treatment in + let old_stms = !old_statements in + old_statements := []; + Generated_type.Change + { old_stms; trans_stm; error_treatment; with_dot } + :: output lines statements end else output_statement lines begin_loc stmt statements | PROCEDURE_DIVISION_DOT { end_loc } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; if i = end_loc.line then begin - (* for now, just put it back *) - Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; - output lines statements + Generated_type.Added { content = " *> REMOVED: " ^ line } + :: (* for now, just put it back *) + Generated_type.Added + { content = " PROCEDURE DIVISION." } + :: output lines statements end else - output_statement lines begin_loc stmt statements + Generated_type.Added { content = " *> REMOVED: " ^ line } + :: output_statement lines begin_loc stmt statements + | DECLARATION _ -> + Generated_type.Added { content = " *> REMOVED: " ^ line } + :: output lines statements + (* | IS_SQLVAR { end_loc } -> - if i = begin_loc.line then begin - let before_macro = String.sub line 0 begin_loc.char in - Printf.bprintf ctxt.b "%s%s" before_macro - "SOME STRING THAT REPLACE IS SQLVAR"; - if begin_loc.line <> end_loc.line then - Printf.bprintf ctxt.b "\n " - end; - if i = end_loc.line then ( - let len = String.length line in - (* This code won't work with tabulations, because - the end_loc.char is wrong in such a case *) - let after_macro = - String.sub line (end_loc.char + 1) (len - end_loc.char - 1) - in - Printf.bprintf ctxt.b "%s\n" after_macro; - output lines statements - ) else - output_statement lines begin_loc stmt statements + + if i = begin_loc.line then begin + let before_macro = String.sub line 0 begin_loc.char in + Printf.bprintf ctxt.b "%s%s" before_macro + "SOME STRING THAT REPLACE IS SQLVAR"; + if begin_loc.line <> end_loc.line then + Printf.bprintf ctxt.b "\n " + end; + if i = end_loc.line then ( + let len = String.length line in + (* This code won't work with tabulations, because + the end_loc.char is wrong in such a case *) + let after_macro = + String.sub line (end_loc.char + 1) (len - end_loc.char - 1) + in + Printf.bprintf ctxt.b "%s\n" after_macro; + output lines statements + ) else + output_statement lines begin_loc stmt statements *) | BEGIN_PROCEDURE_DIVISION { enabled } -> - if !enabled then - begin_procedure_division ~ctxt ~loc:begin_loc - else - Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; - output cur_lines statements + ( if !enabled then + begin_procedure_division ~loc:begin_loc + else + [ Generated_type.Added + { content = " *> BEGIN PROCEDURE DIVISION disabled" } + ] ) + @ output cur_lines statements | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:begin_loc; - output cur_lines statements + end_procedure_division ~loc:begin_loc @ output cur_lines statements | COPY { end_loc; filename; contents } -> - Printf.bprintf ctxt.b " *> INLINED: %s\n" line; + let added = + Generated_type.Added { content = " *> INLINED:" ^ line } + in if i = end_loc.line then begin let copylines = EzString.split contents '\n' in let copylines = List.mapi (fun i line -> (filename, i + 1, line)) copylines in let lines = copylines @ lines in - output lines statements + added :: output lines statements end else - output_statement lines begin_loc stmt statements ) + added :: output_statement lines begin_loc stmt statements ) in - output lines sql_statements; + let result = output lines sql_statements in + let b = Buffer.create 1000 in + let ctxt = { b; main_filename = filename } in + Printf.bprintf ctxt.b "%s" + (Format.asprintf "%a" Generated_type.Printer.pp result); Buffer.contents b diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml new file mode 100644 index 000000000..f5eec7096 --- /dev/null +++ b/src/lsp/sql_preproc/generated_type.ml @@ -0,0 +1,125 @@ +type ref_value = + | Reference of + { prefix : string; + var : string + } + | Value of + { prefix : string; + var : string + } + +type error_treatment = + | Error_treatment of + { prefix : string; + condition : whenever_condition; + continuation : whenever_continuation + } + +and whenever_condition = + | Not_found_whenever + | SqlError_whenever + | SqlWarning_whenever + +and whenever_continuation = + | Continue + | Perform of string + | Goto of string + +type trans_stm = + | CallStatic of + { prefix : string; + fun_name : string; + ref_value : ref_value list (*Can be empty*) + } + | Copy of + { prefix : string; + file_name : string + } + +type generated_stm = + | NoChange of { content : string } + | Added of { content : string } + | Change of + { old_stms : string list; + trans_stm : trans_stm list; + error_treatment : error_treatment list; + with_dot : bool + } + +type generated = generated_stm list + +module Printer = struct + let rec pp fmt gen = + match gen with + | h :: t -> Format.fprintf fmt "%a%a" pp_gene h pp t + | [] -> () + + and pp_gene fmt x = + match x with + | NoChange { content } -> Format.fprintf fmt "%s\n" content + | Added { content } -> Format.fprintf fmt "%s\n" content + | Change { old_stms; trans_stm; error_treatment; with_dot } -> + let dot = + if with_dot then + "." + else + "" + in + Format.fprintf fmt "%a\n%a\n%a%s" pp_old_stms old_stms pp_trans_stm + trans_stm pp_error_treatment error_treatment dot + + and pp_old_stms fmt x = + match x with + | h :: t -> Format.fprintf fmt " *> REMOVED: %s\n%a" h pp_old_stms t + | [] -> () + + and pp_trans_stm fmt x = + match x with + | h :: t -> Format.fprintf fmt "%a\n%a" pp_trans_stm_aux h pp_trans_stm t + | [] -> () + + and pp_error_treatment fmt x = + match x with + | h :: t -> + Format.fprintf fmt "%a\n%a" pp_error_treatment_aux h pp_error_treatment t + | [] -> () + + and pp_trans_stm_aux fmt x = + match x with + | CallStatic { prefix; fun_name; ref_value } -> + Format.fprintf fmt "%sCALL STATIC \"%s\" USING\n%a\n%sEND-CALL\n" prefix + fun_name pp_ref_value_list ref_value prefix + | Copy { prefix; file_name } -> + Format.fprintf fmt "%sCOPY %s" prefix file_name + + and pp_error_treatment_aux fmt = function + | Error_treatment { prefix; condition; continuation } -> begin + let print_continuation fmt continuation = + match continuation with + | Continue -> Format.fprintf fmt "CONTINUE" + | Perform sqlVarToken -> Format.fprintf fmt "PERFORM %s" sqlVarToken + | Goto sqlVarToken -> Format.fprintf fmt "GOTO %s" sqlVarToken + in + match condition with + | Not_found_whenever -> + Format.fprintf fmt "%sWHEN SQLCODE = 100\n%s%a" prefix prefix + print_continuation continuation + | SqlError_whenever -> + Format.fprintf fmt "%sWHEN SQLCODE < 0\n%s%a" prefix prefix + print_continuation continuation + | SqlWarning_whenever -> + Format.fprintf fmt "%sWHEN SQLCODE < 0\n%s%a" prefix prefix + print_continuation continuation + end + + and pp_ref_value_list fmt x = + match x with + | h :: t -> Format.fprintf fmt "%a\n%a" pp_ref_value h pp_ref_value_list t + | [] -> () + + and pp_ref_value fmt x = + match x with + | Reference { prefix; var } -> + Format.fprintf fmt "%sBY REFERENCE %s" prefix var + | Value { prefix; var } -> Format.fprintf fmt "%sBY VALUE %s" prefix var +end diff --git a/src/lsp/sql_preproc/old_generate.ml b/src/lsp/sql_preproc/old_generate.ml new file mode 100644 index 000000000..1100084b7 --- /dev/null +++ b/src/lsp/sql_preproc/old_generate.ml @@ -0,0 +1,386 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +open EzCompat +open Types +open Sql_ast + +let linkage_section = + {| *> SQL addition in linkage section: + 01 SOME-ARG PIC X(9). +|} + +let begin_procedure_division ~ctxt:_ ~loc:_ = + (* We might want to add something at the begining of PROCEDURE DIVISION ? *) + () + +let end_procedure_division ~ctxt:_ ~loc:_ = + (* We might want to add something before the end of PROCEDURE DIVISION ? *) + () + +(* let strlit lit = Format.asprintf "%a" Printer.pp_lit lit *) + +(* let strlitopt = function + | Some lit -> Some (strlit lit) + | None -> None *) + +let cob_var_id_opt (cob_var : cobolVarId option) = + match cob_var with + | Some cob -> Some cob.payload + | None -> None + +let cob_var_opt = function + | Some var -> ( + match var with + | CobVarNotNull cobolVarId -> Some cobolVarId.payload + | CobVarNullIndicator (var, _) -> Some var.payload ) + | None -> None + +let var_opt = function + | Some var -> ( + match var with + | SqlVar sqlVarToken -> Some ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"") + | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) + | None -> None + +let generate ~filename ~contents ~cobol_unit sql_statements = + let working_storage_section, new_var_map = + Data_gestion.transform sql_statements + in + + let get_length str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.length + | None -> Sql_typeck.get_length cobol_unit str + in + + let get_some_cob_var_length (cob_var : cobolVarId option) = + match cob_var with + | Some x -> Some (get_length x.payload) + | None -> None + in + + let get_some_length var = + match var with + | Some (CobolVar (CobVarNotNull cobol_var)) -> + get_some_cob_var_length (Some cobol_var) + | _ -> None + in + + let get_type str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.vartype + | None -> Sql_typeck.get_type cobol_unit str + in + let get_scale str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.scale + | None -> Sql_typeck.get_scale cobol_unit str + in + let get_flags str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.flags + | None -> Sql_typeck.get_flags cobol_unit str + in + let get_ind_addr str = + match Data_gestion.find_opt new_var_map str with + | Some a -> a.ind_addr + | None -> Sql_typeck.get_ind_addr cobol_unit str + in + + + (* split lines and numerotate them *) + let lines = EzString.split contents '\n' in + let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in + (*string to add at the end of every sql processed*) + let error_treatment = ref "" in + let print_error_treatement ctxt = + if !error_treatment <> "" then ( + Printf.bprintf ctxt.b " EVALUATE TRUE\n"; + Printf.bprintf ctxt.b "%s\n" !error_treatment; + Printf.bprintf ctxt.b " END-EVALUATE\n" + ) + in + + (* The result will be stored in this buffer: *) + let b = Buffer.create 1000 in + + let ctxt = { b; main_filename = filename } in + let final_loc = { filename; line = -1; char = 0 } in + + let generatesql_connect ?(data_source = "x\"00\"") ?(data_source_tl = 0) + ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) + ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) ?(d_username = "x\"00\"") + ?(username_tl = 0) ?(d_password = "x\"00\"") ?(password_tl = 0) () = + " CALL STATIC \"GIXSQLConnect\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE " ^ data_source + ^ "\n BY VALUE " + ^ string_of_int data_source_tl + ^ "\n BY REFERENCE " ^ d_connection_id + ^ "\n BY VALUE " + ^ string_of_int connection_id_tl + ^ "\n BY REFERENCE " ^ d_dbname + ^ "\n BY VALUE " ^ string_of_int dbname_tl + ^ "\n BY REFERENCE " ^ d_username + ^ "\n BY VALUE " ^ string_of_int username_tl + ^ "\n BY REFERENCE " ^ d_password + ^ "\n BY VALUE " ^ string_of_int password_tl + ^ "\n END-CALL" + in + + let generatesql_connect_reset ?(d_connection_id = "x\"00\"") + ?(connection_id_tl = 0) () = + " CALL STATIC \"GIXSQLConnectReset\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE " ^ d_connection_id + ^ "\n BY VALUE " + ^ string_of_int connection_id_tl + ^ "\n END-CALL" + in + + let generate_whenever_continuation = function + | Continue -> "CONTINUE" + | Perform sqlVarToken -> "PERFORM " ^ sqlVarToken.payload + | Goto sqlVarToken -> "GOTO " ^ sqlVarToken.payload + in + + let generate_whenever c k = + match c with + | Not_found_whenever -> + " WHEN SQLCODE = 100\n " + ^ generate_whenever_continuation k + ^ "\n" + | SqlError_whenever -> + " WHEN SQLCODE < 0\n " + ^ generate_whenever_continuation k + ^ "\n" + | SqlWarning_whenever -> + " WHEN SQLCODE < 0\n " + ^ generate_whenever_continuation k + ^ "\n" + in + + let get_name_cobol_var (cobol_var : cobol_var) = + match cobol_var with + | CobVarNotNull c -> c.payload + | CobVarNullIndicator (c, n) -> c.payload ^ n.payload + in + + let rec generate_select_into_rec vars = + match vars with + | h :: t -> + let h = get_name_cobol_var h in + " CALL STATIC \"GIXSQLSetResultParams\" USING\n\ + \ BY VALUE " + ^ string_of_int (get_type h) + ^ "\n BY VALUE " + ^ string_of_int (get_length h) + ^ "\n BY VALUE " + ^ string_of_int (get_scale h) + ^ "\n BY VALUE " + ^ string_of_int (get_flags h) + ^ "\n BY REFERENCE " ^ h ^ "\n BY REFERENCE " + ^ string_of_int (get_ind_addr h) + ^ "\n END-CALL\n" ^ generate_select_into_rec t + | [] -> "" + in + let generate_select_into_one vars = + " CALL STATIC \"GIXSQLExecSelectIntoOne\" USING\n\ + \ BY REFERENCE SQLCA\n\ + \ BY REFERENCE x\"00\"\n\ + \ BY VALUE 0\n\ + \ BY REFERENCE SQ0001\n\ + \ BY VALUE 0\n\ + \ BY VALUE 5\n" + ^ string_of_int (List.length vars) + ^ "\n END-CALL\n" + in + + let generate_select_into vars = + " CALL STATIC \"GIXSQLStartSQL\"\n END-CALL" + ^ generate_select_into_rec vars + ^ generate_select_into_one vars + ^ " CALL STATIC \"GIXSQLEndSQL\"\n END-CALL\n" + in + + let generatesql ~loc ~line ~ctxt esql_instuction = + match esql_instuction with + | Include sqlvar -> + let before_macro = String.sub line 0 loc.char in + Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload; + print_error_treatement ctxt + | Connect cs -> + begin + match cs with + | Connect_reset lit -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect_reset ?d_connection_id:(var_opt lit) ()) + | Connect_to_idby + { dbname; db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_dbname:dbname.payload + ~dbname_tl:(get_length dbname.payload) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () ) + | Connect_to { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ?d_password:(cob_var_id_opt password) + ?password_tl:(get_some_cob_var_length password) + () ) + | Connect_using { db_data_source } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect ~data_source:db_data_source.payload + ~data_source_tl:(get_length db_data_source.payload) + () ) + | Connect_user { db_conn_id; db_data_source; username; password } -> + Printf.bprintf ctxt.b "%s" + (generatesql_connect + ?data_source:(cob_var_id_opt db_data_source) + ?data_source_tl:(get_some_cob_var_length db_data_source) + ?d_connection_id:(var_opt db_conn_id) + ?connection_id_tl:(get_some_length db_conn_id) + ~d_username:username.payload + ~username_tl:(get_length username.payload) + ~d_password:password.payload + ~password_tl:(get_length password.payload) + () ) + end; + print_error_treatement ctxt + | Whenever (c, k) -> + error_treatment := generate_whenever c k ^ !error_treatment + | SelectInto { vars; _ } -> + Printf.bprintf ctxt.b "%s" (generate_select_into vars) + | _ -> ignore (loc, line, ctxt, esql_instuction) + in + + let rec output lines statements = + match statements with + | [] -> + List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines + | (begin_loc, stmt) :: statements -> begin + match begin_loc with + | None -> + List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines; + begin + match stmt with + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:final_loc + | _ -> () + end + | Some begin_loc -> output_statement lines begin_loc stmt statements + end + and output_statement cur_lines begin_loc stmt statements = + match cur_lines with + | [] -> assert false + | (filename, i, line) :: lines -> ( + if filename <> begin_loc.filename || i < begin_loc.line then begin + Printf.bprintf ctxt.b "%s\n" line; + output_statement lines begin_loc stmt statements + end else + match stmt with + | LINKAGE_SECTION { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b linkage_section; + output lines statements + end else begin + Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; + Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; + Buffer.add_string ctxt.b linkage_section; + output cur_lines statements + end + | WORKING_STORAGE { defined } -> + if defined then begin + Printf.bprintf ctxt.b "%s\n" line; + Buffer.add_string ctxt.b working_storage_section; + output lines statements + end else begin + Printf.bprintf ctxt.b + " *> Add missing WORKING-STORAGE SECTION\n"; + Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; + Buffer.add_string ctxt.b working_storage_section; + output cur_lines statements + end + | EXEC_SQL { end_loc; with_dot; tokens } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + generatesql ~loc:begin_loc ~line ~ctxt tokens; + (* ignore (tokens); *) + Misc.add_dot ~with_dot b; + output lines statements + end else + output_statement lines begin_loc stmt statements + | PROCEDURE_DIVISION_DOT { end_loc } -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + if i = end_loc.line then begin + (* for now, just put it back *) + Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; + output lines statements + end else + output_statement lines begin_loc stmt statements + | DECLARATION _ -> + Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; + output lines statements + (* | IS_SQLVAR { end_loc } -> + if i = begin_loc.line then begin + let before_macro = String.sub line 0 begin_loc.char in + Printf.bprintf ctxt.b "%s%s" before_macro + "SOME STRING THAT REPLACE IS SQLVAR"; + if begin_loc.line <> end_loc.line then + Printf.bprintf ctxt.b "\n " + end; + if i = end_loc.line then ( + let len = String.length line in + (* This code won't work with tabulations, because + the end_loc.char is wrong in such a case *) + let after_macro = + String.sub line (end_loc.char + 1) (len - end_loc.char - 1) + in + Printf.bprintf ctxt.b "%s\n" after_macro; + output lines statements + ) else + output_statement lines begin_loc stmt statements *) + | BEGIN_PROCEDURE_DIVISION { enabled } -> + if !enabled then + begin_procedure_division ~ctxt ~loc:begin_loc + else + Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; + output cur_lines statements + | END_PROCEDURE_DIVISION -> + end_procedure_division ~ctxt ~loc:begin_loc; + output cur_lines statements + | COPY { end_loc; filename; contents } -> + Printf.bprintf ctxt.b " *> INLINED: %s\n" line; + if i = end_loc.line then begin + let copylines = EzString.split contents '\n' in + let copylines = + List.mapi (fun i line -> (filename, i + 1, line)) copylines + in + let lines = copylines @ lines in + output lines statements + end else + output_statement lines begin_loc stmt statements ) + in + output lines sql_statements; + Buffer.contents b diff --git a/src/lsp/sql_preproc/transform.mli b/src/lsp/sql_preproc/old_generate.mli similarity index 87% rename from src/lsp/sql_preproc/transform.mli rename to src/lsp/sql_preproc/old_generate.mli index 066f2a563..c85c14211 100644 --- a/src/lsp/sql_preproc/transform.mli +++ b/src/lsp/sql_preproc/old_generate.mli @@ -8,7 +8,9 @@ (* *) (**************************************************************************) -val transform : - Cobol_unit.Types.cobol_unit -> +val generate : + filename:string -> + contents:string -> + cobol_unit:Cobol_unit.Types.cobol_unit -> (Types.loc option * Types.statements) list -> - (string * Cobol_unit.Types.cobol_unit) + string diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 10827eb6f..e9f6514a1 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -21,7 +21,7 @@ let rec find_dot tokens = let parse ~config ~filename ~contents = let program_id = ref None in let sql_statements = ref [] in -(* let var_statements = ref [] in *) + (* let var_statements = ref [] in *) let procedure_division_found = ref None in let working_storage_found = ref false in let linkage_section_found = ref false in @@ -41,12 +41,21 @@ let parse ~config ~filename ~contents = Misc.error ~loc "multiple programs in the same file are not supported" end; iter tokens - (*TODO: Other case gestion (ex: 01 NUM1 PIC 99V99.)*) -(* | (NUMBER priority, loc) :: (IDENT name, _ ) :: (IDENT "PIC", _ ) :: (IDENT var_type, _ ) :: (LPAREN, _ ) :: (IDENT size, _ ) :: (RPAREN, _ ) :: tokens -> - var_add_statement ~loc (priority, name, var_type, size); - iter tokens *) - | (IDENT "IS", loc) :: (IDENT "SQLVAR", end_loc) :: tokens -> - sql_add_statement ~loc (IS_SQLVAR { end_loc }); + (*Exemple : 01 VCFLD SQL TYPE IS VARCHAR(100).*) + | (INTEGER importance, loc) + :: (IDENT name, _) + :: (IDENT "SQL", _) + :: (IDENT "TYPE", _) + :: (IDENT "IS", _) + :: (IDENT sql_type, _) + :: (LPAREN, _) + :: (INTEGER sql_type_size, _) + :: (RPAREN, end_loc) + :: tokens -> + let declaration = + SQL_type_is { importance; name; sql_type; sql_type_size } + in + sql_add_statement ~loc (DECLARATION { end_loc; declaration }); iter tokens | (PROCEDURE, loc) :: (DIVISION, _) :: tokens -> let end_loc, tokens = find_dot tokens in @@ -155,12 +164,12 @@ let parse ~config ~filename ~contents = let params = List.rev params in let sqlStr = "EXEC SQL " ^ String.concat " " params ^ " END-EXEC" in (* Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; - *) + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) + let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in - (* Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; - *) +(* Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; *) + sql_add_statement ~loc (EXEC_SQL { end_loc; with_dot; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." diff --git a/src/lsp/sql_preproc/sql_typeck.ml b/src/lsp/sql_preproc/sql_typeck.ml index de03250c7..3bf1403af 100644 --- a/src/lsp/sql_preproc/sql_typeck.ml +++ b/src/lsp/sql_preproc/sql_typeck.ml @@ -10,33 +10,66 @@ open Cobol_data.Types -let get_x_info (cu:Cobol_unit.Types.cobol_unit) name_str = +let get_x_info (cu : Cobol_unit.Types.cobol_unit) name_str = (* May raise Not_found | Cobol_unit.Qualmap.Ambiguous _ *) - try Cobol_unit.Qualmap.find - (Cobol_unit.Qual.name - (Cobol_common.Srcloc.flagit name_str Cobol_common.Srcloc.dummy) ) - cu.unit_data.data_items.named - with - | Not_found -> Pretty.out " \"%s\" not found " name_str; failwith "Var not found" - | Cobol_unit.Qualmap.Ambiguous _ -> Pretty.out " \"%s\" not found. qualname nel lazy_t found" name_str; failwith "Var not found" + (Cobol_unit.Qual.name + (Cobol_common.Srcloc.flagit name_str Cobol_common.Srcloc.dummy) ) + cu.unit_data.data_items.named +let get_length cu name = + try + let x_info = get_x_info cu name in + match x_info with + | Data_field { def = { payload = { field_size; _ }; _ }; _ } -> + let size = Cobol_data.Memory.(as_bits field_size / 8) in + (* Pretty.out "Size of \"%s\" is %u Bytes@." name size; *) + size + | _ -> 0 + with + | Not_found -> + (* Pretty.out " \"%s\" not found " name; *) + 0 + | Cobol_unit.Qualmap.Ambiguous _ -> + (* Pretty.out " \"%s\" not found. qualname nel lazy_t found" name; *) + 0 +(*TODO*) +let get_type _cu _name = 16 -let get_size cu name = - let x_info = get_x_info cu name - in - match x_info with - | Data_field { def = { payload = { field_size; _ }; _ }; _ } -> - let size = Cobol_data.Memory.(as_bits field_size / 8) in - Pretty.out "Size of \"%s\" is %u Bytes@." name size; - size - | _ -> 0 +let get_scale cu name = + try + let x_info = get_x_info cu name in + match x_info with + | Data_field { def = { payload = { field_layout; _ }; _ }; _ } -> begin + match field_layout with + | Elementary_field { usage = Display picture; _ } -> ( + match picture.category with + | FixedNum { scale; _ } + | FloatNum { scale; _ } -> + scale + | _ -> 0 ) + | Elementary_field _ + | Struct_field _ -> + 0 + end + | _ -> 0 + with + | Not_found -> + (* Pretty.out " \"%s\" not found " name; *) + 0 + | Cobol_unit.Qualmap.Ambiguous _ -> + (* Pretty.out " \"%s\" not found. qualname nel lazy_t found" name; *) + 0 + +(*TODO*) +let get_flags _cu _name = 0 +(*TODO*) +let get_ind_addr _cu _name = 0 -let print_name (cu:Cobol_unit.Types.cobol_unit) = - let x_info = get_x_info cu "VBFLD" - in +let print_name (cu : Cobol_unit.Types.cobol_unit) = + let x_info = get_x_info cu "VBFLD" in match x_info with | Data_field { def = { payload = { field_layout; field_size; _ }; _ }; _ } -> Pretty.out "Size of VBFLD is %u Bytes@." diff --git a/src/lsp/sql_preproc/transform.ml b/src/lsp/sql_preproc/transform.ml deleted file mode 100644 index 05ea734f5..000000000 --- a/src/lsp/sql_preproc/transform.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2021-2023 OCamlPro SAS *) -(* *) -(* All rights reserved. *) -(* This file is distributed under the terms of the *) -(* OCAMLPRO-NON-COMMERCIAL license. *) -(* *) -(**************************************************************************) - -open Sql_ast -open Types - -let num = ref 0 - -let transform_stm (_, stm) = - match stm with - | EXEC_SQL { tokens; _ } -> ( - match tokens with - | SelectInto { select; select_options; _ } -> - let s = Format.asprintf "SELECT %a%a" Printer.pp_select_lst select Printer.pp_select_options_lst select_options in - let size = String.length s in - num:=!num+1; - " 01 SQ"^string_of_int !num^".\n\ - \ 02 FILLER PIC X("^string_of_int size^") VALUE \"" ^ s ^ "\".\n\ - \ 02 FILLER PIC X(1) VALUE X\"00\".\n" - | _ -> "" ) - | _ -> "" - -let rec transform cobol_unit sql_statements = - match sql_statements with - | h :: t -> - let (sql, _) = transform cobol_unit t in - (transform_stm h ^ sql, cobol_unit) - | [] -> ("", cobol_unit) diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml index 0d25078f8..a3a8eb100 100644 --- a/src/lsp/sql_preproc/types.ml +++ b/src/lsp/sql_preproc/types.ml @@ -19,6 +19,10 @@ type loc = { filename : string ; line : int ; char : int } +(* type sql_type = BINARY | VARBINARY | CHAR | VARCHAR *) +type declaration = + | SQL_type_is of { importance:string; name:string; sql_type : string; sql_type_size : string } + (* These statements show how we could keep information and modify the corresponding places in the code *) @@ -33,7 +37,8 @@ type statements = | BEGIN_PROCEDURE_DIVISION of { enabled : bool ref } | END_PROCEDURE_DIVISION | COPY of { end_loc : loc ; filename : string ; contents : string } - | IS_SQLVAR of { end_loc : loc } +(* | IS_SQLVAR of { end_loc : loc } *) + | DECLARATION of { end_loc:loc; declaration : declaration } type handle = { From 213d2d1d9271c13aa9bedaa26a276d31369bf5d0 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Mon, 29 Jul 2024 12:28:51 +0200 Subject: [PATCH 08/37] Start transaction --- src/lsp/sql_preproc/data_gestion.ml | 1 + src/lsp/sql_preproc/generate.ml | 92 ++++-- src/lsp/sql_preproc/generated_type.ml | 19 +- src/lsp/sql_preproc/old_generate.ml | 386 -------------------------- src/lsp/sql_preproc/old_generate.mli | 16 -- 5 files changed, 83 insertions(+), 431 deletions(-) delete mode 100644 src/lsp/sql_preproc/old_generate.ml delete mode 100644 src/lsp/sql_preproc/old_generate.mli diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 8e8f7aa96..a3341a36d 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -47,6 +47,7 @@ let transform_stm map (_, stm) = (Format.asprintf "SELECT %a%a" Printer.pp_select_lst select Printer.pp_select_options_lst select_options ) | Begin -> create_new_var ("BEGIN") + | StartTransaction -> create_new_var("START TRANSACTION") | _ -> ("", map) ) | DECLARATION { declaration; _ } -> ( match declaration with diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index be0bd2781..cefbca2c2 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -112,6 +112,19 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in (*GENERATE FUNCTION*) + let generate_start_end_sql prefix smt = + let startSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLStartSQL"; ref_value = [] } + in + let endSql = + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLEndSQL"; ref_value = [] } + in + let trans_stm = (startSql :: smt) @ [ endSql ] in + trans_stm + in + let generatesql_connect_reset ~prefix ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) () = let fun_name = "GIXSQLConnectReset" in @@ -150,6 +163,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let generatesql_connect cs prefix = + (*TODO: Some of these a unsuported in gixSql -> emit a preproc warning + list of unsuported connection: + mode 5 and 6 when named ("AT/AS db_conn_id ") + mode 4 (ex: CONNECT :DBUSR IDENTIFIED BY :DBPWD)*) match cs with | Connect_reset lit -> [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) @@ -258,27 +275,42 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let generate_select_into prefix vars = - let startSql = - Generated_type.CallStatic - { prefix; fun_name = "GIXSQLStartSQL"; ref_value = [] } - in let selects_into_vars = List.map (generate_select_into_rec prefix) vars in let selects_into = generate_select_into_one prefix vars in - let endSql = - Generated_type.CallStatic - { prefix; fun_name = "GIXSQLEndSQL"; ref_value = [] } - in let trans_stm = - (startSql :: selects_into_vars) @ (selects_into :: [ endSql ]) + generate_start_end_sql prefix (selects_into_vars @ [ selects_into ]) in trans_stm in - let generate_declare prefix = - let startSql = - Generated_type.CallStatic - { prefix; fun_name = "GIXSQLStartSQL"; ref_value = [] } + let generate_GIXSQLExec prefix name = + let fun_name = "GIXSQLExec" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = "\"" ^ name ^ "\" & x\"00\"" } + ] in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generate_rollback prefix rb_work_or_tran rb_args = + match (rb_work_or_tran, rb_args) with + | None, None -> + generate_start_end_sql prefix [ generate_GIXSQLExec prefix "ROLLBACK" ] + | _ -> [ Generated_type.Todo { prefix } ] + in + + let generate_commit prefix rb_work_or_tran rb_args = + match (rb_work_or_tran, rb_args) with + | None, false -> + generate_start_end_sql prefix [ generate_GIXSQLExec prefix "COMMIT" ] + | _ -> [ Generated_type.Todo { prefix } ] + in + + let generate_declare prefix = let fun_name = "GIXSQLExec" in let ref_value = let var_name = @@ -294,14 +326,27 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let declare = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let endSql = - Generated_type.CallStatic - { prefix; fun_name = "GIXSQLEndSQL"; ref_value = [] } - in - let trans_stm = startSql :: declare :: [ endSql ] in + let trans_stm = generate_start_end_sql prefix [ declare ] in trans_stm in +let generate_close_cursor prefix sql_var_token = + let fun_name = "GIXSQLCursorClose" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = "\"" ^ sql_var_token ^ "\" x\"00\"" } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } + +in + + (* GIXSQL CALL STATIC "GIXSQLCursorClose" USING +GIXSQL BY REFERENCE SQLCA +GIXSQL BY REFERENCE "TSQL029A_CRSR02" & x"00" +GIXSQL END-CALL. *) + let generatesql ~loc ~line esql_instuction = let prefix = String.sub line 0 loc.char in match esql_instuction with @@ -311,6 +356,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | Connect cs -> generatesql_connect cs prefix | Disconnect lit -> [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) () ] + | DisconnectAll -> [ generatesql_connect_reset ~prefix ?d_connection_id:(Some "\"*\" & x\"00\"") () ] | Whenever (c, k) -> error_treatment := generate_whenever ~prefix c k :: !error_treatment; [] @@ -319,13 +365,14 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | BeginDeclare | EndDeclare -> [] (*do nothing*) - | StartTransaction - | DisconnectAll + | Rollback (rb_work_or_tran, rb_args) -> + generate_rollback prefix rb_work_or_tran rb_args + | Commit (rb_work_or_tran, b) -> generate_commit prefix rb_work_or_tran b + | Close var -> [generate_close_cursor prefix var.payload] + | StartTransaction -> generate_declare prefix | At (_, _) | Sql _ | Exeption _ - | Rollback (_, _) - | Commit (_, _) | Savepoint _ | DeclareTable (_, _) | DeclareCursor _ @@ -333,7 +380,6 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | ExecuteImmediate _ | ExecuteIntoUsing _ | Open (_, _) - | Close _ | Fetch (_, _) | Insert (_, _) | Delete _ diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index f5eec7096..8ed891619 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -22,8 +22,8 @@ and whenever_condition = and whenever_continuation = | Continue - | Perform of string - | Goto of string + | Perform of string + | Goto of string type trans_stm = | CallStatic of @@ -35,6 +35,7 @@ type trans_stm = { prefix : string; file_name : string } + | Todo of { prefix : string } type generated_stm = | NoChange of { content : string } @@ -65,7 +66,7 @@ module Printer = struct else "" in - Format.fprintf fmt "%a\n%a\n%a%s" pp_old_stms old_stms pp_trans_stm + Format.fprintf fmt "%a\n%a%a%s" pp_old_stms old_stms pp_trans_stm trans_stm pp_error_treatment error_treatment dot and pp_old_stms fmt x = @@ -87,10 +88,11 @@ module Printer = struct and pp_trans_stm_aux fmt x = match x with | CallStatic { prefix; fun_name; ref_value } -> - Format.fprintf fmt "%sCALL STATIC \"%s\" USING\n%a\n%sEND-CALL\n" prefix - fun_name pp_ref_value_list ref_value prefix + Format.fprintf fmt "%sCALL STATIC \"%s\"%a%sEND-CALL" prefix fun_name + pp_ref_value_list ref_value prefix | Copy { prefix; file_name } -> Format.fprintf fmt "%sCOPY %s" prefix file_name + | Todo { prefix } -> Format.fprintf fmt "%sTODO" prefix and pp_error_treatment_aux fmt = function | Error_treatment { prefix; condition; continuation } -> begin @@ -113,9 +115,14 @@ module Printer = struct end and pp_ref_value_list fmt x = + let rec pp_ref_value_list_aux fmt x = + match x with + | h :: t -> Format.fprintf fmt "%a\n%a" pp_ref_value h pp_ref_value_list_aux t + | [] -> () + in match x with - | h :: t -> Format.fprintf fmt "%a\n%a" pp_ref_value h pp_ref_value_list t | [] -> () + | _ -> Format.fprintf fmt " USING\n%a" pp_ref_value_list_aux x and pp_ref_value fmt x = match x with diff --git a/src/lsp/sql_preproc/old_generate.ml b/src/lsp/sql_preproc/old_generate.ml deleted file mode 100644 index 1100084b7..000000000 --- a/src/lsp/sql_preproc/old_generate.ml +++ /dev/null @@ -1,386 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2021-2023 OCamlPro SAS *) -(* *) -(* All rights reserved. *) -(* This file is distributed under the terms of the *) -(* OCAMLPRO-NON-COMMERCIAL license. *) -(* *) -(**************************************************************************) - -open EzCompat -open Types -open Sql_ast - -let linkage_section = - {| *> SQL addition in linkage section: - 01 SOME-ARG PIC X(9). -|} - -let begin_procedure_division ~ctxt:_ ~loc:_ = - (* We might want to add something at the begining of PROCEDURE DIVISION ? *) - () - -let end_procedure_division ~ctxt:_ ~loc:_ = - (* We might want to add something before the end of PROCEDURE DIVISION ? *) - () - -(* let strlit lit = Format.asprintf "%a" Printer.pp_lit lit *) - -(* let strlitopt = function - | Some lit -> Some (strlit lit) - | None -> None *) - -let cob_var_id_opt (cob_var : cobolVarId option) = - match cob_var with - | Some cob -> Some cob.payload - | None -> None - -let cob_var_opt = function - | Some var -> ( - match var with - | CobVarNotNull cobolVarId -> Some cobolVarId.payload - | CobVarNullIndicator (var, _) -> Some var.payload ) - | None -> None - -let var_opt = function - | Some var -> ( - match var with - | SqlVar sqlVarToken -> Some ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"") - | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) - | None -> None - -let generate ~filename ~contents ~cobol_unit sql_statements = - let working_storage_section, new_var_map = - Data_gestion.transform sql_statements - in - - let get_length str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.length - | None -> Sql_typeck.get_length cobol_unit str - in - - let get_some_cob_var_length (cob_var : cobolVarId option) = - match cob_var with - | Some x -> Some (get_length x.payload) - | None -> None - in - - let get_some_length var = - match var with - | Some (CobolVar (CobVarNotNull cobol_var)) -> - get_some_cob_var_length (Some cobol_var) - | _ -> None - in - - let get_type str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.vartype - | None -> Sql_typeck.get_type cobol_unit str - in - let get_scale str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.scale - | None -> Sql_typeck.get_scale cobol_unit str - in - let get_flags str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.flags - | None -> Sql_typeck.get_flags cobol_unit str - in - let get_ind_addr str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.ind_addr - | None -> Sql_typeck.get_ind_addr cobol_unit str - in - - - (* split lines and numerotate them *) - let lines = EzString.split contents '\n' in - let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in - (*string to add at the end of every sql processed*) - let error_treatment = ref "" in - let print_error_treatement ctxt = - if !error_treatment <> "" then ( - Printf.bprintf ctxt.b " EVALUATE TRUE\n"; - Printf.bprintf ctxt.b "%s\n" !error_treatment; - Printf.bprintf ctxt.b " END-EVALUATE\n" - ) - in - - (* The result will be stored in this buffer: *) - let b = Buffer.create 1000 in - - let ctxt = { b; main_filename = filename } in - let final_loc = { filename; line = -1; char = 0 } in - - let generatesql_connect ?(data_source = "x\"00\"") ?(data_source_tl = 0) - ?(d_connection_id = "x\"00\"") ?(connection_id_tl = 0) - ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) ?(d_username = "x\"00\"") - ?(username_tl = 0) ?(d_password = "x\"00\"") ?(password_tl = 0) () = - " CALL STATIC \"GIXSQLConnect\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE " ^ data_source - ^ "\n BY VALUE " - ^ string_of_int data_source_tl - ^ "\n BY REFERENCE " ^ d_connection_id - ^ "\n BY VALUE " - ^ string_of_int connection_id_tl - ^ "\n BY REFERENCE " ^ d_dbname - ^ "\n BY VALUE " ^ string_of_int dbname_tl - ^ "\n BY REFERENCE " ^ d_username - ^ "\n BY VALUE " ^ string_of_int username_tl - ^ "\n BY REFERENCE " ^ d_password - ^ "\n BY VALUE " ^ string_of_int password_tl - ^ "\n END-CALL" - in - - let generatesql_connect_reset ?(d_connection_id = "x\"00\"") - ?(connection_id_tl = 0) () = - " CALL STATIC \"GIXSQLConnectReset\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE " ^ d_connection_id - ^ "\n BY VALUE " - ^ string_of_int connection_id_tl - ^ "\n END-CALL" - in - - let generate_whenever_continuation = function - | Continue -> "CONTINUE" - | Perform sqlVarToken -> "PERFORM " ^ sqlVarToken.payload - | Goto sqlVarToken -> "GOTO " ^ sqlVarToken.payload - in - - let generate_whenever c k = - match c with - | Not_found_whenever -> - " WHEN SQLCODE = 100\n " - ^ generate_whenever_continuation k - ^ "\n" - | SqlError_whenever -> - " WHEN SQLCODE < 0\n " - ^ generate_whenever_continuation k - ^ "\n" - | SqlWarning_whenever -> - " WHEN SQLCODE < 0\n " - ^ generate_whenever_continuation k - ^ "\n" - in - - let get_name_cobol_var (cobol_var : cobol_var) = - match cobol_var with - | CobVarNotNull c -> c.payload - | CobVarNullIndicator (c, n) -> c.payload ^ n.payload - in - - let rec generate_select_into_rec vars = - match vars with - | h :: t -> - let h = get_name_cobol_var h in - " CALL STATIC \"GIXSQLSetResultParams\" USING\n\ - \ BY VALUE " - ^ string_of_int (get_type h) - ^ "\n BY VALUE " - ^ string_of_int (get_length h) - ^ "\n BY VALUE " - ^ string_of_int (get_scale h) - ^ "\n BY VALUE " - ^ string_of_int (get_flags h) - ^ "\n BY REFERENCE " ^ h ^ "\n BY REFERENCE " - ^ string_of_int (get_ind_addr h) - ^ "\n END-CALL\n" ^ generate_select_into_rec t - | [] -> "" - in - let generate_select_into_one vars = - " CALL STATIC \"GIXSQLExecSelectIntoOne\" USING\n\ - \ BY REFERENCE SQLCA\n\ - \ BY REFERENCE x\"00\"\n\ - \ BY VALUE 0\n\ - \ BY REFERENCE SQ0001\n\ - \ BY VALUE 0\n\ - \ BY VALUE 5\n" - ^ string_of_int (List.length vars) - ^ "\n END-CALL\n" - in - - let generate_select_into vars = - " CALL STATIC \"GIXSQLStartSQL\"\n END-CALL" - ^ generate_select_into_rec vars - ^ generate_select_into_one vars - ^ " CALL STATIC \"GIXSQLEndSQL\"\n END-CALL\n" - in - - let generatesql ~loc ~line ~ctxt esql_instuction = - match esql_instuction with - | Include sqlvar -> - let before_macro = String.sub line 0 loc.char in - Printf.bprintf ctxt.b "%sCOPY %s\n" before_macro sqlvar.payload; - print_error_treatement ctxt - | Connect cs -> - begin - match cs with - | Connect_reset lit -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect_reset ?d_connection_id:(var_opt lit) ()) - | Connect_to_idby - { dbname; db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_dbname:dbname.payload - ~dbname_tl:(get_length dbname.payload) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ~d_password:password.payload - ~password_tl:(get_length password.payload) - () ) - | Connect_to { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ?d_password:(cob_var_id_opt password) - ?password_tl:(get_some_cob_var_length password) - () ) - | Connect_using { db_data_source } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect ~data_source:db_data_source.payload - ~data_source_tl:(get_length db_data_source.payload) - () ) - | Connect_user { db_conn_id; db_data_source; username; password } -> - Printf.bprintf ctxt.b "%s" - (generatesql_connect - ?data_source:(cob_var_id_opt db_data_source) - ?data_source_tl:(get_some_cob_var_length db_data_source) - ?d_connection_id:(var_opt db_conn_id) - ?connection_id_tl:(get_some_length db_conn_id) - ~d_username:username.payload - ~username_tl:(get_length username.payload) - ~d_password:password.payload - ~password_tl:(get_length password.payload) - () ) - end; - print_error_treatement ctxt - | Whenever (c, k) -> - error_treatment := generate_whenever c k ^ !error_treatment - | SelectInto { vars; _ } -> - Printf.bprintf ctxt.b "%s" (generate_select_into vars) - | _ -> ignore (loc, line, ctxt, esql_instuction) - in - - let rec output lines statements = - match statements with - | [] -> - List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines - | (begin_loc, stmt) :: statements -> begin - match begin_loc with - | None -> - List.iter (fun (_, _, line) -> Printf.bprintf ctxt.b "%s\n" line) lines; - begin - match stmt with - | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:final_loc - | _ -> () - end - | Some begin_loc -> output_statement lines begin_loc stmt statements - end - and output_statement cur_lines begin_loc stmt statements = - match cur_lines with - | [] -> assert false - | (filename, i, line) :: lines -> ( - if filename <> begin_loc.filename || i < begin_loc.line then begin - Printf.bprintf ctxt.b "%s\n" line; - output_statement lines begin_loc stmt statements - end else - match stmt with - | LINKAGE_SECTION { defined } -> - if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b linkage_section; - output lines statements - end else begin - Printf.bprintf ctxt.b " *> Add missing LINKAGE SECTION\n"; - Printf.bprintf ctxt.b " LINKAGE SECTION.\n"; - Buffer.add_string ctxt.b linkage_section; - output cur_lines statements - end - | WORKING_STORAGE { defined } -> - if defined then begin - Printf.bprintf ctxt.b "%s\n" line; - Buffer.add_string ctxt.b working_storage_section; - output lines statements - end else begin - Printf.bprintf ctxt.b - " *> Add missing WORKING-STORAGE SECTION\n"; - Printf.bprintf ctxt.b " WORKING-STORAGE SECTION.\n"; - Buffer.add_string ctxt.b working_storage_section; - output cur_lines statements - end - | EXEC_SQL { end_loc; with_dot; tokens } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; - if i = end_loc.line then begin - generatesql ~loc:begin_loc ~line ~ctxt tokens; - (* ignore (tokens); *) - Misc.add_dot ~with_dot b; - output lines statements - end else - output_statement lines begin_loc stmt statements - | PROCEDURE_DIVISION_DOT { end_loc } -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; - if i = end_loc.line then begin - (* for now, just put it back *) - Printf.bprintf ctxt.b " PROCEDURE DIVISION.\n"; - output lines statements - end else - output_statement lines begin_loc stmt statements - | DECLARATION _ -> - Printf.bprintf ctxt.b " *> REMOVED: %s\n" line; - output lines statements - (* | IS_SQLVAR { end_loc } -> - if i = begin_loc.line then begin - let before_macro = String.sub line 0 begin_loc.char in - Printf.bprintf ctxt.b "%s%s" before_macro - "SOME STRING THAT REPLACE IS SQLVAR"; - if begin_loc.line <> end_loc.line then - Printf.bprintf ctxt.b "\n " - end; - if i = end_loc.line then ( - let len = String.length line in - (* This code won't work with tabulations, because - the end_loc.char is wrong in such a case *) - let after_macro = - String.sub line (end_loc.char + 1) (len - end_loc.char - 1) - in - Printf.bprintf ctxt.b "%s\n" after_macro; - output lines statements - ) else - output_statement lines begin_loc stmt statements *) - | BEGIN_PROCEDURE_DIVISION { enabled } -> - if !enabled then - begin_procedure_division ~ctxt ~loc:begin_loc - else - Printf.bprintf ctxt.b " *> BEGIN PROCEDURE DIVISION disabled\n"; - output cur_lines statements - | END_PROCEDURE_DIVISION -> - end_procedure_division ~ctxt ~loc:begin_loc; - output cur_lines statements - | COPY { end_loc; filename; contents } -> - Printf.bprintf ctxt.b " *> INLINED: %s\n" line; - if i = end_loc.line then begin - let copylines = EzString.split contents '\n' in - let copylines = - List.mapi (fun i line -> (filename, i + 1, line)) copylines - in - let lines = copylines @ lines in - output lines statements - end else - output_statement lines begin_loc stmt statements ) - in - output lines sql_statements; - Buffer.contents b diff --git a/src/lsp/sql_preproc/old_generate.mli b/src/lsp/sql_preproc/old_generate.mli deleted file mode 100644 index c85c14211..000000000 --- a/src/lsp/sql_preproc/old_generate.mli +++ /dev/null @@ -1,16 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2021-2023 OCamlPro SAS *) -(* *) -(* All rights reserved. *) -(* This file is distributed under the terms of the *) -(* OCAMLPRO-NON-COMMERCIAL license. *) -(* *) -(**************************************************************************) - -val generate : - filename:string -> - contents:string -> - cobol_unit:Cobol_unit.Types.cobol_unit -> - (Types.loc option * Types.statements) list -> - string From 500b28411ba22d0781c36a2522213bcbac6905da Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Mon, 29 Jul 2024 13:05:31 +0200 Subject: [PATCH 09/37] drom --- .drom | 8 ++++---- opam/sql_preproc.opam | 2 +- src/lsp/sql_preproc/version.mlt | 2 +- src/vendor/ez_toml/dune | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.drom b/.drom index 6aee5ab77..2038a1952 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -7a4cef2517d11b7e1d1bb11f8c16913c:. +878df3cde45b12780e5fa7889241d3c2:. # end context for . # begin context for .github/workflows/workflow.yml @@ -185,7 +185,7 @@ ec375db9ddc4ed967f4099edcb93ea4e:opam/pretty.opam # begin context for opam/sql_preproc.opam # file opam/sql_preproc.opam -71904574a5ea8c45065594c6f5f0f92f:opam/sql_preproc.opam +543cdcbf21d4c759fe2315e53fd42d03:opam/sql_preproc.opam # end context for opam/sql_preproc.opam # begin context for opam/superbol-free.opam @@ -470,7 +470,7 @@ e0c73ea039315b0cfa5b4a7ac54a1484:src/lsp/sql_ast/dune # begin context for src/lsp/sql_preproc/version.mlt # file src/lsp/sql_preproc/version.mlt -32d077864212af27904137e71df668a7:src/lsp/sql_preproc/version.mlt +de6c46a271140f4f52b2580e0d876351:src/lsp/sql_preproc/version.mlt # end context for src/lsp/sql_preproc/version.mlt # begin context for src/lsp/superbol-free/dune @@ -525,7 +525,7 @@ b3a1a4662424391d83d94daf0c79756b:src/superbol-studio-oss/dune # begin context for src/vendor/ez_toml/dune # file src/vendor/ez_toml/dune -87fe96c228b8cb51be7268c7e3cdd5b5:src/vendor/ez_toml/dune +aad8ac8a26ae15e3501dd5ea3b49ec9a:src/vendor/ez_toml/dune # end context for src/vendor/ez_toml/dune # begin context for src/vendor/ez_toml/index.mld diff --git a/opam/sql_preproc.opam b/opam/sql_preproc.opam index aac275da4..cc1deae08 100644 --- a/opam/sql_preproc.opam +++ b/opam/sql_preproc.opam @@ -2,7 +2,7 @@ # Do not modify, or add to the `skip` field of `drom.toml`. opam-version: "2.0" name: "sql_preproc" -version: "0.1.3" +version: "0.1.4" license: "MIT" synopsis: "SuperBOL Studio OSS Project" description: "SuperBOL Studio OSS is a new platform for COBOL" diff --git a/src/lsp/sql_preproc/version.mlt b/src/lsp/sql_preproc/version.mlt index c4b5410bf..53cdfe262 100644 --- a/src/lsp/sql_preproc/version.mlt +++ b/src/lsp/sql_preproc/version.mlt @@ -18,7 +18,7 @@ let commit_hash = query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") let commit_date = query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") -let version = "0.1.3" +let version = "0.1.4" let string_option = function | None -> "None" diff --git a/src/vendor/ez_toml/dune b/src/vendor/ez_toml/dune index d5ace455e..ae93cc418 100644 --- a/src/vendor/ez_toml/dune +++ b/src/vendor/ez_toml/dune @@ -13,8 +13,8 @@ ) -(menhir (modules internal_parser)) (ocamllex internal_lexer) +(menhir (modules internal_parser)) (rule (targets version.ml) From 61c5c87b71c79a8c497bfd9043a66d13204f062e Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Fri, 2 Aug 2024 15:23:08 +0200 Subject: [PATCH 10/37] add some Cursor utilities --- src/lsp/sql_preproc/data_gestion.ml | 174 ++++++++++++++--- src/lsp/sql_preproc/data_gestion.mli | 7 +- src/lsp/sql_preproc/generate.ml | 267 +++++++++++++++++--------- src/lsp/sql_preproc/generated_type.ml | 69 ++++++- src/lsp/sql_preproc/misc.ml | 7 + src/lsp/sql_preproc/misc.mli | 2 + 6 files changed, 394 insertions(+), 132 deletions(-) diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index a3341a36d..40051199f 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -10,6 +10,7 @@ open Sql_ast open Types +open Generated_type module StringMap = Map.Make (String) type variable_information = @@ -28,28 +29,109 @@ let add_var ~map ~name ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) let num = ref 0 -let transform_stm map (_, stm) = +let transform_stm map (_, stm) filename = + let prefix = " " in let create_new_var content = - (*TODO: a function that cut (with &) the resquest if too long*) let size = String.length content in num := !num + 1; - let name = "SQ" ^ string_of_int !num in - ( " 01 " ^ name ^ ".\n 02 FILLER PIC X(" - ^ string_of_int size ^ ") VALUE \"" ^ content - ^ "\".\n 02 FILLER PIC X(1) VALUE X\"00\".\n", + let var_name = "SQ" ^ string_of_int !num in + let field = + let prefix = prefix ^ " " in + [ Simple_var_declaration + { prefix; + var_importance = "02"; + var_name = None; + var_type = "X(" ^ string_of_int size ^ ")"; + var_content = Some content + }; + Simple_var_declaration + { prefix; + var_importance = "02"; + var_name = None; + var_type = "X(1)"; + var_content = Some "X\"00\"" + } + ] + in + ( [ Declaration + (Field_var_declaration + { prefix; var_importance = "01"; var_name; field } ) + ], add_var ~map ~name:("SQ" ^ string_of_int !num) ?length:(Some size) () ) in - match stm with - | EXEC_SQL { tokens; _ } -> ( + let add_cur cur_name map ws filename = + let pre_cur_name = "GIXSQL-CI-F-"^Misc.extract_filename filename^"-" in + let ws = + Declaration + (Simple_var_declaration + { prefix; + var_importance = "01"; + var_name = Some (pre_cur_name ^ cur_name); + var_type = "X"; + var_content = None + } ) + :: ws + in + let map = + add_var ~map ~name:(pre_cur_name ^ cur_name) ?length:(Some 0) () + in + (ws, map) + in + + let rec trans_sql tokens = match tokens with + | At (_, sql) -> trans_sql sql | SelectInto { select; select_options; _ } -> - create_new_var - (Format.asprintf "SELECT %a%a" Printer.pp_select_lst select - Printer.pp_select_options_lst select_options ) - | Begin -> create_new_var ("BEGIN") - | StartTransaction -> create_new_var("START TRANSACTION") - | _ -> ("", map) ) - | DECLARATION { declaration; _ } -> ( + let ws, map = + create_new_var + (Format.asprintf "SELECT %a%a" Sql_ast.Printer.pp_select_lst select + Sql_ast.Printer.pp_select_options_lst select_options ) + in + (ws, map) + | Begin -> + let ws, map = create_new_var "BEGIN" in + (ws, map) + | StartTransaction -> + let ws, map = create_new_var "START TRANSACTION" in + (ws, map) + | Sql sql -> + let ws, map = + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) + in + (ws, map) + | Insert _ | Savepoint _-> + let ws, map = + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) + in + (ws, map) + | Rollback (rb_work_or_tran, rb_args) -> begin + match (rb_work_or_tran, rb_args) with + | _, Some (To savepoint) -> + let ws, map = + create_new_var ("ROLLBACK TO SAVEPOINT " ^ savepoint.payload) + in + (ws, map) + | _ -> ([], map) + end + | DeclareCursor cur -> begin + match cur with + | DeclareCursorSql (cur_name, query) -> + let ws, map = + create_new_var + (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query) + in + let ws, map = add_cur cur_name.payload map ws filename in + + (ws, map) + (*TODO*) + | DeclareCursorVar (_cur_name, _var_name) -> ([], map) (*TODO*) + | DeclareCursorWhithHold (_cur_name, _query) -> ([], map) + (*TODO*) + end + | _ -> ([], map) + in + + let trans_declaration declaration = match declaration with | SQL_type_is { importance; name; sql_type; sql_type_size } -> begin match sql_type with @@ -58,30 +140,68 @@ let transform_stm map (_, stm) = let map = add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () in - ( " " ^ importance ^ " " ^ name ^ " PIC X(" ^ sql_type_size - ^ ").\n", + + ( [ Declaration + (Simple_var_declaration + { prefix; + var_importance = importance; + var_name = Some name; + var_type = "X(" ^ sql_type_size ^ ")"; + var_content = None + } ) + ], map ) | "VARBINARY" | "VARCHAR" -> let map = add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () in - ( " " ^ importance ^ " " ^ name ^ ".\n 49 " ^ name - ^ "-LEN PIC 9(8) COMP-5.\n 49 " ^ name ^ "-ARR PIC X(" - ^ sql_type_size ^ ").\n", + let field = + let prefix = prefix ^ " " in + [ Simple_var_declaration + { prefix; + var_importance = "49"; + var_name = Some (name ^ "LEN"); + var_type = "9(8) COMP-5"; + var_content = None + }; + Simple_var_declaration + { prefix; + var_importance = "49"; + var_name = Some (name ^ "ARR"); + var_type = "X(" ^ sql_type_size ^ ")"; + var_content = None + } + ] + in + + let decl = + Field_var_declaration + { prefix; var_importance = importance; var_name = name; field } + in + + ( [ Declaration decl ], + (* " " ^ importance ^ " " ^ name ^ ".\n 49 " ^ name + ^ "-LEN PIC 9(8) COMP-5.\n 49 " ^ name ^ "-ARR PIC X(" + ^ sql_type_size ^ ").\n", *) map ) | _ -> failwith "Unknow type." - end ) - | _ -> ("", map) + end + in + + match stm with + | EXEC_SQL { tokens; _ } -> trans_sql tokens + | DECLARATION { declaration; _ } -> trans_declaration declaration + | _ -> ([], map) -let transform sql_statements = +let transform sql_statements filename = let rec transform_rec map sql_statements = match sql_statements with | h :: t -> - let smt, map = transform_stm map h in - let sql, map = transform_rec map t in - (smt ^ sql, map) - | [] -> ("", map) + let ws, map = transform_stm map h filename in + let ws', map = transform_rec map t in + (ws @ ws', map) + | [] -> ([], map) in let init_map = StringMap.empty in transform_rec init_map sql_statements diff --git a/src/lsp/sql_preproc/data_gestion.mli b/src/lsp/sql_preproc/data_gestion.mli index 8646b2cde..be0d0f3f5 100644 --- a/src/lsp/sql_preproc/data_gestion.mli +++ b/src/lsp/sql_preproc/data_gestion.mli @@ -7,7 +7,6 @@ (* OCAMLPRO-NON-COMMERCIAL license. *) (* *) (**************************************************************************) - type t type variable_information = @@ -17,9 +16,9 @@ type variable_information = flags : int; ind_addr : int } - +(*return working_storage_section (only declaration),, new_var_map*) val transform : - (Types.loc option * Types.statements) list -> - (string * t) + (Types.loc option * Types.statements) list -> string -> + (Generated_type.trans_stm list * t) val find_opt : t -> string -> variable_information option diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index cefbca2c2..eaa819b40 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -12,17 +12,17 @@ open EzCompat open Types open Sql_ast +let comment str = + Generated_type.Added + { content = [ Generated_type.Comment { content = str } ] } + let generate ~filename ~contents ~cobol_unit sql_statements = - let linkage_section = Generated_type.Added { content = "" } in + let linkage_section = comment "" in let begin_procedure_division ~loc:_ = (* We might want to add something at the begining of PROCEDURE DIVISION ? *) - [ Generated_type.Added { content = "" } ] + [ comment "" ] in - let end_procedure_division ~loc:_ = - (* TODO CURSOR DIVISION*) - [ Generated_type.Added { content = "" } ] - in (* split lines and numerotate them *) let lines = EzString.split contents '\n' in let lines = List.mapi (fun i line -> (filename, i + 1, line)) lines in @@ -30,25 +30,29 @@ let generate ~filename ~contents ~cobol_unit sql_statements = (*string to add at the end of every sql processed*) (* The result will be stored in this buffer: *) - let final_loc = { filename; line = -1; char = 0 } in + let _final_loc = { filename; line = -1; char = 0 } in let error_treatment = ref [] in let old_statements = ref [] in + let cursor_declararation = ref [] in let num = ref 0 in (*GET FUNCTION*) (*TODOOOO*) let working_storage_section, new_var_map = - let ws, nvm = Data_gestion.transform sql_statements in - ( [ Generated_type.Added - { content = " *> Begin generated WORKING-STORAGE SECTION" }; + let ws, nvm = Data_gestion.transform sql_statements filename in + ( [ comment ">Begin generated WORKING-STORAGE SECTION"; Generated_type.Added { content = ws }; - Generated_type.Added - { content = " *> End genererated WORKING-STORAGE SECTION" } + comment "> End genererated WORKING-STORAGE SECTION" ], nvm ) in + let end_procedure_division cd = + (comment "> ESQL CURSOR DECLARATIONS (START)" :: cd) + @ [ comment "> ESQL CURSOR DECLARATIONS (END)" ] + in + let cob_var_id_opt (cob_var : cobolVarId option) = match cob_var with | Some cob -> Some cob.payload @@ -165,7 +169,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generatesql_connect cs prefix = (*TODO: Some of these a unsuported in gixSql -> emit a preproc warning list of unsuported connection: - mode 5 and 6 when named ("AT/AS db_conn_id ") + mode 5 and 6 when named ("AT/AS db_conn_id ") mode 4 (ex: CONNECT :DBUSR IDENTIFIED BY :DBPWD)*) match cs with | Connect_reset lit -> @@ -242,6 +246,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let h = get_name_cobol_var arg in let fun_name = "GIXSQLSetResultParams" in let ref_value = + let prefix = prefix ^ " " in [ Generated_type.Value { prefix; var = string_of_int (get_type h) }; Generated_type.Value { prefix; var = string_of_int (get_length h) }; Generated_type.Value { prefix; var = string_of_int (get_scale h) }; @@ -254,7 +259,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into_one prefix vars = + let generate_select_into_one prefix vars ?(at = "x\"00\"") () = let size = string_of_int (List.length vars) in let fun_name = "GIXSQLExecSelectIntoOne" in let ref_value = @@ -264,7 +269,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Reference { prefix; var = at }; Generated_type.Value { prefix; var = "0" }; Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" }; @@ -274,21 +279,21 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into prefix vars = + let generate_select_into prefix vars ?(at = "x\"00\"") () = let selects_into_vars = List.map (generate_select_into_rec prefix) vars in - let selects_into = generate_select_into_one prefix vars in + let selects_into = generate_select_into_one prefix vars ~at () in let trans_stm = generate_start_end_sql prefix (selects_into_vars @ [ selects_into ]) in trans_stm in - let generate_GIXSQLExec prefix name = + let generate_GIXSQLExec prefix name ?(at = "x\"00\"") () = let fun_name = "GIXSQLExec" in let ref_value = let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Reference { prefix; var = at }; Generated_type.Value { prefix; var = "0" }; Generated_type.Reference { prefix; var = "\"" ^ name ^ "\" & x\"00\"" } ] @@ -296,21 +301,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_rollback prefix rb_work_or_tran rb_args = - match (rb_work_or_tran, rb_args) with - | None, None -> - generate_start_end_sql prefix [ generate_GIXSQLExec prefix "ROLLBACK" ] - | _ -> [ Generated_type.Todo { prefix } ] - in - - let generate_commit prefix rb_work_or_tran rb_args = - match (rb_work_or_tran, rb_args) with - | None, false -> - generate_start_end_sql prefix [ generate_GIXSQLExec prefix "COMMIT" ] - | _ -> [ Generated_type.Todo { prefix } ] - in - - let generate_declare prefix = + let generate_declare prefix ?(at = "x\"00\"") () = let fun_name = "GIXSQLExec" in let ref_value = let var_name = @@ -319,7 +310,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = "x\"00\"" }; + Generated_type.Reference { prefix; var = at }; Generated_type.Value { prefix; var = "0" }; Generated_type.Reference { prefix; var = var_name } ] @@ -330,63 +321,155 @@ let generate ~filename ~contents ~cobol_unit sql_statements = trans_stm in -let generate_close_cursor prefix sql_var_token = - let fun_name = "GIXSQLCursorClose" in - let ref_value = - let prefix = prefix ^ " " in - [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = "\"" ^ sql_var_token ^ "\" x\"00\"" } - ] + let generate_rollback prefix rb_work_or_tran rb_args ?(at = "x\"00\"") () = + match (rb_work_or_tran, rb_args) with + | None, None -> + generate_start_end_sql prefix + [ generate_GIXSQLExec prefix "ROLLBACK" ~at () ] + | _, Some (To _) -> generate_declare prefix () + | _ -> [ Generated_type.Todo { prefix } ] in - Generated_type.CallStatic { prefix; fun_name; ref_value } -in + let generate_commit prefix rb_work_or_tran rb_args ?(at = "x\"00\"") () = + match (rb_work_or_tran, rb_args) with + | None, false -> + generate_start_end_sql prefix + [ generate_GIXSQLExec prefix "COMMIT" ~at () ] + | _ -> [ Generated_type.Todo { prefix } ] + in - (* GIXSQL CALL STATIC "GIXSQLCursorClose" USING -GIXSQL BY REFERENCE SQLCA -GIXSQL BY REFERENCE "TSQL029A_CRSR02" & x"00" -GIXSQL END-CALL. *) + let add_to_cursor_declararation prefix cur ?(at = "x\"00\"") () = + let adding = + match cur with + | DeclareCursorSql (cur_name, _) -> begin + let fun_name = "GIXSQLCursorDeclare" in + let ref_value = + let cursor_name = "\"TSQL003A_" ^ cur_name.payload ^ "\" & x\"00\"" in + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = cursor_name }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = var_name }; + Generated_type.Value { prefix; var = "0" } + ] + in + [ Generated_type.GotoStatement + { prefix; + target = + "GIXSQL-CI-P-" + ^ Misc.extract_filename filename + ^ "-" ^ cur_name.payload + }; + Generated_type.CallStatic { prefix; fun_name; ref_value } + ] + end + (* GIXSQL GIXSQL-CI-P-TSQL003A-CRSR01. + GIXSQL CALL STATIC "GIXSQLCursorDeclare" USING + GIXSQL BY REFERENCE SQLCA + GIXSQL BY REFERENCE "CONN1" & x"00" + GIXSQL BY VALUE 0 + GIXSQL BY REFERENCE "TSQL003A_CRSR01" & x"00" + GIXSQL BY VALUE 0 + GIXSQL BY REFERENCE SQ0001 + GIXSQL BY VALUE 0 + GIXSQL END-CALL. *) + | DeclareCursorVar (_cur_name, _var_name) -> + [ Generated_type.Todo { prefix } ] + | DeclareCursorWhithHold (_cur_name, _query) -> + [ Generated_type.Todo { prefix } ] + in + let st = Generated_type.Added { content = adding } in + let cd = st :: !cursor_declararation in + cursor_declararation := cd + in + + let generate_close_cursor prefix sql_var_token = + let fun_name = "GIXSQLCursorClose" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference + { prefix; var = "\"" ^ sql_var_token ^ "\" x\"00\"" } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generate_at prefix sql ?(at = "x\"00\"") () = + match sql with + | SelectInto { vars; _ } -> + generate_select_into prefix vars ~at () (*TODO AT*) + | Rollback (rb_work_or_tran, rb_args) -> + generate_rollback prefix rb_work_or_tran rb_args ~at () + | Commit (rb_work_or_tran, b) -> + generate_commit prefix rb_work_or_tran b ~at () + | DeclareCursor cur -> + add_to_cursor_declararation prefix cur ~at (); + [] + | Insert _ + | Savepoint _ + | StartTransaction + | Sql _ -> + generate_declare prefix ~at () + | DeclareTable _ + | Prepare _ + | ExecuteImmediate _ + | ExecuteIntoUsing _ + | Delete _ + | Update _ -> + [ Generated_type.Todo { prefix } ] + | _ -> failwith "Unexeped At" + in let generatesql ~loc ~line esql_instuction = let prefix = String.sub line 0 loc.char in match esql_instuction with + | Sql _ + | SelectInto _ + | StartTransaction + | DeclareTable _ + | DeclareCursor _ + | Prepare _ + | ExecuteImmediate _ + | ExecuteIntoUsing _ + | Savepoint _ + | Rollback _ + | Commit _ + | Insert _ + | Delete _ + | Update _ -> + generate_at prefix esql_instuction ?at:(Some "x\"00\"") () | Include sqlvar -> (* let prefix = String.sub line 0 loc.char in *) [ Generated_type.Copy { prefix; file_name = sqlvar.payload } ] | Connect cs -> generatesql_connect cs prefix | Disconnect lit -> [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) () ] - | DisconnectAll -> [ generatesql_connect_reset ~prefix ?d_connection_id:(Some "\"*\" & x\"00\"") () ] + | DisconnectAll -> + [ generatesql_connect_reset ~prefix + ?d_connection_id:(Some "\"*\" & x\"00\"") () + ] | Whenever (c, k) -> error_treatment := generate_whenever ~prefix c k :: !error_treatment; [] - | SelectInto { vars; _ } -> generate_select_into prefix vars - | Begin -> generate_declare prefix + | Begin -> generate_declare prefix () | BeginDeclare | EndDeclare -> [] (*do nothing*) - | Rollback (rb_work_or_tran, rb_args) -> - generate_rollback prefix rb_work_or_tran rb_args - | Commit (rb_work_or_tran, b) -> generate_commit prefix rb_work_or_tran b - | Close var -> [generate_close_cursor prefix var.payload] - | StartTransaction -> generate_declare prefix - | At (_, _) - | Sql _ + | Close var -> [ generate_close_cursor prefix var.payload ] + | At (at, sql) -> generate_at prefix sql ?at:(var_opt (Some at)) () | Exeption _ - | Savepoint _ - | DeclareTable (_, _) - | DeclareCursor _ - | Prepare (_, _) - | ExecuteImmediate _ - | ExecuteIntoUsing _ | Open (_, _) | Fetch (_, _) - | Insert (_, _) - | Delete _ - | Update (_, _, _) | Ignore _ -> (*TODO*) - [] + [ Generated_type.Todo { prefix } ] in let rec output lines statements = @@ -406,7 +489,7 @@ GIXSQL END-CALL. *) begin match stmt with | END_PROCEDURE_DIVISION -> - res @ end_procedure_division ~loc:final_loc + res @ end_procedure_division (List.rev !cursor_declararation) | _ -> res end | Some begin_loc -> output_statement lines begin_loc stmt statements @@ -425,9 +508,9 @@ GIXSQL END-CALL. *) Generated_type.NoChange { content = line } :: ([ linkage_section ] @ output lines statements) end else begin - Generated_type.Added - { content = " *> Add missing LINKAGE SECTION" } - :: Generated_type.Added { content = " LINKAGE SECTION." } + comment "> Add missing LINKAGE SECTION" + :: Generated_type.Added + { content = [ Generated_type.LinkageSection ] } :: ([ linkage_section ] @ output cur_lines statements) end | WORKING_STORAGE { defined } -> @@ -435,25 +518,21 @@ GIXSQL END-CALL. *) Generated_type.NoChange { content = line } :: (working_storage_section @ output lines statements) end else begin - Generated_type.Added - { content = " *> Add missing WORKING-STORAGE SECTION" } + comment "> Add missing WORKING-STORAGE SECTION" :: Generated_type.Added - { content = " WORKING-STORAGE SECTION." } + { content = [ Generated_type.WorkingStorageSection ] } :: (working_storage_section @ output cur_lines statements) end | EXEC_SQL { end_loc; with_dot; tokens } -> - let with_dot = - match tokens with - | BeginDeclare - | EndDeclare -> - false - | _ -> with_dot - in old_statements := line :: !old_statements; if i = end_loc.line then begin let trans_stm = generatesql ~loc:begin_loc ~line tokens in - let error_treatment = !error_treatment in - let old_stms = !old_statements in + let old_stms = List.rev !old_statements in + let with_dot, error_treatment = + match trans_stm with + | [] -> false, [] (*if nothing is generated, we don't need error treatment or dots *) + | _ -> with_dot, !error_treatment + in old_statements := []; Generated_type.Change { old_stms; trans_stm; error_treatment; with_dot } @@ -462,17 +541,16 @@ GIXSQL END-CALL. *) output_statement lines begin_loc stmt statements | PROCEDURE_DIVISION_DOT { end_loc } -> if i = end_loc.line then begin - Generated_type.Added { content = " *> REMOVED: " ^ line } + comment ("> REMOVED: " ^ line) :: (* for now, just put it back *) Generated_type.Added - { content = " PROCEDURE DIVISION." } + { content = [ Generated_type.ProcedureDivision ] } :: output lines statements end else - Generated_type.Added { content = " *> REMOVED: " ^ line } + comment ("> REMOVED: " ^ line) :: output_statement lines begin_loc stmt statements | DECLARATION _ -> - Generated_type.Added { content = " *> REMOVED: " ^ line } - :: output lines statements + comment ("> REMOVED: " ^ line) :: output lines statements (* | IS_SQLVAR { end_loc } -> @@ -498,16 +576,13 @@ GIXSQL END-CALL. *) ( if !enabled then begin_procedure_division ~loc:begin_loc else - [ Generated_type.Added - { content = " *> BEGIN PROCEDURE DIVISION disabled" } - ] ) + [ comment "> BEGIN PROCEDURE DIVISION disabled" ] ) @ output cur_lines statements | END_PROCEDURE_DIVISION -> - end_procedure_division ~loc:begin_loc @ output cur_lines statements + end_procedure_division (List.rev !cursor_declararation) + @ output cur_lines statements | COPY { end_loc; filename; contents } -> - let added = - Generated_type.Added { content = " *> INLINED:" ^ line } - in + let added = comment ("> INLINED:" ^ line) in if i = end_loc.line then begin let copylines = EzString.split contents '\n' in let copylines = diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index 8ed891619..c972f4e8f 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -25,6 +25,21 @@ and whenever_continuation = | Perform of string | Goto of string +type declaration = + | Simple_var_declaration of + { prefix : string; + var_importance : string; + var_name : string option; + var_type : string; + var_content : string option + } + | Field_var_declaration of + { prefix : string; + var_importance : string; + var_name : string; + field : declaration list + } + type trans_stm = | CallStatic of { prefix : string; @@ -35,11 +50,21 @@ type trans_stm = { prefix : string; file_name : string } + | GotoStatement of + { prefix : string; + target : string + } + | Declaration of declaration + | Comment of { content : string } + | Section of { name : string } + | LinkageSection + | WorkingStorageSection + | ProcedureDivision | Todo of { prefix : string } type generated_stm = | NoChange of { content : string } - | Added of { content : string } + | Added of { content : trans_stm list } | Change of { old_stms : string list; trans_stm : trans_stm list; @@ -50,6 +75,8 @@ type generated_stm = type generated = generated_stm list module Printer = struct + (*TODO: a function that cut (with &) the resquest if too long*) + let rec pp fmt gen = match gen with | h :: t -> Format.fprintf fmt "%a%a" pp_gene h pp t @@ -58,7 +85,7 @@ module Printer = struct and pp_gene fmt x = match x with | NoChange { content } -> Format.fprintf fmt "%s\n" content - | Added { content } -> Format.fprintf fmt "%s\n" content + | Added { content } -> Format.fprintf fmt "%a\n" pp_trans_stm content | Change { old_stms; trans_stm; error_treatment; with_dot } -> let dot = if with_dot then @@ -66,7 +93,7 @@ module Printer = struct else "" in - Format.fprintf fmt "%a\n%a%a%s" pp_old_stms old_stms pp_trans_stm + Format.fprintf fmt "%a\n%a%a%s\n" pp_old_stms old_stms pp_trans_stm trans_stm pp_error_treatment error_treatment dot and pp_old_stms fmt x = @@ -87,13 +114,44 @@ module Printer = struct and pp_trans_stm_aux fmt x = match x with + | Section { name } -> Format.fprintf fmt " %s" name + | Comment { content } -> Format.fprintf fmt "ADDED *%s" content | CallStatic { prefix; fun_name; ref_value } -> Format.fprintf fmt "%sCALL STATIC \"%s\"%a%sEND-CALL" prefix fun_name pp_ref_value_list ref_value prefix | Copy { prefix; file_name } -> Format.fprintf fmt "%sCOPY %s" prefix file_name + | GotoStatement { prefix; target } -> Format.fprintf fmt "%sGOTO %s" prefix target + | Declaration d -> Format.fprintf fmt "%a" pp_declaration d + | LinkageSection -> Format.fprintf fmt "LINKAGE SECTION." + | WorkingStorageSection -> Format.fprintf fmt "WORKING-STORAGE SECTION." + | ProcedureDivision -> Format.fprintf fmt "PROCEDURE DIVISION." | Todo { prefix } -> Format.fprintf fmt "%sTODO" prefix + and pp_declaration fmt = function + | Simple_var_declaration + { prefix; var_importance; var_name; var_type; var_content } -> + let var_name = + match var_name with + | Some n -> n + | None -> "FILLER" + in + let var_content = + match var_content with + | Some n -> n + | None -> "" + in + Format.fprintf fmt "%s%s %s %s %s." prefix var_importance var_name + var_type var_content + | Field_var_declaration { prefix; var_importance; var_name; field } -> + Format.fprintf fmt "%s%s %s.%a" prefix var_importance var_name pp_field + field + + and pp_field fmt x = + match x with + | h :: t -> Format.fprintf fmt "\n%a%a" pp_declaration h pp_field t + | [] -> Format.fprintf fmt "" + and pp_error_treatment_aux fmt = function | Error_treatment { prefix; condition; continuation } -> begin let print_continuation fmt continuation = @@ -117,11 +175,12 @@ module Printer = struct and pp_ref_value_list fmt x = let rec pp_ref_value_list_aux fmt x = match x with - | h :: t -> Format.fprintf fmt "%a\n%a" pp_ref_value h pp_ref_value_list_aux t + | h :: t -> + Format.fprintf fmt "%a\n%a" pp_ref_value h pp_ref_value_list_aux t | [] -> () in match x with - | [] -> () + | [] -> Format.fprintf fmt "\n" | _ -> Format.fprintf fmt " USING\n%a" pp_ref_value_list_aux x and pp_ref_value fmt x = diff --git a/src/lsp/sql_preproc/misc.ml b/src/lsp/sql_preproc/misc.ml index 88fb580f6..02ea61af3 100644 --- a/src/lsp/sql_preproc/misc.ml +++ b/src/lsp/sql_preproc/misc.ml @@ -100,3 +100,10 @@ let resolve_copy ~config file = | file -> Filename.concat dir file in iter_exts config.copy_exts + + + let extract_filename path = + let parts = Str.split (Str.regexp "/") path in + let filename_with_ext = List.hd (List.rev parts) in + let filename_parts = Str.split (Str.regexp "\\.") filename_with_ext in + List.hd filename_parts \ No newline at end of file diff --git a/src/lsp/sql_preproc/misc.mli b/src/lsp/sql_preproc/misc.mli index ab171c649..0a26f6be1 100644 --- a/src/lsp/sql_preproc/misc.mli +++ b/src/lsp/sql_preproc/misc.mli @@ -24,3 +24,5 @@ val string_of_token : Cobol_indent.Types.token -> string val add_dot : with_dot:bool -> Buffer.t -> unit val resolve_copy : config:Types.config -> string -> string + +val extract_filename : string -> string From ad2bf0a837551ad92a71f0f05ce6dff2b65e1dc9 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Mon, 12 Aug 2024 14:34:17 +0200 Subject: [PATCH 11/37] fix Select Into --- src/lsp/sql_ast/sql_ast.ml | 4 +- src/lsp/sql_parser/grammar.mly | 2 +- src/lsp/sql_parser/lexer.mll | 2 +- src/lsp/sql_preproc/data_gestion.ml | 35 ++- src/lsp/sql_preproc/generate.ml | 375 +++++++++++++++++++++----- src/lsp/sql_preproc/generated_type.ml | 36 ++- src/lsp/sql_preproc/misc.ml | 223 ++++++++++++--- src/lsp/sql_preproc/misc.mli | 16 +- 8 files changed, 563 insertions(+), 130 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index a23395b80..55bd3dbcb 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -84,7 +84,7 @@ and esql_instuction = | DisconnectAll | Open of sqlVarToken * cobol_var list option (*cursor name*) | Close of sqlVarToken (*cursor name*) - | Fetch of sql_instruction * cobol_var list + | Fetch of sqlVarToken * cobol_var list | Insert of table * value list | Delete of sql_instruction | Update of sqlVarToken * sql_update * update_arg option @@ -311,7 +311,7 @@ module Printer = struct (lst, "USING") | Close cursor -> Format.fprintf fmt "CLOSE %s" cursor.payload | Fetch (sql, var) -> - Format.fprintf fmt "FETCH %a INTO %a" pp_sql sql pp_cob_lst var + Format.fprintf fmt "FETCH %s INTO %a" sql.payload pp_cob_lst var | Insert (tab, v) -> Format.fprintf fmt "INSERT INTO %a VALUES %a" pp_table tab pp_value v | Delete sql -> Format.fprintf fmt "DELETE %a" pp_sql sql diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 61cb8db61..716ca631a 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -146,7 +146,7 @@ let esql_with_opt_at := (*Unexeped At, but we have to parse it*) | OPEN; cursor = sql_var_name; ul = option(using_list_cob_var); {Open (cursor, ul)} -| FETCH; sql=sql; l = into_list_cob_var; {Fetch(sql,l)} +| FETCH; sql=sql_var_name; l = into_list_cob_var; {Fetch(sql,l)} | CLOSE; cursor = sql_var_name; {Close cursor} let begin_end_stm := diff --git a/src/lsp/sql_parser/lexer.mll b/src/lsp/sql_parser/lexer.mll index 0aea19d09..bde336a73 100644 --- a/src/lsp/sql_parser/lexer.mll +++ b/src/lsp/sql_parser/lexer.mll @@ -131,7 +131,7 @@ rule token = parse { get_keyword s } | number as n { NUMBER n } - | '\'' ( ['A'-'Z' 'a'-'z' '0'-'9' '_' '(' '*' ')' '.' '[' ']']* as s) '\'' + | '\'' ( ['A'-'Z' 'a'-'z' '0'-'9' '_' '(' '*' ')' '.' '[' ']' ' ' '+' '=' ',' ]* as s) '\'' { STRING s} | "||" diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 40051199f..537e983b1 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -32,6 +32,7 @@ let num = ref 0 let transform_stm map (_, stm) filename = let prefix = " " in let create_new_var content = + let content = "\"" ^ Misc.replace_colon_words content ^ "\"" in let size = String.length content in num := !num + 1; let var_name = "SQ" ^ string_of_int !num in @@ -60,7 +61,7 @@ let transform_stm map (_, stm) filename = add_var ~map ~name:("SQ" ^ string_of_int !num) ?length:(Some size) () ) in let add_cur cur_name map ws filename = - let pre_cur_name = "GIXSQL-CI-F-"^Misc.extract_filename filename^"-" in + let pre_cur_name = "GIXSQL-CI-F-" ^ Misc.extract_filename filename ^ "-" in let ws = Declaration (Simple_var_declaration @@ -94,16 +95,30 @@ let transform_stm map (_, stm) filename = | StartTransaction -> let ws, map = create_new_var "START TRANSACTION" in (ws, map) - | Sql sql -> - let ws, map = - create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) - in - (ws, map) - | Insert _ | Savepoint _-> + | Sql sql -> ( + match sql with + | Sql_ast.SqlInstr w :: _ when w = "VAR" -> + ([], map) + (*TODO: find what this should be replaced with. I think Gix juste ignorer these instruction, but mabe not*) + | _ -> + let ws, map = + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) + in + (ws, map) ) + | Insert _ + | Savepoint _ -> let ws, map = create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) in (ws, map) + | ExecuteImmediate sql -> ( + match sql with + | [ Sql_ast.SqlVarToken CobolVar CobVarNotNull _ ] -> ([], map) + | _ -> + let ws, map = + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) + in + (ws, map) ) | Rollback (rb_work_or_tran, rb_args) -> begin match (rb_work_or_tran, rb_args) with | _, Some (To savepoint) -> @@ -161,14 +176,14 @@ let transform_stm map (_, stm) filename = [ Simple_var_declaration { prefix; var_importance = "49"; - var_name = Some (name ^ "LEN"); + var_name = Some (name ^ "-LEN"); var_type = "9(8) COMP-5"; var_content = None }; Simple_var_declaration { prefix; var_importance = "49"; - var_name = Some (name ^ "ARR"); + var_name = Some (name ^ "-ARR"); var_type = "X(" ^ sql_type_size ^ ")"; var_content = None } @@ -186,7 +201,7 @@ let transform_stm map (_, stm) filename = ^ sql_type_size ^ ").\n", *) map ) | _ -> failwith "Unknow type." - end + end in match stm with diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index eaa819b40..adecad491 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -34,7 +34,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let error_treatment = ref [] in let old_statements = ref [] in - let cursor_declararation = ref [] in + let cursor_declaration = ref [] in let num = ref 0 in (*GET FUNCTION*) @@ -49,8 +49,23 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let end_procedure_division cd = - (comment "> ESQL CURSOR DECLARATIONS (START)" :: cd) - @ [ comment "> ESQL CURSOR DECLARATIONS (END)" ] + Generated_type.Added + { content = + [ Generated_type.Comment + { content = "> ESQL CURSOR DECLARATIONS (START)" }; + Generated_type.GotoStatement + { prefix = " "; target = "GIX-SKIP-CRSR-INIT" } + ] + } + :: cd + @ [ Generated_type.Added + { content = + [ Generated_type.Section { name = "GIX-SKIP-CRSR-INIT" }; + Generated_type.Comment + { content = "> ESQL CURSOR DECLARATIONS (END)" } + ] + } + ] in let cob_var_id_opt (cob_var : cobolVarId option) = @@ -115,6 +130,20 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | None -> Sql_typeck.get_ind_addr cobol_unit str in + let get_at_info some_var = + match some_var with + | None -> ("x\"00\"", 0) + | Some var -> ( + match var with + | SqlVar sqlVarToken -> ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"", 0) + | CobolVar cobol_var -> ( + match cobol_var with + | CobVarNotNull cobolVarId -> + (cobolVarId.payload, get_length cobolVarId.payload) + | CobVarNullIndicator (var, _) -> (var.payload, get_length var.payload) + ) ) + in + (*GENERATE FUNCTION*) let generate_start_end_sql prefix smt = let startSql = @@ -242,7 +271,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | CobVarNullIndicator (c, n) -> c.payload ^ n.payload in - let generate_select_into_rec prefix arg = + let generate_set_result_param prefix arg = let h = get_name_cobol_var arg in let fun_name = "GIXSQLSetResultParams" in let ref_value = @@ -259,7 +288,26 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into_one prefix vars ?(at = "x\"00\"") () = + (* Todo: refactory *) + let generate_set_sql_param prefix arg = + let h = get_name_cobol_var arg in + let fun_name = "GIXSQLSetSQLParams" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Value { prefix; var = string_of_int (get_type h) }; + Generated_type.Value { prefix; var = string_of_int (get_length h) }; + Generated_type.Value { prefix; var = string_of_int (get_scale h) }; + Generated_type.Value { prefix; var = string_of_int (get_flags h) }; + Generated_type.Reference { prefix; var = h }; + Generated_type.Reference + { prefix; var = string_of_int (get_ind_addr h) } + ] + in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generate_select_into_one prefix vars ?at () = + let at_name, at_size = get_at_info at in let size = string_of_int (List.length vars) in let fun_name = "GIXSQLExecSelectIntoOne" in let ref_value = @@ -269,8 +317,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at }; - Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" }; Generated_type.Value { prefix; var = size } @@ -279,29 +327,59 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into prefix vars ?(at = "x\"00\"") () = - let selects_into_vars = List.map (generate_select_into_rec prefix) vars in - let selects_into = generate_select_into_one prefix vars ~at () in + let generate_select_into prefix vars select_options select ?at () = + let selects_into_vars = List.map (generate_set_result_param prefix) vars in + let selects_into = generate_select_into_one prefix vars ?at () in + let cob_vars = Misc.extract_cob_var_select select @ (Misc.extract_cob_var_select_option_list select_options) in + let trans_cob_var = List.map (generate_set_result_param prefix) cob_vars in let trans_stm = - generate_start_end_sql prefix (selects_into_vars @ [ selects_into ]) + generate_start_end_sql prefix (selects_into_vars @ trans_cob_var @[ selects_into ]) in trans_stm in - let generate_GIXSQLExec prefix name ?(at = "x\"00\"") () = + let generate_fetch_into_one prefix (sql : sqlVarToken) = + let var = + "\"" + ^ Misc.extract_filename filename + ^ "_" ^ sql.payload ^ "\" & x\"00\" " + in + Generated_type.CallStatic + { prefix; + fun_name = "GIXSQLCursorFetchOne"; + ref_value = + (let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var } + ] ) + } + in + + let generate_fetch prefix sql cob = + let fetch_into_vars = List.map (generate_set_result_param prefix) cob in + let fetch_into = generate_fetch_into_one prefix sql in + let trans_stm = + generate_start_end_sql prefix (fetch_into_vars @ [ fetch_into ]) + in + trans_stm + in + + let generate_GIXSQLExec prefix name ?at () = + let at_name, at_size = get_at_info at in let fun_name = "GIXSQLExec" in let ref_value = let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at }; - Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = "\"" ^ name ^ "\" & x\"00\"" } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_declare prefix ?(at = "x\"00\"") () = + let generate_declare prefix ?at () = + let at_name, at_size = get_at_info at in let fun_name = "GIXSQLExec" in let ref_value = let var_name = @@ -310,8 +388,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at }; - Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = var_name } ] in @@ -321,24 +399,47 @@ let generate ~filename ~contents ~cobol_unit sql_statements = trans_stm in - let generate_rollback prefix rb_work_or_tran rb_args ?(at = "x\"00\"") () = + let generate_rollback prefix rb_work_or_tran rb_args ?at () = match (rb_work_or_tran, rb_args) with | None, None -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "ROLLBACK" ~at () ] + [ generate_GIXSQLExec prefix "ROLLBACK" ?at () ] | _, Some (To _) -> generate_declare prefix () | _ -> [ Generated_type.Todo { prefix } ] in - let generate_commit prefix rb_work_or_tran rb_args ?(at = "x\"00\"") () = + let generate_commit prefix rb_work_or_tran rb_args ?at () = match (rb_work_or_tran, rb_args) with | None, false -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "COMMIT" ~at () ] + [ generate_GIXSQLExec prefix "COMMIT" ?at () ] | _ -> [ Generated_type.Todo { prefix } ] in - let add_to_cursor_declararation prefix cur ?(at = "x\"00\"") () = + let generate_simpl_execute_immediat prefix var ?at () = + let name = + match var with + | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull var)) ] -> var.payload + | _ -> + num := !num + 1; + "SQ" ^ string_of_int !num + in + let at_name, at_size = get_at_info at in + let fun_name = "GIXSQLExecImmediate" in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference { prefix; var = name }; + Generated_type.Value { prefix; var = "0" } (*Todo*) + ] + in + [ Generated_type.CallStatic { prefix; fun_name; ref_value } ] + in + + let add_to_cursor_declaration prefix cur ?at () = + let at_name, at_size = get_at_info at in let adding = match cur with | DeclareCursorSql (cur_name, _) -> begin @@ -351,17 +452,16 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at }; - Generated_type.Value { prefix; var = "0" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = cursor_name }; Generated_type.Value { prefix; var = "0" }; Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" } ] in - [ Generated_type.GotoStatement - { prefix; - target = + [ Generated_type.Section + { name = "GIXSQL-CI-P-" ^ Misc.extract_filename filename ^ "-" ^ cur_name.payload @@ -369,24 +469,83 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } ] end - (* GIXSQL GIXSQL-CI-P-TSQL003A-CRSR01. - GIXSQL CALL STATIC "GIXSQLCursorDeclare" USING - GIXSQL BY REFERENCE SQLCA - GIXSQL BY REFERENCE "CONN1" & x"00" - GIXSQL BY VALUE 0 - GIXSQL BY REFERENCE "TSQL003A_CRSR01" & x"00" - GIXSQL BY VALUE 0 - GIXSQL BY REFERENCE SQ0001 - GIXSQL BY VALUE 0 - GIXSQL END-CALL. *) | DeclareCursorVar (_cur_name, _var_name) -> [ Generated_type.Todo { prefix } ] | DeclareCursorWhithHold (_cur_name, _query) -> [ Generated_type.Todo { prefix } ] in let st = Generated_type.Added { content = adding } in - let cd = st :: !cursor_declararation in - cursor_declararation := cd + let cd = st :: !cursor_declaration in + cursor_declaration := cd + in + + let generate_prepare_stm prefix (var_name : sqlVarToken) sql_instr ?at () = + let at_name, at_size = get_at_info at in + let sql_name = + match sql_instr with + | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull cobolVarId)) ] -> + cobolVarId.payload + | _ -> failwith "Not implemented in Gix" + (*These case are not implemented in GixSql's runtime *) + in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference + { prefix; var = "\"" ^ var_name.payload ^ "\" & x\"00\"" }; + Generated_type.Reference { prefix; var = sql_name }; + Generated_type.Value { prefix; var = "0" } (*todo*) + ] + in + [ Generated_type.CallStatic + { prefix; fun_name = "GIXSQLPrepareStatement"; ref_value } + ] + in + + (* + GIXSQL CALL STATIC "GIXSQLExecPrepared" USING + GIXSQL BY REFERENCE SQLCA + GIXSQL BY REFERENCE x"00" + GIXSQL BY VALUE 0 + GIXSQL BY REFERENCE "SQLSTMT1" & x"00" + GIXSQL BY VALUE 2 + GIXSQL END-CALL *) + let generate_exec_prepared prefix (executed_string : sqlVarToken) + into_hostref_list ?at () = + let at_name, at_size = get_at_info at in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference + { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; + Generated_type.Value + { prefix; var = string_of_int (List.length into_hostref_list) } + (*todo*) + ] + in + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLPrepareStatement"; ref_value } + in + + let generate_execute_into_using prefix executed_string + ?(opt_into_hostref_list = []) ?(opt_using_hostref_list = []) ?at () = + ignore opt_into_hostref_list; + (*todo*) + let execute_using_vars = + List.map (generate_set_sql_param prefix) opt_using_hostref_list + in + let exec_prepared = + generate_exec_prepared prefix executed_string opt_using_hostref_list ?at + () + in + let trans_stm = + generate_start_end_sql prefix (execute_using_vars @ [ exec_prepared ]) + in + trans_stm in let generate_close_cursor prefix sql_var_token = @@ -395,39 +554,108 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference - { prefix; var = "\"" ^ sql_var_token ^ "\" x\"00\"" } + { prefix; + var = + "\"" + ^ Misc.extract_filename filename + ^ "_" ^ sql_var_token ^ "\" x\"00\"" + } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_at prefix sql ?(at = "x\"00\"") () = + let generate_open_cursor prefix (cursor_name : sqlVarToken) cobol_lst = + match cobol_lst with + | Some _ -> [ Generated_type.Todo { prefix } ] + | None -> + let cursor_name' = + Misc.extract_filename filename ^ "-" ^ cursor_name.payload + in + let if1 = + let prefix = prefix ^ " " in + [ Generated_type.PerformStatement + { prefix; target = "GIXSQL-CI-P-" ^ cursor_name' }; + Generated_type.If + { prefix; + condition = "SQLCODE = 0"; + if_stm = + (let prefix = prefix ^ " " in + [ Generated_type.Move + { prefix; src = "X"; dest = "GIXSQL-CI-F-" ^ cursor_name' } + ] ) + } + ] + in + let if2 = + let prefix = prefix ^ " " in + [ Generated_type.CallStatic + { prefix; + fun_name = "SQGIXSQLCursorOpen"; + ref_value = + (let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference + { prefix; + var = + "\"" + ^ Misc.extract_filename filename + ^ "_" ^ cursor_name.payload ^ "\" & x\"00\"" + } + ] ) + } + ] + in + [ Generated_type.If + { prefix; + condition = "GIXSQL-CI-F-" ^ cursor_name' ^ " = ' '"; + if_stm = if1 + }; + Generated_type.If + { prefix; + condition = "GIXSQL-CI-F-" ^ cursor_name' ^ " = 'X'"; + if_stm = if2 + } + ] + in + + let generate_at prefix sql ?at () = match sql with - | SelectInto { vars; _ } -> - generate_select_into prefix vars ~at () (*TODO AT*) + | SelectInto { vars; select_options; select} -> + generate_select_into prefix vars select_options select ?at () (*TODO AT*) | Rollback (rb_work_or_tran, rb_args) -> - generate_rollback prefix rb_work_or_tran rb_args ~at () + generate_rollback prefix rb_work_or_tran rb_args ?at () | Commit (rb_work_or_tran, b) -> - generate_commit prefix rb_work_or_tran b ~at () + generate_commit prefix rb_work_or_tran b ?at () | DeclareCursor cur -> - add_to_cursor_declararation prefix cur ~at (); + add_to_cursor_declaration prefix cur ?at (); [] + | ExecuteImmediate var -> generate_simpl_execute_immediat prefix var ?at () | Insert _ | Savepoint _ - | StartTransaction - | Sql _ -> - generate_declare prefix ~at () + | StartTransaction -> + generate_declare prefix ?at () + | Sql sql -> ( + match sql with + | Sql_ast.SqlInstr w :: _ when w = "VAR" -> + [] + (*TODO: find what this should be replaced with. I think Gix juste ignorer these instruction, but mabe not*) + | _ -> generate_declare prefix ?at () ) + | Prepare (var_name, sql_instr) -> + generate_prepare_stm prefix var_name sql_instr ?at () + | ExecuteIntoUsing + { executed_string; opt_into_hostref_list; opt_using_hostref_list } -> + generate_execute_into_using prefix executed_string ?opt_into_hostref_list + ?opt_using_hostref_list ?at () | DeclareTable _ - | Prepare _ - | ExecuteImmediate _ - | ExecuteIntoUsing _ | Delete _ | Update _ -> [ Generated_type.Todo { prefix } ] + (*Unexeped At, should trigger an error*) | _ -> failwith "Unexeped At" in - let generatesql ~loc ~line esql_instuction = + let rec generatesql ~loc ~line esql_instuction = let prefix = String.sub line 0 loc.char in match esql_instuction with | Sql _ @@ -444,13 +672,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | Insert _ | Delete _ | Update _ -> - generate_at prefix esql_instuction ?at:(Some "x\"00\"") () + generate_at prefix esql_instuction () | Include sqlvar -> (* let prefix = String.sub line 0 loc.char in *) [ Generated_type.Copy { prefix; file_name = sqlvar.payload } ] | Connect cs -> generatesql_connect cs prefix - | Disconnect lit -> - [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt lit) () ] + | Disconnect var -> + [ generatesql_connect_reset ~prefix ?d_connection_id:(var_opt var) + ?connection_id_tl:(get_some_length var) () + ] | DisconnectAll -> [ generatesql_connect_reset ~prefix ?d_connection_id:(Some "\"*\" & x\"00\"") () @@ -463,10 +693,25 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | EndDeclare -> [] (*do nothing*) | Close var -> [ generate_close_cursor prefix var.payload ] - | At (at, sql) -> generate_at prefix sql ?at:(var_opt (Some at)) () + | At (at, sql) -> begin + match sql with + (*Unexpeted At, we print an error and ignore it*) + (*todo: change Generated_type.NonFatalErrorWarning by proper warning*) + | Fetch _ + | Open _ + | Close _ -> + Generated_type.NonFatalErrorWarning + { content = + "AT DB-NAME is not allowed for CURSOR access, always used from \ + CURSOR DECLARE" + } + :: generatesql ~loc ~line sql + | _ -> generate_at prefix sql ~at () + end + | Open (sql_var_token, cobol_lst) -> + generate_open_cursor prefix sql_var_token cobol_lst + | Fetch (sql, cob) -> generate_fetch prefix sql cob | Exeption _ - | Open (_, _) - | Fetch (_, _) | Ignore _ -> (*TODO*) [ Generated_type.Todo { prefix } ] @@ -489,7 +734,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = begin match stmt with | END_PROCEDURE_DIVISION -> - res @ end_procedure_division (List.rev !cursor_declararation) + res @ end_procedure_division (List.rev !cursor_declaration) | _ -> res end | Some begin_loc -> output_statement lines begin_loc stmt statements @@ -530,8 +775,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let old_stms = List.rev !old_statements in let with_dot, error_treatment = match trans_stm with - | [] -> false, [] (*if nothing is generated, we don't need error treatment or dots *) - | _ -> with_dot, !error_treatment + | [] -> + ( false, + [] + (*if nothing is generated, we don't need error treatment or dots *) + ) + | _ -> (with_dot, !error_treatment) in old_statements := []; Generated_type.Change @@ -579,7 +828,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [ comment "> BEGIN PROCEDURE DIVISION disabled" ] ) @ output cur_lines statements | END_PROCEDURE_DIVISION -> - end_procedure_division (List.rev !cursor_declararation) + end_procedure_division (List.rev !cursor_declaration) @ output cur_lines statements | COPY { end_loc; filename; contents } -> let added = comment ("> INLINED:" ^ line) in diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index c972f4e8f..287dc61f6 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -54,12 +54,28 @@ type trans_stm = { prefix : string; target : string } + | PerformStatement of + { prefix : string; + target : string + } + | If of + { prefix : string; + condition : string; + if_stm : trans_stm list + } + | Move of + { prefix : string; + src : string; + dest : string + } | Declaration of declaration | Comment of { content : string } | Section of { name : string } | LinkageSection | WorkingStorageSection | ProcedureDivision + (*these type are for debug*) + | NonFatalErrorWarning of { content : string } | Todo of { prefix : string } type generated_stm = @@ -103,6 +119,7 @@ module Printer = struct and pp_trans_stm fmt x = match x with + | [ h ] -> Format.fprintf fmt "%a" pp_trans_stm_aux h | h :: t -> Format.fprintf fmt "%a\n%a" pp_trans_stm_aux h pp_trans_stm t | [] -> () @@ -121,11 +138,22 @@ module Printer = struct pp_ref_value_list ref_value prefix | Copy { prefix; file_name } -> Format.fprintf fmt "%sCOPY %s" prefix file_name - | GotoStatement { prefix; target } -> Format.fprintf fmt "%sGOTO %s" prefix target + | GotoStatement { prefix; target } -> + Format.fprintf fmt "%sGOTO %s" prefix target + | PerformStatement { prefix; target } -> + Format.fprintf fmt "%sPERFORM %s" prefix target + | If { prefix; condition; if_stm } -> + Format.fprintf fmt "%sIF %s THEN\n%a\n%sEND-IF" prefix condition + pp_trans_stm if_stm prefix + | Move { prefix; src; dest } -> + Format.fprintf fmt "%sMOVE '%s' TO %s" prefix src dest | Declaration d -> Format.fprintf fmt "%a" pp_declaration d - | LinkageSection -> Format.fprintf fmt "LINKAGE SECTION." - | WorkingStorageSection -> Format.fprintf fmt "WORKING-STORAGE SECTION." - | ProcedureDivision -> Format.fprintf fmt "PROCEDURE DIVISION." + | LinkageSection -> Format.fprintf fmt " LINKAGE SECTION." + | WorkingStorageSection -> + Format.fprintf fmt " WORKING-STORAGE SECTION." + | ProcedureDivision -> Format.fprintf fmt " PROCEDURE DIVISION." + | NonFatalErrorWarning { content } -> + Format.fprintf fmt " *> WARNING: %s" content | Todo { prefix } -> Format.fprintf fmt "%sTODO" prefix and pp_declaration fmt = function diff --git a/src/lsp/sql_preproc/misc.ml b/src/lsp/sql_preproc/misc.ml index 02ea61af3..5cb9c4e0a 100644 --- a/src/lsp/sql_preproc/misc.ml +++ b/src/lsp/sql_preproc/misc.ml @@ -13,42 +13,42 @@ open Cobol_indent.Types open Types let loc_of_edit ~filename e = - { filename ; - line = e.tok_edit.edit.lnum ; - char = e.tok_indent + e.tok_edit.edit.offset_orig ; + { filename; + line = e.tok_edit.edit.lnum; + char = e.tok_indent + e.tok_edit.edit.offset_orig } let error ?loc fmt = - Printf.kprintf (fun s -> + Printf.kprintf + (fun s -> Printf.eprintf "Error"; - begin match loc with + begin + match loc with | None -> () - | Some loc -> - Printf.eprintf " at %s:%d" loc.filename loc.line + | Some loc -> Printf.eprintf " at %s:%d" loc.filename loc.line end; Printf.eprintf ": %s\n%!" s; Printf.eprintf "Aborting.\n%!"; - exit 2 - ) fmt + exit 2 ) + fmt let warning ?loc fmt = - Printf.kprintf (fun s -> + Printf.kprintf + (fun s -> Printf.eprintf "Warning"; - begin match loc with + begin + match loc with | None -> () - | Some loc -> - Printf.eprintf " at %s:%d" loc.filename loc.line + | Some loc -> Printf.eprintf " at %s:%d" loc.filename loc.line end; - Printf.eprintf ": %s\n%!" s; - ) fmt - + Printf.eprintf ": %s\n%!" s ) + fmt let string_of_token = function | IDENT tok -> tok | CHARS tok -> tok | INTEGER tok -> tok | NUMBER tok -> tok - | DOT -> "." | LPAREN -> "(" | RPAREN -> ")" @@ -68,42 +68,177 @@ let string_of_token = function | DOLLAR -> "$" | AMPER -> "&" | SHARP -> "#" + | tok -> ( + try Hashtbl.find Cobol_indent.Lexer.keyword2string tok with + | Not_found -> failwith (Cobol_indent.Misc.string_of_token tok) ) - | tok -> - try - Hashtbl.find Cobol_indent.Lexer.keyword2string tok - with Not_found -> - failwith ( Cobol_indent.Misc.string_of_token tok ) - -let add_dot ~with_dot b = - if with_dot then - Printf.bprintf b " .\n" +let add_dot ~with_dot b = if with_dot then Printf.bprintf b " .\n" let resolve_copy ~config file = - let rec iter_exts exts = match exts with - | [] -> - raise Not_found - | ext :: exts -> - let file = String.lowercase_ascii (file ^ ext) in - match iter_paths file (Lazy.force config.copy_path) with - | exception Not_found -> iter_exts exts - | filename -> filename - + | [] -> raise Not_found + | ext :: exts -> ( + let file = String.lowercase_ascii (file ^ ext) in + match iter_paths file (Lazy.force config.copy_path) with + | exception Not_found -> iter_exts exts + | filename -> filename ) and iter_paths file path = match path with | [] -> raise Not_found - | (dir, map) :: path -> - match StringMap.find file map with - | exception Not_found -> iter_paths file path - | file -> Filename.concat dir file + | (dir, map) :: path -> ( + match StringMap.find file map with + | exception Not_found -> iter_paths file path + | file -> Filename.concat dir file ) in iter_exts config.copy_exts +let rec extract_cob_complex_lit = function + | Sql_ast.SqlCompLit (LiteralVar (CobolVar variable)) + | SqlCompAs (LiteralVar (CobolVar variable), _) -> + [ variable ] + | SqlCompFun (_, sql_op_list) -> extract_cob_var_select sql_op_list + | _ -> [] + +and extract_cob_var_sql_op = function + | Sql_ast.SqlOpLit compl_lit -> extract_cob_complex_lit compl_lit + | SqlOpBinop (_, compl_lit, sql_op) -> + extract_cob_complex_lit compl_lit @ extract_cob_var_sql_op sql_op + +and extract_cob_var_select = function + | h :: t -> extract_cob_var_sql_op h @ extract_cob_var_select t + | [] -> [] + +and extract_lit = function + | Sql_ast.LiteralVar (CobolVar variable) -> [ variable ] + | _ -> [] + +and extract_from_join_option = function + | Sql_ast.JoinOn sc -> extract_from_search_condition sc + | _ -> [] + +and extract_from_search_condition = function + | WhereConditionOr (search_condition1, search_condition2) + | WhereConditionAnd (search_condition1, search_condition2) -> + extract_from_search_condition search_condition1 + @ extract_from_search_condition search_condition2 + | WhereConditionNot search_condition -> + extract_from_search_condition search_condition + | WhereConditionCompare sql_compare -> ( + match sql_compare with + | CompareQuery (complex_literal, _, sql_instruction) -> + extract_cob_complex_lit complex_literal @ extract_cob_var sql_instruction + | CompareLit (complex_literal1, _, complex_literal2) -> + extract_cob_complex_lit complex_literal1 + @ extract_cob_complex_lit complex_literal2 ) + | WhereConditionIn (InVarLst (lit, comp_lit_list)) -> + let rec extract_comp_lit_list lst = + match lst with + | h :: t -> extract_cob_complex_lit h @ extract_comp_lit_list t + | [] -> [] + in + extract_lit lit @ extract_comp_lit_list comp_lit_list + | WhereConditionBetween (Between (l1, l2, l3)) -> + extract_lit l1 @ extract_lit l2 @ extract_lit l3 + | WhereConditionIsNull variable -> ( + match variable with + | CobolVar v -> [ v ] + | SqlVar _ -> [] ) + +and extract_cob_var_select_option = function + | Sql_ast.From from_stm -> + let rec extract_from_stm = function + | h :: t -> + let rec extract_from_tbl_ref = function + | Sql_ast.FromLitAs (table_ref, literal) -> + extract_from_tbl_ref table_ref @ extract_lit literal + | FromLit literal -> extract_lit literal + | FromSelect sql_query -> extract_cob_var_query sql_query + | Join (table_ref1, _, table_ref2, Some join_option) -> + extract_from_tbl_ref table_ref1 + @ extract_from_tbl_ref table_ref2 + @ extract_from_join_option join_option + | Join (table_ref1, _, table_ref2, _) -> + extract_from_tbl_ref table_ref1 @ extract_from_tbl_ref table_ref2 + in + extract_from_tbl_ref h @ extract_from_stm t + | [] -> [] + in + extract_from_stm from_stm + | Sql_ast.Where search_condition + | Having search_condition -> + extract_from_search_condition search_condition + | OrderBy sql_orderBy_list -> + let rec extract_sql_orderBy = function + | Sql_ast.Asc lit :: h + | Desc lit :: h -> + extract_lit lit @ extract_sql_orderBy h + | [] -> [] + in + extract_sql_orderBy sql_orderBy_list + | GroupBy literal_list -> + let rec extract_sql_lit_list = function + | h :: t -> extract_lit h @ extract_sql_lit_list t + | [] -> [] + in + extract_sql_lit_list literal_list + +and extract_cob_var_query sql_query = + match sql_query with + | Sql_ast.SelectUnion (sql_query1, sql_query2) + | Sql_ast.SelectExcept (sql_query1, sql_query2) + | Sql_ast.SelectIntersect (sql_query1, sql_query2) -> + extract_cob_var_query sql_query1 @ extract_cob_var_query sql_query2 + | Sql_ast.SelectQuery (sql_select, sql_select_option_list) -> + extract_cob_var_select sql_select + @ extract_cob_var_select_option_list sql_select_option_list + +and extract_cob_var_select_option_list = function + | h :: t -> + extract_cob_var_select_option h @ extract_cob_var_select_option_list t + | [] -> [] + +and extract_cob_var sql = + match sql with + | Sql_ast.SqlVarToken (CobolVar variable) :: t -> + variable :: extract_cob_var t + | Sql_ast.SqlLit (LiteralVar (CobolVar variable)) :: t -> + variable :: extract_cob_var t + | Sql_ast.SqlQuery sql_query :: t -> + extract_cob_var_query sql_query @ extract_cob_var t + | [] -> [] + | _ :: t -> extract_cob_var t + +let extract_filename path = + let parts = Str.split (Str.regexp "/") path in + let filename_with_ext = List.hd (List.rev parts) in + let filename_parts = Str.split (Str.regexp "\\.") filename_with_ext in + List.hd filename_parts + +let replace_colon_words str = + let buffer = Buffer.create (String.length str) in + let count = ref 0 in + let len = String.length str in + let i = ref 0 in + + while !i < len do + if str.[!i] = ':' then ( + incr count; + Buffer.add_string buffer ("$" ^ string_of_int !count); + incr i; + while + !i < len + && str.[!i] <> ' ' + && str.[!i] <> ',' + && str.[!i] <> ')' + && str.[!i] <> '(' + do + incr i + done + ) else ( + Buffer.add_char buffer str.[!i]; + incr i + ) + done; - let extract_filename path = - let parts = Str.split (Str.regexp "/") path in - let filename_with_ext = List.hd (List.rev parts) in - let filename_parts = Str.split (Str.regexp "\\.") filename_with_ext in - List.hd filename_parts \ No newline at end of file + Buffer.contents buffer diff --git a/src/lsp/sql_preproc/misc.mli b/src/lsp/sql_preproc/misc.mli index 0a26f6be1..5a87942e3 100644 --- a/src/lsp/sql_preproc/misc.mli +++ b/src/lsp/sql_preproc/misc.mli @@ -10,12 +10,9 @@ open EzCompat -val error : - ?loc:Types.loc -> ('a, unit, string, 'b) format4 -> 'a +val error : ?loc:Types.loc -> ('a, unit, string, 'b) format4 -> 'a -val warning : - ?loc:Types.loc -> - ('a, unit, string, unit) format4 -> 'a +val warning : ?loc:Types.loc -> ('a, unit, string, unit) format4 -> 'a val loc_of_edit : filename:string -> Cobol_indent.Types.token_descr -> Types.loc @@ -25,4 +22,13 @@ val add_dot : with_dot:bool -> Buffer.t -> unit val resolve_copy : config:Types.config -> string -> string +val extract_cob_var_query : Sql_ast.sql_query -> Sql_ast.cobol_var list + +val extract_cob_var_select_option_list : + Sql_ast.sql_select_option list -> Sql_ast.cobol_var list + +val extract_cob_var_select : Sql_ast.sql_select -> Sql_ast.cobol_var list + val extract_filename : string -> string + +val replace_colon_words : string -> string From 5c987a90c2fb66ea8639074ea6bf8e2f1a2b74d0 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Mon, 12 Aug 2024 16:15:16 +0200 Subject: [PATCH 12/37] add Prepare Into and fix typos --- src/lsp/sql_preproc/generate.ml | 67 ++++++++++++++++++++------- src/lsp/sql_preproc/generated_type.ml | 2 +- 2 files changed, 52 insertions(+), 17 deletions(-) diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index adecad491..358510888 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -306,9 +306,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_select_into_one prefix vars ?at () = + let generate_select_into_one prefix vars cob_vars ?at () = let at_name, at_size = get_at_info at in - let size = string_of_int (List.length vars) in let fun_name = "GIXSQLExecSelectIntoOne" in let ref_value = let var_name = @@ -320,8 +319,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = var_name }; - Generated_type.Value { prefix; var = "0" }; - Generated_type.Value { prefix; var = size } + Generated_type.Value + { prefix; var = string_of_int (List.length cob_vars) }; + Generated_type.Value { prefix; var = string_of_int (List.length vars) } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } @@ -329,11 +329,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_select_into prefix vars select_options select ?at () = let selects_into_vars = List.map (generate_set_result_param prefix) vars in - let selects_into = generate_select_into_one prefix vars ?at () in - let cob_vars = Misc.extract_cob_var_select select @ (Misc.extract_cob_var_select_option_list select_options) in - let trans_cob_var = List.map (generate_set_result_param prefix) cob_vars in + let cob_vars = + Misc.extract_cob_var_select select + @ Misc.extract_cob_var_select_option_list select_options + in + let trans_cob_var = List.map (generate_set_sql_param prefix) cob_vars in + let selects_into = generate_select_into_one prefix vars cob_vars ?at () in let trans_stm = - generate_start_end_sql prefix (selects_into_vars @ trans_cob_var @[ selects_into ]) + generate_start_end_sql prefix + (selects_into_vars @ trans_cob_var @ [ selects_into ]) in trans_stm in @@ -496,7 +500,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = "\"" ^ var_name.payload ^ "\" & x\"00\"" }; Generated_type.Reference { prefix; var = sql_name }; - Generated_type.Value { prefix; var = "0" } (*todo*) + Generated_type.Value + { prefix; var = string_of_int (get_length sql_name) } + (*todo*) ] in [ Generated_type.CallStatic @@ -531,19 +537,48 @@ let generate ~filename ~contents ~cobol_unit sql_statements = { prefix; fun_name = "GIXSQLPrepareStatement"; ref_value } in + let generate_exec_prepared_into prefix (executed_string : sqlVarToken) + into_hostref_list opt_using_hostref_list ?at () = +let at_name, at_size = get_at_info at in +let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference + { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; + Generated_type.Value + { prefix; var = string_of_int (List.length into_hostref_list) }; + Generated_type.Value + { prefix; var = string_of_int (List.length opt_using_hostref_list) } + (*todo*) + ] +in +Generated_type.CallStatic + { prefix; fun_name = "GIXSQLExecPreparedInto"; ref_value } +in + let generate_execute_into_using prefix executed_string ?(opt_into_hostref_list = []) ?(opt_using_hostref_list = []) ?at () = - ignore opt_into_hostref_list; - (*todo*) - let execute_using_vars = + let into_hostref_set_result_param = + List.map (generate_set_result_param prefix) opt_into_hostref_list + in + let using_hostref_set_sql = List.map (generate_set_sql_param prefix) opt_using_hostref_list in let exec_prepared = - generate_exec_prepared prefix executed_string opt_using_hostref_list ?at - () + match opt_into_hostref_list with + | [] -> + generate_exec_prepared prefix executed_string opt_using_hostref_list ?at + () + | _ -> + generate_exec_prepared_into prefix executed_string + opt_using_hostref_list opt_into_hostref_list ?at () in let trans_stm = - generate_start_end_sql prefix (execute_using_vars @ [ exec_prepared ]) + generate_start_end_sql prefix + ( using_hostref_set_sql @ into_hostref_set_result_param + @ [ exec_prepared ] ) in trans_stm in @@ -621,7 +656,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_at prefix sql ?at () = match sql with - | SelectInto { vars; select_options; select} -> + | SelectInto { vars; select_options; select } -> generate_select_into prefix vars select_options select ?at () (*TODO AT*) | Rollback (rb_work_or_tran, rb_args) -> generate_rollback prefix rb_work_or_tran rb_args ?at () diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index 287dc61f6..bd099ceed 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -169,7 +169,7 @@ module Printer = struct | Some n -> n | None -> "" in - Format.fprintf fmt "%s%s %s %s %s." prefix var_importance var_name + Format.fprintf fmt "%s%s %s PIC %s %s." prefix var_importance var_name var_type var_content | Field_var_declaration { prefix; var_importance; var_name; field } -> Format.fprintf fmt "%s%s %s.%a" prefix var_importance var_name pp_field From 45be81d5793991d8ebab1cb12b07a3dad99c5d8a Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Tue, 13 Aug 2024 13:53:12 +0200 Subject: [PATCH 13/37] fix Insert --- src/lsp/sql_preproc/generate.ml | 259 ++++++++++++++++++-------- src/lsp/sql_preproc/generated_type.ml | 15 +- 2 files changed, 191 insertions(+), 83 deletions(-) diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 358510888..adf067765 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -35,6 +35,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let error_treatment = ref [] in let old_statements = ref [] in let cursor_declaration = ref [] in + let in_pro_div = ref true in let num = ref 0 in (*GET FUNCTION*) @@ -54,7 +55,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [ Generated_type.Comment { content = "> ESQL CURSOR DECLARATIONS (START)" }; Generated_type.GotoStatement - { prefix = " "; target = "GIX-SKIP-CRSR-INIT" } + { prefix = " "; target = "GIX-SKIP-CRSR-INIT" } ] } :: cd @@ -376,28 +377,34 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; - Generated_type.Reference { prefix; var = "\"" ^ name ^ "\" & x\"00\"" } + Generated_type.Reference { prefix; var = name } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generate_declare prefix ?at () = + let generate_GIXSQLExecParam prefix name value_list ?at () = let at_name, at_size = get_at_info at in - let fun_name = "GIXSQLExec" in + let fun_name = "GIXSQLExecParams" in let ref_value = - let var_name = - num := !num + 1; - "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) - in let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; - Generated_type.Reference { prefix; var = var_name } + Generated_type.Reference { prefix; var = name }; + Generated_type.Value + { prefix; var = string_of_int (List.length value_list) } ] in - let declare = Generated_type.CallStatic { prefix; fun_name; ref_value } in + Generated_type.CallStatic { prefix; fun_name; ref_value } + in + + let generate_declare prefix ?at () = + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + let declare = generate_GIXSQLExec prefix var_name ?at () in let trans_stm = generate_start_end_sql prefix [ declare ] in trans_stm @@ -407,7 +414,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match (rb_work_or_tran, rb_args) with | None, None -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "ROLLBACK" ?at () ] + [ generate_GIXSQLExec prefix "\"ROLLBACK \" & x\"00\"" ?at () ] | _, Some (To _) -> generate_declare prefix () | _ -> [ Generated_type.Todo { prefix } ] in @@ -416,7 +423,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match (rb_work_or_tran, rb_args) with | None, false -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "COMMIT" ?at () ] + [ generate_GIXSQLExec prefix "\"COMMIT\" & x\"00\"" ?at () ] | _ -> [ Generated_type.Todo { prefix } ] in @@ -444,39 +451,70 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let add_to_cursor_declaration prefix cur ?at () = let at_name, at_size = get_at_info at in - let adding = + let cur_name, cob_var_lst, _with_hold = match cur with - | DeclareCursorSql (cur_name, _) -> begin - let fun_name = "GIXSQLCursorDeclare" in - let ref_value = - let cursor_name = "\"TSQL003A_" ^ cur_name.payload ^ "\" & x\"00\"" in - let var_name = - num := !num + 1; - "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) - in - let prefix = prefix ^ " " in - [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at_name }; - Generated_type.Value { prefix; var = string_of_int at_size }; - Generated_type.Reference { prefix; var = cursor_name }; - Generated_type.Value { prefix; var = "0" }; - Generated_type.Reference { prefix; var = var_name }; - Generated_type.Value { prefix; var = "0" } - ] + | DeclareCursorSql (cur_name, sql) -> + (cur_name, Misc.extract_cob_var_query sql, false) + | DeclareCursorVar (cur_name, cob_var_lst) -> + let var = + match cob_var_lst with + | SqlVar _ -> [] + | CobolVar v -> [ v ] in - [ Generated_type.Section - { name = - "GIXSQL-CI-P-" - ^ Misc.extract_filename filename - ^ "-" ^ cur_name.payload - }; - Generated_type.CallStatic { prefix; fun_name; ref_value } + (cur_name, var, false) + | DeclareCursorWhithHold (cur_name, query) -> + (cur_name, Misc.extract_cob_var_query query, true) + in + + let cursor_name = "\"TSQL003A_" ^ cur_name.payload ^ "\" & x\"00\"" in + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + + let fun_name, cursor_declare = + match cob_var_lst with + | [] -> + let prefix = prefix ^ " " in + ( "GIXSQLCursorDeclare", + [ Generated_type.Reference { prefix; var = var_name }; + Generated_type.Value { prefix; var = "0" } + ] ) + | _ -> + let prefix = prefix ^ " " in + ( "GIXSQLCursorDeclareParams", + [ Generated_type.Reference { prefix; var = var_name }; + Generated_type.Value { prefix; var = "0" }; + Generated_type.Value + { prefix; var = string_of_int (List.length cob_var_lst) } + ] ) + in + let adding = + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference { prefix; var = cursor_name }; + Generated_type.Value { prefix; var = "0" } ] - end - | DeclareCursorVar (_cur_name, _var_name) -> - [ Generated_type.Todo { prefix } ] - | DeclareCursorWhithHold (_cur_name, _query) -> - [ Generated_type.Todo { prefix } ] + @ cursor_declare + in + List.map (generate_set_sql_param prefix) cob_var_lst + @ [ Generated_type.CallStatic { prefix; fun_name; ref_value } ] + in + let adding = + [ Generated_type.Section + { name = + "GIXSQL-CI-P-" + ^ Misc.extract_filename filename + ^ "-" ^ cur_name.payload + } + ] + @ + match cob_var_lst with + | [] -> adding + | _ -> generate_start_end_sql prefix adding in let st = Generated_type.Added { content = adding } in let cd = st :: !cursor_declaration in @@ -538,25 +576,25 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let generate_exec_prepared_into prefix (executed_string : sqlVarToken) - into_hostref_list opt_using_hostref_list ?at () = -let at_name, at_size = get_at_info at in -let ref_value = - let prefix = prefix ^ " " in - [ Generated_type.Reference { prefix; var = "SQLCA" }; - Generated_type.Reference { prefix; var = at_name }; - Generated_type.Value { prefix; var = string_of_int at_size }; - Generated_type.Reference - { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; - Generated_type.Value - { prefix; var = string_of_int (List.length into_hostref_list) }; - Generated_type.Value - { prefix; var = string_of_int (List.length opt_using_hostref_list) } - (*todo*) - ] -in -Generated_type.CallStatic - { prefix; fun_name = "GIXSQLExecPreparedInto"; ref_value } -in + into_hostref_list opt_using_hostref_list ?at () = + let at_name, at_size = get_at_info at in + let ref_value = + let prefix = prefix ^ " " in + [ Generated_type.Reference { prefix; var = "SQLCA" }; + Generated_type.Reference { prefix; var = at_name }; + Generated_type.Value { prefix; var = string_of_int at_size }; + Generated_type.Reference + { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; + Generated_type.Value + { prefix; var = string_of_int (List.length into_hostref_list) }; + Generated_type.Value + { prefix; var = string_of_int (List.length opt_using_hostref_list) } + (*todo*) + ] + in + Generated_type.CallStatic + { prefix; fun_name = "GIXSQLExecPreparedInto"; ref_value } + in let generate_execute_into_using prefix executed_string ?(opt_into_hostref_list = []) ?(opt_using_hostref_list = []) ?at () = @@ -600,6 +638,22 @@ in Generated_type.CallStatic { prefix; fun_name; ref_value } in + let generate_open_cursor_aux prefix cursor_name = + let prefix = prefix ^ " " in + [ Generated_type.PerformStatement + { prefix; target = "GIXSQL-CI-P-" ^ cursor_name }; + Generated_type.If + { prefix; + condition = "SQLCODE = 0"; + if_stm = + (let prefix = prefix ^ " " in + [ Generated_type.Move + { prefix; src = "X"; dest = "GIXSQL-CI-F-" ^ cursor_name } + ] ) + } + ] + in + let generate_open_cursor prefix (cursor_name : sqlVarToken) cobol_lst = match cobol_lst with | Some _ -> [ Generated_type.Todo { prefix } ] @@ -607,21 +661,6 @@ in let cursor_name' = Misc.extract_filename filename ^ "-" ^ cursor_name.payload in - let if1 = - let prefix = prefix ^ " " in - [ Generated_type.PerformStatement - { prefix; target = "GIXSQL-CI-P-" ^ cursor_name' }; - Generated_type.If - { prefix; - condition = "SQLCODE = 0"; - if_stm = - (let prefix = prefix ^ " " in - [ Generated_type.Move - { prefix; src = "X"; dest = "GIXSQL-CI-F-" ^ cursor_name' } - ] ) - } - ] - in let if2 = let prefix = prefix ^ " " in [ Generated_type.CallStatic @@ -644,7 +683,7 @@ in [ Generated_type.If { prefix; condition = "GIXSQL-CI-F-" ^ cursor_name' ^ " = ' '"; - if_stm = if1 + if_stm = generate_open_cursor_aux prefix cursor_name' }; Generated_type.If { prefix; @@ -654,6 +693,46 @@ in ] in + let generate_declare_cursor prefix cur = + let curname = + match cur with + | DeclareCursorSql (curname, _) + | DeclareCursorVar (curname, _) + | DeclareCursorWhithHold (curname, _) -> + curname + in + let curname = Misc.extract_filename filename ^ "-" ^ curname.payload in + let if1 = generate_open_cursor_aux prefix curname in + [ Generated_type.IfElse + { prefix; + condition = "GIXSQL-CI-F-" ^ curname ^ " = ' '"; + if_stm = if1; + else_stm = + [ Generated_type.Move + { prefix = prefix ^ " "; src = "0"; dest = "SQLCODE" } + ] + } + ] + in + + let generate_insert prefix ?value_list ?at () = + match value_list with + | None -> generate_declare prefix ?at () + | Some value_list -> + let rec generate_insert_rec prefix vl ?at () = + match vl with + | [] -> + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + [ generate_GIXSQLExecParam prefix var_name value_list ?at () ] + | h :: t -> + generate_set_sql_param prefix h :: generate_insert_rec prefix t ?at () + in + generate_insert_rec prefix value_list ?at () + in + let generate_at prefix sql ?at () = match sql with | SelectInto { vars; select_options; select } -> @@ -664,9 +743,28 @@ in generate_commit prefix rb_work_or_tran b ?at () | DeclareCursor cur -> add_to_cursor_declaration prefix cur ?at (); - [] + if !in_pro_div then begin + generate_declare_cursor prefix cur + end else + [] | ExecuteImmediate var -> generate_simpl_execute_immediat prefix var ?at () - | Insert _ + | Insert (_, value_list) -> + let value_list = + let rec value_list_cob_var = function + | ValueList ll :: t -> + let rec ll_cob_value = function + | LiteralVar (CobolVar c) :: t -> c :: ll_cob_value t + | [] -> [] + | _ :: t -> ll_cob_value t + in + ll_cob_value ll @ value_list_cob_var t + | [] -> [] + | _ :: t -> value_list_cob_var t + in + value_list_cob_var value_list + in + + generate_insert prefix ~value_list ?at () | Savepoint _ | StartTransaction -> generate_declare prefix ?at () @@ -674,7 +772,7 @@ in match sql with | Sql_ast.SqlInstr w :: _ when w = "VAR" -> [] - (*TODO: find what this should be replaced with. I think Gix juste ignorer these instruction, but mabe not*) + (*TODO: find what this should be replaced with. I think Gix juste ignore these instruction, but mabe not*) | _ -> generate_declare prefix ?at () ) | Prepare (var_name, sql_instr) -> generate_prepare_stm prefix var_name sql_instr ?at () @@ -857,6 +955,7 @@ in ) else output_statement lines begin_loc stmt statements *) | BEGIN_PROCEDURE_DIVISION { enabled } -> + in_pro_div := true; ( if !enabled then begin_procedure_division ~loc:begin_loc else diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index bd099ceed..269cd24ef 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -63,6 +63,12 @@ type trans_stm = condition : string; if_stm : trans_stm list } + | IfElse of + { prefix : string; + condition : string; + if_stm : trans_stm list; + else_stm : trans_stm list + } | Move of { prefix : string; src : string; @@ -131,7 +137,7 @@ module Printer = struct and pp_trans_stm_aux fmt x = match x with - | Section { name } -> Format.fprintf fmt " %s" name + | Section { name } -> Format.fprintf fmt " %s" name | Comment { content } -> Format.fprintf fmt "ADDED *%s" content | CallStatic { prefix; fun_name; ref_value } -> Format.fprintf fmt "%sCALL STATIC \"%s\"%a%sEND-CALL" prefix fun_name @@ -139,12 +145,15 @@ module Printer = struct | Copy { prefix; file_name } -> Format.fprintf fmt "%sCOPY %s" prefix file_name | GotoStatement { prefix; target } -> - Format.fprintf fmt "%sGOTO %s" prefix target + Format.fprintf fmt "%sGO TO %s" prefix target | PerformStatement { prefix; target } -> Format.fprintf fmt "%sPERFORM %s" prefix target | If { prefix; condition; if_stm } -> Format.fprintf fmt "%sIF %s THEN\n%a\n%sEND-IF" prefix condition - pp_trans_stm if_stm prefix + pp_trans_stm if_stm prefix + | IfElse { prefix; condition; if_stm; else_stm } -> + Format.fprintf fmt "%sIF %s THEN\n%a\n%sELSE\n%a\n%sEND-IF" prefix condition + pp_trans_stm if_stm prefix pp_trans_stm else_stm prefix | Move { prefix; src; dest } -> Format.fprintf fmt "%sMOVE '%s' TO %s" prefix src dest | Declaration d -> Format.fprintf fmt "%a" pp_declaration d From ca64c9d996e27642384e804a186e84c41d6fc313 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Wed, 14 Aug 2024 10:33:50 +0200 Subject: [PATCH 14/37] fix select into and simplification --- src/lsp/sql_ast/sql_ast.ml | 4 +- src/lsp/sql_parser/lexer.mll | 12 ++- src/lsp/sql_preproc/data_gestion.ml | 2 + src/lsp/sql_preproc/generate.ml | 60 +++++++----- src/lsp/sql_preproc/misc.ml | 143 ++++++---------------------- src/lsp/sql_preproc/misc.mli | 7 +- 6 files changed, 77 insertions(+), 151 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index 55bd3dbcb..8a3763ff3 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -277,9 +277,9 @@ module Printer = struct | Rollback (rb_work_or_tran, rb_args) -> Format.fprintf fmt "ROLLBACK %a %a" pp_some_rb_work_or_tran rb_work_or_tran pp_rb_args rb_args - | Commit (rb_work_or_tran, bool) -> + | Commit (rb_work_or_tran, b) -> let s = - match bool with + match b with | true -> "RELEASE" | false -> "" in diff --git a/src/lsp/sql_parser/lexer.mll b/src/lsp/sql_parser/lexer.mll index bde336a73..e85d33232 100644 --- a/src/lsp/sql_parser/lexer.mll +++ b/src/lsp/sql_parser/lexer.mll @@ -131,16 +131,18 @@ rule token = parse { get_keyword s } | number as n { NUMBER n } - | '\'' ( ['A'-'Z' 'a'-'z' '0'-'9' '_' '(' '*' ')' '.' '[' ']' ' ' '+' '=' ',' ]* as s) '\'' + | '\'' ( [^ '\'']* as s) '\'' + { STRING s} + | '\"' ( [^ '\"']* as s) '\"' { STRING s} | "||" { OR } - | ['='] + | '=' { EQUAL } - | ['+'] + | '+' { PLUS } - | ['-'] + | '-' { MINUS } | "<=" { LESS_EQ } @@ -162,6 +164,8 @@ rule token = parse { RPAR } | '*' { STAR } + | ';' + { SEMICOLON } | ' ' { token lexbuf } | _ as c diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 537e983b1..0949d42d3 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -143,6 +143,8 @@ let transform_stm map (_, stm) filename = | DeclareCursorWhithHold (_cur_name, _query) -> ([], map) (*TODO*) end + | Exeption _ -> create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) + | _ -> ([], map) in diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index adf067765..ab7da64b8 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -290,8 +290,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in (* Todo: refactory *) - let generate_set_sql_param prefix arg = - let h = get_name_cobol_var arg in + let generate_set_sql_param prefix h = let fun_name = "GIXSQLSetSQLParams" in let ref_value = let prefix = prefix ^ " " in @@ -331,9 +330,13 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_select_into prefix vars select_options select ?at () = let selects_into_vars = List.map (generate_set_result_param prefix) vars in let cob_vars = - Misc.extract_cob_var_select select - @ Misc.extract_cob_var_select_option_list select_options + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_select_lst select) + @ Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_select_options_lst + select_options ) in + let trans_cob_var = List.map (generate_set_sql_param prefix) cob_vars in let selects_into = generate_select_into_one prefix vars cob_vars ?at () in let trans_stm = @@ -454,16 +457,22 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let cur_name, cob_var_lst, _with_hold = match cur with | DeclareCursorSql (cur_name, sql) -> - (cur_name, Misc.extract_cob_var_query sql, false) - | DeclareCursorVar (cur_name, cob_var_lst) -> + ( cur_name, + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query sql), + false ) + | DeclareCursorVar (cur_name, cur_var) -> let var = - match cob_var_lst with + match cur_var with | SqlVar _ -> [] - | CobolVar v -> [ v ] + | CobolVar v -> [ get_name_cobol_var v ] in (cur_name, var, false) | DeclareCursorWhithHold (cur_name, query) -> - (cur_name, Misc.extract_cob_var_query query, true) + ( cur_name, + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query), + true ) in let cursor_name = "\"TSQL003A_" ^ cur_name.payload ^ "\" & x\"00\"" in @@ -598,6 +607,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_execute_into_using prefix executed_string ?(opt_into_hostref_list = []) ?(opt_using_hostref_list = []) ?at () = + let opt_using_hostref_list = + List.map get_name_cobol_var opt_using_hostref_list + in let into_hostref_set_result_param = List.map (generate_set_result_param prefix) opt_into_hostref_list in @@ -730,7 +742,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | h :: t -> generate_set_sql_param prefix h :: generate_insert_rec prefix t ?at () in - generate_insert_rec prefix value_list ?at () + generate_start_end_sql prefix + (generate_insert_rec prefix value_list ?at ()) in let generate_at prefix sql ?at () = @@ -750,18 +763,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | ExecuteImmediate var -> generate_simpl_execute_immediat prefix var ?at () | Insert (_, value_list) -> let value_list = - let rec value_list_cob_var = function - | ValueList ll :: t -> - let rec ll_cob_value = function - | LiteralVar (CobolVar c) :: t -> c :: ll_cob_value t - | [] -> [] - | _ :: t -> ll_cob_value t - in - ll_cob_value ll @ value_list_cob_var t - | [] -> [] - | _ :: t -> value_list_cob_var t - in - value_list_cob_var value_list + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_value value_list) in generate_insert prefix ~value_list ?at () @@ -844,7 +847,18 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | Open (sql_var_token, cobol_lst) -> generate_open_cursor prefix sql_var_token cobol_lst | Fetch (sql, cob) -> generate_fetch prefix sql cob - | Exeption _ + | Exeption e -> + let var_name = + num := !num + 1; + "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + in + let cob_var_list = + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_exception e) + in + generate_start_end_sql prefix + ( List.map (generate_set_sql_param prefix) cob_var_list + @ [ generate_GIXSQLExecParam prefix var_name cob_var_list () ] ) | Ignore _ -> (*TODO*) [ Generated_type.Todo { prefix } ] diff --git a/src/lsp/sql_preproc/misc.ml b/src/lsp/sql_preproc/misc.ml index 5cb9c4e0a..37f35cfb2 100644 --- a/src/lsp/sql_preproc/misc.ml +++ b/src/lsp/sql_preproc/misc.ml @@ -93,121 +93,23 @@ let resolve_copy ~config file = in iter_exts config.copy_exts -let rec extract_cob_complex_lit = function - | Sql_ast.SqlCompLit (LiteralVar (CobolVar variable)) - | SqlCompAs (LiteralVar (CobolVar variable), _) -> - [ variable ] - | SqlCompFun (_, sql_op_list) -> extract_cob_var_select sql_op_list - | _ -> [] - -and extract_cob_var_sql_op = function - | Sql_ast.SqlOpLit compl_lit -> extract_cob_complex_lit compl_lit - | SqlOpBinop (_, compl_lit, sql_op) -> - extract_cob_complex_lit compl_lit @ extract_cob_var_sql_op sql_op - -and extract_cob_var_select = function - | h :: t -> extract_cob_var_sql_op h @ extract_cob_var_select t - | [] -> [] - -and extract_lit = function - | Sql_ast.LiteralVar (CobolVar variable) -> [ variable ] - | _ -> [] - -and extract_from_join_option = function - | Sql_ast.JoinOn sc -> extract_from_search_condition sc - | _ -> [] - -and extract_from_search_condition = function - | WhereConditionOr (search_condition1, search_condition2) - | WhereConditionAnd (search_condition1, search_condition2) -> - extract_from_search_condition search_condition1 - @ extract_from_search_condition search_condition2 - | WhereConditionNot search_condition -> - extract_from_search_condition search_condition - | WhereConditionCompare sql_compare -> ( - match sql_compare with - | CompareQuery (complex_literal, _, sql_instruction) -> - extract_cob_complex_lit complex_literal @ extract_cob_var sql_instruction - | CompareLit (complex_literal1, _, complex_literal2) -> - extract_cob_complex_lit complex_literal1 - @ extract_cob_complex_lit complex_literal2 ) - | WhereConditionIn (InVarLst (lit, comp_lit_list)) -> - let rec extract_comp_lit_list lst = - match lst with - | h :: t -> extract_cob_complex_lit h @ extract_comp_lit_list t - | [] -> [] - in - extract_lit lit @ extract_comp_lit_list comp_lit_list - | WhereConditionBetween (Between (l1, l2, l3)) -> - extract_lit l1 @ extract_lit l2 @ extract_lit l3 - | WhereConditionIsNull variable -> ( - match variable with - | CobolVar v -> [ v ] - | SqlVar _ -> [] ) - -and extract_cob_var_select_option = function - | Sql_ast.From from_stm -> - let rec extract_from_stm = function - | h :: t -> - let rec extract_from_tbl_ref = function - | Sql_ast.FromLitAs (table_ref, literal) -> - extract_from_tbl_ref table_ref @ extract_lit literal - | FromLit literal -> extract_lit literal - | FromSelect sql_query -> extract_cob_var_query sql_query - | Join (table_ref1, _, table_ref2, Some join_option) -> - extract_from_tbl_ref table_ref1 - @ extract_from_tbl_ref table_ref2 - @ extract_from_join_option join_option - | Join (table_ref1, _, table_ref2, _) -> - extract_from_tbl_ref table_ref1 @ extract_from_tbl_ref table_ref2 + and extract_cob_var_name str = + let len = String.length str in + let rec aux i acc = + if i >= len then List.rev acc + else if str.[i] = ':' then + let start = i + 1 in + let rec find_end j = + if j >= len || str.[j] = ' ' || str.[j] = ',' || str.[j] = ')' || str.[j] = '(' then j + else find_end (j + 1) in - extract_from_tbl_ref h @ extract_from_stm t - | [] -> [] - in - extract_from_stm from_stm - | Sql_ast.Where search_condition - | Having search_condition -> - extract_from_search_condition search_condition - | OrderBy sql_orderBy_list -> - let rec extract_sql_orderBy = function - | Sql_ast.Asc lit :: h - | Desc lit :: h -> - extract_lit lit @ extract_sql_orderBy h - | [] -> [] - in - extract_sql_orderBy sql_orderBy_list - | GroupBy literal_list -> - let rec extract_sql_lit_list = function - | h :: t -> extract_lit h @ extract_sql_lit_list t - | [] -> [] + let end_pos = find_end start in + let var_name = String.sub str start (end_pos - start) in + if List.mem var_name acc then aux end_pos acc + else aux end_pos (var_name :: acc) + else aux (i + 1) acc in - extract_sql_lit_list literal_list - -and extract_cob_var_query sql_query = - match sql_query with - | Sql_ast.SelectUnion (sql_query1, sql_query2) - | Sql_ast.SelectExcept (sql_query1, sql_query2) - | Sql_ast.SelectIntersect (sql_query1, sql_query2) -> - extract_cob_var_query sql_query1 @ extract_cob_var_query sql_query2 - | Sql_ast.SelectQuery (sql_select, sql_select_option_list) -> - extract_cob_var_select sql_select - @ extract_cob_var_select_option_list sql_select_option_list - -and extract_cob_var_select_option_list = function - | h :: t -> - extract_cob_var_select_option h @ extract_cob_var_select_option_list t - | [] -> [] - -and extract_cob_var sql = - match sql with - | Sql_ast.SqlVarToken (CobolVar variable) :: t -> - variable :: extract_cob_var t - | Sql_ast.SqlLit (LiteralVar (CobolVar variable)) :: t -> - variable :: extract_cob_var t - | Sql_ast.SqlQuery sql_query :: t -> - extract_cob_var_query sql_query @ extract_cob_var t - | [] -> [] - | _ :: t -> extract_cob_var t + aux 0 [] let extract_filename path = let parts = Str.split (Str.regexp "/") path in @@ -220,11 +122,11 @@ let replace_colon_words str = let count = ref 0 in let len = String.length str in let i = ref 0 in + let tbl = Hashtbl.create 10 in while !i < len do if str.[!i] = ':' then ( - incr count; - Buffer.add_string buffer ("$" ^ string_of_int !count); + let start = !i + 1 in incr i; while !i < len @@ -234,7 +136,16 @@ let replace_colon_words str = && str.[!i] <> '(' do incr i - done + done; + let var_name = String.sub str start (!i - start) in + if Hashtbl.mem tbl var_name then + Buffer.add_string buffer + ("$" ^ string_of_int (Hashtbl.find tbl var_name)) + else ( + incr count; + Hashtbl.add tbl var_name !count; + Buffer.add_string buffer ("$" ^ string_of_int !count) + ) ) else ( Buffer.add_char buffer str.[!i]; incr i diff --git a/src/lsp/sql_preproc/misc.mli b/src/lsp/sql_preproc/misc.mli index 5a87942e3..e0bb8941e 100644 --- a/src/lsp/sql_preproc/misc.mli +++ b/src/lsp/sql_preproc/misc.mli @@ -22,12 +22,7 @@ val add_dot : with_dot:bool -> Buffer.t -> unit val resolve_copy : config:Types.config -> string -> string -val extract_cob_var_query : Sql_ast.sql_query -> Sql_ast.cobol_var list - -val extract_cob_var_select_option_list : - Sql_ast.sql_select_option list -> Sql_ast.cobol_var list - -val extract_cob_var_select : Sql_ast.sql_select -> Sql_ast.cobol_var list +val extract_cob_var_name : string -> string list val extract_filename : string -> string From a85b84256f113bbf7df69e5de6ca5e0bfc7cd0ab Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Fri, 16 Aug 2024 17:16:41 +0200 Subject: [PATCH 15/37] rework error_treatment, fix cursor, add DeclareTable --- src/lsp/sql_preproc/data_gestion.ml | 9 +- src/lsp/sql_preproc/generate.ml | 154 ++++++++++++++++++-------- src/lsp/sql_preproc/generated_type.ml | 82 +++++++------- 3 files changed, 157 insertions(+), 88 deletions(-) diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 0949d42d3..ded173687 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -32,8 +32,8 @@ let num = ref 0 let transform_stm map (_, stm) filename = let prefix = " " in let create_new_var content = - let content = "\"" ^ Misc.replace_colon_words content ^ "\"" in - let size = String.length content in + let new_content = "\"" ^ Misc.replace_colon_words content ^ "\"" in + let size = (String.length new_content) -2 in (*Because " are part of this string"*) num := !num + 1; let var_name = "SQ" ^ string_of_int !num in let field = @@ -43,7 +43,7 @@ let transform_stm map (_, stm) filename = var_importance = "02"; var_name = None; var_type = "X(" ^ string_of_int size ^ ")"; - var_content = Some content + var_content = Some new_content }; Simple_var_declaration { prefix; @@ -106,7 +106,8 @@ let transform_stm map (_, stm) filename = in (ws, map) ) | Insert _ - | Savepoint _ -> + | Savepoint _ + | Delete _ -> let ws, map = create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) in diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index ab7da64b8..83ec407bc 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -14,7 +14,10 @@ open Sql_ast let comment str = Generated_type.Added - { content = [ Generated_type.Comment { content = str } ] } + { content = [ Generated_type.Comment { content = str } ]; + error_treatment = None; + with_dot = false + } let generate ~filename ~contents ~cobol_unit sql_statements = let linkage_section = comment "" in @@ -32,7 +35,16 @@ let generate ~filename ~contents ~cobol_unit sql_statements = (* The result will be stored in this buffer: *) let _final_loc = { filename; line = -1; char = 0 } in - let error_treatment = ref [] in + let error_treatment = + ref + Generated_type. + { prefix = " "; + not_found_whenever = None; + sql_error_whenever = None; + sql_warning_whenever = None + } + in + let is_error_treatment = ref false in let old_statements = ref [] in let cursor_declaration = ref [] in let in_pro_div = ref true in @@ -43,32 +55,13 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let working_storage_section, new_var_map = let ws, nvm = Data_gestion.transform sql_statements filename in ( [ comment ">Begin generated WORKING-STORAGE SECTION"; - Generated_type.Added { content = ws }; + Generated_type.Added + { content = ws; error_treatment = None; with_dot = false }; comment "> End genererated WORKING-STORAGE SECTION" ], nvm ) in - let end_procedure_division cd = - Generated_type.Added - { content = - [ Generated_type.Comment - { content = "> ESQL CURSOR DECLARATIONS (START)" }; - Generated_type.GotoStatement - { prefix = " "; target = "GIX-SKIP-CRSR-INIT" } - ] - } - :: cd - @ [ Generated_type.Added - { content = - [ Generated_type.Section { name = "GIX-SKIP-CRSR-INIT" }; - Generated_type.Comment - { content = "> ESQL CURSOR DECLARATIONS (END)" } - ] - } - ] - in - let cob_var_id_opt (cob_var : cobolVarId option) = match cob_var with | Some cob -> Some cob.payload @@ -250,20 +243,38 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ] in - let generate_whenever ~prefix c k = - let condition = - match c with - | Sql_ast.Not_found_whenever -> Generated_type.Not_found_whenever - | Sql_ast.SqlError_whenever -> Generated_type.SqlError_whenever - | Sql_ast.SqlWarning_whenever -> Generated_type.SqlWarning_whenever - in + let change_error ~prefix c k = + let old_error = !error_treatment in let continuation = match k with | Sql_ast.Continue -> Generated_type.Continue | Sql_ast.Perform x -> Generated_type.Perform x.payload | Sql_ast.Goto x -> Generated_type.Goto x.payload in - Generated_type.Error_treatment { prefix; condition; continuation } + let new_error = + match c with + | Sql_ast.Not_found_whenever -> + Generated_type. + { prefix; + not_found_whenever = Some continuation; + sql_error_whenever = old_error.sql_error_whenever; + sql_warning_whenever = old_error.sql_warning_whenever + } + | Sql_ast.SqlError_whenever -> + { prefix; + not_found_whenever = old_error.not_found_whenever; + sql_error_whenever = Some continuation; + sql_warning_whenever = old_error.sql_warning_whenever + } + | Sql_ast.SqlWarning_whenever -> + { prefix; + not_found_whenever = old_error.not_found_whenever; + sql_error_whenever = old_error.sql_error_whenever; + sql_warning_whenever = Some continuation + } + in + error_treatment := new_error; + is_error_treatment := true in let get_name_cobol_var (cobol_var : cobol_var) = @@ -289,7 +300,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - (* Todo: refactory *) + (* Todo: refactory? *) let generate_set_sql_param prefix h = let fun_name = "GIXSQLSetSQLParams" in let ref_value = @@ -446,13 +457,20 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = name }; - Generated_type.Value { prefix; var = "0" } (*Todo*) + Generated_type.Value { prefix; var = string_of_int (get_length name) } ] in [ Generated_type.CallStatic { prefix; fun_name; ref_value } ] in let add_to_cursor_declaration prefix cur ?at () = + let adding = (prefix, cur, at) in + let cd = adding :: !cursor_declaration in + cursor_declaration := cd + in + + let create_from_cursor_declaration (prefix, cur, at) = + let prefix = prefix ^ " " in let at_name, at_size = get_at_info at in let cur_name, cob_var_lst, _with_hold = match cur with @@ -525,9 +543,35 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | [] -> adding | _ -> generate_start_end_sql prefix adding in - let st = Generated_type.Added { content = adding } in - let cd = st :: !cursor_declaration in - cursor_declaration := cd + Generated_type.Added + { content = adding; + error_treatment = (if !is_error_treatment then Some !error_treatment else None); + with_dot = true + } + in + + let end_procedure_division cd_list = + Generated_type.Added + { content = + [ Generated_type.Comment + { content = "> ESQL CURSOR DECLARATIONS (START)" }; + Generated_type.GotoStatement + { prefix = " "; target = "GIX-SKIP-CRSR-INIT" } + ]; + error_treatment = None; + with_dot = false + } + :: List.map create_from_cursor_declaration cd_list + @ [ Generated_type.Added + { content = + [ Generated_type.Section { name = "GIX-SKIP-CRSR-INIT" }; + Generated_type.Comment + { content = "> ESQL CURSOR DECLARATIONS (END)" } + ]; + error_treatment = None; + with_dot = false + } + ] in let generate_prepare_stm prefix (var_name : sqlVarToken) sql_instr ?at () = @@ -581,7 +625,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ] in Generated_type.CallStatic - { prefix; fun_name = "GIXSQLPrepareStatement"; ref_value } + { prefix; fun_name = "GIXSQLExecPrepared"; ref_value } in let generate_exec_prepared_into prefix (executed_string : sqlVarToken) @@ -783,8 +827,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = { executed_string; opt_into_hostref_list; opt_using_hostref_list } -> generate_execute_into_using prefix executed_string ?opt_into_hostref_list ?opt_using_hostref_list ?at () - | DeclareTable _ - | Delete _ + | DeclareTable _ -> + (*Parser error on DECLARE TABLE statements in Gix, idk if Gix runtime can handle it*) + [ Generated_type.Todo { prefix } ] + | Delete sql_instr -> + let value_list = + Misc.extract_cob_var_name + (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql_instr) + in + generate_insert prefix ~value_list ?at () | Update _ -> [ Generated_type.Todo { prefix } ] (*Unexeped At, should trigger an error*) @@ -822,7 +873,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ?d_connection_id:(Some "\"*\" & x\"00\"") () ] | Whenever (c, k) -> - error_treatment := generate_whenever ~prefix c k :: !error_treatment; + change_error ~prefix c k; [] | Begin -> generate_declare prefix () | BeginDeclare @@ -860,8 +911,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ( List.map (generate_set_sql_param prefix) cob_var_list @ [ generate_GIXSQLExecParam prefix var_name cob_var_list () ] ) | Ignore _ -> - (*TODO*) - [ Generated_type.Todo { prefix } ] + (*Ignore, not implemented in Gix (but if this is just ignore, this should do the trick)*) + [ ] in let rec output lines statements = @@ -902,7 +953,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = end else begin comment "> Add missing LINKAGE SECTION" :: Generated_type.Added - { content = [ Generated_type.LinkageSection ] } + { content = [ Generated_type.LinkageSection ]; + error_treatment = None; + with_dot = false + } :: ([ linkage_section ] @ output cur_lines statements) end | WORKING_STORAGE { defined } -> @@ -912,7 +966,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = end else begin comment "> Add missing WORKING-STORAGE SECTION" :: Generated_type.Added - { content = [ Generated_type.WorkingStorageSection ] } + { content = [ Generated_type.WorkingStorageSection ]; + error_treatment = None; + with_dot = false + } :: (working_storage_section @ output cur_lines statements) end | EXEC_SQL { end_loc; with_dot; tokens } -> @@ -924,10 +981,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match trans_stm with | [] -> ( false, - [] + None (*if nothing is generated, we don't need error treatment or dots *) ) - | _ -> (with_dot, !error_treatment) + | _ -> (with_dot, if !is_error_treatment then Some !error_treatment else None) in old_statements := []; Generated_type.Change @@ -940,7 +997,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = comment ("> REMOVED: " ^ line) :: (* for now, just put it back *) Generated_type.Added - { content = [ Generated_type.ProcedureDivision ] } + { content = [ Generated_type.ProcedureDivision ]; + error_treatment = None; + with_dot = false + } :: output lines statements end else comment ("> REMOVED: " ^ line) diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index 269cd24ef..ceac5f4b7 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -9,16 +9,11 @@ type ref_value = } type error_treatment = - | Error_treatment of - { prefix : string; - condition : whenever_condition; - continuation : whenever_continuation - } - -and whenever_condition = - | Not_found_whenever - | SqlError_whenever - | SqlWarning_whenever + { prefix : string; + not_found_whenever : whenever_continuation option; + sql_warning_whenever : whenever_continuation option; + sql_error_whenever : whenever_continuation option + } and whenever_continuation = | Continue @@ -86,11 +81,15 @@ type trans_stm = type generated_stm = | NoChange of { content : string } - | Added of { content : trans_stm list } + | Added of + { content : trans_stm list; + error_treatment : error_treatment option; + with_dot : bool + } | Change of { old_stms : string list; trans_stm : trans_stm list; - error_treatment : error_treatment list; + error_treatment : error_treatment option; with_dot : bool } @@ -107,7 +106,14 @@ module Printer = struct and pp_gene fmt x = match x with | NoChange { content } -> Format.fprintf fmt "%s\n" content - | Added { content } -> Format.fprintf fmt "%a\n" pp_trans_stm content + | Added { content; error_treatment; with_dot } -> + let dot = + if with_dot then + "." + else + "" + in + Format.fprintf fmt "%a%a%s\n" pp_trans_stm content pp_error_treatment error_treatment dot | Change { old_stms; trans_stm; error_treatment; with_dot } -> let dot = if with_dot then @@ -129,12 +135,6 @@ module Printer = struct | h :: t -> Format.fprintf fmt "%a\n%a" pp_trans_stm_aux h pp_trans_stm t | [] -> () - and pp_error_treatment fmt x = - match x with - | h :: t -> - Format.fprintf fmt "%a\n%a" pp_error_treatment_aux h pp_error_treatment t - | [] -> () - and pp_trans_stm_aux fmt x = match x with | Section { name } -> Format.fprintf fmt " %s" name @@ -150,10 +150,10 @@ module Printer = struct Format.fprintf fmt "%sPERFORM %s" prefix target | If { prefix; condition; if_stm } -> Format.fprintf fmt "%sIF %s THEN\n%a\n%sEND-IF" prefix condition - pp_trans_stm if_stm prefix + pp_trans_stm if_stm prefix | IfElse { prefix; condition; if_stm; else_stm } -> - Format.fprintf fmt "%sIF %s THEN\n%a\n%sELSE\n%a\n%sEND-IF" prefix condition - pp_trans_stm if_stm prefix pp_trans_stm else_stm prefix + Format.fprintf fmt "%sIF %s THEN\n%a\n%sELSE\n%a\n%sEND-IF" prefix + condition pp_trans_stm if_stm prefix pp_trans_stm else_stm prefix | Move { prefix; src; dest } -> Format.fprintf fmt "%sMOVE '%s' TO %s" prefix src dest | Declaration d -> Format.fprintf fmt "%a" pp_declaration d @@ -189,25 +189,33 @@ module Printer = struct | h :: t -> Format.fprintf fmt "\n%a%a" pp_declaration h pp_field t | [] -> Format.fprintf fmt "" - and pp_error_treatment_aux fmt = function - | Error_treatment { prefix; condition; continuation } -> begin + and pp_error_treatment fmt = function + | Some + { prefix; not_found_whenever; sql_warning_whenever; sql_error_whenever } + -> begin let print_continuation fmt continuation = match continuation with - | Continue -> Format.fprintf fmt "CONTINUE" - | Perform sqlVarToken -> Format.fprintf fmt "PERFORM %s" sqlVarToken - | Goto sqlVarToken -> Format.fprintf fmt "GOTO %s" sqlVarToken + | Continue -> Format.fprintf fmt " CONTINUE" + | Perform sqlVarToken -> Format.fprintf fmt " PERFORM %s" sqlVarToken + | Goto sqlVarToken -> Format.fprintf fmt " GO TO %s" sqlVarToken + in + let print_error fmt (not_found_whenever, str) = + match not_found_whenever with + | Some continuation -> + Format.fprintf fmt "\n%s%s\n%s%a" prefix str prefix print_continuation + continuation + | None -> Format.fprintf fmt "\n%s%s\n%s%s" prefix str prefix " CONTINUE" in - match condition with - | Not_found_whenever -> - Format.fprintf fmt "%sWHEN SQLCODE = 100\n%s%a" prefix prefix - print_continuation continuation - | SqlError_whenever -> - Format.fprintf fmt "%sWHEN SQLCODE < 0\n%s%a" prefix prefix - print_continuation continuation - | SqlWarning_whenever -> - Format.fprintf fmt "%sWHEN SQLCODE < 0\n%s%a" prefix prefix - print_continuation continuation + Format.fprintf fmt "\n%sEVALUATE TRUE%a%a%a\n%sEND-EVALUATE" prefix + print_error + (not_found_whenever, "WHEN SQLCODE = 100") + print_error + (sql_warning_whenever, "WHEN SQLCODE = 1") + print_error + (sql_error_whenever, "WHEN SQLCODE < 0") + prefix end + | None -> () and pp_ref_value_list fmt x = let rec pp_ref_value_list_aux fmt x = From 4f9eb716c34e3943b66d4ea1e20eeb0460969a42 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Tue, 20 Aug 2024 16:52:15 +0200 Subject: [PATCH 16/37] fix Cursor and fix some type calculation --- src/lsp/sql_preproc/data_gestion.ml | 55 +++++++++++---------- src/lsp/sql_preproc/data_gestion.mli | 2 +- src/lsp/sql_preproc/generate.ml | 54 ++++++++++++++------- src/lsp/sql_preproc/sql_typeck.ml | 71 +++++++++++++++++++++++++++- 4 files changed, 136 insertions(+), 46 deletions(-) diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index ded173687..4ed84ec5a 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -31,9 +31,10 @@ let num = ref 0 let transform_stm map (_, stm) filename = let prefix = " " in - let create_new_var content = - let new_content = "\"" ^ Misc.replace_colon_words content ^ "\"" in - let size = (String.length new_content) -2 in (*Because " are part of this string"*) + let create_new_var content ?(remplace=true) () = + let new_content = if remplace then "\"" ^ Misc.replace_colon_words content ^ "\"" else content in + let size = String.length new_content - 2 in + (*Because " are part of this string"*) num := !num + 1; let var_name = "SQ" ^ string_of_int !num in let field = @@ -58,7 +59,7 @@ let transform_stm map (_, stm) filename = (Field_var_declaration { prefix; var_importance = "01"; var_name; field } ) ], - add_var ~map ~name:("SQ" ^ string_of_int !num) ?length:(Some size) () ) + add_var ~map ~name:("SQ" ^ string_of_int !num) ~length:size () ) in let add_cur cur_name map ws filename = let pre_cur_name = "GIXSQL-CI-F-" ^ Misc.extract_filename filename ^ "-" in @@ -74,7 +75,7 @@ let transform_stm map (_, stm) filename = :: ws in let map = - add_var ~map ~name:(pre_cur_name ^ cur_name) ?length:(Some 0) () + add_var ~map ~name:(pre_cur_name ^ cur_name) ~length:0 () in (ws, map) in @@ -86,14 +87,14 @@ let transform_stm map (_, stm) filename = let ws, map = create_new_var (Format.asprintf "SELECT %a%a" Sql_ast.Printer.pp_select_lst select - Sql_ast.Printer.pp_select_options_lst select_options ) + Sql_ast.Printer.pp_select_options_lst select_options ) () in (ws, map) | Begin -> - let ws, map = create_new_var "BEGIN" in + let ws, map = create_new_var "BEGIN" () in (ws, map) | StartTransaction -> - let ws, map = create_new_var "START TRANSACTION" in + let ws, map = create_new_var "START TRANSACTION" () in (ws, map) | Sql sql -> ( match sql with @@ -102,50 +103,54 @@ let transform_stm map (_, stm) filename = (*TODO: find what this should be replaced with. I think Gix juste ignorer these instruction, but mabe not*) | _ -> let ws, map = - create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) () in (ws, map) ) | Insert _ - | Savepoint _ + | Savepoint _ | Delete _ -> let ws, map = - create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) () in (ws, map) | ExecuteImmediate sql -> ( match sql with - | [ Sql_ast.SqlVarToken CobolVar CobVarNotNull _ ] -> ([], map) + | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull _)) ] -> ([], map) | _ -> - let ws, map = - create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) + let ws, map = + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) () in (ws, map) ) | Rollback (rb_work_or_tran, rb_args) -> begin match (rb_work_or_tran, rb_args) with | _, Some (To savepoint) -> let ws, map = - create_new_var ("ROLLBACK TO SAVEPOINT " ^ savepoint.payload) + create_new_var ("ROLLBACK TO SAVEPOINT " ^ savepoint.payload) () in (ws, map) | _ -> ([], map) end | DeclareCursor cur -> begin match cur with - | DeclareCursorSql (cur_name, query) -> + | DeclareCursorSql (cur_name, query) + | DeclareCursorWhithHold (cur_name, query) -> (*TODO: WhithHold specificity if there are any*) let ws, map = create_new_var - (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query) + (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query) () in let ws, map = add_cur cur_name.payload map ws filename in (ws, map) - (*TODO*) - | DeclareCursorVar (_cur_name, _var_name) -> ([], map) (*TODO*) - | DeclareCursorWhithHold (_cur_name, _query) -> ([], map) - (*TODO*) - end - | Exeption _ -> create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) + | DeclareCursorVar (cur_name, var_name) -> + let ws, map = + create_new_var (Format.asprintf "\"@%a\"" Sql_ast.Printer.pp_var var_name) ~remplace:false () + in + let ws, map = add_cur cur_name.payload map ws filename in + (ws, map) + end + | Exeption _ -> + create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) () | _ -> ([], map) in @@ -156,7 +161,7 @@ let transform_stm map (_, stm) filename = | "BINARY" | "CHAR" -> let map = - add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () + add_var ~map ~name ~length:(int_of_string sql_type_size) () in ( [ Declaration @@ -172,7 +177,7 @@ let transform_stm map (_, stm) filename = | "VARBINARY" | "VARCHAR" -> let map = - add_var ~map ~name ?length:(Some (int_of_string sql_type_size)) () + add_var ~map ~name ~length:(int_of_string sql_type_size) () in let field = let prefix = prefix ^ " " in diff --git a/src/lsp/sql_preproc/data_gestion.mli b/src/lsp/sql_preproc/data_gestion.mli index be0d0f3f5..0ea1ca18f 100644 --- a/src/lsp/sql_preproc/data_gestion.mli +++ b/src/lsp/sql_preproc/data_gestion.mli @@ -16,7 +16,7 @@ type variable_information = flags : int; ind_addr : int } -(*return working_storage_section (only declaration),, new_var_map*) +(*return working_storage_section (only declaration) * new_var_map*) val transform : (Types.loc option * Types.statements) list -> string -> (Generated_type.trans_stm list * t) diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 83ec407bc..880bbedc3 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -47,7 +47,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let is_error_treatment = ref false in let old_statements = ref [] in let cursor_declaration = ref [] in - let in_pro_div = ref true in + let in_pro_div = ref false in let num = ref 0 in (*GET FUNCTION*) @@ -464,39 +464,43 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let add_to_cursor_declaration prefix cur ?at () = - let adding = (prefix, cur, at) in + num := !num + 1; + let name = "SQ" ^ string_of_int !num in + let adding = (prefix, cur, at, name) in let cd = adding :: !cursor_declaration in cursor_declaration := cd in - let create_from_cursor_declaration (prefix, cur, at) = + let create_from_cursor_declaration (prefix, cur, at, var_name) = let prefix = prefix ^ " " in let at_name, at_size = get_at_info at in - let cur_name, cob_var_lst, _with_hold = + let cur_name, cob_var_lst, var_name, _with_hold = match cur with | DeclareCursorSql (cur_name, sql) -> ( cur_name, Misc.extract_cob_var_name (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query sql), + var_name, false ) - | DeclareCursorVar (cur_name, cur_var) -> - let var = - match cur_var with - | SqlVar _ -> [] - | CobolVar v -> [ get_name_cobol_var v ] - in - (cur_name, var, false) | DeclareCursorWhithHold (cur_name, query) -> ( cur_name, Misc.extract_cob_var_name (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query), + var_name, true ) + | DeclareCursorVar (cur_name, cur_var) -> + let var = + match cur_var with + | SqlVar _ -> var_name + | CobolVar v -> get_name_cobol_var v + in + (cur_name, [], var, false) in - let cursor_name = "\"TSQL003A_" ^ cur_name.payload ^ "\" & x\"00\"" in - let var_name = - num := !num + 1; - "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) + let cursor_name = + "\"" + ^ Misc.extract_filename filename + ^ "_" ^ cur_name.payload ^ "\" & x\"00\"" in let fun_name, cursor_declare = @@ -545,7 +549,11 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in Generated_type.Added { content = adding; - error_treatment = (if !is_error_treatment then Some !error_treatment else None); + error_treatment = + ( if !is_error_treatment then + Some !error_treatment + else + None ); with_dot = true } in @@ -912,7 +920,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = @ [ generate_GIXSQLExecParam prefix var_name cob_var_list () ] ) | Ignore _ -> (*Ignore, not implemented in Gix (but if this is just ignore, this should do the trick)*) - [ ] + [] in let rec output lines statements = @@ -984,7 +992,17 @@ let generate ~filename ~contents ~cobol_unit sql_statements = None (*if nothing is generated, we don't need error treatment or dots *) ) - | _ -> (with_dot, if !is_error_treatment then Some !error_treatment else None) + | _ -> ( + match tokens with + | DeclareCursor _ + | At (_, DeclareCursor _) -> + (with_dot, None) + | _ -> + ( with_dot, + if !is_error_treatment then + Some !error_treatment + else + None ) ) in old_statements := []; Generated_type.Change diff --git a/src/lsp/sql_preproc/sql_typeck.ml b/src/lsp/sql_preproc/sql_typeck.ml index 3bf1403af..c45c43761 100644 --- a/src/lsp/sql_preproc/sql_typeck.ml +++ b/src/lsp/sql_preproc/sql_typeck.ml @@ -34,8 +34,75 @@ let get_length cu name = (* Pretty.out " \"%s\" not found. qualname nel lazy_t found" name; *) 0 -(*TODO*) -let get_type _cu _name = 16 +type cobol_types = + | UNKNOWN + | COBOL_TYPE_UNSIGNED_NUMBER + | COBOL_TYPE_SIGNED_NUMBER_TS (* trailing separate *) + | COBOL_TYPE_SIGNED_NUMBER_TC (* trailing combined *) + | COBOL_TYPE_SIGNED_NUMBER_LS (* leading separate *) + | COBOL_TYPE_SIGNED_NUMBER_LC (* leading combined *) + | COBOL_TYPE_UNSIGNED_NUMBER_PD (* packed decimal *) + | COBOL_TYPE_SIGNED_NUMBER_PD (* packed decimal *) + | COBOL_TYPE_ALPHANUMERIC + | COBOL_TYPE_UNSIGNED_BINARY + | COBOL_TYPE_SIGNED_BINARY + | COBOL_TYPE_JAPANESE + | COBOL_TYPE_GROUP + | COBOL_TYPE_FLOAT + | COBOL_TYPE_DOUBLE + | COBOL_TYPE_NATIONAL + +let cobol_types_to_int = function + | UNKNOWN -> 0 + | COBOL_TYPE_UNSIGNED_NUMBER -> 1 + | COBOL_TYPE_SIGNED_NUMBER_TS -> 2 + | COBOL_TYPE_SIGNED_NUMBER_TC -> 3 + | COBOL_TYPE_SIGNED_NUMBER_LS -> 4 + | COBOL_TYPE_SIGNED_NUMBER_LC -> 5 + | COBOL_TYPE_UNSIGNED_NUMBER_PD -> 8 + | COBOL_TYPE_SIGNED_NUMBER_PD -> 9 + | COBOL_TYPE_ALPHANUMERIC -> 16 + | COBOL_TYPE_UNSIGNED_BINARY -> 22 + | COBOL_TYPE_SIGNED_BINARY -> 23 + | COBOL_TYPE_JAPANESE -> 24 + | COBOL_TYPE_GROUP -> 25 + | COBOL_TYPE_FLOAT -> 26 + | COBOL_TYPE_DOUBLE -> 27 + | COBOL_TYPE_NATIONAL -> 28 + +let get_type cu name = + let cobol_type = + try + let x_info = get_x_info cu name in + match x_info with + | Data_field { def = { payload = { field_layout; _ }; _ }; _ } -> begin + match field_layout with + | Elementary_field { usage = Display picture; _ } -> ( + match picture.category with + | Alphabetic _ -> COBOL_TYPE_ALPHANUMERIC (*?*) + | Alphanumeric _ -> COBOL_TYPE_ALPHANUMERIC + | Boolean _ -> COBOL_TYPE_UNSIGNED_BINARY (*?*) + | National _ -> COBOL_TYPE_NATIONAL + | FixedNum { with_sign; _ } -> + if with_sign then + COBOL_TYPE_SIGNED_NUMBER_TS (*leading? combined? idk*) + else + COBOL_TYPE_UNSIGNED_NUMBER + | FloatNum _ -> UNKNOWN ) + | Elementary_field _ + | Struct_field _ -> + UNKNOWN + end + | _ -> UNKNOWN + with + | Not_found -> + (* Pretty.out " \"%s\" not found " name; *) + UNKNOWN + | Cobol_unit.Qualmap.Ambiguous _ -> + (* Pretty.out " \"%s\" not found. qualname nel lazy_t found" name; *) + UNKNOWN + in + cobol_types_to_int cobol_type let get_scale cu name = try From 6b64ff5b7d178bc8a86d02b1fabae20ca6ebbeed Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Wed, 28 Aug 2024 09:46:39 +0200 Subject: [PATCH 17/37] somes changes --- src/lsp/sql_ast/sql_ast.ml | 18 ++++++++--- src/lsp/sql_parser/grammar.mly | 9 +++++- src/lsp/sql_parser/sql_parser.ml | 7 +++-- src/lsp/sql_preproc/data_gestion.ml | 3 +- src/lsp/sql_preproc/generate.ml | 27 +++++++++++----- src/lsp/sql_preproc/generated_type.ml | 40 ++++++++++++++++++------ src/lsp/sql_preproc/parse.ml | 8 ++--- src/lsp/sql_preproc/sql_typeck.ml | 20 ++++++++++++ src/lsp/superbol_free_lib/command_sql.ml | 24 +++++++++++++- 9 files changed, 126 insertions(+), 30 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index 8a3763ff3..52515c063 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -21,22 +21,23 @@ type cobolVarId = string with_loc [@@deriving ord] type cobol_var = | CobVarNotNull of cobolVarId + | CobVarCasted of cobolVarId * sql_type | CobVarNullIndicator of cobolVarId * cobolVarId [@@deriving ord] -type variable = +and variable = | SqlVar of sqlVarToken | CobolVar of cobol_var [@@deriving ord] -type literal = +and literal = | LiteralVar of variable | LiteralNum of string with_loc | LiteralStr of string with_loc | LiteralDot of string with_loc list [@@deriving ord] -type sql_token = +and sql_token = | SqlInstr of string | SqlVarToken of variable | SqlLit of literal @@ -66,6 +67,7 @@ and esql_instuction = | Rollback of rb_work_or_tran option * rb_args option | Commit of rb_work_or_tran option * bool | Savepoint of variable + | ReleaseSavepoint of variable | SelectInto of { vars : cobol_var list; select : sql_select; @@ -162,6 +164,7 @@ and whenever_continuation = and update_arg = | WhereCurrentOf of sqlVarToken + | WhereUpdate of search_condition | UpdateSql of sql_instruction (*SQL*) @@ -183,6 +186,7 @@ and from_stm = table_ref list and table_ref = | FromLitAs of table_ref * literal | FromLit of literal + | FromFun of sqlVarToken * literal | FromSelect of sql_query | Join of table_ref * join * table_ref * join_option option @@ -286,6 +290,7 @@ module Printer = struct Format.fprintf fmt "COMMIT %a %s" pp_some_rb_work_or_tran rb_work_or_tran s | Savepoint s -> Format.fprintf fmt "SAVEPOINT %a" pp_var s + | ReleaseSavepoint s -> Format.fprintf fmt "RELEASE SAVEPOINT %a" pp_var s | SelectInto { vars; select; select_options } -> Format.fprintf fmt "SELECT %a INTO %a %a" pp_select_lst select pp_cob_lst vars pp_select_options_lst select_options @@ -375,7 +380,9 @@ module Printer = struct and pp_where_arg fmt = function | Some (WhereCurrentOf swhere) -> - Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload + Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload + | Some (WhereUpdate e) -> + Format.fprintf fmt "WHERE %a" pp_sql_condition e | Some (UpdateSql sql) -> pp_sql fmt sql | None -> () @@ -453,6 +460,8 @@ module Printer = struct and pp_cob_var fmt = function | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload + | CobVarCasted (c, t) -> + Format.fprintf fmt ":%s::%a" c.payload pp_sql_type t | CobVarNullIndicator (c, ni) -> Format.fprintf fmt ":%s:%s" c.payload ni.payload @@ -548,6 +557,7 @@ module Printer = struct and pp_table_ref fmt = function | FromLit l -> Format.fprintf fmt "%a" pp_lit l | FromLitAs (l, a) -> Format.fprintf fmt "%a AS %a" pp_table_ref l pp_lit a + | FromFun (v, t) -> Format.fprintf fmt "%a %a" pp_sqlVarToken v pp_lit t | FromSelect s -> Format.fprintf fmt "(%a)" pp_sql_query s | Join (tr1, join, tr2, opt) -> Format.fprintf fmt "%a %s JOIN %a %a" pp_table_ref tr1 (str_join join) diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 716ca631a..81089c15d 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -67,7 +67,9 @@ let cobol_var_id := let cobol_var := | c = cobol_var_id; {CobVarNotNull c} -| c = loc(COBOL_VAR); ni=loc(COBOL_VAR); {CobVarNullIndicator(c, ni)} +| c = cobol_var_id; COLON; COLON; t = sql_type_aux; {CobVarCasted (c, t)} +(*TODO: fix this, it onely work in the context of the preproc*) +| c = cobol_var_id; ni=cobol_var_id; {CobVarNullIndicator(c, ni)} let sql_var_name := | s = loc(WORD); {s} @@ -131,6 +133,8 @@ let esql_with_opt_at := {ExecuteIntoUsing{executed_string; opt_into_hostref_list; opt_using_hostref_list}} | SAVEPOINT; s= variable; {Savepoint s} +| RELEASE; SAVEPOINT; s=variable; + {ReleaseSavepoint s} | ROLLBACK; r=option(rb_work_or_tran); a=option(rb_args); {Rollback(r, a)} | COMMIT; wt= option(rb_work_or_tran); RELEASE; @@ -207,6 +211,7 @@ let execute_immediate_arg := let update_arg := | WHERE; CURRENT; OF; v=sql_var_name; {WhereCurrentOf v} +| WHERE; v=search_condition; {WhereUpdate v} | FROM; sql=sql; {UpdateSql( [SqlInstr "FROM"] @ sql)} let rb_work_or_tran := @@ -308,6 +313,7 @@ let table_ref := let table_ref_simpl := | LPAR; select= sql_query; RPAR; {FromSelect(select)} | LPAR; t = table_ref; RPAR; {t} +| sql_var = sql_var_name; table_name = literal; {FromFun (sql_var, table_name)} | table_name = literal; {FromLit(table_name)} let table_ref_non_rec := @@ -414,6 +420,7 @@ let sql_first_token := | LPAR ; {SqlInstr "(" } | RPAR; {SqlInstr ")" } | NOT; {SqlInstr "NOT" } +| NULL; {SqlInstr "NULL" } | STAR; {SqlInstr "*" } | SET; {SqlInstr "SET"} | FOR; {SqlInstr "FOR" } diff --git a/src/lsp/sql_parser/sql_parser.ml b/src/lsp/sql_parser/sql_parser.ml index 7b4e1c347..8702a6cab 100644 --- a/src/lsp/sql_parser/sql_parser.ml +++ b/src/lsp/sql_parser/sql_parser.ml @@ -66,7 +66,10 @@ let parse text = |> fst |> List.rev in let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in - (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) + (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) ast - let parseString str = Grammar.main Lexer.token str \ No newline at end of file +let parseString str = + let ast = Grammar.main Lexer.token str in +(* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) + ast diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 4ed84ec5a..379e244a4 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -30,7 +30,7 @@ let add_var ~map ~name ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) let num = ref 0 let transform_stm map (_, stm) filename = - let prefix = " " in + let prefix = " " in let create_new_var content ?(remplace=true) () = let new_content = if remplace then "\"" ^ Misc.replace_colon_words content ^ "\"" else content in let size = String.length new_content - 2 in @@ -108,6 +108,7 @@ let transform_stm map (_, stm) filename = (ws, map) ) | Insert _ | Savepoint _ + | ReleaseSavepoint _ | Delete _ -> let ws, map = create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_esql tokens) () diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 880bbedc3..48be91c43 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -68,10 +68,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | None -> None in + (*TODO: CobVarCasted shoould act like the casted type (rn it's ignored)*) let cob_var_opt = function | Some var -> ( match var with | CobVarNotNull cobolVarId -> Some cobolVarId.payload + | CobVarCasted (var, _) -> Some var.payload | CobVarNullIndicator (var, _) -> Some var.payload ) | None -> None in @@ -134,6 +136,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match cobol_var with | CobVarNotNull cobolVarId -> (cobolVarId.payload, get_length cobolVarId.payload) + | CobVarCasted (var, _) -> (var.payload, get_length var.payload) | CobVarNullIndicator (var, _) -> (var.payload, get_length var.payload) ) ) in @@ -280,6 +283,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let get_name_cobol_var (cobol_var : cobol_var) = match cobol_var with | CobVarNotNull c -> c.payload + | CobVarCasted (c, _) -> c.payload | CobVarNullIndicator (c, n) -> c.payload ^ n.payload in @@ -435,7 +439,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_commit prefix rb_work_or_tran rb_args ?at () = match (rb_work_or_tran, rb_args) with - | None, false -> + | None, false + | Some Work, false -> generate_start_end_sql prefix [ generate_GIXSQLExec prefix "\"COMMIT\" & x\"00\"" ?at () ] | _ -> [ Generated_type.Todo { prefix } ] @@ -445,6 +450,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let name = match var with | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull var)) ] -> var.payload + | [ Sql_ast.SqlVarToken (CobolVar (CobVarCasted (var, _))) ] -> var.payload | _ -> num := !num + 1; "SQ" ^ string_of_int !num @@ -452,7 +458,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let at_name, at_size = get_at_info at in let fun_name = "GIXSQLExecImmediate" in let ref_value = - let prefix = prefix ^ " " in + let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; @@ -471,8 +477,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = cursor_declaration := cd in - let create_from_cursor_declaration (prefix, cur, at, var_name) = - let prefix = prefix ^ " " in + let create_from_cursor_declaration (_prefix, cur, at, var_name) = + (* let prefix = prefix ^ " " in *) + let prefix = " " in let at_name, at_size = get_at_info at in let cur_name, cob_var_lst, var_name, _with_hold = match cur with @@ -506,13 +513,13 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let fun_name, cursor_declare = match cob_var_lst with | [] -> - let prefix = prefix ^ " " in + let prefix = " " in ( "GIXSQLCursorDeclare", [ Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" } ] ) | _ -> - let prefix = prefix ^ " " in + let prefix = " " in ( "GIXSQLCursorDeclareParams", [ Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" }; @@ -522,7 +529,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let adding = let ref_value = - let prefix = prefix ^ " " in + let prefix = " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; @@ -588,6 +595,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match sql_instr with | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull cobolVarId)) ] -> cobolVarId.payload + | [ Sql_ast.SqlVarToken (CobolVar (CobVarCasted (cobolVarId, _))) ] -> + cobolVarId.payload | _ -> failwith "Not implemented in Gix" (*These case are not implemented in GixSql's runtime *) in @@ -729,7 +738,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let prefix = prefix ^ " " in [ Generated_type.CallStatic { prefix; - fun_name = "SQGIXSQLCursorOpen"; + fun_name = "GIXSQLCursorOpen"; ref_value = (let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; @@ -821,6 +830,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = generate_insert prefix ~value_list ?at () | Savepoint _ + | ReleaseSavepoint _ | StartTransaction -> generate_declare prefix ?at () | Sql sql -> ( @@ -862,6 +872,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | ExecuteImmediate _ | ExecuteIntoUsing _ | Savepoint _ + | ReleaseSavepoint _ | Rollback _ | Commit _ | Insert _ diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index ceac5f4b7..7b6dc5f8c 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -106,14 +106,15 @@ module Printer = struct and pp_gene fmt x = match x with | NoChange { content } -> Format.fprintf fmt "%s\n" content - | Added { content; error_treatment; with_dot } -> + | Added { content; error_treatment; with_dot } -> let dot = if with_dot then "." else "" in - Format.fprintf fmt "%a%a%s\n" pp_trans_stm content pp_error_treatment error_treatment dot + Format.fprintf fmt "%a%a%s\n" pp_trans_stm content pp_error_treatment + error_treatment dot | Change { old_stms; trans_stm; error_treatment; with_dot } -> let dot = if with_dot then @@ -137,7 +138,7 @@ module Printer = struct and pp_trans_stm_aux fmt x = match x with - | Section { name } -> Format.fprintf fmt " %s" name + | Section { name } -> Format.fprintf fmt " %s." name | Comment { content } -> Format.fprintf fmt "ADDED *%s" content | CallStatic { prefix; fun_name; ref_value } -> Format.fprintf fmt "%sCALL STATIC \"%s\"%a%sEND-CALL" prefix fun_name @@ -145,7 +146,7 @@ module Printer = struct | Copy { prefix; file_name } -> Format.fprintf fmt "%sCOPY %s" prefix file_name | GotoStatement { prefix; target } -> - Format.fprintf fmt "%sGO TO %s" prefix target + Format.fprintf fmt "%sGO TO %s." prefix target | PerformStatement { prefix; target } -> Format.fprintf fmt "%sPERFORM %s" prefix target | If { prefix; condition; if_stm } -> @@ -165,6 +166,22 @@ module Printer = struct Format.fprintf fmt " *> WARNING: %s" content | Todo { prefix } -> Format.fprintf fmt "%sTODO" prefix + + (*TODO: maybe redo this, but nicer*) + and split_line max_length line = + let rec aux acc max_length current_line = + if String.length current_line <= max_length then + List.rev (current_line :: acc) + else + let part = String.sub current_line 0 max_length in + let rest = + String.sub current_line max_length + (String.length current_line - max_length) + in + aux ((part ^ "\"\n & \"") :: acc) 59 rest (*72 (character limit) - 12 (size of prefix ' & "' ) - 1 (for the '"')*) + in + aux [] max_length line + and pp_declaration fmt = function | Simple_var_declaration { prefix; var_importance; var_name; var_type; var_content } -> @@ -175,11 +192,15 @@ module Printer = struct in let var_content = match var_content with - | Some n -> n + | Some n -> "VALUE " ^ n | None -> "" in - Format.fprintf fmt "%s%s %s PIC %s %s." prefix var_importance var_name - var_type var_content + let line = + Printf.sprintf "%s%s %s PIC %s %s." prefix var_importance var_name + var_type var_content + in + let lines = split_line 71 line in (*72 (character limit) - 1 (for the '"')*) + List.iter (Format.fprintf fmt "%s") lines | Field_var_declaration { prefix; var_importance; var_name; field } -> Format.fprintf fmt "%s%s %s.%a" prefix var_importance var_name pp_field field @@ -197,14 +218,15 @@ module Printer = struct match continuation with | Continue -> Format.fprintf fmt " CONTINUE" | Perform sqlVarToken -> Format.fprintf fmt " PERFORM %s" sqlVarToken - | Goto sqlVarToken -> Format.fprintf fmt " GO TO %s" sqlVarToken + | Goto sqlVarToken -> Format.fprintf fmt " GO TO %s." sqlVarToken in let print_error fmt (not_found_whenever, str) = match not_found_whenever with | Some continuation -> Format.fprintf fmt "\n%s%s\n%s%a" prefix str prefix print_continuation continuation - | None -> Format.fprintf fmt "\n%s%s\n%s%s" prefix str prefix " CONTINUE" + | None -> + Format.fprintf fmt "\n%s%s\n%s%s" prefix str prefix " CONTINUE" in Format.fprintf fmt "\n%sEVALUATE TRUE%a%a%a\n%sEND-EVALUATE" prefix print_error diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index e9f6514a1..76896760c 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -163,12 +163,12 @@ let parse ~config ~filename ~contents = let params = List.rev params in let sqlStr = "EXEC SQL " ^ String.concat " " params ^ " END-EXEC" in - (* Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) + Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in -(* Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; *) + Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; sql_add_statement ~loc (EXEC_SQL { end_loc; with_dot; tokens = sql }); iter tokens diff --git a/src/lsp/sql_preproc/sql_typeck.ml b/src/lsp/sql_preproc/sql_typeck.ml index c45c43761..d763b9d6c 100644 --- a/src/lsp/sql_preproc/sql_typeck.ml +++ b/src/lsp/sql_preproc/sql_typeck.ml @@ -37,20 +37,40 @@ let get_length cu name = type cobol_types = | UNKNOWN | COBOL_TYPE_UNSIGNED_NUMBER + (*ex: PIC 9(018).*) | COBOL_TYPE_SIGNED_NUMBER_TS (* trailing separate *) + (*pas d'exemple dans les tests de gix que j'ai réussi a preprocesser*) | COBOL_TYPE_SIGNED_NUMBER_TC (* trailing combined *) + (*ex: PIC S9(09) + PIC S9(018)*) | COBOL_TYPE_SIGNED_NUMBER_LS (* leading separate *) + (*pas d'exemple*) | COBOL_TYPE_SIGNED_NUMBER_LC (* leading combined *) + (*pas d'exemple*) | COBOL_TYPE_UNSIGNED_NUMBER_PD (* packed decimal *) + (*pas d'exemple*) | COBOL_TYPE_SIGNED_NUMBER_PD (* packed decimal *) + (*pas d'exemple*) | COBOL_TYPE_ALPHANUMERIC + (*ex: PIC 9(018) COMP-3. + PIC 9(018)V9(12) COMP-3*) | COBOL_TYPE_UNSIGNED_BINARY + (*ex: PIC S9(018)V9(12) COMP-3 (???????) + PIC S9(018)V9(12) COMP-3. + PIC S99V99 COMP-3. + 03 FLD01 PIC S9(4) USAGE COMP-3. (???? USAGE?) *) | COBOL_TYPE_SIGNED_BINARY + (*pas d'exemple*) | COBOL_TYPE_JAPANESE + (*pas d'exemple*) | COBOL_TYPE_GROUP + (*pas d'exemple*) | COBOL_TYPE_FLOAT + (*pas d'exemple*) | COBOL_TYPE_DOUBLE + (*pas d'exemple*) | COBOL_TYPE_NATIONAL + (*pas d'exemple*) let cobol_types_to_int = function | UNKNOWN -> 0 diff --git a/src/lsp/superbol_free_lib/command_sql.ml b/src/lsp/superbol_free_lib/command_sql.ml index 3369d914f..c2b6faa07 100644 --- a/src/lsp/superbol_free_lib/command_sql.ml +++ b/src/lsp/superbol_free_lib/command_sql.ml @@ -70,7 +70,29 @@ let parse ~sql_in_copybooks ~copy_exts common files = Sql_preproc.Main.preproc ~sql_in_copybooks ~copy_path ~copy_exts ~filename ~source_format () ~cobol_unit in - Printf.printf "%s%!" contents ) + let output_file filename s = + match filename with + | "-" -> + Printf.printf "%s\n%!" s + | _ -> + let oc = open_out filename in + output_string oc s; + close_out oc; + Printf.eprintf "File %S generated\n%!" filename + in + let name_change filename = + if Filename.check_suffix filename ".cob" then + let base_name = Filename.chop_suffix filename ".cob" in + base_name ^ ".pp.cob" + else if Filename.check_suffix filename ".cbl" then + let base_name = Filename.chop_suffix filename ".cbl" in + base_name ^ ".pp.cbl" + else + filename + in + + output_file (name_change filename) contents + (* Printf.printf "%s%!" contents *) ) files let preproc_cmd = From a2be3da086edab777cbf2ec93914aeeffa590d99 Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Mon, 9 Sep 2024 09:35:23 +0200 Subject: [PATCH 18/37] better copy --- src/lsp/sql_ast/sql_ast.ml | 41 ++++++++++++++++------- src/lsp/sql_parser/grammar.mly | 52 ++++++++++++++++++++++-------- src/lsp/sql_parser/lexer.mll | 1 + src/lsp/sql_preproc/parse.ml | 5 +-- test/output-tests/reparse.expected | 2 +- 5 files changed, 73 insertions(+), 28 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index 52515c063..e0cf1790e 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -49,7 +49,8 @@ and sql_instruction = sql_token list and complex_literal = | SqlCompLit of literal - | SqlCompAs of literal * sqlVarToken (*ex: SMT AS INT*) + | SqlCompAsType of literal * sql_type_name (*ex: SMT AS INT*) + | SqlCompAsVar of literal * sqlVarToken | SqlCompFun of sqlVarToken * sql_op list | SqlCompStar @@ -146,11 +147,18 @@ and connect_syntax = (*WHENEVER*) and sql_type = - | NotNull of sql_type + { sql_type : sql_type_name; + size : literal option; + not_null : bool; + with_default : bool + } + +and sql_type_name = + | Char | Date | Integer | Timestamp - | VarChar of literal + | VarChar and whenever_condition = | Not_found_whenever @@ -186,7 +194,7 @@ and from_stm = table_ref list and table_ref = | FromLitAs of table_ref * literal | FromLit of literal - | FromFun of sqlVarToken * literal + | FromFun of sqlVarToken * literal | FromSelect of sql_query | Join of table_ref * join * table_ref * join_option option @@ -362,12 +370,21 @@ module Printer = struct and pp_var_type fmt (l, t) = Format.fprintf fmt "%s\t %a" l.payload pp_sql_type t - and pp_sql_type fmt = function - | NotNull v -> Format.fprintf fmt "%a NOT NULL" pp_sql_type v + and pp_sql_type_name fmt test = + match test with + | Char -> Format.fprintf fmt "CHAR" | Date -> Format.fprintf fmt "DATE" | Integer -> Format.fprintf fmt "INTEGER" | Timestamp -> Format.fprintf fmt "TIMESTAMP" - | VarChar i -> Format.fprintf fmt "VARCHAR(%a)" pp_lit i + | VarChar -> Format.fprintf fmt "VARCHAR" + and pp_sql_type fmt { sql_type; size; not_null; with_default } = + + pp_sql_type_name fmt sql_type; + ( match size with + | Some lit -> Format.fprintf fmt " (%a)" pp_lit lit + | None -> () ); + if not_null then Format.fprintf fmt " NOT NULL"; + if with_default then Format.fprintf fmt " WITH DEFAULT" and pp_one_value fmt = function | ValueDefault -> Format.fprintf fmt "DEFAULT" @@ -380,9 +397,8 @@ module Printer = struct and pp_where_arg fmt = function | Some (WhereCurrentOf swhere) -> - Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload - | Some (WhereUpdate e) -> - Format.fprintf fmt "WHERE %a" pp_sql_condition e + Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload + | Some (WhereUpdate e) -> Format.fprintf fmt "WHERE %a" pp_sql_condition e | Some (UpdateSql sql) -> pp_sql fmt sql | None -> () @@ -440,7 +456,8 @@ module Printer = struct and pp_complex_literal fmt = function | SqlCompLit v -> Format.fprintf fmt "%a" pp_lit v - | SqlCompAs (l, v) -> Format.fprintf fmt "%a AS %s" pp_lit l v.payload + | SqlCompAsType (l, v) -> Format.fprintf fmt "%a AS %a" pp_lit l pp_sql_type_name v + | SqlCompAsVar (l, v) -> Format.fprintf fmt "%a AS %s" pp_lit l v.payload | SqlCompFun (funName, args) -> let pp_args fmt lst = list_comma fmt (lst, pp_sql_op) in Format.fprintf fmt "%s(%a)" funName.payload pp_args args @@ -460,7 +477,7 @@ module Printer = struct and pp_cob_var fmt = function | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload - | CobVarCasted (c, t) -> + | CobVarCasted (c, t) -> Format.fprintf fmt ":%s::%a" c.payload pp_sql_type t | CobVarNullIndicator (c, ni) -> Format.fprintf fmt ":%s:%s" c.payload ni.payload diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index 81089c15d..ed6bb4529 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -42,7 +42,7 @@ open Cobol_common.Srcloc.INFIX (*Sort by*) %token DESC ASC (*types*) -%token VARCHAR DATE INTEGER TIMESTAMP +%token VARCHAR DATE INTEGER TIMESTAMP CHAR (*exeptions*) %token THEN RAISE EXCEPTION %token WORD @@ -67,8 +67,8 @@ let cobol_var_id := let cobol_var := | c = cobol_var_id; {CobVarNotNull c} -| c = cobol_var_id; COLON; COLON; t = sql_type_aux; {CobVarCasted (c, t)} -(*TODO: fix this, it onely work in the context of the preproc*) +| c = cobol_var_id; COLON; COLON; t = sql_type; {CobVarCasted (c, t)} +(*TODO: fix this, it maybe only work in the context of the preproc*) | c = cobol_var_id; ni=cobol_var_id; {CobVarNullIndicator(c, ni)} let sql_var_name := @@ -175,15 +175,39 @@ let value_list := let table_lst := | s = sql_var_name; t=sql_type; {(s, t)} + + let sql_type:= -| s = sql_type_aux; NOT; NULL; {NotNull s} -| s = sql_type_aux; {s} +| s = type_name; l=size_opt; b1=not_null_opt; b2=with_default_opt; { + { + sql_type = s; + size = l; + not_null = b1; + with_default = b2; + } + } + +let type_name:= + | CHAR; { Char } + | DATE; { Date } + | INTEGER; { Integer } + | TIMESTAMP; { Timestamp } + | VARCHAR; { VarChar } + +let size_opt:= + | LPAR; l=literal; RPAR; { Some (l) } + | /* empty */ { None } + +let not_null_opt:= + | NOT; NULL; { true } + | /* empty */ { false } + +let with_default_opt:= + | WITH; DEFAULT; { true } + | /* empty */ { false } + + -let sql_type_aux := -| DATE; {Date} -| INTEGER; {Integer} -| TIMESTAMP; {Timestamp} -| VARCHAR; LPAR; l=literal; RPAR; {VarChar l} (*TODO: forUpdate is incomplete, I have to implement this syntaxe: FOR { @@ -270,8 +294,8 @@ let whenever_condition := let whenever_continuation := | CONTINUE; {Continue} | PERFORM; label= sql_var_name; {Perform label} -| GOTO; stmt_label= sql_var_name; {Goto stmt_label} -| GO; TO; stmt_label= sql_var_name; {Goto stmt_label} +| GOTO; option(COLON); stmt_label= sql_var_name; {Goto stmt_label} +| GO; TO; option(COLON); stmt_label= sql_var_name; {Goto stmt_label} (*SQL Stuff*) @@ -391,7 +415,8 @@ let sql_op := let sql_complex_literal := | LPAR; s= sql_complex_literal; RPAR; {s} -| v= literal; AS; c=sql_var_name; {SqlCompAs(v, c)} +| v= literal; AS; c=type_name; {SqlCompAsType(v, c)} +| v= literal; AS; c=sql_var_name; {SqlCompAsVar(v, c)} | v= literal; {SqlCompLit v } | fun_name=sql_var_name; LPAR; args = separated_list(COMMA, sql_op) ; RPAR; {SqlCompFun(fun_name, args)} @@ -431,6 +456,7 @@ let sql_first_token := | FROM; {SqlInstr "FROM" } | WHERE; {SqlInstr"WHERE"} | ORDER; BY; {SqlInstr"ORDER BY"} +| CHAR; {SqlInstr"CHAR"} | VARCHAR; {SqlInstr"VARCHAR"} | DATE; {SqlInstr"DATE"} | INTEGER; {SqlInstr"INTEGER"} diff --git a/src/lsp/sql_parser/lexer.mll b/src/lsp/sql_parser/lexer.mll index e85d33232..699172b06 100644 --- a/src/lsp/sql_parser/lexer.mll +++ b/src/lsp/sql_parser/lexer.mll @@ -27,6 +27,7 @@ "BEGIN", BEGIN; "BETWEEN", BETWEEN; "BY", BY; + "CHAR", CHAR; "CLOSE", CLOSE; "COMMIT", COMMIT; "CONNECT", CONNECT; diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 76896760c..cd2a6285b 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -122,11 +122,12 @@ let parse ~config ~filename ~contents = end; linkage_section_found := true; if config.verbosity > 1 then - Printf.eprintf "LINKAGE SECTION found at %d\n%!" loc.line; + Format.fprintf Format.std_formatter "LINKAGE SECTION found at %d\n%!" loc.line; sql_add_statement ~loc (LINKAGE_SECTION { defined = true }); iter tokens | (COPY, loc) :: (tok, _) :: (DOT, end_loc) :: tokens - when config.sql_in_copybooks -> + | (EXEC, loc) :: (IDENT "SQL", _) :: (IDENT "INCLUDE", _) :: (tok, _) :: (END_EXEC, end_loc) :: tokens + when config.sql_in_copybooks && (Misc.string_of_token tok != "SQLCA")-> let file = Misc.string_of_token tok in begin match Misc.resolve_copy ~config file with diff --git a/test/output-tests/reparse.expected b/test/output-tests/reparse.expected index ba005bbb2..e00935d1a 100644 --- a/test/output-tests/reparse.expected +++ b/test/output-tests/reparse.expected @@ -255,7 +255,7 @@ Re-parsing `test/testsuite/sql/gixsql_test/TSQL037A-SQLITE.cbl': Re-parsing `test/testsuite/sql/gixsql_test/TSQL037B-MYSQL.cbl': Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL037B-PGSQL.cbl': - Parse: Failure. + Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL037B-SQLITE.cbl': Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL038A.cbl': From 917bd30c5d1a95c121c70a4cdc90944cc476f31f Mon Sep 17 00:00:00 2001 From: Lily Olivier Date: Fri, 20 Sep 2024 17:31:12 +0200 Subject: [PATCH 19/37] note for the one who will continue this work --- .../notes_in_french/know_limitation.md | 6 ++ .../notes_in_french/test_maj/gix/Makefile | 21 ++++ .../notes_in_french/test_maj/gix/createdb.cob | 72 +++++++++++++ .../notes_in_french/test_maj/gix/dbenv.sh | 8 ++ .../notes_in_french/test_maj/gix/sumdb.cob | 101 ++++++++++++++++++ .../notes_in_french/test_maj/how_to.md | 22 ++++ .../notes_in_french/test_maj/me/CREATEDB.cob | 72 +++++++++++++ .../notes_in_french/test_maj/me/Makefile | 21 ++++ .../notes_in_french/test_maj/me/SUMDB.cob | 101 ++++++++++++++++++ .../notes_in_french/test_maj/me/dbenv.sh | 8 ++ src/lsp/sql_preproc/parse.ml | 9 +- 11 files changed, 436 insertions(+), 5 deletions(-) create mode 100644 src/lsp/sql_preproc/notes_in_french/know_limitation.md create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/gix/Makefile create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/gix/createdb.cob create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/gix/dbenv.sh create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/gix/sumdb.cob create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/how_to.md create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/me/CREATEDB.cob create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/me/Makefile create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/me/SUMDB.cob create mode 100644 src/lsp/sql_preproc/notes_in_french/test_maj/me/dbenv.sh diff --git a/src/lsp/sql_preproc/notes_in_french/know_limitation.md b/src/lsp/sql_preproc/notes_in_french/know_limitation.md new file mode 100644 index 000000000..15591d6b3 --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/know_limitation.md @@ -0,0 +1,6 @@ +# État de la pr +- les types ne sont pas toujours bien calculés. Typeck ne fonctionne malheureusement pas du tout dans le cas où les variables proviennent d’un copy ou d’un include. La fonction get_type n’est pas complète. Les types sont vraiment bizarre, je trouve. + +- Certains cas ne sont pas gérés. On peut les trouver facilement puisqu’elles renvoient un objet Generated_type.Todo { prefix } + +Good luck! \ No newline at end of file diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/gix/Makefile b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/Makefile new file mode 100644 index 000000000..8e698c308 --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/Makefile @@ -0,0 +1,21 @@ + +COBC=cobc +COBFLAGS=-g + +COBCPY=/opt/cobol/gixsql/share/gixsql/copy +GIXPPFLAGS=-e -S -I $(COBCPY) +GIXPP=gixpp + +all: createdb.exe sumdb.exe + +createdb.exe: createdb.cob + $(GIXPP) $(GIXPPFLAGS) -i ./createdb.cob -o createdb.pp.cob + $(COBC) -lgixsql -x -o createdb.exe createdb.pp.cob + +sumdb.exe: sumdb.cob + $(GIXPP) $(GIXPPFLAGS) -i ./sumdb.cob -o sumdb.pp.cob + $(COBC) -lgixsql -x -o sumdb.exe sumdb.pp.cob + +clean: + rm -f *~ *.log *.pp.cob *.o *.so *.exe + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/gix/createdb.cob b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/createdb.cob new file mode 100644 index 000000000..a28ca502b --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/createdb.cob @@ -0,0 +1,72 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. CREATEDB. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM PIC 9(6). + + EXEC SQL BEGIN DECLARE SECTION END-EXEC. + 01 DB-SOURCE PIC X(50) VALUE SPACE. + 01 DB-USER PIC X(30) VALUE SPACE. + 01 DB-PASS PIC X(20) VALUE SPACE. + EXEC SQL END DECLARE SECTION END-EXEC. + + EXEC SQL INCLUDE SQLCA END-EXEC. + + PROCEDURE DIVISION. + + MAIN. + + * NOTE: IT SEEMS SQL ERROR HANDLERS ALWAYS CAUSE + * THE PROGRAM TO BE TERMINATED AFTER BEING CALLED + EXEC SQL WHENEVER SQLERROR PERFORM SQL_ERROR END-EXEC + EXEC SQL WHENEVER SQLWARNING PERFORM SQL_ERROR END-EXEC + + DISPLAY "CONNECTING" + + ACCEPT DB-SOURCE FROM ENVIRONMENT "COB_DBSOURCE" + ACCEPT DB-USER FROM ENVIRONMENT "COB_DBUSER" + ACCEPT DB-PASS FROM ENVIRONMENT "COB_DBPASS" + + EXEC SQL + CONNECT TO :DB-SOURCE USER :DB-USER USING :DB-PASS + END-EXEC + + DISPLAY "DROPPING TABLE IF PRESENT" + + EXEC SQL + DROP TABLE IF EXISTS NUMBERS + END-EXEC + + DISPLAY "CREATING TABLE" + + EXEC SQL + CREATE TABLE NUMBERS ( + NUMBER NUMERIC(6,0) NOT NULL, + CONSTRAINT PK_NUMBER PRIMARY KEY (NUMBER) + ) + END-EXEC + + DISPLAY "INSERTING NUMBERS" + + PERFORM VARYING NUM FROM 1 BY 1 UNTIL NUM > 10000 + EXEC SQL + INSERT INTO NUMBERS VALUES (:NUM) + END-EXEC + END-PERFORM + + DISPLAY "DISCONNECTING" + + EXEC SQL + DISCONNECT ALL + END-EXEC + + DISPLAY "DONE" + STOP RUN. + + SQL_ERROR. + DISPLAY "SQL ERROR !" + DISPLAY "SQLCODE: " SQLCODE + DISPLAY "ERRCODE: " SQLSTATE + DISPLAY SQLERRMC + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/gix/dbenv.sh b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/dbenv.sh new file mode 100644 index 000000000..b26f9802a --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/dbenv.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +# Source this file before running any COBOL program that uses the DB ! +# Of course you should have set up your PostgreSQL server and database + +export COB_DBSOURCE="pgsql://localhost:5432/testdb" +export COB_DBUSER="postgres" +export COB_DBPASS="postgres" diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/gix/sumdb.cob b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/sumdb.cob new file mode 100644 index 000000000..730cb413a --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/gix/sumdb.cob @@ -0,0 +1,101 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. CREATEDB. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM PIC 9(6). + 01 NUM-COUNT PIC 9(6). + 01 NUM-SUM PIC 9(8). + + EXEC SQL BEGIN DECLARE SECTION END-EXEC. + 01 DB-SOURCE PIC X(50) VALUE SPACE. + 01 DB-USER PIC X(30) VALUE SPACE. + 01 DB-PASS PIC X(20) VALUE SPACE. + EXEC SQL END DECLARE SECTION END-EXEC. + + EXEC SQL INCLUDE SQLCA END-EXEC. + + PROCEDURE DIVISION. + + MAIN. + + * NOTE: IT SEEMS SQL ERROR HANDLERS ALWAYS CAUSE + * THE PROGRAM TO BE TERMINATED AFTER BEING CALLED + EXEC SQL WHENEVER SQLERROR PERFORM SQL_ERROR END-EXEC + EXEC SQL WHENEVER SQLWARNING PERFORM SQL_ERROR END-EXEC + + DISPLAY "CONNECTING" + + ACCEPT DB-SOURCE FROM ENVIRONMENT "COB_DBSOURCE" + ACCEPT DB-USER FROM ENVIRONMENT "COB_DBUSER" + ACCEPT DB-PASS FROM ENVIRONMENT "COB_DBPASS" + + EXEC SQL + CONNECT TO :DB-SOURCE USER :DB-USER USING :DB-PASS + END-EXEC + + DISPLAY "COUNTING NUMBERS" + + EXEC SQL + SELECT COUNT(*) INTO :NUM-COUNT FROM NUMBERS + END-EXEC. + DISPLAY "NUMBER COUNT: " NUM-COUNT + + DISPLAY "BEGINING TRANSACTION" + + * NOTE: REQUIRED TO USE CURSORS + EXEC SQL + START TRANSACTION + END-EXEC + + DISPLAY "CREATING CURSOR" + + EXEC SQL + DECLARE CUR CURSOR FOR + SELECT NUMBER FROM NUMBERS + * NOTE: BUG IF MISSING PERIOD HERE + END-EXEC. + EXEC SQL + OPEN CUR + END-EXEC + + DISPLAY "SUMMING NUMBERS" + + EXEC SQL + FETCH CUR INTO :NUM + END-EXEC + PERFORM UNTIL SQLCODE NOT = ZERO + ADD NUM TO NUM-SUM + EXEC SQL + FETCH CUR INTO :NUM + END-EXEC + END-PERFORM + DISPLAY "NUMBER SUM: " NUM-SUM + + DISPLAY "CLOSING CURSOR" + + EXEC SQL + CLOSE CUR + END-EXEC + + DISPLAY "ENDING TRANSACTION" + + EXEC SQL + COMMIT WORK + END-EXEC. + + DISPLAY "DISCONNECTING" + + EXEC SQL + DISCONNECT ALL + END-EXEC + + DISPLAY "DONE" + STOP RUN. + + SQL_ERROR. + DISPLAY "SQL ERROR !" + DISPLAY "SQLCODE: " SQLCODE + DISPLAY "ERRCODE: " SQLSTATE + DISPLAY SQLERRMC + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/how_to.md b/src/lsp/sql_preproc/notes_in_french/test_maj/how_to.md new file mode 100644 index 000000000..30fd3e5d0 --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/how_to.md @@ -0,0 +1,22 @@ +Comment faire le premier test ! +Dans le dossier, il y a deux dossiers, gix et me. Gix est un témoin Pour tester, c'est facile, on fait +# Génération +make + + +# Charge les informations de connexion de la base dans l'environnement +source dbenv.sh + + +# Lance le programme qui crée la base +./createdb.exe + + +# Lance le programme qui lit la base +./sumdb.exe + + + + + Il y a peut-être des choses à remplacer dans le makefile, selon l'endroit où vous avez installé les exécutables de gix et superbol + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/me/CREATEDB.cob b/src/lsp/sql_preproc/notes_in_french/test_maj/me/CREATEDB.cob new file mode 100644 index 000000000..a28ca502b --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/me/CREATEDB.cob @@ -0,0 +1,72 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. CREATEDB. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM PIC 9(6). + + EXEC SQL BEGIN DECLARE SECTION END-EXEC. + 01 DB-SOURCE PIC X(50) VALUE SPACE. + 01 DB-USER PIC X(30) VALUE SPACE. + 01 DB-PASS PIC X(20) VALUE SPACE. + EXEC SQL END DECLARE SECTION END-EXEC. + + EXEC SQL INCLUDE SQLCA END-EXEC. + + PROCEDURE DIVISION. + + MAIN. + + * NOTE: IT SEEMS SQL ERROR HANDLERS ALWAYS CAUSE + * THE PROGRAM TO BE TERMINATED AFTER BEING CALLED + EXEC SQL WHENEVER SQLERROR PERFORM SQL_ERROR END-EXEC + EXEC SQL WHENEVER SQLWARNING PERFORM SQL_ERROR END-EXEC + + DISPLAY "CONNECTING" + + ACCEPT DB-SOURCE FROM ENVIRONMENT "COB_DBSOURCE" + ACCEPT DB-USER FROM ENVIRONMENT "COB_DBUSER" + ACCEPT DB-PASS FROM ENVIRONMENT "COB_DBPASS" + + EXEC SQL + CONNECT TO :DB-SOURCE USER :DB-USER USING :DB-PASS + END-EXEC + + DISPLAY "DROPPING TABLE IF PRESENT" + + EXEC SQL + DROP TABLE IF EXISTS NUMBERS + END-EXEC + + DISPLAY "CREATING TABLE" + + EXEC SQL + CREATE TABLE NUMBERS ( + NUMBER NUMERIC(6,0) NOT NULL, + CONSTRAINT PK_NUMBER PRIMARY KEY (NUMBER) + ) + END-EXEC + + DISPLAY "INSERTING NUMBERS" + + PERFORM VARYING NUM FROM 1 BY 1 UNTIL NUM > 10000 + EXEC SQL + INSERT INTO NUMBERS VALUES (:NUM) + END-EXEC + END-PERFORM + + DISPLAY "DISCONNECTING" + + EXEC SQL + DISCONNECT ALL + END-EXEC + + DISPLAY "DONE" + STOP RUN. + + SQL_ERROR. + DISPLAY "SQL ERROR !" + DISPLAY "SQLCODE: " SQLCODE + DISPLAY "ERRCODE: " SQLSTATE + DISPLAY SQLERRMC + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/me/Makefile b/src/lsp/sql_preproc/notes_in_french/test_maj/me/Makefile new file mode 100644 index 000000000..ef4ff1d01 --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/me/Makefile @@ -0,0 +1,21 @@ + +COBC=cobc +COBFLAGS=-g + +COBCPY=/opt/cobol/gixsql/share/gixsql/copy +GIXPPFLAGS= --copybooks -I $(COBCPY) +GIXPP = ~/Projects/superbol-studio-oss/superbol-free-linux-x64 sql preproc + +all: CREATEDB.exe SUMDB.exe + +CREATEDB.exe: CREATEDB.cob + $(GIXPP) $(GIXPPFLAGS) ./CREATEDB.cob + $(COBC) -lgixsql -x -o CREATEDB.exe CREATEDB.pp.cob + +SUMDB.exe: SUMDB.cob + $(GIXPP) $(GIXPPFLAGS) ./SUMDB.cob + $(COBC) -lgixsql -x -o SUMDB.exe SUMDB.pp.cob + +clean: + rm -f *~ *.log *.pp.cob *.o *.so *.exe + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/me/SUMDB.cob b/src/lsp/sql_preproc/notes_in_french/test_maj/me/SUMDB.cob new file mode 100644 index 000000000..abb4d133a --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/me/SUMDB.cob @@ -0,0 +1,101 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. CREATEDB. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM PIC 9(6). + 01 NUM-COUNT PIC 9(6). + 01 NUM-SUM PIC 9(8). + + EXEC SQL BEGIN DECLARE SECTION END-EXEC. + 01 DB-SOURCE PIC X(50) VALUE SPACE. + 01 DB-USER PIC X(30) VALUE SPACE. + 01 DB-PASS PIC X(20) VALUE SPACE. + EXEC SQL END DECLARE SECTION END-EXEC. + + EXEC SQL INCLUDE SQLCA END-EXEC. + + PROCEDURE DIVISION. + + MAIN. + + * NOTE: IT SEEMS SQL ERROR HANDLERS ALWAYS CAUSE + * THE PROGRAM TO BE TERMINATED AFTER BEING CALLED + EXEC SQL WHENEVER SQLERROR PERFORM SQL_ERROR END-EXEC + EXEC SQL WHENEVER SQLWARNING PERFORM SQL_ERROR END-EXEC + + DISPLAY "CONNECTING" + + ACCEPT DB-SOURCE FROM ENVIRONMENT "COB_DBSOURCE" + ACCEPT DB-USER FROM ENVIRONMENT "COB_DBUSER" + ACCEPT DB-PASS FROM ENVIRONMENT "COB_DBPASS" + + EXEC SQL + CONNECT TO :DB-SOURCE USER :DB-USER USING :DB-PASS + END-EXEC + + DISPLAY "COUNTING NUMBERS" + + EXEC SQL + SELECT COUNT(*) INTO :NUM-COUNT FROM NUMBERS + END-EXEC. + DISPLAY "NUMBER COUNT: " NUM-COUNT + + DISPLAY "BEGINING TRANSACTION" + + * NOTE: REQUIRED TO USE CURSORS + EXEC SQL + START TRANSACTION + END-EXEC + + DISPLAY "CREATING CURSOR" + + EXEC SQL + DECLARE CUR CURSOR FOR + SELECT NUMBER FROM NUMBERS + * NOTE: BUG IF MISSING PERIOD HERE + END-EXEC. + EXEC SQL + OPEN CUR + END-EXEC + + DISPLAY "SUMMING NUMBERS" + + EXEC SQL + FETCH CUR INTO :NUM + END-EXEC + PERFORM UNTIL SQLCODE NOT = ZERO + ADD NUM TO NUM-SUM + EXEC SQL + FETCH CUR INTO :NUM + END-EXEC + END-PERFORM + DISPLAY "NUMBER SUM: " NUM-SUM + + DISPLAY "CLOSING CURSOR" + + EXEC SQL + CLOSE CUR + END-EXEC + + DISPLAY "ENDING TRANSACTION" + + EXEC SQL + COMMIT WORK + END-EXEC. + + DISPLAY "DISCONNECTING" + + EXEC SQL + DISCONNECT ALL + END-EXEC + + DISPLAY "DONE" + STOP RUN. + + SQL_ERROR. + DISPLAY "SQL ERROR !" + DISPLAY "SQLCODE: " SQLCODE + DISPLAY "ERRCODE: " SQLSTATE + DISPLAY SQLERRMC. + diff --git a/src/lsp/sql_preproc/notes_in_french/test_maj/me/dbenv.sh b/src/lsp/sql_preproc/notes_in_french/test_maj/me/dbenv.sh new file mode 100644 index 000000000..b26f9802a --- /dev/null +++ b/src/lsp/sql_preproc/notes_in_french/test_maj/me/dbenv.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +# Source this file before running any COBOL program that uses the DB ! +# Of course you should have set up your PostgreSQL server and database + +export COB_DBSOURCE="pgsql://localhost:5432/testdb" +export COB_DBUSER="postgres" +export COB_DBPASS="postgres" diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index cd2a6285b..944b44431 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -21,7 +21,6 @@ let rec find_dot tokens = let parse ~config ~filename ~contents = let program_id = ref None in let sql_statements = ref [] in - (* let var_statements = ref [] in *) let procedure_division_found = ref None in let working_storage_found = ref false in let linkage_section_found = ref false in @@ -164,12 +163,12 @@ let parse ~config ~filename ~contents = let params = List.rev params in let sqlStr = "EXEC SQL " ^ String.concat " " params ^ " END-EXEC" in - Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; +(* Format.fprintf Format.std_formatter "\nSTRING\n"; + Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in - Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; +(* Format.fprintf Format.std_formatter "\nAST\n"; + Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; *) sql_add_statement ~loc (EXEC_SQL { end_loc; with_dot; tokens = sql }); iter tokens From 4e38236db9351b8902a1805c5df7867cd94f90be Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 4 Oct 2024 16:33:27 +0200 Subject: [PATCH 20/37] fix: merge build errors --- src/lsp/superbol_free_lib/command_sql.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/lsp/superbol_free_lib/command_sql.ml b/src/lsp/superbol_free_lib/command_sql.ml index c2b6faa07..16f723b5a 100644 --- a/src/lsp/superbol_free_lib/command_sql.ml +++ b/src/lsp/superbol_free_lib/command_sql.ml @@ -57,9 +57,8 @@ let typeck_file { preproc_options; parser_options } filename = end let parse ~sql_in_copybooks ~copy_exts common files = - let { preproc_options = { source_format; libpath = copy_path; _ }; _ } = - common - in + let source_format = common.preproc_options.source_format in + let copy_path = common.preproc_options.copybook_lookup_config.lookup_path in let source_format = Cobol_indent.Config.source_format source_format in List.iter (fun filename -> @@ -79,8 +78,8 @@ let parse ~sql_in_copybooks ~copy_exts common files = output_string oc s; close_out oc; Printf.eprintf "File %S generated\n%!" filename - in - let name_change filename = + in + let name_change filename = if Filename.check_suffix filename ".cob" then let base_name = Filename.chop_suffix filename ".cob" in base_name ^ ".pp.cob" @@ -114,9 +113,10 @@ let preproc_cmd = ( [ "copybooks" ], Arg.Set sql_in_copybooks, EZCMD.info "Preprocess copybooks also (without REPLACING)" ); - ( [ "ext" ], - Arg.String (fun s -> copy_exts := !copy_exts @ [ "." ^ s ]), - EZCMD.info ~docv:"EXT" - "Add .EXT as an extension to find copybooks (default is cpy)" ) + (* I (@NeoKaios) removed that as it conflicts with another option *) + (* ( [ "ext" ], *) + (* Arg.String (fun s -> copy_exts := !copy_exts @ [ "." ^ s ]), *) + (* EZCMD.info ~docv:"EXT" *) + (* "Add .EXT as an extension to find copybooks (default is cpy)" ) *) ] ) ~doc:"Preprocess SQL EXECs" From ba14fe95311f23150a388ef59bafead71619cdfa Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 7 Oct 2024 16:22:08 +0200 Subject: [PATCH 21/37] fix: problem with long sql stmt generation - fix sql stmt generation when stmt is exactly 72 char long - unify prefix on all preproc genereted lines --- src/lsp/sql_preproc/data_gestion.ml | 2 +- src/lsp/sql_preproc/generate.ml | 3 +- src/lsp/sql_preproc/generated_type.ml | 61 ++++++++++++++++----------- 3 files changed, 39 insertions(+), 27 deletions(-) diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 379e244a4..def3c5b53 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -30,7 +30,7 @@ let add_var ~map ~name ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) let num = ref 0 let transform_stm map (_, stm) filename = - let prefix = " " in + let prefix = Generated_type.Printer.preproc_prefix ^ " " in let create_new_var content ?(remplace=true) () = let new_content = if remplace then "\"" ^ Misc.replace_colon_words content ^ "\"" else content in let size = String.length new_content - 2 in diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 48be91c43..fed6f8787 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -861,7 +861,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let rec generatesql ~loc ~line esql_instuction = - let prefix = String.sub line 0 loc.char in + let prefix = Generated_type.Printer.preproc_prefix + ^ String.sub line 6 (loc.char-6) in match esql_instuction with | Sql _ | SelectInto _ diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index 7b6dc5f8c..6c506a86b 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -96,7 +96,7 @@ type generated_stm = type generated = generated_stm list module Printer = struct - (*TODO: a function that cut (with &) the resquest if too long*) + let preproc_prefix = "SQLBOL" let rec pp fmt gen = match gen with @@ -122,12 +122,14 @@ module Printer = struct else "" in - Format.fprintf fmt "%a\n%a%a%s\n" pp_old_stms old_stms pp_trans_stm + Format.fprintf fmt "%a%a%a%s\n" pp_old_stms old_stms pp_trans_stm trans_stm pp_error_treatment error_treatment dot and pp_old_stms fmt x = match x with - | h :: t -> Format.fprintf fmt " *> REMOVED: %s\n%a" h pp_old_stms t + | h :: t -> + let old_line = String.sub h 7 (String.length h - 7) in + Format.fprintf fmt "%s*%s\n%a" preproc_prefix old_line pp_old_stms t | [] -> () and pp_trans_stm fmt x = @@ -138,8 +140,8 @@ module Printer = struct and pp_trans_stm_aux fmt x = match x with - | Section { name } -> Format.fprintf fmt " %s." name - | Comment { content } -> Format.fprintf fmt "ADDED *%s" content + | Section { name } -> Format.fprintf fmt "%s %s." preproc_prefix name + | Comment { content } -> Format.fprintf fmt "%s*%s" preproc_prefix content | CallStatic { prefix; fun_name; ref_value } -> Format.fprintf fmt "%sCALL STATIC \"%s\"%a%sEND-CALL" prefix fun_name pp_ref_value_list ref_value prefix @@ -158,29 +160,38 @@ module Printer = struct | Move { prefix; src; dest } -> Format.fprintf fmt "%sMOVE '%s' TO %s" prefix src dest | Declaration d -> Format.fprintf fmt "%a" pp_declaration d - | LinkageSection -> Format.fprintf fmt " LINKAGE SECTION." + | LinkageSection -> Format.fprintf fmt "%s LINKAGE SECTION." preproc_prefix | WorkingStorageSection -> - Format.fprintf fmt " WORKING-STORAGE SECTION." - | ProcedureDivision -> Format.fprintf fmt " PROCEDURE DIVISION." + Format.fprintf fmt "%s WORKING-STORAGE SECTION." preproc_prefix + | ProcedureDivision -> Format.fprintf fmt "%s PROCEDURE DIVISION." preproc_prefix | NonFatalErrorWarning { content } -> - Format.fprintf fmt " *> WARNING: %s" content + Format.fprintf fmt "%s* WARNING: %s" preproc_prefix content | Todo { prefix } -> Format.fprintf fmt "%sTODO" prefix - (*TODO: maybe redo this, but nicer*) - and split_line max_length line = - let rec aux acc max_length current_line = - if String.length current_line <= max_length then - List.rev (current_line :: acc) - else - let part = String.sub current_line 0 max_length in - let rest = - String.sub current_line max_length - (String.length current_line - max_length) - in - aux ((part ^ "\"\n & \"") :: acc) 59 rest (*72 (character limit) - 12 (size of prefix ' & "' ) - 1 (for the '"')*) - in - aux [] max_length line + and max_line_width = 72 + and split_line line = + (* NOTE: this function makes a lot of assumptions, mainly the fact that + the reason a line is too long is because of a VALUE literal clause + where literal is a double quoted string *) + let rec aux acc current_line = + let len = String.length current_line in + if len <= max_line_width then + List.rev (current_line :: acc) + else if len == max_line_width + 1 + then + (* only closing period remains *) + let line = String.sub current_line 0 max_line_width in + List.rev ((preproc_prefix ^ "-.") :: line :: acc) + else + let first = String.sub current_line 0 max_line_width in + let rest = + String.sub current_line max_line_width + (String.length current_line - max_line_width) + in + aux (first :: acc) (preproc_prefix ^ "-\"" ^ rest) + in + aux [] line and pp_declaration fmt = function | Simple_var_declaration @@ -199,8 +210,8 @@ module Printer = struct Printf.sprintf "%s%s %s PIC %s %s." prefix var_importance var_name var_type var_content in - let lines = split_line 71 line in (*72 (character limit) - 1 (for the '"')*) - List.iter (Format.fprintf fmt "%s") lines + let lines = split_line line in + Format.fprintf fmt "%s" (String.concat "\n" lines) | Field_var_declaration { prefix; var_importance; var_name; field } -> Format.fprintf fmt "%s%s %s.%a" prefix var_importance var_name pp_field field From 6e81be0d1635ce928a07606a454af80d1a8f0900 Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 7 Oct 2024 16:23:09 +0200 Subject: [PATCH 22/37] docs: how to run gixsql test for superbol --- test/testsuite/sql/RUN_GIXSQL_TESTS.md | 67 ++++++++++ .../sql/superbol-preproc-for-gixsql.patch | 114 ++++++++++++++++++ 2 files changed, 181 insertions(+) create mode 100644 test/testsuite/sql/RUN_GIXSQL_TESTS.md create mode 100644 test/testsuite/sql/superbol-preproc-for-gixsql.patch diff --git a/test/testsuite/sql/RUN_GIXSQL_TESTS.md b/test/testsuite/sql/RUN_GIXSQL_TESTS.md new file mode 100644 index 000000000..63d687061 --- /dev/null +++ b/test/testsuite/sql/RUN_GIXSQL_TESTS.md @@ -0,0 +1,67 @@ +# How to run GixSQL testsuite : + +## Install GixSQL + +Following https://github.com/mridoni/gixsql/tree/main?tab=readme-ov-file#linux you can build GixSQL locally + +## Configure at least one database type + +This requires creating one user (e.g. `test`) with password access (e.g. `test`), and 2 databases (e.g. `testdb1` and `testdb2`). +Postgres with the provided user, password and database names will be used for the rest of the setup. + +Note: mysql tests fails on Linux, it seems to be a case sensitivity issue between Windows and Linux. + +From the doc https://dev.mysql.com/doc/refman/8.0/en/identifier-case-sensitivity.html +> In MySQL, databases correspond to directories within the data directory. Each table within a database corresponds to at least one file within the database directory (and possibly more, depending on the storage engine). Triggers also correspond to files. Consequently, the case sensitivity of the underlying operating system plays a part in the case sensitivity of database, table, and trigger names. This means such names are not case-sensitive in Windows, but are case-sensitive in most varieties of Unix. + +## Patch file + +I created a git patch file with my modification of GixSQL : `superbol-preproc-for-gixsql.patch` +The command `git am path/to/patch` inside the GixSQL repo will apply those changes. + +The patch file contains the following changes : +- Setup `gixsql_test_local_linux.xml` for a standard install +- Edition of two `.cs` file for the execution of superbol's preprocessor + +- Make sure the temp folder `/tmp/gixsql-test` exists +- The superbol-free executable is accessible at `/opt/superbol-free-linux-x64` (symbolic linking works) + +## GixSQL XML config file + +The fields in `gixsql_test_local_linux.xml` are described in https://github.com/mridoni/gixsql/blob/main/TESTING.md. + +Make sure to check the following : +- set `gixsql-install-base` : probably `/opt/gixsql` if you followed the default for GixSQL install +- clear `test-filter` : allow executing all test files +- set your configured databases in `dbtype-filter` : `pgsql` if you want only Postgres +- remove the `mem-check` field +- depending on you installation of GnuCOBOL change the `compiler` fields + - `bin_dir_path` can be `/usr/local/bin` + - `lib_dir_path` can be `/usr/local/lib` + - `config_dir_path` can be `/usr/local/share/gnucobol/config` +- in `data-sources` configure the 2 databases required for each database type + +## Building & executing the testsuite + +Building the testsuite is described here : https://github.com/mridoni/gixsql/blob/main/TESTING.md#building-the-test-runner. +Things to consider : +- This require dotnet 6.0 SDK +- The command `dotnet build gixsql-tests-nunit/gixsql-tests-nunit.csproj` is slow and will block at `Determining projects to restore...` for some time (5 minutes). + +Executing the testsuite with `dotnet gixsql-tests-nunit/bin/Debug/net6.0/gixsql-tests-nunit.dll` should work and execute the test either with GixSQL preprocessor or SuperBOL preprocessor if the patch file was applied + +### Additionnal considerations + +At the moment of writing, and with my config (Postgres on linux), the following test seemed to fail even when executed with `gixpp` : + +``` +Failed tests: +(#000) - TSQL004A/x64/gcc/pgsql - CURSOR + misc data types : KO +(#000) - TSQL005D/x64/gcc/pgsql - BINARY/VARBINARY data types : KO +(#091) - TSQL030A/x64/gcc/pgsql - Show-stopper bug in pgsql_prepare : KO +Run: 71 - Success: 68 - Failed: 3 +``` + +The test `TSQL004A` fails due to a invalid preprocessor option. (line 237 of `gixsql_test_data.xml`) +The other two fail due to preprocessor errors. + diff --git a/test/testsuite/sql/superbol-preproc-for-gixsql.patch b/test/testsuite/sql/superbol-preproc-for-gixsql.patch new file mode 100644 index 000000000..04d824ea0 --- /dev/null +++ b/test/testsuite/sql/superbol-preproc-for-gixsql.patch @@ -0,0 +1,114 @@ +From 2ac8acac539025b62c398d543556712fd908f579 Mon Sep 17 00:00:00 2001 +From: NeoKaios +Date: Mon, 7 Oct 2024 14:18:59 +0200 +Subject: [PATCH] feat: using superbol preprocessor + +--- + gixsql-tests-nunit/CompilerConfig2.cs | 2 +- + gixsql-tests-nunit/GixSqlDynamicTestRunner.cs | 2 +- + gixsql-tests-nunit/Runner.cs | 2 +- + .../gixsql_test_local_linux.xml | 20 +++++++++---------- + 4 files changed, 13 insertions(+), 13 deletions(-) + +diff --git a/gixsql-tests-nunit/CompilerConfig2.cs b/gixsql-tests-nunit/CompilerConfig2.cs +index 3596ad6..f25db7b 100644 +--- a/gixsql-tests-nunit/CompilerConfig2.cs ++++ b/gixsql-tests-nunit/CompilerConfig2.cs +@@ -88,7 +88,7 @@ namespace gixsql_tests + } + else + { +- cc.gixpp_exe = Path.Combine(cc.gixsql_bin_path, "gixpp"); ++ cc.gixpp_exe = "/opt/superbol-free-linux-x64"; + if (!File.Exists(cc.gixpp_exe)) throw new Exception(cc.gixpp_exe); + + cc.cobc_exe = Path.Combine(cc.cobc_bin_dir_path, "cobc"); +diff --git a/gixsql-tests-nunit/GixSqlDynamicTestRunner.cs b/gixsql-tests-nunit/GixSqlDynamicTestRunner.cs +index cdb24cc..99d8e82 100644 +--- a/gixsql-tests-nunit/GixSqlDynamicTestRunner.cs ++++ b/gixsql-tests-nunit/GixSqlDynamicTestRunner.cs +@@ -242,7 +242,7 @@ namespace gixsql_tests + if (client_pp_params == null) + client_pp_params = String.Empty; + } +- string gixpp_args = $"-e -v -S -I. -I{cc.gixsql_copy_path} -i {msrc} -o {pp_file} {client_pp_params}"; ++ string gixpp_args = $"sql preproc -I. -I{cc.gixsql_copy_path} --copybooks {msrc}"; + if (td.AdditionalPreProcessParams != String.Empty) + gixpp_args += (" " + td.AdditionalPreProcessParams); + +diff --git a/gixsql-tests-nunit/Runner.cs b/gixsql-tests-nunit/Runner.cs +index 512583f..acdaafc 100644 +--- a/gixsql-tests-nunit/Runner.cs ++++ b/gixsql-tests-nunit/Runner.cs +@@ -42,7 +42,7 @@ namespace gixsql_tests_nunit + } + } + +- int num_results_ok = results.Count(a => a.Value == "KO"); ++ int num_results_ok = results.Count(a => a.Value == "OK"); + int num_results_ko = results.Count(a => a.Value == "KO"); + + int mlen = results.Select(a => a.Key.Length).Max(); +diff --git a/gixsql-tests-nunit/gixsql_test_local_linux.xml b/gixsql-tests-nunit/gixsql_test_local_linux.xml +index bafb784..c39e555 100644 +--- a/gixsql-tests-nunit/gixsql_test_local_linux.xml ++++ b/gixsql-tests-nunit/gixsql_test_local_linux.xml +@@ -2,12 +2,12 @@ + + + +- /home/marchetto/gixsql/dist ++ /opt/gixsql + 1 + 0 +- TSQL042A +- odbc +- valgrind --log-file=valgrind-${testid}-${arch}-${dbtype}.txt --leak-check=full --suppressions=/home/marchetto/gixsql/suppressions.txt ++ ++ pgsql ++ + /tmp/gixsql-test + + +@@ -24,9 +24,9 @@ + + + +- /usr/bin +- /usr/lib +- /etc/gnucobol ++ /usr/local/bin ++ /usr/local/lib ++ /usr/local/share/gnucobol/config + + + +@@ -71,7 +71,7 @@ + + + +- 192.168.56.1 ++ localhost + 5432 + testdb1 + test +@@ -79,14 +79,14 @@ + native_cursors=off + + +- 192.168.56.1 ++ localhost + 5432 + testdb2 + test + test + native_cursors=off + +- ++ + + 192.168.1.171 + 3306 +-- +2.40.1 + From 93430b2f7ac13c672b998df1c0a2de16abf8e4d8 Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 11 Oct 2024 17:01:39 +0200 Subject: [PATCH 23/37] fix: multiple bugfixes and refactors --- src/lsp/sql_ast/sql_ast.ml | 2 +- src/lsp/sql_preproc/data_gestion.ml | 169 ++++++++++++++++--------- src/lsp/sql_preproc/generate.ml | 127 ++++++++++++------- src/lsp/sql_preproc/generated_type.ml | 9 +- src/lsp/sql_preproc/gix_enum.ml | 23 ++++ src/lsp/sql_preproc/parse.ml | 62 ++++++--- src/lsp/sql_preproc/sql_typeck.ml | 35 +++-- src/lsp/sql_preproc/types.ml | 11 +- test/testsuite/sql/RUN_GIXSQL_TESTS.md | 16 ++- 9 files changed, 312 insertions(+), 142 deletions(-) create mode 100644 src/lsp/sql_preproc/gix_enum.ml diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index e0cf1790e..dee182da4 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -620,7 +620,7 @@ module Printer = struct and pp_lit fmt = function | LiteralNum n -> Format.fprintf fmt "%s" n.payload - | LiteralStr n -> Format.fprintf fmt "%s" n.payload + | LiteralStr n -> Format.fprintf fmt "'%s'" n.payload | LiteralVar n -> Format.fprintf fmt "%a" pp_var n | LiteralDot lst -> let rec pp_aux fmt = function diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index def3c5b53..7256fa4fe 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -23,8 +23,24 @@ type variable_information = type t = variable_information StringMap.t -let add_var ~map ~name ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) - ?(ind_addr = 0) () = +let get_length = function + | Binary size | Varbinary size | Varchar size | Char size -> size + | Float (digit, scale_opt) -> + Printf.eprintf "WARNING : Untested length of FLOAT field\n"; + digit + Option.value ~default:0 scale_opt + +let get_type = function + | Float _ -> Sql_typeck.(cobol_types_to_int COBOL_TYPE_FLOAT) (* not sure of that, may be double? *) + | _ -> Sql_typeck.(cobol_types_to_int COBOL_TYPE_ALPHANUMERIC) + +let get_flags = function + | Binary _ -> Gix_enum.Flag.binary + | Varbinary _ -> Gix_enum.Flag.binary lor Gix_enum.Flag.varlen + | Varchar _ -> Gix_enum.Flag.varlen + | Char _ | Float _ -> Gix_enum.Flag.none + +let add_var ?(length = 0) ?(vartype = 0) ?(scale = 0) ?(flags = 0) + ?(ind_addr = 0) map name = StringMap.add name { length; vartype; scale; flags; ind_addr } map let num = ref 0 @@ -59,7 +75,7 @@ let transform_stm map (_, stm) filename = (Field_var_declaration { prefix; var_importance = "01"; var_name; field } ) ], - add_var ~map ~name:("SQ" ^ string_of_int !num) ~length:size () ) + add_var ~length:size map ("SQ" ^ string_of_int !num) ) in let add_cur cur_name map ws filename = let pre_cur_name = "GIXSQL-CI-F-" ^ Misc.extract_filename filename ^ "-" in @@ -74,9 +90,7 @@ let transform_stm map (_, stm) filename = } ) :: ws in - let map = - add_var ~map ~name:(pre_cur_name ^ cur_name) ~length:0 () - in + let map = add_var ~length:0 map (pre_cur_name ^ cur_name) in (ws, map) in @@ -98,9 +112,38 @@ let transform_stm map (_, stm) filename = (ws, map) | Sql sql -> ( match sql with + | Sql_ast.SqlInstr "VAR" :: + Sql_ast.SqlInstr varname :: + Sql_ast.SqlInstr "IS" :: + Sql_ast.SqlInstr typ :: + Sql_ast.SqlInstr "(" :: + Sql_ast.SqlInstr size :: + Sql_ast.SqlInstr ")" :: _ -> + (* patch to fix TSQL005C, this is surely not generic enough + and should probably be treated in parse.ml ? *) + Printf.eprintf "Warning : EXEC SQL VAR with %s %s %s\n" varname typ size; + let flags = + if String.starts_with ~prefix:"VAR" typ + then Gix_enum.Flag.autotrim + else Gix_enum.Flag.none + in + let length = int_of_string size in + let typ = match typ with + | "BINARY" -> Binary length + | "VARBINARY" -> Varbinary length + | "VARCHAR" -> Varchar length + | "CHAR" -> Char length + | "FLOAT" -> Float (length, None) + | unknown -> Pretty.failwith "Unknow type %s" unknown + in + let vartype = get_type typ in + ([], add_var ~vartype ~length ~flags map varname) | Sql_ast.SqlInstr w :: _ when w = "VAR" -> + Printf.eprintf "Warning : ignoring EXEC SQL VAR statement\n"; ([], map) - (*TODO: find what this should be replaced with. I think Gix juste ignorer these instruction, but mabe not*) + (*TODO: GIX uses this to add flag on certain variable + (see TSQL005C, where VCFLD2 has flag varlen due to an EXEC SQL VAR statement) + *) | _ -> let ws, map = create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) () @@ -156,61 +199,71 @@ let transform_stm map (_, stm) filename = in let trans_declaration declaration = - match declaration with - | SQL_type_is { importance; name; sql_type; sql_type_size } -> begin - match sql_type with - | "BINARY" - | "CHAR" -> - let map = - add_var ~map ~name ~length:(int_of_string sql_type_size) () - in - - ( [ Declaration - (Simple_var_declaration - { prefix; - var_importance = importance; - var_name = Some name; - var_type = "X(" ^ sql_type_size ^ ")"; - var_content = None - } ) - ], - map ) - | "VARBINARY" - | "VARCHAR" -> - let map = - add_var ~map ~name ~length:(int_of_string sql_type_size) () - in - let field = - let prefix = prefix ^ " " in - [ Simple_var_declaration + let SQL_type_is { importance; name; sql_type } = + declaration in + let vartype = get_type sql_type in + let flags = get_flags sql_type in + let field_length = (get_length sql_type) in + let map = add_var + ~length:field_length + ~vartype + ~flags + map name + in + let field_length = string_of_int field_length in + (match sql_type with + | Binary _ + | Char _ -> + [ Declaration + (Simple_var_declaration { prefix; - var_importance = "49"; - var_name = Some (name ^ "-LEN"); - var_type = "9(8) COMP-5"; + var_importance = importance; + var_name = Some name; + var_type = "X(" ^ field_length ^ ")"; var_content = None - }; - Simple_var_declaration + } ) + ] + | Float (digit, scale) -> + let var_type = + let scale = match scale with + | None -> "" + | Some scale -> Printf.sprintf "V9(%d)" scale + in + Printf.sprintf "S9(%d)%s" digit scale + in + [ Declaration + (Simple_var_declaration { prefix; - var_importance = "49"; - var_name = Some (name ^ "-ARR"); - var_type = "X(" ^ sql_type_size ^ ")"; + var_importance = importance; + var_name = Some name; + var_type; var_content = None - } - ] - in - - let decl = - Field_var_declaration - { prefix; var_importance = importance; var_name = name; field } - in - - ( [ Declaration decl ], - (* " " ^ importance ^ " " ^ name ^ ".\n 49 " ^ name - ^ "-LEN PIC 9(8) COMP-5.\n 49 " ^ name ^ "-ARR PIC X(" - ^ sql_type_size ^ ").\n", *) - map ) - | _ -> failwith "Unknow type." - end + } ) + ] + | Varbinary _ + | Varchar _ -> + let field = + let prefix = prefix ^ " " in + [ Simple_var_declaration + { prefix; + var_importance = "49"; + var_name = Some (name ^ "-LEN"); + var_type = "9(8) COMP-5"; + var_content = None + }; + Simple_var_declaration + { prefix; + var_importance = "49"; + var_name = Some (name ^ "-ARR"); + var_type = "X(" ^ field_length ^ ")"; + var_content = None + } + ] + in + let decl = + Field_var_declaration + { prefix; var_importance = importance; var_name = name; field } + in [ Declaration decl ]) , map in match stm with diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index fed6f8787..131508041 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -19,6 +19,11 @@ let comment str = with_dot = false } +let line_if_not_empty line = + if String.length (String.trim (String.sub line 7 (String.length line - 7))) > 0 + then [Generated_type.NoChange { content = line }] + else [] + let generate ~filename ~contents ~cobol_unit sql_statements = let linkage_section = comment "" in let begin_procedure_division ~loc:_ = @@ -35,16 +40,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = (* The result will be stored in this buffer: *) let _final_loc = { filename; line = -1; char = 0 } in - let error_treatment = - ref - Generated_type. - { prefix = " "; - not_found_whenever = None; - sql_error_whenever = None; - sql_warning_whenever = None - } - in - let is_error_treatment = ref false in + let error_treatment = ref None in let old_statements = ref [] in let cursor_declaration = ref [] in let in_pro_div = ref false in @@ -86,9 +82,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | None -> None in - let get_length str = + let get_length ?(negative_if_varlen=false) str = match Data_gestion.find_opt new_var_map str with - | Some a -> a.length + | Some a -> + if a.flags land Gix_enum.Flag.varlen > 0 + then + if negative_if_varlen + then -(a.length + 4) + else a.length + 4 + else a.length | None -> Sql_typeck.get_length cobol_unit str in @@ -112,8 +114,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let get_scale str = match Data_gestion.find_opt new_var_map str with - | Some a -> a.scale - | None -> Sql_typeck.get_scale cobol_unit str + | Some a -> - a.scale + | None -> - Sql_typeck.get_scale cobol_unit str in let get_flags str = match Data_gestion.find_opt new_var_map str with @@ -247,7 +249,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let change_error ~prefix c k = - let old_error = !error_treatment in + let old_not_found_whenever, old_warning_whenever, old_error_whenever = + match !error_treatment with + | Some Generated_type. + { sql_error_whenever; not_found_whenever; sql_warning_whenever ; _ } -> + not_found_whenever, sql_warning_whenever, sql_error_whenever + | None -> None, None, None in let continuation = match k with | Sql_ast.Continue -> Generated_type.Continue @@ -260,24 +267,23 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type. { prefix; not_found_whenever = Some continuation; - sql_error_whenever = old_error.sql_error_whenever; - sql_warning_whenever = old_error.sql_warning_whenever + sql_error_whenever = old_error_whenever; + sql_warning_whenever = old_warning_whenever } | Sql_ast.SqlError_whenever -> { prefix; - not_found_whenever = old_error.not_found_whenever; + not_found_whenever = old_not_found_whenever; sql_error_whenever = Some continuation; - sql_warning_whenever = old_error.sql_warning_whenever + sql_warning_whenever = old_warning_whenever } | Sql_ast.SqlWarning_whenever -> { prefix; - not_found_whenever = old_error.not_found_whenever; - sql_error_whenever = old_error.sql_error_whenever; + not_found_whenever = old_not_found_whenever; + sql_error_whenever = old_error_whenever; sql_warning_whenever = Some continuation } in - error_treatment := new_error; - is_error_treatment := true + error_treatment := Some new_error; in let get_name_cobol_var (cobol_var : cobol_var) = @@ -463,7 +469,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference { prefix; var = name }; - Generated_type.Value { prefix; var = string_of_int (get_length name) } + Generated_type.Value { prefix; var = + string_of_int (get_length ~negative_if_varlen:true name) } ] in [ Generated_type.CallStatic { prefix; fun_name; ref_value } ] @@ -477,9 +484,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = cursor_declaration := cd in - let create_from_cursor_declaration (_prefix, cur, at, var_name) = - (* let prefix = prefix ^ " " in *) - let prefix = " " in + let create_from_cursor_declaration (prefix, cur, at, var_name) = let at_name, at_size = get_at_info at in let cur_name, cob_var_lst, var_name, _with_hold = match cur with @@ -511,15 +516,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let fun_name, cursor_declare = + let prefix = prefix ^ " " in match cob_var_lst with | [] -> - let prefix = " " in ( "GIXSQLCursorDeclare", [ Generated_type.Reference { prefix; var = var_name }; - Generated_type.Value { prefix; var = "0" } + Generated_type.Value { prefix; var = + string_of_int (get_length ~negative_if_varlen:true var_name) } ] ) | _ -> - let prefix = " " in ( "GIXSQLCursorDeclareParams", [ Generated_type.Reference { prefix; var = var_name }; Generated_type.Value { prefix; var = "0" }; @@ -529,7 +534,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let adding = let ref_value = - let prefix = " " in + let prefix = prefix ^ " " in [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; @@ -556,11 +561,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in Generated_type.Added { content = adding; - error_treatment = - ( if !is_error_treatment then - Some !error_treatment - else - None ); + error_treatment = !error_treatment; with_dot = true } in @@ -609,7 +610,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = { prefix; var = "\"" ^ var_name.payload ^ "\" & x\"00\"" }; Generated_type.Reference { prefix; var = sql_name }; Generated_type.Value - { prefix; var = string_of_int (get_length sql_name) } + { prefix; var = + string_of_int (get_length ~negative_if_varlen:true sql_name) } (*todo*) ] in @@ -727,10 +729,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ] in - let generate_open_cursor prefix (cursor_name : sqlVarToken) cobol_lst = - match cobol_lst with - | Some _ -> [ Generated_type.Todo { prefix } ] - | None -> + let generate_open_cursor prefix (cursor_name : sqlVarToken) cobol_lst = + (* in TSQL004B, the using statment doesn't seem to change the open statement *) + ignore(cobol_lst); let cursor_name' = Misc.extract_filename filename ^ "-" ^ cursor_name.payload in @@ -764,7 +765,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = if_stm = if2 } ] - in + in let generate_declare_cursor prefix cur = let curname = @@ -847,6 +848,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ?opt_using_hostref_list ?at () | DeclareTable _ -> (*Parser error on DECLARE TABLE statements in Gix, idk if Gix runtime can handle it*) + (* indeed, gix *seems* to not be doing anything with it, this requires further testing tho *) [ Generated_type.Todo { prefix } ] | Delete sql_instr -> let value_list = @@ -861,6 +863,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let rec generatesql ~loc ~line esql_instuction = + (* tabulation makes this fails somehow, TSQL009A *) let prefix = Generated_type.Printer.preproc_prefix ^ String.sub line 6 (loc.char-6) in match esql_instuction with @@ -971,6 +974,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.NoChange { content = line } :: ([ linkage_section ] @ output lines statements) end else begin + (* idk why she added that, it makes the test 7A fail *) comment "> Add missing LINKAGE SECTION" :: Generated_type.Added { content = [ Generated_type.LinkageSection ]; @@ -992,6 +996,37 @@ let generate ~filename ~contents ~cobol_unit sql_statements = } :: (working_storage_section @ output cur_lines statements) end + | EXEC_SQL_IGNORE { end_loc; begin_of_ignore_loc } -> + Printf.eprintf "%d,%d\n" begin_of_ignore_loc.line begin_of_ignore_loc.char; + begin if i = begin_loc.line + then [comment "ESQL IGNORED SECTION"] + else [] end + @ + begin if i = begin_of_ignore_loc.line + then + let end_char_pos = + if i = end_loc.line + then end_loc.char + else String.length line + in + let start_char_pos = begin_of_ignore_loc.char in + let len = end_char_pos - start_char_pos in + let prefix = String.sub line 0 7 in + let line = String.sub line start_char_pos len in + line_if_not_empty (prefix ^ line) + else if end_loc.line = i + then + let line = String.sub line 0 end_loc.char in + line_if_not_empty line + else [] end + @ + if i = end_loc.line + then comment "END OF ESQL IGNORED SECTION" + :: output lines statements + else + (if i > begin_of_ignore_loc.line + then [Generated_type.NoChange { content = line }] + else []) @ output_statement lines begin_loc stmt statements | EXEC_SQL { end_loc; with_dot; tokens } -> old_statements := line :: !old_statements; if i = end_loc.line then begin @@ -1010,11 +1045,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | At (_, DeclareCursor _) -> (with_dot, None) | _ -> - ( with_dot, - if !is_error_treatment then - Some !error_treatment - else - None ) ) + ( with_dot, !error_treatment)) in old_statements := []; Generated_type.Change @@ -1039,7 +1070,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = comment ("> REMOVED: " ^ line) :: output lines statements (* | IS_SQLVAR { end_loc } -> - + if i = begin_loc.line then begin let before_macro = String.sub line 0 begin_loc.char in Printf.bprintf ctxt.b "%s%s" before_macro diff --git a/src/lsp/sql_preproc/generated_type.ml b/src/lsp/sql_preproc/generated_type.ml index 6c506a86b..e48c47023 100644 --- a/src/lsp/sql_preproc/generated_type.ml +++ b/src/lsp/sql_preproc/generated_type.ml @@ -180,9 +180,10 @@ module Printer = struct List.rev (current_line :: acc) else if len == max_line_width + 1 then - (* only closing period remains *) - let line = String.sub current_line 0 max_line_width in - List.rev ((preproc_prefix ^ "-.") :: line :: acc) + (* only closing period remains, this hack is required to avoid cobc warnings *) + let line = String.sub current_line 0 (max_line_width-2) ^ "\"" in + let end_of_string = String.sub current_line (max_line_width-2) 3 in + List.rev ((preproc_prefix ^ " & \"" ^ end_of_string) :: line :: acc) else let first = String.sub current_line 0 max_line_width in let rest = @@ -229,7 +230,7 @@ module Printer = struct match continuation with | Continue -> Format.fprintf fmt " CONTINUE" | Perform sqlVarToken -> Format.fprintf fmt " PERFORM %s" sqlVarToken - | Goto sqlVarToken -> Format.fprintf fmt " GO TO %s." sqlVarToken + | Goto sqlVarToken -> Format.fprintf fmt " GO TO %s" sqlVarToken in let print_error fmt (not_found_whenever, str) = match not_found_whenever with diff --git a/src/lsp/sql_preproc/gix_enum.ml b/src/lsp/sql_preproc/gix_enum.ml new file mode 100644 index 000000000..da766a583 --- /dev/null +++ b/src/lsp/sql_preproc/gix_enum.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(**************************************************************************) + +(* +#define CBL_FIELD_FLAG_NONE (uint32_t)0x0 +#define CBL_FIELD_FLAG_VARLEN (uint32_t)0x80 +#define CBL_FIELD_FLAG_BINARY (uint32_t)0x100 +#define CBL_FIELD_FLAG_AUTOTRIM (uint32_t)0x200 +*) + +module Flag = struct + let none = 0x0 + let varlen = 0x80 + let binary = 0x100 + let autotrim = 0x200 +end diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 944b44431..5be435569 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -46,13 +46,39 @@ let parse ~config ~filename ~contents = :: (IDENT "SQL", _) :: (IDENT "TYPE", _) :: (IDENT "IS", _) - :: (IDENT sql_type, _) + :: (IDENT typ, _) :: (LPAREN, _) - :: (INTEGER sql_type_size, _) + :: (INTEGER size, _) :: (RPAREN, end_loc) :: tokens -> + let size = int_of_string size in + let sql_type = match typ with + | "BINARY" -> Binary size + | "VARBINARY" -> Varbinary size + | "VARCHAR" -> Varchar size + | "CHAR" -> Char size + | "FLOAT" -> Float (size, None) + | unknown -> Pretty.failwith "Unknow type %s" unknown + in + let declaration = + SQL_type_is { importance; name; sql_type } + in + sql_add_statement ~loc (DECLARATION { end_loc; declaration }); + iter tokens + | (INTEGER importance, loc) + :: (IDENT name, _) + :: (IDENT "SQL", _) :: (IDENT "TYPE", _) :: (IDENT "IS", _) + :: (IDENT "FLOAT", _) :: (LPAREN, _) + :: (NUMBER digits_n_scale, _) :: (RPAREN, end_loc) :: tokens -> + let digits, scale = + match String.split_on_char ',' digits_n_scale with + | [digits; scale] -> int_of_string digits, int_of_string scale + | _ -> + Pretty.failwith + "ERROR: invalid argument for FLOAT sql type : FLOAT(%s)" digits_n_scale + in let declaration = - SQL_type_is { importance; name; sql_type; sql_type_size } + SQL_type_is { importance; name; sql_type=Float (digits, Some scale) } in sql_add_statement ~loc (DECLARATION { end_loc; declaration }); iter tokens @@ -120,12 +146,12 @@ let parse ~config ~filename ~contents = working_storage_found := true end; linkage_section_found := true; - if config.verbosity > 1 then + if config.verbosity > 0 then Format.fprintf Format.std_formatter "LINKAGE SECTION found at %d\n%!" loc.line; sql_add_statement ~loc (LINKAGE_SECTION { defined = true }); iter tokens | (COPY, loc) :: (tok, _) :: (DOT, end_loc) :: tokens - | (EXEC, loc) :: (IDENT "SQL", _) :: (IDENT "INCLUDE", _) :: (tok, _) :: (END_EXEC, end_loc) :: tokens + | (EXEC, loc) :: (IDENT "SQL", _) :: (IDENT "INCLUDE", _) :: (tok, _) :: (END_EXEC, end_loc) :: tokens when config.sql_in_copybooks && (Misc.string_of_token tok != "SQLCA")-> let file = Misc.string_of_token tok in begin @@ -138,8 +164,12 @@ let parse ~config ~filename ~contents = sql_add_statement ~loc (COPY { end_loc; filename; contents }); tokenize_file ~filename ~contents tokens end + | (EXEC, loc) :: (IDENT "SQL", _) :: (IDENT "IGNORE", loc2) :: tokens -> + if config.verbosity > 0 then + Printf.eprintf "EXEC SQL IGNORE found at line %d\n%!" loc.line; + iter_ignored_sql loc { loc2 with char = loc2.char + 6 } tokens | (EXEC, loc) :: (IDENT "SQL", _) :: tokens -> - if config.verbosity > 1 then + if config.verbosity > 0 then Printf.eprintf "EXEC SQL found at line %d\n%!" loc.line; begin match tokens with @@ -150,32 +180,32 @@ let parse ~config ~filename ~contents = and iter_sql loc params tokens = match tokens with | (END_EXEC, end_loc) :: tokens -> - (* TODO: check if there is a ending DOT on the same line. If - yes, we need to output also a DOT at the end of the - translation. *) let end_loc, with_dot, tokens = match tokens with | (DOT, end_loc) :: tokens -> (end_loc, true, tokens) | tokens -> (end_loc, false, tokens) in - if config.verbosity > 1 then + if config.verbosity > 0 then Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; let params = List.rev params in let sqlStr = "EXEC SQL " ^ String.concat " " params ^ " END-EXEC" in -(* Format.fprintf Format.std_formatter "\nSTRING\n"; - Format.fprintf Format.std_formatter "\n%s\n" sqlStr; *) - let sql = Sql_parser.parseString (Lexing.from_string sqlStr) in -(* Format.fprintf Format.std_formatter "\nAST\n"; - Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp sql; *) - sql_add_statement ~loc (EXEC_SQL { end_loc; with_dot; tokens = sql }); iter tokens | [] -> failwith "missing END-EXEC." | (tok, _) :: tokens -> let tok = Misc.string_of_token tok in iter_sql loc (tok :: params) tokens + and iter_ignored_sql loc begin_of_ignore_loc tokens = + match tokens with + | (END_EXEC, end_loc) :: tokens -> + if config.verbosity > 0 then + Printf.eprintf "END-EXEC found at %d\n%!" end_loc.line; + sql_add_statement ~loc (EXEC_SQL_IGNORE { end_loc; begin_of_ignore_loc }); + iter tokens + | _ :: tokens -> iter_ignored_sql loc begin_of_ignore_loc tokens + | [] -> failwith "missing END-EXEC." and tokenize_file ~filename ~contents tokens = let { Cobol_indent.Scanner.toks = new_tokens; _ } = Cobol_indent.Scanner.tokenize ~filename ~config:config.scanner_config diff --git a/src/lsp/sql_preproc/sql_typeck.ml b/src/lsp/sql_preproc/sql_typeck.ml index d763b9d6c..43fa520dd 100644 --- a/src/lsp/sql_preproc/sql_typeck.ml +++ b/src/lsp/sql_preproc/sql_typeck.ml @@ -11,6 +11,7 @@ open Cobol_data.Types let get_x_info (cu : Cobol_unit.Types.cobol_unit) name_str = + (* TODO: this needs to include refs from EXEC SQL INCLUDE stmt : TSQL042A *) (* May raise Not_found | Cobol_unit.Qualmap.Ambiguous _ *) Cobol_unit.Qualmap.find (Cobol_unit.Qual.name @@ -21,10 +22,14 @@ let get_length cu name = try let x_info = get_x_info cu name in match x_info with - | Data_field { def = { payload = { field_size; _ }; _ }; _ } -> - let size = Cobol_data.Memory.(as_bits field_size / 8) in - (* Pretty.out "Size of \"%s\" is %u Bytes@." name size; *) - size + | Data_field { def = { payload = { field_size; field_layout; _ }; _ }; _ } -> + let size = Cobol_data.Memory.(as_bits field_size / 8) in + begin match field_layout with + | Elementary_field { usage = Packed_decimal pic; _ } -> + begin match pic.category with + | FixedNum { digits; _ } -> digits + | _ -> size end + | _ -> size end | _ -> 0 with | Not_found -> @@ -41,24 +46,22 @@ type cobol_types = | COBOL_TYPE_SIGNED_NUMBER_TS (* trailing separate *) (*pas d'exemple dans les tests de gix que j'ai réussi a preprocesser*) | COBOL_TYPE_SIGNED_NUMBER_TC (* trailing combined *) - (*ex: PIC S9(09) + (*ex: PIC S9(09) PIC S9(018)*) | COBOL_TYPE_SIGNED_NUMBER_LS (* leading separate *) (*pas d'exemple*) | COBOL_TYPE_SIGNED_NUMBER_LC (* leading combined *) (*pas d'exemple*) | COBOL_TYPE_UNSIGNED_NUMBER_PD (* packed decimal *) - (*pas d'exemple*) - | COBOL_TYPE_SIGNED_NUMBER_PD (* packed decimal *) - (*pas d'exemple*) - | COBOL_TYPE_ALPHANUMERIC (*ex: PIC 9(018) COMP-3. PIC 9(018)V9(12) COMP-3*) - | COBOL_TYPE_UNSIGNED_BINARY - (*ex: PIC S9(018)V9(12) COMP-3 (???????) + | COBOL_TYPE_SIGNED_NUMBER_PD (* packed decimal *) + (*ex: PIC S9(018)V9(12) COMP-3 PIC S9(018)V9(12) COMP-3. PIC S99V99 COMP-3. 03 FLD01 PIC S9(4) USAGE COMP-3. (???? USAGE?) *) + | COBOL_TYPE_ALPHANUMERIC + | COBOL_TYPE_UNSIGNED_BINARY | COBOL_TYPE_SIGNED_BINARY (*pas d'exemple*) | COBOL_TYPE_JAPANESE @@ -97,6 +100,13 @@ let get_type cu name = match x_info with | Data_field { def = { payload = { field_layout; _ }; _ }; _ } -> begin match field_layout with + | Elementary_field { usage = Packed_decimal picture; _ } -> + (match picture.category with + | FixedNum { with_sign=true; _ } -> + COBOL_TYPE_SIGNED_NUMBER_PD + | FixedNum { with_sign=false; _ } -> + COBOL_TYPE_UNSIGNED_NUMBER_PD + | _ -> UNKNOWN) | Elementary_field { usage = Display picture; _ } -> ( match picture.category with | Alphabetic _ -> COBOL_TYPE_ALPHANUMERIC (*?*) @@ -105,7 +115,7 @@ let get_type cu name = | National _ -> COBOL_TYPE_NATIONAL | FixedNum { with_sign; _ } -> if with_sign then - COBOL_TYPE_SIGNED_NUMBER_TS (*leading? combined? idk*) + COBOL_TYPE_SIGNED_NUMBER_TC else COBOL_TYPE_UNSIGNED_NUMBER | FloatNum _ -> UNKNOWN ) @@ -130,6 +140,7 @@ let get_scale cu name = match x_info with | Data_field { def = { payload = { field_layout; _ }; _ }; _ } -> begin match field_layout with + | Elementary_field { usage = Packed_decimal picture; _ } | Elementary_field { usage = Display picture; _ } -> ( match picture.category with | FixedNum { scale; _ } diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml index a3a8eb100..2f4d84fc7 100644 --- a/src/lsp/sql_preproc/types.ml +++ b/src/lsp/sql_preproc/types.ml @@ -19,9 +19,15 @@ type loc = { filename : string ; line : int ; char : int } -(* type sql_type = BINARY | VARBINARY | CHAR | VARCHAR *) +type sql_type = + | Binary of int + | Varbinary of int + | Char of int + | Varchar of int + | Float of int * int option (* FLOAT(8) or FLOAT(4,2) *) + type declaration = - | SQL_type_is of { importance:string; name:string; sql_type : string; sql_type_size : string } + | SQL_type_is of { importance:string; name:string; sql_type: sql_type } (* These statements show how we could keep information and modify the corresponding places in the code *) @@ -39,6 +45,7 @@ type statements = | COPY of { end_loc : loc ; filename : string ; contents : string } (* | IS_SQLVAR of { end_loc : loc } *) | DECLARATION of { end_loc:loc; declaration : declaration } + | EXEC_SQL_IGNORE of { end_loc: loc; begin_of_ignore_loc: loc } type handle = { diff --git a/test/testsuite/sql/RUN_GIXSQL_TESTS.md b/test/testsuite/sql/RUN_GIXSQL_TESTS.md index 63d687061..5d835de1a 100644 --- a/test/testsuite/sql/RUN_GIXSQL_TESTS.md +++ b/test/testsuite/sql/RUN_GIXSQL_TESTS.md @@ -48,9 +48,10 @@ Things to consider : - This require dotnet 6.0 SDK - The command `dotnet build gixsql-tests-nunit/gixsql-tests-nunit.csproj` is slow and will block at `Determining projects to restore...` for some time (5 minutes). +Before executing the testsuite, the `GIXTEST_LOCAL_CONFIG` env variable needs to exists and be set to full path of your `gixsql_test_local_linux.xml` file. Executing the testsuite with `dotnet gixsql-tests-nunit/bin/Debug/net6.0/gixsql-tests-nunit.dll` should work and execute the test either with GixSQL preprocessor or SuperBOL preprocessor if the patch file was applied -### Additionnal considerations +### Additionnal considerations for gixpp tests At the moment of writing, and with my config (Postgres on linux), the following test seemed to fail even when executed with `gixpp` : @@ -65,3 +66,16 @@ Run: 71 - Success: 68 - Failed: 3 The test `TSQL004A` fails due to a invalid preprocessor option. (line 237 of `gixsql_test_data.xml`) The other two fail due to preprocessor errors. +### What I discovered for our test + +- TSQL005A : some BY VALUE are different (2 instead of -2 for NUM1) +- TSQL009A 42A : fails due to issue in cobol_indent maybe ? there is a tabulation as a first caracter in the line 66 +- TSQL018 : preproc error due to invalid arguments covers a grammar error in test TSQL018B-1 +- TSQL022A : varying not supported, also the test depends on preprocess file content +- TSQL025A : group vars need to be split into their elementary element +- TSQL026A - 27A : requires detecting varlen group var from non esql variable (eg SQLCOMMAND) +- TSQL033-1 : --no-rec-code option to implement somehow +- TSQL037A B : implement -P varchar option, seems to activate flag autotrim on some fields +- TSQL041A : grammar error 'SELECT CASE WHEN' +- TSQL042A : some var have :VAR:NULL-IND form, this is not supported + From ff2a92721de569b4370c5efa17e7e59786473917 Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 14 Oct 2024 14:19:07 +0200 Subject: [PATCH 24/37] fix: grammar and add cbsql to cob_extension --- package.json | 4 +- src/lsp/sql_parser/grammar.mly | 126 +++++++++--------- src/lsp/superbol_free_lib/command_sql.ml | 69 +++++----- src/lsp/superbol_free_lib/vscode_extension.ml | 2 +- 4 files changed, 103 insertions(+), 98 deletions(-) diff --git a/package.json b/package.json index c224c09af..594206b37 100644 --- a/package.json +++ b/package.json @@ -4,7 +4,7 @@ }, "activationEvents": [ "onLanguage:cobol", - "workspaceContains:**/*.[cC]{ob,OB,bl,BL,py,PY,bx,BX}", + "workspaceContains:**/*.[cC]{ob,OB,bl,BL,py,PY,bx,BX,bsql}", "workspaceContains:{_superbol,superbol.toml}" ], "contributes": { @@ -419,7 +419,7 @@ "COBOL" ], "filenamePatterns": [ - "*.[cC]{ob,OB,bl,BL,py,PY,bx,BX}" + "*.[cC]{ob,OB,bl,BL,py,PY,bx,BX,bsql}" ], "configuration": "./syntaxes/language-configuration.json" }, diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index ed6bb4529..eb80fef1c 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -30,7 +30,7 @@ open Cobol_common.Srcloc.INFIX (*For Transaction*) %token START TRANSACTION (*For Rollback*) -%token ROLLBACK WORK RELEASE SAVEPOINT +%token ROLLBACK WORK RELEASE SAVEPOINT (*For commit*) %token COMMIT (*FOr other esql with opt at*) @@ -50,7 +50,7 @@ open Cobol_common.Srcloc.INFIX %token NUMBER %token COBOL_VAR %token BACKSLASH_VAR -%start main +%start main %% @@ -59,31 +59,31 @@ let loc (X) == | x = X; { x &@ Sql_overlay_manager.join_limits $sloc } let main := -| EXEC; SQL; stm = esql; END_EXEC; EOF; {stm} +| EXEC; SQL; stm = esql; SEMICOLON?; END_EXEC; EOF; {stm} let cobol_var_id := -| COLON; c=loc(WORD); {c} +| COLON; c=loc(WORD); {c} | c = loc(COBOL_VAR); {c} let cobol_var := | c = cobol_var_id; {CobVarNotNull c} -| c = cobol_var_id; COLON; COLON; t = sql_type; {CobVarCasted (c, t)} +| c = cobol_var_id; COLON; COLON; t = sql_type; {CobVarCasted (c, t)} (*TODO: fix this, it maybe only work in the context of the preproc*) | c = cobol_var_id; ni=cobol_var_id; {CobVarNullIndicator(c, ni)} let sql_var_name := -| s = loc(WORD); {s} +| s = loc(WORD); {s} (* | s = loc(STRING); {LiteralStr s} *) (*TODO*) let simpl_var := -| s = sql_var_name; {SqlVar s} -| s = cobol_var_id; {CobolVar(CobVarNotNull s)} +| s = sql_var_name; {SqlVar s} +| s = cobol_var_id; {CobolVar(CobVarNotNull s)} -let variable := -| s = sql_var_name; {SqlVar s} -| s = cobol_var; {CobolVar s} +let variable := +| s = sql_var_name; {SqlVar s} +| s = cobol_var; {CobolVar s} -let literalVar := +let literalVar := | v = variable; {LiteralVar v} | t = sql_var_name; DOT; lst = separated_nonempty_list(DOT, sql_var_name); {LiteralDot (t::lst)} @@ -93,7 +93,7 @@ let literal := | s = loc(STRING); {LiteralStr s} (*TODO Differentiate 'variable' and "string" and 'char' *) -let esql := +let esql := | AT; v = simpl_var; stm = esql_with_opt_at; {At(v, stm)} | stm = esql_with_opt_at; {stm} | BEGIN; {Begin} @@ -107,45 +107,45 @@ let esql := | DISCONNECT; ALL; {DisconnectAll} | IGNORE; sql = sql; {Ignore sql} (*TODO the "sql" can be anything*) -let esql_with_opt_at := +let esql_with_opt_at := | i = sql; {Sql i} -| select = sql_select; INTO; - vars = separated_nonempty_list(COMMA, cobol_var); +| select = sql_select; INTO; + vars = separated_nonempty_list(COMMA, cobol_var); select_options = list(select_option); {SelectInto{vars; select; select_options}} -| START; TRANSACTION; +| START; TRANSACTION; {StartTransaction} | DECLARE; table_name= literalVar; TABLE; LPAR; sql=separated_nonempty_list(COMMA, table_lst); RPAR; {DeclareTable(table_name, sql)} -| DECLARE; crs= sql_var_name; CURSOR; FOR; var= variable; +| DECLARE; crs= sql_var_name; CURSOR; FOR; var= variable; {DeclareCursor(DeclareCursorVar(crs, var))} | DECLARE; crs= sql_var_name; CURSOR; FOR; sql=sql_query; option(forUpdate); - {DeclareCursor(DeclareCursorSql(crs, sql))} + {DeclareCursor(DeclareCursorSql(crs, sql))} | DECLARE; crs= sql_var_name; CURSOR; WITH; HOLD; FOR; sql=sql_query; option(forUpdate); - {DeclareCursor(DeclareCursorWhithHold(crs, sql))} -| PREPARE; name= sql_var_name; FROM; sql=sql; + {DeclareCursor(DeclareCursorWhithHold(crs, sql))} +| PREPARE; name= sql_var_name; FROM; sql=sql; {Prepare(name, sql)} -| EXECUTE; IMMEDIATE; arg=execute_immediate_arg; +| EXECUTE; IMMEDIATE; arg=execute_immediate_arg; {ExecuteImmediate arg} -| EXECUTE; executed_string= sql_var_name; - opt_into_hostref_list = option(into_list_cob_var); - opt_using_hostref_list= option(using_list_cob_var); +| EXECUTE; executed_string= sql_var_name; + opt_into_hostref_list = option(into_list_cob_var); + opt_using_hostref_list= option(using_list_cob_var); {ExecuteIntoUsing{executed_string; opt_into_hostref_list; opt_using_hostref_list}} -| SAVEPOINT; s= variable; +| SAVEPOINT; s= variable; {Savepoint s} -| RELEASE; SAVEPOINT; s=variable; +| RELEASE; SAVEPOINT; s=variable; {ReleaseSavepoint s} | ROLLBACK; r=option(rb_work_or_tran); a=option(rb_args); {Rollback(r, a)} -| COMMIT; wt= option(rb_work_or_tran); RELEASE; +| COMMIT; wt= option(rb_work_or_tran); RELEASE; {Commit(wt, true)} -| COMMIT; wt= option(rb_work_or_tran); +| COMMIT; wt= option(rb_work_or_tran); {Commit(wt, false)} | INSERT; INTO; tab = table; VALUES; v=value; {Insert (tab, v)} -| DELETE; sql= sql; +| DELETE; sql= sql; {Delete sql} -| UPDATE; table=sql_var_name; sql=sql_update; x=option(update_arg); +| UPDATE; table=sql_var_name; sql=sql_update; x=option(update_arg); {Update(table, sql, x)} (*Unexeped At, but we have to parse it*) @@ -211,12 +211,12 @@ let with_default_opt:= (*TODO: forUpdate is incomplete, I have to implement this syntaxe: FOR { - READ ONLY + READ ONLY | UPDATE [OF unqualified-column-name[, unqualified-column-name]. ..] }*) -let forUpdate := -| FOR; UPDATE; {} +let forUpdate := +| FOR; UPDATE; {} @@ -245,19 +245,19 @@ let rb_work_or_tran := let rb_args := | RELEASE; {Release} | TO; SAVEPOINT; v = sql_var_name; {To v} -| TO; v = sql_var_name; {To v} +| TO; v = sql_var_name; {To v} let connect_stm := (* -EXEC SQL CONNECT TO :dbname [ AS :db_conn_id ] -USER :username USING :db_data_source -IDENTIFIED BY :password +EXEC SQL CONNECT TO :dbname [ AS :db_conn_id ] +USER :username USING :db_data_source +IDENTIFIED BY :password *) | TO; dbname= cobol_var_id; db_conn_id=option(as_var); USER; username= cobol_var_id; USING; db_data_source= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; { Connect_to_idby {dbname; db_conn_id; username; db_data_source; password} } -(* +(* EXEC SQL CONNECT TO :db_data_source [ AS :db_conn_id ] USER :username.:opt_password [ USING password ]; -> Supporté si il n'y as pas de opt_passwod @@ -265,26 +265,26 @@ USER :username.:opt_password [ USING password ]; | TO; db_data_source= cobol_var_id; db_conn_id=option(as_var); USER; username= cobol_var_id; password = option(using_var); { Connect_to {db_data_source; db_conn_id; username; password} } -(* -EXEC SQL CONNECT USING :db_data_source -(credentials must be embedded to be able to connect) +(* +EXEC SQL CONNECT USING :db_data_source +(credentials must be embedded to be able to connect) *) | USING; db_data_source= cobol_var_id; {Connect_using{db_data_source}} -(* -EXEC SQL CONNECT :username IDENTIFIED BY :password +(* +EXEC SQL CONNECT :username IDENTIFIED BY :password [ AT :db_conn_id ] [ USING :db_data_source] (mode 4 is unsupported) *) -| username= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; +| username= cobol_var_id; IDENTIFIED; BY; password= cobol_var_id; db_conn_id = option(at_var); db_data_source= option(using_var); {Connect_user{username; password; db_conn_id; db_data_source}} -| RESET; name=option( simpl_var); +| RESET; name=option( simpl_var); {Connect_reset name } let at_var:= AT; p= simpl_var; {p} let using_var:= USING; p= cobol_var_id; {p} -let as_var:= AS; v= simpl_var; {v} +let as_var:= AS; v= simpl_var; {v} let whenever_condition := | NOT; FOUND; {Not_found_whenever} @@ -299,7 +299,7 @@ let whenever_continuation := (*SQL Stuff*) -let sql_com_query := +let sql_com_query := | LPAR; s = sql_query; RPAR; {s} | s = sql_lil_query; {s} @@ -316,7 +316,7 @@ let sql_select:= | SELECT; x = separated_list(COMMA, sql_op); {x} let select_option := -| FROM; f= from_stm; {From f} +| FROM; f= from_stm; {From f} | ORDER; BY; l=separated_nonempty_list(COMMA, order_by); {OrderBy(l)} | WHERE; s = search_condition; {Where s} | GROUP; BY; x = separated_list(COMMA, literal); {GroupBy x} @@ -330,8 +330,8 @@ let order_by:= let from_stm := | lst = separated_nonempty_list(COMMA, table_ref); {lst} -let table_ref := -| j = qualified_join;{j} +let table_ref := +| j = qualified_join;{j} | t = table_ref_non_rec; {t} let table_ref_simpl := @@ -353,7 +353,7 @@ let join_type := | LEFT; option(OUTER); {LeftJoin} | RIGHT; option(OUTER); {RightJoin} -let qualified_join_option := +let qualified_join_option := | ON; s = search_condition; {JoinOn(s)} (*| USING; s=separated_nonempty_list(COMMA, sql_var_name); {JoinUsing(s)}*) @@ -373,21 +373,21 @@ let search_condition_aux2 := let predicate := | c = comparison_predicate; {WhereConditionCompare c} -| i = in_predicate; {WhereConditionIn i} +| i = in_predicate; {WhereConditionIn i} | b = between_predicate; { WhereConditionBetween b} | r = variable; IS; NULL; {WhereConditionIsNull r} let between_predicate := | l=literal; BETWEEN; l1=literal; AND; l2=literal; {Between (l, l1, l2)} -let in_predicate:= +let in_predicate:= | l = literal; IN; LPAR; lst = separated_nonempty_list(COMMA, sql_complex_literal); RPAR; {InVarLst(l, lst)} let comparison_predicate:= | l = sql_complex_literal; c = compOp; LPAR; sql = sql_query; RPAR; {CompareQuery(l, c, [SqlQuery sql])} | l = sql_complex_literal; c = compOp; l2 = sql_complex_literal; {CompareLit(l, c, l2)} -let compOp := +let compOp := | LESS; {Less} (* < *) | GREAT; {Great} (* > *) | LESS_EQ; {LessEq} (* <= *) @@ -397,8 +397,8 @@ let compOp := -(*For exemple -SET +(*For exemple +SET CID = CID + :VAR1, FLD01 = FLD01 + :VAR2, FLD02 = CONCAT(FLD02, CAST(:VAR3 AS VARCHAR)) @@ -409,7 +409,7 @@ let sql_update := let sql_equal := s = sql_var_name; EQUAL; op = sql_op; {(s, op)} -let sql_op := +let sql_op := | c=sql_complex_literal; o= binop; v=sql_op; {SqlOpBinop(o, c, v)} | a = sql_complex_literal; { SqlOpLit a } @@ -419,22 +419,22 @@ let sql_complex_literal := | v= literal; AS; c=sql_var_name; {SqlCompAsVar(v, c)} | v= literal; {SqlCompLit v } | fun_name=sql_var_name; LPAR; args = separated_list(COMMA, sql_op) ; RPAR; - {SqlCompFun(fun_name, args)} + {SqlCompFun(fun_name, args)} | STAR; {SqlCompStar} -let binop := +let binop := | PLUS; {Add} | MINUS; {Minus} | STAR; {Times} | OR; {Or} -let sql := +let sql := | t = sql_no_simpl_cobol; {t} | t = cobol_var; {[SqlVarToken( CobolVar t)]} let sql_no_simpl_cobol := -| t = sql_first_token; x = list(sql_token); {[t] @ x} +| t = sql_first_token; x = list(sql_token); {[t] @ x} (*Note for the futur me: a list can be empty*) | s = sql_query; {[SqlQuery s]} @@ -474,7 +474,7 @@ let sql_token_not_first := | t = cobol_var_id; {SqlVarToken( CobolVar(CobVarNotNull t)) } -let sql_token := +let sql_token := | s = sql_first_token; {s} | s = sql_token_not_first; {s} diff --git a/src/lsp/superbol_free_lib/command_sql.ml b/src/lsp/superbol_free_lib/command_sql.ml index 16f723b5a..177d974aa 100644 --- a/src/lsp/superbol_free_lib/command_sql.ml +++ b/src/lsp/superbol_free_lib/command_sql.ml @@ -56,46 +56,48 @@ let typeck_file { preproc_options; parser_options } filename = *) end -let parse ~sql_in_copybooks ~copy_exts common files = +let parse ~sql_in_copybooks ~copy_exts ~test_extension common files = let source_format = common.preproc_options.source_format in let copy_path = common.preproc_options.copybook_lookup_config.lookup_path in let source_format = Cobol_indent.Config.source_format source_format in List.iter (fun filename -> - let common, _ = Common_args.get () in - let cobol_unit = typeck_file (common ()) filename in - (*TODO appel a typeck ici*) - let contents = - Sql_preproc.Main.preproc ~sql_in_copybooks ~copy_path ~copy_exts - ~filename ~source_format () ~cobol_unit - in - let output_file filename s = - match filename with - | "-" -> - Printf.printf "%s\n%!" s - | _ -> - let oc = open_out filename in - output_string oc s; - close_out oc; - Printf.eprintf "File %S generated\n%!" filename - in - let name_change filename = - if Filename.check_suffix filename ".cob" then - let base_name = Filename.chop_suffix filename ".cob" in - base_name ^ ".pp.cob" - else if Filename.check_suffix filename ".cbl" then - let base_name = Filename.chop_suffix filename ".cbl" in - base_name ^ ".pp.cbl" - else - filename - in - - output_file (name_change filename) contents - (* Printf.printf "%s%!" contents *) ) + let common, _ = Common_args.get () in + let cobol_unit = typeck_file (common ()) filename in + (*TODO appel a typeck ici*) + let contents = + Sql_preproc.Main.preproc ~sql_in_copybooks ~copy_path ~copy_exts + ~filename ~source_format () ~cobol_unit + in + let output_file filename s = + match filename with + | "-" -> + Printf.printf "%s\n%!" s + | _ -> + let oc = open_out filename in + output_string oc s; + close_out oc; + Printf.eprintf "File %S generated\n%!" filename + in + let new_filename = + let extension = Filename.extension filename in + if test_extension + then + let base_name = Filename.chop_suffix filename extension in + base_name ^ ".cbsql" + else if String.equal extension ".cob" || String.equal extension ".cbl" + then + let base_name = Filename.chop_suffix filename extension in + base_name ^ ".pp" ^ extension + else + filename + in + output_file new_filename contents) files let preproc_cmd = let sql_in_copybooks = ref false in + let test_extension = ref false in let copy_exts = ref [] in let files = ref [] in let common, common_args = Common_args.get () in @@ -104,7 +106,7 @@ let preproc_cmd = let common = common () in Printexc.record_backtrace true; parse ~sql_in_copybooks:!sql_in_copybooks ~copy_exts:!copy_exts common - !files ) + ~test_extension:!test_extension !files ) ~args: ( common_args @ [ ( [], @@ -113,6 +115,9 @@ let preproc_cmd = ( [ "copybooks" ], Arg.Set sql_in_copybooks, EZCMD.info "Preprocess copybooks also (without REPLACING)" ); + ( [ "test-ext" ], + Arg.Set test_extension, + EZCMD.info "Set file extension to .cbsql" ); (* I (@NeoKaios) removed that as it conflicts with another option *) (* ( [ "ext" ], *) (* Arg.String (fun s -> copy_exts := !copy_exts @ [ "." ^ s ]), *) diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 02e758d11..056490c37 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -90,7 +90,7 @@ let package = "@types/node", "^20.3.2"; ] -let cob_extensions_pattern = "[cC]{ob,OB,bl,BL,py,PY,bx,BX}" +let cob_extensions_pattern = "[cC]{ob,OB,bl,BL,py,PY,bx,BX,bsql}" let contributes = Manifest.contributes () ~languages: [ From 36c117a6d9fccce34f294d5a255ee0d8ab736a91 Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 14 Oct 2024 14:32:51 +0200 Subject: [PATCH 25/37] feat: update gixsql testsuite doc --- test/testsuite/sql/RUN_GIXSQL_TESTS.md | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/test/testsuite/sql/RUN_GIXSQL_TESTS.md b/test/testsuite/sql/RUN_GIXSQL_TESTS.md index 5d835de1a..9d29499cf 100644 --- a/test/testsuite/sql/RUN_GIXSQL_TESTS.md +++ b/test/testsuite/sql/RUN_GIXSQL_TESTS.md @@ -3,6 +3,7 @@ ## Install GixSQL Following https://github.com/mridoni/gixsql/tree/main?tab=readme-ov-file#linux you can build GixSQL locally +Or with the PR https://github.com/OCamlPro/gixsql/pull/2. ## Configure at least one database type @@ -14,17 +15,13 @@ Note: mysql tests fails on Linux, it seems to be a case sensitivity issue betwee From the doc https://dev.mysql.com/doc/refman/8.0/en/identifier-case-sensitivity.html > In MySQL, databases correspond to directories within the data directory. Each table within a database corresponds to at least one file within the database directory (and possibly more, depending on the storage engine). Triggers also correspond to files. Consequently, the case sensitivity of the underlying operating system plays a part in the case sensitivity of database, table, and trigger names. This means such names are not case-sensitive in Windows, but are case-sensitive in most varieties of Unix. -## Patch file +## Modifying gixsql testsuite -I created a git patch file with my modification of GixSQL : `superbol-preproc-for-gixsql.patch` -The command `git am path/to/patch` inside the GixSQL repo will apply those changes. +The following PR https://github.com/OCamlPro/gixsql/pull/4 contains modification to the test runner source code that allows executing the testsuite with `superbol sql preproc` instead of `gixpp`. +The superbol-free executable needs to be accessible at `/opt/superbol-free-linux-x64` (symbolic linking works) -The patch file contains the following changes : -- Setup `gixsql_test_local_linux.xml` for a standard install -- Edition of two `.cs` file for the execution of superbol's preprocessor - -- Make sure the temp folder `/tmp/gixsql-test` exists -- The superbol-free executable is accessible at `/opt/superbol-free-linux-x64` (symbolic linking works) +Configuring and running the testsuite can be done in 1 command using the PR https://github.com/OCamlPro/gixsql/pull/2. +Or manually by following the next two section ## GixSQL XML config file @@ -66,7 +63,7 @@ Run: 71 - Success: 68 - Failed: 3 The test `TSQL004A` fails due to a invalid preprocessor option. (line 237 of `gixsql_test_data.xml`) The other two fail due to preprocessor errors. -### What I discovered for our test +### What I discovered using gixsql testsuite - TSQL005A : some BY VALUE are different (2 instead of -2 for NUM1) - TSQL009A 42A : fails due to issue in cobol_indent maybe ? there is a tabulation as a first caracter in the line 66 @@ -79,3 +76,4 @@ The other two fail due to preprocessor errors. - TSQL041A : grammar error 'SELECT CASE WHEN' - TSQL042A : some var have :VAR:NULL-IND form, this is not supported +[This issue](https://github.com/OCamlPro/superbol-studio-oss/issues/371) explains that in more details. From ff34002972b0abf5ee1d425bf9ff89cc8e9b9c63 Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 16 Oct 2024 11:36:07 +0200 Subject: [PATCH 26/37] fix: failing test --- src/lsp/sql_ast/sql_ast.ml | 2 +- src/lsp/sql_parser/lexer.mll | 34 ++++++++++++++--------------- src/lsp/sql_preproc/data_gestion.ml | 9 +++++++- test/output-tests/reparse.expected | 4 ++-- 4 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index dee182da4..e0cf1790e 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -620,7 +620,7 @@ module Printer = struct and pp_lit fmt = function | LiteralNum n -> Format.fprintf fmt "%s" n.payload - | LiteralStr n -> Format.fprintf fmt "'%s'" n.payload + | LiteralStr n -> Format.fprintf fmt "%s" n.payload | LiteralVar n -> Format.fprintf fmt "%a" pp_var n | LiteralDot lst -> let rec pp_aux fmt = function diff --git a/src/lsp/sql_parser/lexer.mll b/src/lsp/sql_parser/lexer.mll index 699172b06..8e5805761 100644 --- a/src/lsp/sql_parser/lexer.mll +++ b/src/lsp/sql_parser/lexer.mll @@ -112,7 +112,7 @@ let get_keyword s = try Hashtbl.find kwd_table (String.uppercase_ascii s) - with Not_found -> WORD s + with Not_found -> WORD s } let number = '-'? ['0'-'9']+ (','['0'-'9']+)? @@ -128,33 +128,33 @@ rule token = parse { COBOL_VAR s } | '\\' (['a'-'z' 'A'-'Z']['A'-'Z' 'a'-'z' '0'-'9' '_']* as s) { BACKSLASH_VAR s } - | ['a'-'z' 'A'-'Z' '0'-'9']['A'-'Z' 'a'-'z' '0'-'9' '-' '_' '*' ]* as s + | ['a'-'z' 'A'-'Z' '0'-'9']['A'-'Z' 'a'-'z' '0'-'9' '-' '_' '*' ]* as s { get_keyword s } | number as n { NUMBER n } - | '\'' ( [^ '\'']* as s) '\'' + | '\'' [^ '\'']* '\'' as s { STRING s} - | '\"' ( [^ '\"']* as s) '\"' + | '\"' [^ '\"']* '\"' as s { STRING s} | "||" { OR } - | '=' + | '=' { EQUAL } - | '+' + | '+' { PLUS } - | '-' + | '-' { MINUS } - | "<=" + | "<=" { LESS_EQ } - | ">=" + | ">=" { GREAT_EQ } - | "<" + | "<" { LESS } - | ">" - { GREAT } - | ":" - { COLON } + | ">" + { GREAT } + | ":" + { COLON } | ',' { COMMA } | '.' @@ -167,11 +167,11 @@ rule token = parse { STAR } | ';' { SEMICOLON } - | ' ' + | ' ' { token lexbuf } - | _ as c + | _ as c { failwith (Printf.sprintf "unexpected character: %C" c) } -(* | _ as s +(* | _ as s { TOKEN s } *) | eof { EOF } diff --git a/src/lsp/sql_preproc/data_gestion.ml b/src/lsp/sql_preproc/data_gestion.ml index 7256fa4fe..0a5da09f4 100644 --- a/src/lsp/sql_preproc/data_gestion.ml +++ b/src/lsp/sql_preproc/data_gestion.ml @@ -162,7 +162,14 @@ let transform_stm map (_, stm) filename = | [ Sql_ast.SqlVarToken (CobolVar (CobVarNotNull _)) ] -> ([], map) | _ -> let ws, map = - create_new_var (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql) () + let content = + let content = Format.asprintf "%a" Sql_ast.Printer.pp_sql sql in + if String.starts_with ~prefix:"'" content || + String.starts_with ~prefix:"\"" content + then String.sub content 1 (String.length content - 2) + else content + in + create_new_var content () in (ws, map) ) | Rollback (rb_work_or_tran, rb_args) -> begin diff --git a/test/output-tests/reparse.expected b/test/output-tests/reparse.expected index e00935d1a..898c08b44 100644 --- a/test/output-tests/reparse.expected +++ b/test/output-tests/reparse.expected @@ -261,9 +261,9 @@ Re-parsing `test/testsuite/sql/gixsql_test/TSQL037B-SQLITE.cbl': Re-parsing `test/testsuite/sql/gixsql_test/TSQL038A.cbl': Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL039A.cbl': - Parse: Failure. + Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL040A.cbl': - Parse: Failure. + Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL041A-ORACLE.cbl': Parse: Failure. Re-parsing `test/testsuite/sql/gixsql_test/TSQL041A.cbl': From 85cd08cc498e4ea26e5a4d0d25addf7a67833585 Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 16 Oct 2024 11:40:40 +0200 Subject: [PATCH 27/37] feat: add sql_ast visitor, fix typo in types --- src/lsp/sql_ast/sql_ast.ml | 621 +---------------------------- src/lsp/sql_ast/types.ml | 632 ++++++++++++++++++++++++++++++ src/lsp/sql_ast/visitor.ml | 379 ++++++++++++++++++ src/lsp/sql_parser/grammar.mly | 2 +- src/lsp/sql_preproc/types.ml | 2 +- src/lsp/superbol_preprocs/esql.ml | 4 +- 6 files changed, 1017 insertions(+), 623 deletions(-) create mode 100644 src/lsp/sql_ast/types.ml create mode 100644 src/lsp/sql_ast/visitor.ml diff --git a/src/lsp/sql_ast/sql_ast.ml b/src/lsp/sql_ast/sql_ast.ml index e0cf1790e..f81e5f8fd 100644 --- a/src/lsp/sql_ast/sql_ast.ml +++ b/src/lsp/sql_ast/sql_ast.ml @@ -10,623 +10,6 @@ (* of this source tree. *) (* *) (**************************************************************************) -open Cobol_common -(**************************************************************************) -(* AST *) -(**************************************************************************) -type sqlVarToken = string with_loc [@@deriving ord] - -type cobolVarId = string with_loc [@@deriving ord] - -type cobol_var = - | CobVarNotNull of cobolVarId - | CobVarCasted of cobolVarId * sql_type - | CobVarNullIndicator of cobolVarId * cobolVarId -[@@deriving ord] - -and variable = - | SqlVar of sqlVarToken - | CobolVar of cobol_var -[@@deriving ord] - -and literal = - | LiteralVar of variable - | LiteralNum of string with_loc - | LiteralStr of string with_loc - | LiteralDot of string with_loc list -[@@deriving ord] - -and sql_token = - | SqlInstr of string - | SqlVarToken of variable - | SqlLit of literal - | SqlQuery of sql_query - | SqlEquality of sql_equal (*TODO: remove*) - | SqlSearchCondition of search_condition (*TODO: remove*) - -and sql_instruction = sql_token list - -and complex_literal = - | SqlCompLit of literal - | SqlCompAsType of literal * sql_type_name (*ex: SMT AS INT*) - | SqlCompAsVar of literal * sqlVarToken - | SqlCompFun of sqlVarToken * sql_op list - | SqlCompStar - -and esql_instuction = - | At of variable * esql_instuction - | Sql of sql_instruction - | Begin - | BeginDeclare - | Exeption of try_block - | EndDeclare - | StartTransaction - | Whenever of whenever_condition * whenever_continuation - | Include of sqlVarToken - | Connect of connect_syntax - | Rollback of rb_work_or_tran option * rb_args option - | Commit of rb_work_or_tran option * bool - | Savepoint of variable - | ReleaseSavepoint of variable - | SelectInto of - { vars : cobol_var list; - select : sql_select; - select_options : sql_select_option list - } - | DeclareTable of literal * (sqlVarToken * sql_type) list - | DeclareCursor of cursor - | Prepare of sqlVarToken * sql_instruction - | ExecuteImmediate of sql_instruction - | ExecuteIntoUsing of - { executed_string : sqlVarToken; - opt_into_hostref_list : cobol_var list option; - opt_using_hostref_list : cobol_var list option - } - | Disconnect of variable option (*db_id*) - | DisconnectAll - | Open of sqlVarToken * cobol_var list option (*cursor name*) - | Close of sqlVarToken (*cursor name*) - | Fetch of sqlVarToken * cobol_var list - | Insert of table * value list - | Delete of sql_instruction - | Update of sqlVarToken * sql_update * update_arg option - | Ignore of sql_instruction - -and try_block = - { try_instruction : esql_instuction; - try_exceptions : sql_exception list - } - -and sql_exception = RaiseAndPrint of sqlVarToken * string with_loc * cobol_var - -and cursor = - | DeclareCursorSql of sqlVarToken * sql_query - | DeclareCursorVar of sqlVarToken * variable - | DeclareCursorWhithHold of sqlVarToken * sql_query - -and table = - | Table of sqlVarToken - | TableLst of sqlVarToken * sqlVarToken list - -and value = - | ValueNull - | ValueDefault - | ValueList of literal list - -and rb_work_or_tran = - | Work - | Transaction - -and rb_args = - | Release - | To of sqlVarToken - -and connect_syntax = - | Connect_to_idby of - { dbname : cobolVarId; - db_conn_id : variable option; - username : cobolVarId; - db_data_source : cobolVarId; - password : cobolVarId - } - | Connect_to of - { db_data_source : cobolVarId; - db_conn_id : variable option; - username : cobolVarId; - password : cobolVarId option - } - | Connect_using of { db_data_source : cobolVarId } - | Connect_user of - { username : cobolVarId; - password : cobolVarId; - db_conn_id : variable option; - db_data_source : cobolVarId option - } - | Connect_reset of variable option - -(*WHENEVER*) -and sql_type = - { sql_type : sql_type_name; - size : literal option; - not_null : bool; - with_default : bool - } - -and sql_type_name = - | Char - | Date - | Integer - | Timestamp - | VarChar - -and whenever_condition = - | Not_found_whenever - | SqlError_whenever - | SqlWarning_whenever - -and whenever_continuation = - | Continue - | Perform of sqlVarToken (*A label in cob program*) - | Goto of sqlVarToken (*TODO doc*) - -and update_arg = - | WhereCurrentOf of sqlVarToken - | WhereUpdate of search_condition - | UpdateSql of sql_instruction - -(*SQL*) -and sql_query = - | SelectUnion of sql_query * sql_query - | SelectExcept of sql_query * sql_query - | SelectIntersect of sql_query * sql_query - | SelectQuery of sql_select * sql_select_option list - -and sql_select_option = - | From of from_stm - | Where of search_condition - | OrderBy of sql_orderBy list - | GroupBy of literal list - | Having of search_condition - -and from_stm = table_ref list - -and table_ref = - | FromLitAs of table_ref * literal - | FromLit of literal - | FromFun of sqlVarToken * literal - | FromSelect of sql_query - | Join of table_ref * join * table_ref * join_option option - -and join = - | InnerJoin - | NaturalJoin - | LeftJoin - | RightJoin - -and join_option = - | JoinOn of search_condition - | JoinUsing of sqlVarToken list - -and sql_orderBy = - | Asc of literal - | Desc of literal - -and sql_select = sql_op list - -and sql_update = sql_equal list - -and sql_equal = sqlVarToken * sql_op - -and sql_op = - | SqlOpLit of complex_literal - | SqlOpBinop of (sql_binop * complex_literal * sql_op) - -and sql_binop = - | Add - | Minus - | Times - | Or - -and search_condition = - | WhereConditionOr of search_condition * search_condition - | WhereConditionAnd of search_condition * search_condition - | WhereConditionNot of search_condition - | WhereConditionCompare of sql_compare - | WhereConditionIn of sql_condition_in - | WhereConditionBetween of between_condition - | WhereConditionIsNull of variable - -and between_condition = Between of literal * literal * literal - -and sql_condition_in = InVarLst of literal * complex_literal list - -and sql_compare = - | CompareQuery of complex_literal * comp_operator * sql_instruction - | CompareLit of complex_literal * comp_operator * complex_literal - -and comp_operator = - | Less - | Great - | LessEq - | GreatEq - | EqualComp - | Diff -[@@deriving ord] - -(**************************************************************************) -(* COMPARE *) -(**************************************************************************) -let compare = compare_esql_instuction - -(**************************************************************************) -(* PRETTY PRINT *) -(**************************************************************************) -module Printer = struct - let rec list_comma (fmt : Format.formatter) - (g : 'a list * (Format.formatter -> 'a -> unit)) : unit = - let x, f = g in - match x with - | [] -> Format.fprintf fmt "" - | [ ele ] -> Format.fprintf fmt "%a" f ele - | ele :: t -> Format.fprintf fmt "%a, %a" f ele list_comma (t, f) - - let rec pp fmt x = Format.fprintf fmt "EXEC SQL %a END-EXEC" pp_esql x - - and pp_esql fmt = function - | At (v, instr) -> Format.fprintf fmt "AT %a %a" pp_var v pp_esql instr - | Sql instr -> pp_sql fmt instr - | Begin -> Format.fprintf fmt "BEGIN" - | Exeption e -> Format.fprintf fmt "BEGIN %a END;" pp_exception e - | BeginDeclare -> Format.fprintf fmt "BEGIN DECLARE SECTION" - | EndDeclare -> Format.fprintf fmt "END DECLARE SECTION" - | StartTransaction -> Format.fprintf fmt "START TRANSACTION" - | Whenever (c, k) -> - Format.fprintf fmt "WHENEVER %a %a" pp_whenever_condtion c - pp_whenever_continuation k - | Include i -> Format.fprintf fmt "INCLUDE %s" i.payload - | Connect c -> Format.fprintf fmt "CONNECT %a" pp_connect c - | Rollback (rb_work_or_tran, rb_args) -> - Format.fprintf fmt "ROLLBACK %a %a" pp_some_rb_work_or_tran - rb_work_or_tran pp_rb_args rb_args - | Commit (rb_work_or_tran, b) -> - let s = - match b with - | true -> "RELEASE" - | false -> "" - in - Format.fprintf fmt "COMMIT %a %s" pp_some_rb_work_or_tran rb_work_or_tran - s - | Savepoint s -> Format.fprintf fmt "SAVEPOINT %a" pp_var s - | ReleaseSavepoint s -> Format.fprintf fmt "RELEASE SAVEPOINT %a" pp_var s - | SelectInto { vars; select; select_options } -> - Format.fprintf fmt "SELECT %a INTO %a %a" pp_select_lst select pp_cob_lst - vars pp_select_options_lst select_options - | DeclareTable (var, sql) -> - Format.fprintf fmt "DECLARE %a TABLE (%a)" pp_lit var pp_declare sql - | DeclareCursor cursor -> pp_cursor fmt cursor - | Prepare (str, sql) -> - Format.fprintf fmt "PREPARE %s FROM %a" str.payload pp_sql sql - | ExecuteImmediate sql -> - Format.fprintf fmt "EXECUTE IMMEDIATE %a" pp_sql sql - | ExecuteIntoUsing - { executed_string; opt_into_hostref_list; opt_using_hostref_list } -> - Format.fprintf fmt "EXECUTE %s %a %a" executed_string.payload - pp_some_cob_lst - (opt_into_hostref_list, "INTO") - pp_some_cob_lst - (opt_using_hostref_list, "USING") - | Disconnect sdbname -> - Format.fprintf fmt "DISCONNECT %a" pp_some_var (sdbname, "") - | DisconnectAll -> Format.fprintf fmt "DISCONNECT ALL" - | Open (cursor, lst) -> - Format.fprintf fmt "OPEN %s %a" cursor.payload pp_some_cob_lst - (lst, "USING") - | Close cursor -> Format.fprintf fmt "CLOSE %s" cursor.payload - | Fetch (sql, var) -> - Format.fprintf fmt "FETCH %s INTO %a" sql.payload pp_cob_lst var - | Insert (tab, v) -> - Format.fprintf fmt "INSERT INTO %a VALUES %a" pp_table tab pp_value v - | Delete sql -> Format.fprintf fmt "DELETE %a" pp_sql sql - | Update (table, equallst, swhere) -> - Format.fprintf fmt "UPDATE %s SET %a %a" table.payload pp_sql_update - equallst pp_where_arg swhere - | Ignore lst -> Format.fprintf fmt "IGNORE %a" pp_sql lst - - and pp_exception fmt e = - Format.fprintf fmt "%a; EXCEPTION %a" pp_esql e.try_instruction - pp_exception_list e.try_exceptions - - and pp_exception_list fmt l = - let pp_one_exception fmt = function - | RaiseAndPrint (name, str, cob_var) -> - Format.fprintf fmt "WHEN %s THEN RAISE EXCEPTION %s, %a" name.payload - str.payload pp_cob_var cob_var - in - List.iter (Format.fprintf fmt " %a; " pp_one_exception) l - - and pp_cursor fmt = function - | DeclareCursorSql (var, sql) -> - Format.fprintf fmt "DECLARE %s CURSOR FOR %a" var.payload pp_sql_query sql - | DeclareCursorVar (var, v) -> - Format.fprintf fmt "DECLARE %s CURSOR FOR %a" var.payload pp_var v - | DeclareCursorWhithHold (var, sql) -> - Format.fprintf fmt "DECLARE %s CURSOR WITH HOLD FOR %a" var.payload - pp_sql_query sql - - and pp_table fmt = function - | Table t -> Format.fprintf fmt "%s" t.payload - | TableLst (t, lst) -> - let f = pp_sqlVarToken in - let pp_aux fmt lst = list_comma fmt (lst, f) in - Format.fprintf fmt "%s(%a)" t.payload pp_aux lst - - and pp_sqlVarToken fmt x = Format.fprintf fmt "%s" x.payload - - and pp_value fmt x = list_comma fmt (x, pp_one_value) - - and pp_declare fmt x = list_comma fmt (x, pp_var_type) - - and pp_var_type fmt (l, t) = - Format.fprintf fmt "%s\t %a" l.payload pp_sql_type t - - and pp_sql_type_name fmt test = - match test with - | Char -> Format.fprintf fmt "CHAR" - | Date -> Format.fprintf fmt "DATE" - | Integer -> Format.fprintf fmt "INTEGER" - | Timestamp -> Format.fprintf fmt "TIMESTAMP" - | VarChar -> Format.fprintf fmt "VARCHAR" - and pp_sql_type fmt { sql_type; size; not_null; with_default } = - - pp_sql_type_name fmt sql_type; - ( match size with - | Some lit -> Format.fprintf fmt " (%a)" pp_lit lit - | None -> () ); - if not_null then Format.fprintf fmt " NOT NULL"; - if with_default then Format.fprintf fmt " WITH DEFAULT" - - and pp_one_value fmt = function - | ValueDefault -> Format.fprintf fmt "DEFAULT" - | ValueNull -> Format.fprintf fmt "NULL" - | ValueList l -> ( - match l with - | [ x ] -> Format.fprintf fmt "(%a)" pp_lit x - | [] -> Format.fprintf fmt "" - | _ -> Format.fprintf fmt "(%a)" pp_list_lit l ) - - and pp_where_arg fmt = function - | Some (WhereCurrentOf swhere) -> - Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload - | Some (WhereUpdate e) -> Format.fprintf fmt "WHERE %a" pp_sql_condition e - | Some (UpdateSql sql) -> pp_sql fmt sql - | None -> () - - and pp_sql_update_aux fmt (var, op) = - Format.fprintf fmt "%s = %a" var.payload pp_sql_op op - - and pp_sql_update fmt x = list_comma fmt (x, pp_sql_update_aux) - - and pp_sql_op fmt = function - | SqlOpBinop (op, sql1, sql2) -> - Format.fprintf fmt "%a %s %a" pp_complex_literal sql1 (pp_binop op) - pp_sql_op sql2 - | SqlOpLit l -> Format.fprintf fmt "%a" pp_complex_literal l - - and pp_sql_some_condition fmt = function - | Some s -> Format.fprintf fmt "WHERE %a" pp_sql_condition s - | None -> Format.fprintf fmt "" - - and pp_sql_condition fmt = function - | WhereConditionAnd (s1, s2) -> - Format.fprintf fmt "%a AND %a" pp_sql_condition s1 pp_sql_condition s2 - | WhereConditionOr (s1, s2) -> - Format.fprintf fmt "%a OR %a" pp_sql_condition s1 pp_sql_condition s2 - | WhereConditionNot s -> Format.fprintf fmt "NOT %a" pp_sql_condition s - | WhereConditionCompare c -> - let rec pp_compare fmt = function - | CompareLit (l1, c, l2) -> - Format.fprintf fmt "%a %s %a" pp_complex_literal l1 - (comp_op_to_string c) pp_complex_literal l2 - | CompareQuery (l1, c, s) -> - Format.fprintf fmt "%a %s (%a)" pp_complex_literal l1 - (comp_op_to_string c) pp_sql s - and comp_op_to_string = function - | Less -> "<" - | Great -> ">" - | LessEq -> "<=" - | GreatEq -> ">=" - | EqualComp -> "=" - | Diff -> "<>" - in - Format.fprintf fmt "%a" pp_compare c - | WhereConditionIn s -> Format.fprintf fmt "%a" pp_condition_in s - | WhereConditionBetween s -> Format.fprintf fmt "%a" pp_condition_between s - | WhereConditionIsNull v -> Format.fprintf fmt "%a IS NULL" pp_var v - - and pp_condition_in fmt x = - let pp_aux fmt lst = list_comma fmt (lst, pp_complex_literal) in - match x with - | InVarLst (l, vlist) -> - Format.fprintf fmt "%a IN (%a)" pp_lit l pp_aux vlist - - and pp_condition_between fmt = function - | Between (l, l1, l2) -> - Format.fprintf fmt "%a BETWEEN %a AND %a" pp_lit l pp_lit l1 pp_lit l2 - - and pp_complex_literal fmt = function - | SqlCompLit v -> Format.fprintf fmt "%a" pp_lit v - | SqlCompAsType (l, v) -> Format.fprintf fmt "%a AS %a" pp_lit l pp_sql_type_name v - | SqlCompAsVar (l, v) -> Format.fprintf fmt "%a AS %s" pp_lit l v.payload - | SqlCompFun (funName, args) -> - let pp_args fmt lst = list_comma fmt (lst, pp_sql_op) in - Format.fprintf fmt "%s(%a)" funName.payload pp_args args - | SqlCompStar -> Format.fprintf fmt "*" - - and pp_binop = function - | Add -> "+" - | Minus -> "-" - | Times -> "*" - | Or -> "||" - - and pp_some_cob_lst fmt = function - | Some x, s -> Format.fprintf fmt "%s %a" s pp_cob_lst x - | None, _ -> Format.fprintf fmt "" - - and pp_cob_lst fmt x = list_comma fmt (x, pp_cob_var) - - and pp_cob_var fmt = function - | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload - | CobVarCasted (c, t) -> - Format.fprintf fmt ":%s::%a" c.payload pp_sql_type t - | CobVarNullIndicator (c, ni) -> - Format.fprintf fmt ":%s:%s" c.payload ni.payload - - and pp_cob_var_id fmt c = Format.fprintf fmt ":%s" c.payload - - and pp_some_rb_work_or_tran fmt = function - | Some p -> pp_rb_work_or_tran fmt p - | None -> Format.fprintf fmt "" - - and pp_rb_work_or_tran fmt = function - | Work -> Format.fprintf fmt "WORK" - | Transaction -> Format.fprintf fmt "TRANSACTION" - - and pp_rb_args fmt = function - | Some Release -> Format.fprintf fmt "RELEASE" - | Some (To variable) -> - Format.fprintf fmt "TO SAVEPOINT %s" variable.payload - | None -> Format.fprintf fmt "" - - and pp_some_cob_var fmt (x, s) = - match x with - | Some v -> Format.fprintf fmt "%s %a" s pp_cob_var_id v - | None -> Format.fprintf fmt "" - - and pp_connect fmt c = - match c with - | Connect_to_idby { dbname; db_conn_id; username; db_data_source; password } - -> - Format.fprintf fmt "TO %a %a USER %a USING %a IDENTIFIED BY %a" - pp_cob_var_id dbname pp_some_var (db_conn_id, "AS") pp_cob_var_id - username pp_cob_var_id db_data_source pp_cob_var_id password - | Connect_to { db_data_source; db_conn_id; username; password } -> - Format.fprintf fmt "TO %a %a USER %a %a" pp_cob_var_id db_data_source - pp_some_var (db_conn_id, "AS") pp_cob_var_id username pp_some_cob_var - (password, "USING") - | Connect_using { db_data_source } -> - Format.fprintf fmt "USING %a" pp_cob_var_id db_data_source - | Connect_user { username; password; db_conn_id; db_data_source } -> - Format.fprintf fmt "%a IDENTIFIED BY %a %a %a" pp_cob_var_id username - pp_cob_var_id password pp_some_var (db_conn_id, "AT") pp_some_cob_var - (db_data_source, "USING") - | Connect_reset name -> Format.fprintf fmt "RESET%a" pp_some_var (name, "") - - and pp_whenever_condtion fmt = function - | Not_found_whenever -> Format.fprintf fmt "NOT FOUND" - | SqlError_whenever -> Format.fprintf fmt "SQLERROR" - | SqlWarning_whenever -> Format.fprintf fmt "SQLWARNING" - - and pp_whenever_continuation fmt = function - | Continue -> Format.fprintf fmt "CONTINUE" - | Perform label -> Format.fprintf fmt "PERFORM %s" label.payload - | Goto stmt_label -> Format.fprintf fmt "GOTO %s" stmt_label.payload - - and pp_some_sql fmt = function - | Some p -> pp_sql fmt p - | None -> Format.fprintf fmt "" - - and pp_sql fmt = function - | [ h ] -> Format.fprintf fmt "%a" pp_one_token h - | h :: t -> Format.fprintf fmt "%a %a" pp_one_token h pp_sql t - | [] -> Format.fprintf fmt "" - - and pp_one_token fmt = function - | SqlInstr s -> Format.fprintf fmt "%s" s - | SqlVarToken c -> Format.fprintf fmt "%a" pp_var c - | SqlLit l -> Format.fprintf fmt "%a" pp_lit l - | SqlQuery s -> Format.fprintf fmt "%a" pp_sql_query s - | SqlEquality e -> Format.fprintf fmt "%a" pp_sql_update_aux e - | SqlSearchCondition c -> Format.fprintf fmt "%a" pp_sql_condition c - - and pp_sql_query fmt = function - | SelectQuery (s, o) -> - Format.fprintf fmt "SELECT %a %a" pp_select_lst s pp_select_options_lst o - | SelectUnion (s1, s2) -> - Format.fprintf fmt "%a UNION %a" pp_sql_query s1 pp_sql_query s2 - | SelectExcept (s1, s2) -> - Format.fprintf fmt "%a EXCEPT %a" pp_sql_query s1 pp_sql_query s2 - | SelectIntersect (s1, s2) -> - Format.fprintf fmt "%a INTERSECT %a" pp_sql_query s1 pp_sql_query s2 - - and pp_select_options_lst fmt lst = - let pp_one_option fmt = function - | From f -> Format.fprintf fmt "FROM %a" pp_from f - | Where w -> Format.fprintf fmt "WHERE %a" pp_sql_condition w - | OrderBy ob -> Format.fprintf fmt "ORDER BY %a" pp_orderBy ob - | GroupBy gb -> Format.fprintf fmt "GROUP BY %a" pp_group_by gb - | Having w -> Format.fprintf fmt "HAVING %a" pp_sql_condition w - in - List.iter (Format.fprintf fmt " %a" pp_one_option) lst - - and pp_from fmt f = list_comma fmt (f, pp_table_ref) - - and pp_table_ref fmt = function - | FromLit l -> Format.fprintf fmt "%a" pp_lit l - | FromLitAs (l, a) -> Format.fprintf fmt "%a AS %a" pp_table_ref l pp_lit a - | FromFun (v, t) -> Format.fprintf fmt "%a %a" pp_sqlVarToken v pp_lit t - | FromSelect s -> Format.fprintf fmt "(%a)" pp_sql_query s - | Join (tr1, join, tr2, opt) -> - Format.fprintf fmt "%a %s JOIN %a %a" pp_table_ref tr1 (str_join join) - pp_table_ref tr2 pp_table_opt_option opt - - and str_join = function - | InnerJoin -> "INNER" - | NaturalJoin -> "NATURAL" - | LeftJoin -> "LEFT" - | RightJoin -> "RIGHT" - - and pp_table_opt_option fmt = function - | Some w -> pp_table_opt fmt w - | None -> Format.fprintf fmt "" - - and pp_table_opt fmt = function - | JoinOn sc -> Format.fprintf fmt "ON %a" pp_sql_condition sc - | JoinUsing lstvar -> - let pp_aux fmt x = list_comma fmt (x, pp_sqlVarToken) in - Format.fprintf fmt "USING %a" pp_aux lstvar - - and pp_group_by fmt x = Format.fprintf fmt "%a" pp_list_lit x - - and pp_orderBy fmt x = - let pp_aux fmt = function - | Asc v -> Format.fprintf fmt "%a ASC" pp_lit v - | Desc v -> Format.fprintf fmt "%a DESC" pp_lit v - in - list_comma fmt (x, pp_aux) - - and pp_select_lst fmt l = list_comma fmt (l, pp_sql_op) - - and pp_some_var fmt (x, s) = - match x with - | Some v -> Format.fprintf fmt "%s %a" s pp_var v - | None -> Format.fprintf fmt "" - - and pp_var fmt = function - | SqlVar v -> Format.fprintf fmt "%s" v.payload - | CobolVar c -> pp_cob_var fmt c - - and pp_list_lit fmt x = list_comma fmt (x, pp_lit) - - and pp_lit fmt = function - | LiteralNum n -> Format.fprintf fmt "%s" n.payload - | LiteralStr n -> Format.fprintf fmt "%s" n.payload - | LiteralVar n -> Format.fprintf fmt "%a" pp_var n - | LiteralDot lst -> - let rec pp_aux fmt = function - | [] -> Format.fprintf fmt "" - | [ ele ] -> Format.fprintf fmt "%s" ele.payload - | ele :: t -> Format.fprintf fmt "%s.%a" ele.payload pp_aux t - in - pp_aux fmt lst -end +include Types +module Visitor = Visitor diff --git a/src/lsp/sql_ast/types.ml b/src/lsp/sql_ast/types.ml new file mode 100644 index 000000000..421cb0c6a --- /dev/null +++ b/src/lsp/sql_ast/types.ml @@ -0,0 +1,632 @@ +(**************************************************************************) +(* *) +(* 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 + +(**************************************************************************) +(* AST *) +(**************************************************************************) +type sqlVarToken = string with_loc [@@deriving ord] + +type cobolVarId = string with_loc [@@deriving ord] + +type cobol_var = + | CobVarNotNull of cobolVarId + | CobVarCasted of cobolVarId * sql_type + | CobVarNullIndicator of cobolVarId * cobolVarId +[@@deriving ord] + +and variable = + | SqlVar of sqlVarToken + | CobolVar of cobol_var +[@@deriving ord] + +and literal = + | LiteralVar of variable + | LiteralNum of string with_loc + | LiteralStr of string with_loc + | LiteralDot of string with_loc list +[@@deriving ord] + +and sql_token = + | SqlInstr of string + | SqlVarToken of variable + | SqlLit of literal + | SqlQuery of sql_query + | SqlEquality of sql_equal (*TODO: remove*) + | SqlSearchCondition of search_condition (*TODO: remove*) + +and sql_instruction = sql_token list + +and complex_literal = + | SqlCompLit of literal + | SqlCompAsType of literal * sql_type_name (*ex: SMT AS INT*) + | SqlCompAsVar of literal * sqlVarToken + | SqlCompFun of sqlVarToken * sql_op list + | SqlCompStar + +and esql_instruction = + | At of variable * esql_instruction + | Sql of sql_instruction + | Begin + | BeginDeclare + | Exeption of try_block + | EndDeclare + | StartTransaction + | Whenever of whenever_condition * whenever_continuation + | Include of sqlVarToken + | Connect of connect_syntax + | Rollback of rb_work_or_tran option * rb_args option + | Commit of rb_work_or_tran option * bool + | Savepoint of variable + | ReleaseSavepoint of variable + | SelectInto of + { vars : cobol_var list; + select : sql_select; + select_options : sql_select_option list + } + | DeclareTable of literal * (sqlVarToken * sql_type) list + | DeclareCursor of cursor + | Prepare of sqlVarToken * sql_instruction + | ExecuteImmediate of sql_instruction + | ExecuteIntoUsing of + { executed_string : sqlVarToken; + opt_into_hostref_list : cobol_var list option; + opt_using_hostref_list : cobol_var list option + } + | Disconnect of variable option (*db_id*) + | DisconnectAll + | Open of sqlVarToken * cobol_var list option (*cursor name*) + | Close of sqlVarToken (*cursor name*) + | Fetch of sqlVarToken * cobol_var list + | Insert of table * value list + | Delete of sql_instruction + | Update of sqlVarToken * sql_update * update_arg option + | Ignore of sql_instruction + +and try_block = + { try_instruction : esql_instruction; + try_exceptions : sql_exception list + } + +and sql_exception = RaiseAndPrint of sqlVarToken * string with_loc * cobol_var + +and cursor = + | DeclareCursorSql of sqlVarToken * sql_query + | DeclareCursorVar of sqlVarToken * variable + | DeclareCursorWhithHold of sqlVarToken * sql_query + +and table = + | Table of sqlVarToken + | TableLst of sqlVarToken * sqlVarToken list + +and value = + | ValueNull + | ValueDefault + | ValueList of literal list + +and rb_work_or_tran = + | Work + | Transaction + +and rb_args = + | Release + | To of sqlVarToken + +and connect_syntax = + | Connect_to_idby of + { dbname : cobolVarId; + db_conn_id : variable option; + username : cobolVarId; + db_data_source : cobolVarId; + password : cobolVarId + } + | Connect_to of + { db_data_source : cobolVarId; + db_conn_id : variable option; + username : cobolVarId; + password : cobolVarId option + } + | Connect_using of { db_data_source : cobolVarId } + | Connect_user of + { username : cobolVarId; + password : cobolVarId; + db_conn_id : variable option; + db_data_source : cobolVarId option + } + | Connect_reset of variable option + +(*WHENEVER*) +and sql_type = + { sql_type : sql_type_name; + size : literal option; + not_null : bool; + with_default : bool + } + +and sql_type_name = + | Char + | Date + | Integer + | Timestamp + | VarChar + +and whenever_condition = + | Not_found_whenever + | SqlError_whenever + | SqlWarning_whenever + +and whenever_continuation = + | Continue + | Perform of sqlVarToken (*A label in cob program*) + | Goto of sqlVarToken (*TODO doc*) + +and update_arg = + | WhereCurrentOf of sqlVarToken + | WhereUpdate of search_condition + | UpdateSql of sql_instruction + +(*SQL*) +and sql_query = + | SelectUnion of sql_query * sql_query + | SelectExcept of sql_query * sql_query + | SelectIntersect of sql_query * sql_query + | SelectQuery of sql_select * sql_select_option list + +and sql_select_option = + | From of from_stm + | Where of search_condition + | OrderBy of sql_orderBy list + | GroupBy of literal list + | Having of search_condition + +and from_stm = table_ref list + +and table_ref = + | FromLitAs of table_ref * literal + | FromLit of literal + | FromFun of sqlVarToken * literal + | FromSelect of sql_query + | Join of table_ref * join * table_ref * join_option option + +and join = + | InnerJoin + | NaturalJoin + | LeftJoin + | RightJoin + +and join_option = + | JoinOn of search_condition + | JoinUsing of sqlVarToken list + +and sql_orderBy = + | Asc of literal + | Desc of literal + +and sql_select = sql_op list + +and sql_update = sql_equal list + +and sql_equal = sqlVarToken * sql_op + +and sql_op = + | SqlOpLit of complex_literal + | SqlOpBinop of (sql_binop * complex_literal * sql_op) + +and sql_binop = + | Add + | Minus + | Times + | Or + +and search_condition = + | WhereConditionOr of search_condition * search_condition + | WhereConditionAnd of search_condition * search_condition + | WhereConditionNot of search_condition + | WhereConditionCompare of sql_compare + | WhereConditionIn of sql_condition_in + | WhereConditionBetween of between_condition + | WhereConditionIsNull of variable + +and between_condition = Between of literal * literal * literal + +and sql_condition_in = InVarLst of literal * complex_literal list + +and sql_compare = + | CompareQuery of complex_literal * comp_operator * sql_instruction + | CompareLit of complex_literal * comp_operator * complex_literal + +and comp_operator = + | Less + | Great + | LessEq + | GreatEq + | EqualComp + | Diff +[@@deriving ord] + +(**************************************************************************) +(* COMPARE *) +(**************************************************************************) +let compare = compare_esql_instruction + +(**************************************************************************) +(* PRETTY PRINT *) +(**************************************************************************) +module Printer = struct + let rec list_comma (fmt : Format.formatter) + (g : 'a list * (Format.formatter -> 'a -> unit)) : unit = + let x, f = g in + match x with + | [] -> Format.fprintf fmt "" + | [ ele ] -> Format.fprintf fmt "%a" f ele + | ele :: t -> Format.fprintf fmt "%a, %a" f ele list_comma (t, f) + + let rec pp fmt x = Format.fprintf fmt "EXEC SQL %a END-EXEC" pp_esql x + + and pp_esql fmt = function + | At (v, instr) -> Format.fprintf fmt "AT %a %a" pp_var v pp_esql instr + | Sql instr -> pp_sql fmt instr + | Begin -> Format.fprintf fmt "BEGIN" + | Exeption e -> Format.fprintf fmt "BEGIN %a END;" pp_exception e + | BeginDeclare -> Format.fprintf fmt "BEGIN DECLARE SECTION" + | EndDeclare -> Format.fprintf fmt "END DECLARE SECTION" + | StartTransaction -> Format.fprintf fmt "START TRANSACTION" + | Whenever (c, k) -> + Format.fprintf fmt "WHENEVER %a %a" pp_whenever_condtion c + pp_whenever_continuation k + | Include i -> Format.fprintf fmt "INCLUDE %s" i.payload + | Connect c -> Format.fprintf fmt "CONNECT %a" pp_connect c + | Rollback (rb_work_or_tran, rb_args) -> + Format.fprintf fmt "ROLLBACK %a %a" pp_some_rb_work_or_tran + rb_work_or_tran pp_rb_args rb_args + | Commit (rb_work_or_tran, b) -> + let s = + match b with + | true -> "RELEASE" + | false -> "" + in + Format.fprintf fmt "COMMIT %a %s" pp_some_rb_work_or_tran rb_work_or_tran + s + | Savepoint s -> Format.fprintf fmt "SAVEPOINT %a" pp_var s + | ReleaseSavepoint s -> Format.fprintf fmt "RELEASE SAVEPOINT %a" pp_var s + | SelectInto { vars; select; select_options } -> + Format.fprintf fmt "SELECT %a INTO %a %a" pp_select_lst select pp_cob_lst + vars pp_select_options_lst select_options + | DeclareTable (var, sql) -> + Format.fprintf fmt "DECLARE %a TABLE (%a)" pp_lit var pp_declare sql + | DeclareCursor cursor -> pp_cursor fmt cursor + | Prepare (str, sql) -> + Format.fprintf fmt "PREPARE %s FROM %a" str.payload pp_sql sql + | ExecuteImmediate sql -> + Format.fprintf fmt "EXECUTE IMMEDIATE %a" pp_sql sql + | ExecuteIntoUsing + { executed_string; opt_into_hostref_list; opt_using_hostref_list } -> + Format.fprintf fmt "EXECUTE %s %a %a" executed_string.payload + pp_some_cob_lst + (opt_into_hostref_list, "INTO") + pp_some_cob_lst + (opt_using_hostref_list, "USING") + | Disconnect sdbname -> + Format.fprintf fmt "DISCONNECT %a" pp_some_var (sdbname, "") + | DisconnectAll -> Format.fprintf fmt "DISCONNECT ALL" + | Open (cursor, lst) -> + Format.fprintf fmt "OPEN %s %a" cursor.payload pp_some_cob_lst + (lst, "USING") + | Close cursor -> Format.fprintf fmt "CLOSE %s" cursor.payload + | Fetch (sql, var) -> + Format.fprintf fmt "FETCH %s INTO %a" sql.payload pp_cob_lst var + | Insert (tab, v) -> + Format.fprintf fmt "INSERT INTO %a VALUES %a" pp_table tab pp_value v + | Delete sql -> Format.fprintf fmt "DELETE %a" pp_sql sql + | Update (table, equallst, swhere) -> + Format.fprintf fmt "UPDATE %s SET %a %a" table.payload pp_sql_update + equallst pp_where_arg swhere + | Ignore lst -> Format.fprintf fmt "IGNORE %a" pp_sql lst + + and pp_exception fmt e = + Format.fprintf fmt "%a; EXCEPTION %a" pp_esql e.try_instruction + pp_exception_list e.try_exceptions + + and pp_exception_list fmt l = + let pp_one_exception fmt = function + | RaiseAndPrint (name, str, cob_var) -> + Format.fprintf fmt "WHEN %s THEN RAISE EXCEPTION %s, %a" name.payload + str.payload pp_cob_var cob_var + in + List.iter (Format.fprintf fmt " %a; " pp_one_exception) l + + and pp_cursor fmt = function + | DeclareCursorSql (var, sql) -> + Format.fprintf fmt "DECLARE %s CURSOR FOR %a" var.payload pp_sql_query sql + | DeclareCursorVar (var, v) -> + Format.fprintf fmt "DECLARE %s CURSOR FOR %a" var.payload pp_var v + | DeclareCursorWhithHold (var, sql) -> + Format.fprintf fmt "DECLARE %s CURSOR WITH HOLD FOR %a" var.payload + pp_sql_query sql + + and pp_table fmt = function + | Table t -> Format.fprintf fmt "%s" t.payload + | TableLst (t, lst) -> + let f = pp_sqlVarToken in + let pp_aux fmt lst = list_comma fmt (lst, f) in + Format.fprintf fmt "%s(%a)" t.payload pp_aux lst + + and pp_sqlVarToken fmt x = Format.fprintf fmt "%s" x.payload + + and pp_value fmt x = list_comma fmt (x, pp_one_value) + + and pp_declare fmt x = list_comma fmt (x, pp_var_type) + + and pp_var_type fmt (l, t) = + Format.fprintf fmt "%s\t %a" l.payload pp_sql_type t + + and pp_sql_type_name fmt test = + match test with + | Char -> Format.fprintf fmt "CHAR" + | Date -> Format.fprintf fmt "DATE" + | Integer -> Format.fprintf fmt "INTEGER" + | Timestamp -> Format.fprintf fmt "TIMESTAMP" + | VarChar -> Format.fprintf fmt "VARCHAR" + and pp_sql_type fmt { sql_type; size; not_null; with_default } = + + pp_sql_type_name fmt sql_type; + ( match size with + | Some lit -> Format.fprintf fmt " (%a)" pp_lit lit + | None -> () ); + if not_null then Format.fprintf fmt " NOT NULL"; + if with_default then Format.fprintf fmt " WITH DEFAULT" + + and pp_one_value fmt = function + | ValueDefault -> Format.fprintf fmt "DEFAULT" + | ValueNull -> Format.fprintf fmt "NULL" + | ValueList l -> ( + match l with + | [ x ] -> Format.fprintf fmt "(%a)" pp_lit x + | [] -> Format.fprintf fmt "" + | _ -> Format.fprintf fmt "(%a)" pp_list_lit l ) + + and pp_where_arg fmt = function + | Some (WhereCurrentOf swhere) -> + Format.fprintf fmt "WHERE CURRENT OF %s" swhere.payload + | Some (WhereUpdate e) -> Format.fprintf fmt "WHERE %a" pp_sql_condition e + | Some (UpdateSql sql) -> pp_sql fmt sql + | None -> () + + and pp_sql_update_aux fmt (var, op) = + Format.fprintf fmt "%s = %a" var.payload pp_sql_op op + + and pp_sql_update fmt x = list_comma fmt (x, pp_sql_update_aux) + + and pp_sql_op fmt = function + | SqlOpBinop (op, sql1, sql2) -> + Format.fprintf fmt "%a %s %a" pp_complex_literal sql1 (pp_binop op) + pp_sql_op sql2 + | SqlOpLit l -> Format.fprintf fmt "%a" pp_complex_literal l + + and pp_sql_some_condition fmt = function + | Some s -> Format.fprintf fmt "WHERE %a" pp_sql_condition s + | None -> Format.fprintf fmt "" + + and pp_sql_condition fmt = function + | WhereConditionAnd (s1, s2) -> + Format.fprintf fmt "%a AND %a" pp_sql_condition s1 pp_sql_condition s2 + | WhereConditionOr (s1, s2) -> + Format.fprintf fmt "%a OR %a" pp_sql_condition s1 pp_sql_condition s2 + | WhereConditionNot s -> Format.fprintf fmt "NOT %a" pp_sql_condition s + | WhereConditionCompare c -> + let rec pp_compare fmt = function + | CompareLit (l1, c, l2) -> + Format.fprintf fmt "%a %s %a" pp_complex_literal l1 + (comp_op_to_string c) pp_complex_literal l2 + | CompareQuery (l1, c, s) -> + Format.fprintf fmt "%a %s (%a)" pp_complex_literal l1 + (comp_op_to_string c) pp_sql s + and comp_op_to_string = function + | Less -> "<" + | Great -> ">" + | LessEq -> "<=" + | GreatEq -> ">=" + | EqualComp -> "=" + | Diff -> "<>" + in + Format.fprintf fmt "%a" pp_compare c + | WhereConditionIn s -> Format.fprintf fmt "%a" pp_condition_in s + | WhereConditionBetween s -> Format.fprintf fmt "%a" pp_condition_between s + | WhereConditionIsNull v -> Format.fprintf fmt "%a IS NULL" pp_var v + + and pp_condition_in fmt x = + let pp_aux fmt lst = list_comma fmt (lst, pp_complex_literal) in + match x with + | InVarLst (l, vlist) -> + Format.fprintf fmt "%a IN (%a)" pp_lit l pp_aux vlist + + and pp_condition_between fmt = function + | Between (l, l1, l2) -> + Format.fprintf fmt "%a BETWEEN %a AND %a" pp_lit l pp_lit l1 pp_lit l2 + + and pp_complex_literal fmt = function + | SqlCompLit v -> Format.fprintf fmt "%a" pp_lit v + | SqlCompAsType (l, v) -> Format.fprintf fmt "%a AS %a" pp_lit l pp_sql_type_name v + | SqlCompAsVar (l, v) -> Format.fprintf fmt "%a AS %s" pp_lit l v.payload + | SqlCompFun (funName, args) -> + let pp_args fmt lst = list_comma fmt (lst, pp_sql_op) in + Format.fprintf fmt "%s(%a)" funName.payload pp_args args + | SqlCompStar -> Format.fprintf fmt "*" + + and pp_binop = function + | Add -> "+" + | Minus -> "-" + | Times -> "*" + | Or -> "||" + + and pp_some_cob_lst fmt = function + | Some x, s -> Format.fprintf fmt "%s %a" s pp_cob_lst x + | None, _ -> Format.fprintf fmt "" + + and pp_cob_lst fmt x = list_comma fmt (x, pp_cob_var) + + and pp_cob_var fmt = function + | CobVarNotNull c -> Format.fprintf fmt ":%s" c.payload + | CobVarCasted (c, t) -> + Format.fprintf fmt ":%s::%a" c.payload pp_sql_type t + | CobVarNullIndicator (c, ni) -> + Format.fprintf fmt ":%s:%s" c.payload ni.payload + + and pp_cob_var_id fmt c = Format.fprintf fmt ":%s" c.payload + + and pp_some_rb_work_or_tran fmt = function + | Some p -> pp_rb_work_or_tran fmt p + | None -> Format.fprintf fmt "" + + and pp_rb_work_or_tran fmt = function + | Work -> Format.fprintf fmt "WORK" + | Transaction -> Format.fprintf fmt "TRANSACTION" + + and pp_rb_args fmt = function + | Some Release -> Format.fprintf fmt "RELEASE" + | Some (To variable) -> + Format.fprintf fmt "TO SAVEPOINT %s" variable.payload + | None -> Format.fprintf fmt "" + + and pp_some_cob_var fmt (x, s) = + match x with + | Some v -> Format.fprintf fmt "%s %a" s pp_cob_var_id v + | None -> Format.fprintf fmt "" + + and pp_connect fmt c = + match c with + | Connect_to_idby { dbname; db_conn_id; username; db_data_source; password } + -> + Format.fprintf fmt "TO %a %a USER %a USING %a IDENTIFIED BY %a" + pp_cob_var_id dbname pp_some_var (db_conn_id, "AS") pp_cob_var_id + username pp_cob_var_id db_data_source pp_cob_var_id password + | Connect_to { db_data_source; db_conn_id; username; password } -> + Format.fprintf fmt "TO %a %a USER %a %a" pp_cob_var_id db_data_source + pp_some_var (db_conn_id, "AS") pp_cob_var_id username pp_some_cob_var + (password, "USING") + | Connect_using { db_data_source } -> + Format.fprintf fmt "USING %a" pp_cob_var_id db_data_source + | Connect_user { username; password; db_conn_id; db_data_source } -> + Format.fprintf fmt "%a IDENTIFIED BY %a %a %a" pp_cob_var_id username + pp_cob_var_id password pp_some_var (db_conn_id, "AT") pp_some_cob_var + (db_data_source, "USING") + | Connect_reset name -> Format.fprintf fmt "RESET%a" pp_some_var (name, "") + + and pp_whenever_condtion fmt = function + | Not_found_whenever -> Format.fprintf fmt "NOT FOUND" + | SqlError_whenever -> Format.fprintf fmt "SQLERROR" + | SqlWarning_whenever -> Format.fprintf fmt "SQLWARNING" + + and pp_whenever_continuation fmt = function + | Continue -> Format.fprintf fmt "CONTINUE" + | Perform label -> Format.fprintf fmt "PERFORM %s" label.payload + | Goto stmt_label -> Format.fprintf fmt "GOTO %s" stmt_label.payload + + and pp_some_sql fmt = function + | Some p -> pp_sql fmt p + | None -> Format.fprintf fmt "" + + and pp_sql fmt = function + | [ h ] -> Format.fprintf fmt "%a" pp_one_token h + | h :: t -> Format.fprintf fmt "%a %a" pp_one_token h pp_sql t + | [] -> Format.fprintf fmt "" + + and pp_one_token fmt = function + | SqlInstr s -> Format.fprintf fmt "%s" s + | SqlVarToken c -> Format.fprintf fmt "%a" pp_var c + | SqlLit l -> Format.fprintf fmt "%a" pp_lit l + | SqlQuery s -> Format.fprintf fmt "%a" pp_sql_query s + | SqlEquality e -> Format.fprintf fmt "%a" pp_sql_update_aux e + | SqlSearchCondition c -> Format.fprintf fmt "%a" pp_sql_condition c + + and pp_sql_query fmt = function + | SelectQuery (s, o) -> + Format.fprintf fmt "SELECT %a %a" pp_select_lst s pp_select_options_lst o + | SelectUnion (s1, s2) -> + Format.fprintf fmt "%a UNION %a" pp_sql_query s1 pp_sql_query s2 + | SelectExcept (s1, s2) -> + Format.fprintf fmt "%a EXCEPT %a" pp_sql_query s1 pp_sql_query s2 + | SelectIntersect (s1, s2) -> + Format.fprintf fmt "%a INTERSECT %a" pp_sql_query s1 pp_sql_query s2 + + and pp_select_options_lst fmt lst = + let pp_one_option fmt = function + | From f -> Format.fprintf fmt "FROM %a" pp_from f + | Where w -> Format.fprintf fmt "WHERE %a" pp_sql_condition w + | OrderBy ob -> Format.fprintf fmt "ORDER BY %a" pp_orderBy ob + | GroupBy gb -> Format.fprintf fmt "GROUP BY %a" pp_group_by gb + | Having w -> Format.fprintf fmt "HAVING %a" pp_sql_condition w + in + List.iter (Format.fprintf fmt " %a" pp_one_option) lst + + and pp_from fmt f = list_comma fmt (f, pp_table_ref) + + and pp_table_ref fmt = function + | FromLit l -> Format.fprintf fmt "%a" pp_lit l + | FromLitAs (l, a) -> Format.fprintf fmt "%a AS %a" pp_table_ref l pp_lit a + | FromFun (v, t) -> Format.fprintf fmt "%a %a" pp_sqlVarToken v pp_lit t + | FromSelect s -> Format.fprintf fmt "(%a)" pp_sql_query s + | Join (tr1, join, tr2, opt) -> + Format.fprintf fmt "%a %s JOIN %a %a" pp_table_ref tr1 (str_join join) + pp_table_ref tr2 pp_table_opt_option opt + + and str_join = function + | InnerJoin -> "INNER" + | NaturalJoin -> "NATURAL" + | LeftJoin -> "LEFT" + | RightJoin -> "RIGHT" + + and pp_table_opt_option fmt = function + | Some w -> pp_table_opt fmt w + | None -> Format.fprintf fmt "" + + and pp_table_opt fmt = function + | JoinOn sc -> Format.fprintf fmt "ON %a" pp_sql_condition sc + | JoinUsing lstvar -> + let pp_aux fmt x = list_comma fmt (x, pp_sqlVarToken) in + Format.fprintf fmt "USING %a" pp_aux lstvar + + and pp_group_by fmt x = Format.fprintf fmt "%a" pp_list_lit x + + and pp_orderBy fmt x = + let pp_aux fmt = function + | Asc v -> Format.fprintf fmt "%a ASC" pp_lit v + | Desc v -> Format.fprintf fmt "%a DESC" pp_lit v + in + list_comma fmt (x, pp_aux) + + and pp_select_lst fmt l = list_comma fmt (l, pp_sql_op) + + and pp_some_var fmt (x, s) = + match x with + | Some v -> Format.fprintf fmt "%s %a" s pp_var v + | None -> Format.fprintf fmt "" + + and pp_var fmt = function + | SqlVar v -> Format.fprintf fmt "%s" v.payload + | CobolVar c -> pp_cob_var fmt c + + and pp_list_lit fmt x = list_comma fmt (x, pp_lit) + + and pp_lit fmt = function + | LiteralNum n -> Format.fprintf fmt "%s" n.payload + | LiteralStr n -> Format.fprintf fmt "%s" n.payload + | LiteralVar n -> Format.fprintf fmt "%a" pp_var n + | LiteralDot lst -> + let rec pp_aux fmt = function + | [] -> Format.fprintf fmt "" + | [ ele ] -> Format.fprintf fmt "%s" ele.payload + | ele :: t -> Format.fprintf fmt "%s.%a" ele.payload pp_aux t + in + pp_aux fmt lst +end diff --git a/src/lsp/sql_ast/visitor.ml b/src/lsp/sql_ast/visitor.ml new file mode 100644 index 000000000..23f433d2c --- /dev/null +++ b/src/lsp/sql_ast/visitor.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 Types +open Cobol_common.Visitor +open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *) + +(* --- *) + +class ['a] folder = object + inherit ['a] Fold.folder + method fold_cobol_var_id: (cobolVarId, 'a) fold = default + method fold_sql_var_token: (sqlVarToken, 'a) fold = default + method fold_cobol_var: (cobol_var, 'a) fold = default + method fold_variable: (variable, 'a) fold = default + method fold_literal: (literal, 'a) fold = default + method fold_sql_token: (sql_token, 'a) fold = default + method fold_sql_instruction: (sql_instruction, 'a) fold = default + method fold_complex_literal: (complex_literal, 'a) fold = default + method fold_esql_instruction: (esql_instruction, 'a) fold = default + method fold_try_block: (try_block, 'a) fold = default + method fold_sql_exception: (sql_exception, 'a) fold = default + method fold_cursor: (cursor, 'a) fold = default + method fold_table: (table, 'a) fold = default + method fold_value: (value, 'a) fold = default + method fold_rb_work_or_tran: (rb_work_or_tran, 'a) fold = default + method fold_rb_args: (rb_args, 'a) fold = default + method fold_connect_syntax: (connect_syntax, 'a) fold = default + method fold_sql_type: (sql_type, 'a) fold = default + method fold_sql_type_name: (sql_type_name, 'a) fold = default + method fold_whenever_condition: (whenever_condition, 'a) fold = default + method fold_whenever_continuation: (whenever_continuation, 'a) fold = default + method fold_update_arg: (update_arg, 'a) fold = default + method fold_sql_query: (sql_query, 'a) fold = default + method fold_sql_select_option: (sql_select_option, 'a) fold = default + method fold_from_stm: (from_stm, 'a) fold = default + method fold_table_ref: (table_ref, 'a) fold = default + method fold_join: (join, 'a) fold = default + method fold_join_option: (join_option, 'a) fold = default + method fold_sql_orderby: (sql_orderBy, 'a) fold = default + method fold_sql_select: (sql_select, 'a) fold = default + method fold_sql_update: (sql_update, 'a) fold = default + method fold_sql_equal: (sql_equal, 'a) fold = default + method fold_sql_op: (sql_op, 'a) fold = default + method fold_sql_binop: (sql_binop, 'a) fold = default + method fold_search_condition: (search_condition, 'a) fold = default + method fold_between_condition: (between_condition, 'a) fold = default + method fold_sql_condition_in: (sql_condition_in, 'a) fold = default + method fold_sql_compare: (sql_compare, 'a) fold = default + method fold_comp_operator: (comp_operator, 'a) fold = default +end + +let fold_cobol_var_id (v: _ #folder) = leaf v#fold_cobol_var_id +let fold_sql_var_token (v: _ #folder) = leaf v#fold_sql_var_token + +let rec fold_cobol_var (v: _ #folder) = + handle v#fold_cobol_var + ~continue:begin function + | CobVarNotNull c -> fun x -> fold_cobol_var_id v c x + | CobVarCasted (c, t) -> + fun x -> fold_cobol_var_id v c x >> fold_sql_type v t + | CobVarNullIndicator (c, i) -> + fun x -> fold_cobol_var_id v c x >> fold_cobol_var_id v i + end +and fold_variable (v: _ #folder) = + handle v#fold_variable + ~continue: begin function + | SqlVar var -> fold_sql_var_token v var + | CobolVar var -> fold_cobol_var v var + end +and fold_literal (v: _ #folder) = + handle v#fold_literal + ~continue:begin function + | LiteralVar var -> fold_variable v var + | LiteralDot _ | LiteralStr _ | LiteralNum _ -> Fun.id + end +and fold_sql_token (v: _ #folder) = + handle v#fold_sql_token + ~continue:begin function + | SqlInstr _ -> Fun.id + | SqlVarToken var -> fold_variable v var + | SqlLit lit -> fold_literal v lit + | SqlQuery q -> fold_sql_query v q + | SqlEquality eq -> fold_sql_equal v eq + | SqlSearchCondition sc -> fold_search_condition v sc + end +and fold_sql_instruction (v: _ #folder) = + handle v#fold_sql_instruction ~continue:(fold_list ~fold:fold_sql_token v) +and fold_complex_literal (v: _ #folder) = + handle v#fold_complex_literal + ~continue:begin function + | SqlCompLit lit -> fold_literal v lit + | SqlCompAsType (lit, type_name) -> + fun x -> x >> fold_literal v lit >> fold_sql_type_name v type_name + | SqlCompAsVar (lit, var) -> + fun x -> x >> fold_literal v lit >> fold_sql_var_token v var + | SqlCompFun (var, op_list) -> + fun x -> x >> fold_sql_var_token v var >> fold_list ~fold:fold_sql_op v op_list + | SqlCompStar -> Fun.id + end +and fold_esql_instruction (v: _ #folder) = + handle v#fold_esql_instruction + ~continue:begin fun esql x -> + match esql with + | At (var, esql) -> + fold_variable v var x + >> fold_esql_instruction v esql + | Ignore sql + | ExecuteImmediate sql + | Delete sql + | Sql sql -> fold_sql_instruction v sql x + | Begin | BeginDeclare | EndDeclare | StartTransaction | DisconnectAll -> x + | Exeption try_block -> fold_try_block v try_block x + | Whenever (cond, conti) -> + fold_whenever_condition v cond x + >> fold_whenever_continuation v conti + | Close var + | Include var -> fold_sql_var_token v var x + | Connect connect_syntax -> fold_connect_syntax v connect_syntax x + | Rollback (rb_work_or_tran_opt, rb_args_opt) -> + fold_option ~fold:fold_rb_work_or_tran v rb_work_or_tran_opt x + >> fold_option ~fold:fold_rb_args v rb_args_opt + | Commit ((rb_work_or_tran_opt, _)) -> + fold_option ~fold:fold_rb_work_or_tran v rb_work_or_tran_opt x + | SelectInto { vars; select; select_options } -> + fold_list ~fold:fold_cobol_var v vars x + >> fold_sql_select v select + >> fold_list ~fold:fold_sql_select_option v select_options + | DeclareTable (lit, var_type_list) -> + fold_literal v lit x + >> fold_list ~fold:(fun v (var, typ) x -> + x >> fold_sql_var_token v var + >> fold_sql_type v typ) v var_type_list + | DeclareCursor cursor -> + fold_cursor v cursor x + | Prepare (var, sql) -> + fold_sql_var_token v var x + >> fold_sql_instruction v sql + | ExecuteIntoUsing { executed_string; opt_into_hostref_list; opt_using_hostref_list } -> + fold_sql_var_token v executed_string x + >> fold_option ~fold:(fold_list ~fold:fold_cobol_var) v opt_into_hostref_list + >> fold_option ~fold:(fold_list ~fold:fold_cobol_var) v opt_using_hostref_list + | Disconnect var_opt -> + fold_option ~fold:fold_variable v var_opt x + | Open (var, cob_vars) -> + fold_sql_var_token v var x + >> fold_option ~fold:(fold_list ~fold:fold_cobol_var) v cob_vars + | Fetch (var, cob_vars) -> + fold_sql_var_token v var x + >> fold_list ~fold:fold_cobol_var v cob_vars + | Insert (table, values) -> + fold_table v table x + >> fold_list ~fold:fold_value v values + | Update (var, sql_update, update_arg_opt) -> + fold_sql_var_token v var x + >> fold_sql_update v sql_update + >> fold_option ~fold:fold_update_arg v update_arg_opt + | Savepoint variable + | ReleaseSavepoint variable -> + fold_variable v variable x + end +and fold_try_block (v: _ #folder) = + handle v#fold_try_block + ~continue:begin fun { try_instruction; try_exceptions } x -> + fold_esql_instruction v try_instruction x + >> fold_list ~fold:fold_sql_exception v try_exceptions + end +and fold_sql_exception (v: _ #folder) = + handle v#fold_sql_exception + ~continue:begin fun (RaiseAndPrint(var, _, cob_var)) x -> + x + >> fold_sql_var_token v var + >> fold_cobol_var v cob_var + end +and fold_cursor (v: _ #folder) = + handle v#fold_cursor + ~continue:begin function + | DeclareCursorWhithHold (var, query) + | DeclareCursorSql (var, query) -> + fun x -> x >> fold_sql_var_token v var >> fold_sql_query v query + | DeclareCursorVar (var, variable) -> + fun x -> x >> fold_sql_var_token v var >> fold_variable v variable + end +and fold_table (v: _ #folder) = + handle v#fold_table + ~continue:begin function + | Table var -> fold_sql_var_token v var + | TableLst (var, vars) -> + fun x -> x >> fold_sql_var_token v var >> fold_list ~fold:fold_sql_var_token v vars + end +and fold_value (v: _ #folder) = + handle v#fold_value + ~continue:begin function + | ValueNull | ValueDefault -> Fun.id + | ValueList literals -> + fold_list ~fold:fold_literal v literals + end +and fold_rb_work_or_tran (v: _ #folder) = leaf v#fold_rb_work_or_tran +and fold_rb_args (v: _ #folder) = + handle v#fold_rb_args + ~continue:begin function + | Release -> Fun.id + | To var -> fold_sql_var_token v var + end +and fold_connect_syntax (v: _ #folder) = + handle v#fold_connect_syntax + ~continue:begin fun connect_syntax x -> + match connect_syntax with + | Connect_to_idby { dbname; db_conn_id; username; db_data_source; password } -> + fold_cobol_var_id v dbname x + >> fold_option ~fold:fold_variable v db_conn_id + >> fold_cobol_var_id v username + >> fold_cobol_var_id v db_data_source + >> fold_cobol_var_id v password + | Connect_to { db_conn_id; username; db_data_source; password } -> + fold_option ~fold:fold_variable v db_conn_id x + >> fold_cobol_var_id v username + >> fold_cobol_var_id v db_data_source + >> fold_option ~fold:fold_cobol_var_id v password + | Connect_using { db_data_source } -> + fold_cobol_var_id v db_data_source x + | Connect_user { db_conn_id; username; db_data_source; password } -> + fold_option ~fold:fold_variable v db_conn_id x + >> fold_cobol_var_id v username + >> fold_option ~fold:fold_cobol_var_id v db_data_source + >> fold_cobol_var_id v password + | Connect_reset var_opt -> + fold_option ~fold:fold_variable v var_opt x + end +and fold_sql_type (v: _ #folder) = + handle v#fold_sql_type + ~continue: begin fun { sql_type; size; _ } x -> + x + >> fold_sql_type_name v sql_type + >> fold_option ~fold:fold_literal v size + end +and fold_sql_type_name (v: _ #folder) = leaf v#fold_sql_type_name +and fold_whenever_condition (v: _ #folder) = leaf v#fold_whenever_condition +and fold_whenever_continuation (v: _ #folder) = + handle v#fold_whenever_continuation + ~continue: begin function + | Continue -> Fun.id + | Perform var | Goto var -> + fold_sql_var_token v var + end +and fold_update_arg (v: _ #folder) = + handle v#fold_update_arg + ~continue: begin function + | WhereCurrentOf var -> fold_sql_var_token v var + | WhereUpdate search_cond -> fold_search_condition v search_cond + | UpdateSql sql -> fold_sql_instruction v sql + end +and fold_sql_query (v: _ #folder) = + handle v#fold_sql_query + ~continue: begin function + | SelectIntersect (q, q2) + | SelectExcept (q, q2) + | SelectUnion (q, q2) -> + fun x -> x >> fold_sql_query v q >> fold_sql_query v q2 + | SelectQuery (select, select_opts) -> + fun x -> x >> fold_sql_select v select >> fold_list ~fold:fold_sql_select_option v select_opts + end +and fold_sql_select_option (v: _ #folder) = + handle v#fold_sql_select_option + ~continue: begin function + | From from -> fold_from_stm v from + | Having search_cond + | Where search_cond -> fold_search_condition v search_cond + | OrderBy orderBys -> fold_list ~fold:fold_sql_orderby v orderBys + | GroupBy literals -> fold_list ~fold:fold_literal v literals + end +and fold_from_stm (v: _ #folder) = + handle v#fold_from_stm + ~continue:(fold_list ~fold:fold_table_ref v) +and fold_table_ref (v: _ #folder) = + handle v#fold_table_ref + ~continue:begin function + | FromLitAs (table_ref, lit) -> + fun x -> x >> fold_table_ref v table_ref >> fold_literal v lit + | FromLit lit -> fun x -> fold_literal v lit x + | FromFun (var, lit) -> + fun x -> x >> fold_sql_var_token v var >> fold_literal v lit + | FromSelect query -> fun x -> fold_sql_query v query x + | Join (table_ref, join, table_ref2, join_option_opt) -> + fun x -> + fold_table_ref v table_ref x + >> fold_join v join + >> fold_table_ref v table_ref2 + >> fold_option ~fold:fold_join_option v join_option_opt + end +and fold_join (v: _ #folder) = leaf v#fold_join +and fold_join_option (v: _ #folder) = + handle v#fold_join_option + ~continue:begin function + | JoinOn search_cond -> fun x -> fold_search_condition v search_cond x + | JoinUsing vars -> fun x -> fold_list ~fold:fold_sql_var_token v vars x + end +and fold_sql_orderby (v: _ #folder) = + handle v#fold_sql_orderby + ~continue:begin function + | Asc lit | Desc lit -> fun x -> fold_literal v lit x + end +and fold_sql_select (v: _ #folder) = + handle v#fold_sql_select + ~continue:(fold_list ~fold:fold_sql_op v) +and fold_sql_update (v: _ #folder) = + handle v#fold_sql_update + ~continue:(fold_list ~fold:fold_sql_equal v) +and fold_sql_equal (v: _ #folder) = + handle v#fold_sql_equal + ~continue:begin fun (var, op) x -> + fold_sql_var_token v var x >> fold_sql_op v op end +and fold_sql_op (v: _ #folder) = + handle v#fold_sql_op + ~continue:begin function + | SqlOpLit complex_lit -> + fun x -> fold_complex_literal v complex_lit x + | SqlOpBinop (binop, complex_lit, op) -> + fun x -> + fold_sql_binop v binop x + >> fold_complex_literal v complex_lit + >> fold_sql_op v op + end +and fold_sql_binop (v: _ #folder) = leaf v#fold_sql_binop +and fold_search_condition (v: _ #folder) = + handle v#fold_search_condition + ~continue:begin function + | WhereConditionOr (search_cond, search_cond2) + | WhereConditionAnd (search_cond, search_cond2) -> + fun x -> + fold_search_condition v search_cond x + >> fold_search_condition v search_cond2 + | WhereConditionNot search_cond -> + fun x -> fold_search_condition v search_cond x + | WhereConditionCompare comp -> + fun x -> fold_sql_compare v comp x + | WhereConditionIn cond_in -> fun x -> fold_sql_condition_in v cond_in x + | WhereConditionBetween between_cond -> + fun x -> fold_between_condition v between_cond x + | WhereConditionIsNull variable -> fun x -> fold_variable v variable x + end +and fold_between_condition (v: _ #folder) = + handle v#fold_between_condition + ~continue:begin fun (Between (lit, lit2, lit3)) x -> + fold_literal v lit x + >> fold_literal v lit2 + >> fold_literal v lit3 + end +and fold_sql_condition_in (v: _ #folder) = + handle v#fold_sql_condition_in + ~continue:begin fun (InVarLst (lit, complex_lits)) x -> + fold_literal v lit x + >> fold_list ~fold:fold_complex_literal v complex_lits + end +and fold_sql_compare (v: _ #folder) = + handle v#fold_sql_compare + ~continue:begin function + | CompareQuery (complex_lit, comp_op, sql_instr) -> + fun x -> + fold_complex_literal v complex_lit x + >> fold_comp_operator v comp_op + >> fold_sql_instruction v sql_instr + | CompareLit (complex_lit, comp_op, complex_lit2) -> + fun x -> + fold_complex_literal v complex_lit x + >> fold_comp_operator v comp_op + >> fold_complex_literal v complex_lit2 + end +and fold_comp_operator (v: _ #folder) = leaf v#fold_comp_operator diff --git a/src/lsp/sql_parser/grammar.mly b/src/lsp/sql_parser/grammar.mly index eb80fef1c..13d4ea1be 100644 --- a/src/lsp/sql_parser/grammar.mly +++ b/src/lsp/sql_parser/grammar.mly @@ -50,7 +50,7 @@ open Cobol_common.Srcloc.INFIX %token NUMBER %token COBOL_VAR %token BACKSLASH_VAR -%start main +%start main %% diff --git a/src/lsp/sql_preproc/types.ml b/src/lsp/sql_preproc/types.ml index 2f4d84fc7..9a0bda813 100644 --- a/src/lsp/sql_preproc/types.ml +++ b/src/lsp/sql_preproc/types.ml @@ -38,7 +38,7 @@ type statements = | LINKAGE_SECTION of { defined: bool } | EXEC_SQL of { end_loc : loc ; with_dot : bool ; - tokens : Sql_ast.esql_instuction ; + tokens : Sql_ast.esql_instruction ; } | BEGIN_PROCEDURE_DIVISION of { enabled : bool ref } | END_PROCEDURE_DIVISION diff --git a/src/lsp/superbol_preprocs/esql.ml b/src/lsp/superbol_preprocs/esql.ml index 9bfff8007..53e459b73 100644 --- a/src/lsp/superbol_preprocs/esql.ml +++ b/src/lsp/superbol_preprocs/esql.ml @@ -12,7 +12,7 @@ (**************************************************************************) type Cobol_common.Exec_block.TYPES.exec_block += - | Esql_exec_block of Sql_ast.esql_instuction + | Esql_exec_block of Sql_ast.esql_instruction let () = Cobol_common.Exec_block.register_exec_block_type @@ -31,6 +31,6 @@ let () = end let scanner = - Cobol_parser.Options.Stateless_exec_scanner (fun text -> + Cobol_parser.Options.Stateless_exec_scanner (fun text -> Esql_exec_block (Sql_parser.parse text) , [] ) From 9c00487076ba4fa74edec4e95a9a16668b9aa77e Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 16 Oct 2024 11:41:49 +0200 Subject: [PATCH 28/37] chore: refactor, and using ast visitor --- src/lsp/sql_preproc/generate.ml | 134 ++++++++++++++++---------------- src/lsp/sql_preproc/misc.ml | 24 ++---- src/lsp/sql_preproc/misc.mli | 4 +- src/lsp/sql_preproc/parse.ml | 1 + 4 files changed, 75 insertions(+), 88 deletions(-) diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 131508041..4e5c8ff29 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -12,6 +12,9 @@ open EzCompat open Types open Sql_ast +let c_formatted_string str = "\"" ^ str ^ "\" & x\"00\"" +let empty_c_string = "x\"00\"" + let comment str = Generated_type.Added { content = [ Generated_type.Comment { content = str } ]; @@ -77,7 +80,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let var_opt = function | Some var -> ( match var with - | SqlVar sqlVarToken -> Some ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"") + | SqlVar sqlVarToken -> Some (c_formatted_string sqlVarToken.payload) | CobolVar cobol_var -> cob_var_opt (Some cobol_var) ) | None -> None in @@ -122,18 +125,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | Some a -> a.flags | None -> Sql_typeck.get_flags cobol_unit str in - let get_ind_addr str = - match Data_gestion.find_opt new_var_map str with - | Some a -> a.ind_addr - | None -> Sql_typeck.get_ind_addr cobol_unit str - in - let get_at_info some_var = match some_var with - | None -> ("x\"00\"", 0) + | None -> (empty_c_string, 0) | Some var -> ( match var with - | SqlVar sqlVarToken -> ("\"" ^ sqlVarToken.payload ^ "\" & x\"00\"", 0) + | SqlVar sqlVarToken -> (c_formatted_string sqlVarToken.payload, 0) | CobolVar cobol_var -> ( match cobol_var with | CobVarNotNull cobolVarId -> @@ -157,7 +154,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = trans_stm in - let generatesql_connect_reset ~prefix ?(d_connection_id = "x\"00\"") + let generatesql_connect_reset ~prefix ?(d_connection_id = empty_c_string) ?(connection_id_tl = 0) () = let fun_name = "GIXSQLConnectReset" in let ref_value = @@ -170,10 +167,10 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.CallStatic { prefix; fun_name; ref_value } in - let generatesql_connect_aux ~prefix ?(data_source = "x\"00\"") - ?(data_source_tl = 0) ?(d_connection_id = "x\"00\"") - ?(connection_id_tl = 0) ?(d_dbname = "x\"00\"") ?(dbname_tl = 0) - ?(d_username = "x\"00\"") ?(username_tl = 0) ?(d_password = "x\"00\"") + let generatesql_connect_aux ~prefix ?(data_source = empty_c_string) + ?(data_source_tl = 0) ?(d_connection_id = empty_c_string) + ?(connection_id_tl = 0) ?(d_dbname = empty_c_string) ?(dbname_tl = 0) + ?(d_username = empty_c_string) ?(username_tl = 0) ?(d_password = empty_c_string) ?(password_tl = 0) () = let fun_name = "GIXSQLConnect" in let ref_value = @@ -290,9 +287,16 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match cobol_var with | CobVarNotNull c -> c.payload | CobVarCasted (c, _) -> c.payload - | CobVarNullIndicator (c, n) -> c.payload ^ n.payload + | CobVarNullIndicator (c, _) -> c.payload in + let get_null_indicator (cobol_var : cobol_var) = + match cobol_var with + | CobVarNullIndicator (_, n) -> n.payload + | _ -> "0" + in + + let generate_set_result_param prefix arg = let h = get_name_cobol_var arg in let fun_name = "GIXSQLSetResultParams" in @@ -304,14 +308,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Value { prefix; var = string_of_int (get_flags h) }; Generated_type.Reference { prefix; var = h }; Generated_type.Reference - { prefix; var = string_of_int (get_ind_addr h) } + { prefix; var = get_null_indicator arg } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } in (* Todo: refactory? *) - let generate_set_sql_param prefix h = + let generate_set_sql_param prefix arg = + let h = get_name_cobol_var arg in let fun_name = "GIXSQLSetSQLParams" in let ref_value = let prefix = prefix ^ " " in @@ -321,7 +326,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Value { prefix; var = string_of_int (get_flags h) }; Generated_type.Reference { prefix; var = h }; Generated_type.Reference - { prefix; var = string_of_int (get_ind_addr h) } + { prefix; var = get_null_indicator arg } ] in Generated_type.CallStatic { prefix; fun_name; ref_value } @@ -351,13 +356,15 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_select_into prefix vars select_options select ?at () = let selects_into_vars = List.map (generate_set_result_param prefix) vars in let cob_vars = - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_select_lst select) - @ Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_select_options_lst - select_options ) + let option_vars = + Cobol_common.Visitor.fold_list + ~fold:Sql_ast.Visitor.fold_sql_select_option + Misc.cob_var_extractor_folder select_options [] + in + let select_vars = Sql_ast.Visitor.fold_sql_select + Misc.cob_var_extractor_folder select [] + in List.rev (option_vars @ select_vars) in - let trans_cob_var = List.map (generate_set_sql_param prefix) cob_vars in let selects_into = generate_select_into_one prefix vars cob_vars ?at () in let trans_stm = @@ -368,10 +375,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = in let generate_fetch_into_one prefix (sql : sqlVarToken) = - let var = - "\"" - ^ Misc.extract_filename filename - ^ "_" ^ sql.payload ^ "\" & x\"00\" " + let var = c_formatted_string + (Misc.extract_filename filename ^ "_" ^ sql.payload) in Generated_type.CallStatic { prefix; @@ -438,7 +443,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = match (rb_work_or_tran, rb_args) with | None, None -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "\"ROLLBACK \" & x\"00\"" ?at () ] + [ generate_GIXSQLExec prefix (c_formatted_string "ROLLBACK") ?at () ] | _, Some (To _) -> generate_declare prefix () | _ -> [ Generated_type.Todo { prefix } ] in @@ -448,7 +453,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | None, false | Some Work, false -> generate_start_end_sql prefix - [ generate_GIXSQLExec prefix "\"COMMIT\" & x\"00\"" ?at () ] + [ generate_GIXSQLExec prefix (c_formatted_string "COMMIT") ?at () ] | _ -> [ Generated_type.Todo { prefix } ] in @@ -486,18 +491,17 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let create_from_cursor_declaration (prefix, cur, at, var_name) = let at_name, at_size = get_at_info at in - let cur_name, cob_var_lst, var_name, _with_hold = + let cob_var_lst = List.rev @@ + Sql_ast.Visitor.fold_cursor Misc.cob_var_extractor_folder cur [] + in + let cur_name, var_name, _with_hold = match cur with - | DeclareCursorSql (cur_name, sql) -> + | DeclareCursorSql (cur_name, _sql) -> ( cur_name, - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query sql), var_name, false ) - | DeclareCursorWhithHold (cur_name, query) -> + | DeclareCursorWhithHold (cur_name, _query) -> ( cur_name, - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_sql_query query), var_name, true ) | DeclareCursorVar (cur_name, cur_var) -> @@ -506,13 +510,12 @@ let generate ~filename ~contents ~cobol_unit sql_statements = | SqlVar _ -> var_name | CobolVar v -> get_name_cobol_var v in - (cur_name, [], var, false) + (cur_name, var, false) in - let cursor_name = - "\"" - ^ Misc.extract_filename filename - ^ "_" ^ cur_name.payload ^ "\" & x\"00\"" + let cursor_name = c_formatted_string + (Misc.extract_filename filename + ^ "_" ^ cur_name.payload) in let fun_name, cursor_declare = @@ -607,7 +610,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference - { prefix; var = "\"" ^ var_name.payload ^ "\" & x\"00\"" }; + { prefix; var = c_formatted_string var_name.payload }; Generated_type.Reference { prefix; var = sql_name }; Generated_type.Value { prefix; var = @@ -637,7 +640,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference - { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; + { prefix; var = c_formatted_string executed_string.payload }; Generated_type.Value { prefix; var = string_of_int (List.length into_hostref_list) } (*todo*) @@ -656,7 +659,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = Generated_type.Reference { prefix; var = at_name }; Generated_type.Value { prefix; var = string_of_int at_size }; Generated_type.Reference - { prefix; var = "\"" ^ executed_string.payload ^ "\" & x\"00\"" }; + { prefix; var = c_formatted_string executed_string.payload }; Generated_type.Value { prefix; var = string_of_int (List.length into_hostref_list) }; Generated_type.Value @@ -670,9 +673,6 @@ let generate ~filename ~contents ~cobol_unit sql_statements = let generate_execute_into_using prefix executed_string ?(opt_into_hostref_list = []) ?(opt_using_hostref_list = []) ?at () = - let opt_using_hostref_list = - List.map get_name_cobol_var opt_using_hostref_list - in let into_hostref_set_result_param = List.map (generate_set_result_param prefix) opt_into_hostref_list in @@ -703,10 +703,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; - var = - "\"" - ^ Misc.extract_filename filename - ^ "_" ^ sql_var_token ^ "\" x\"00\"" + var = c_formatted_string + (Misc.extract_filename filename + ^ "_" ^ sql_var_token) } ] in @@ -745,10 +744,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [ Generated_type.Reference { prefix; var = "SQLCA" }; Generated_type.Reference { prefix; - var = - "\"" - ^ Misc.extract_filename filename - ^ "_" ^ cursor_name.payload ^ "\" & x\"00\"" + var = c_formatted_string + (Misc.extract_filename filename + ^ "_" ^ cursor_name.payload) } ] ) } @@ -824,12 +822,11 @@ let generate ~filename ~contents ~cobol_unit sql_statements = [] | ExecuteImmediate var -> generate_simpl_execute_immediat prefix var ?at () | Insert (_, value_list) -> - let value_list = - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_value value_list) - in - - generate_insert prefix ~value_list ?at () + let value_list = List.rev @@ + Cobol_common.Visitor.fold_list + ~fold:Sql_ast.Visitor.fold_value Misc.cob_var_extractor_folder + value_list [] + in generate_insert prefix ~value_list ?at () | Savepoint _ | ReleaseSavepoint _ | StartTransaction -> @@ -851,9 +848,9 @@ let generate ~filename ~contents ~cobol_unit sql_statements = (* indeed, gix *seems* to not be doing anything with it, this requires further testing tho *) [ Generated_type.Todo { prefix } ] | Delete sql_instr -> - let value_list = - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_sql sql_instr) + let value_list = List.rev @@ + Sql_ast.Visitor.fold_sql_instruction Misc.cob_var_extractor_folder + sql_instr [] in generate_insert prefix ~value_list ?at () | Update _ -> @@ -893,7 +890,7 @@ let generate ~filename ~contents ~cobol_unit sql_statements = ] | DisconnectAll -> [ generatesql_connect_reset ~prefix - ?d_connection_id:(Some "\"*\" & x\"00\"") () + ?d_connection_id:(Some (c_formatted_string "*")) () ] | Whenever (c, k) -> change_error ~prefix c k; @@ -926,9 +923,8 @@ let generate ~filename ~contents ~cobol_unit sql_statements = num := !num + 1; "SQ" ^ string_of_int !num (*I pray for it to be in the good order*) in - let cob_var_list = - Misc.extract_cob_var_name - (Format.asprintf "%a" Sql_ast.Printer.pp_exception e) + let cob_var_list = List.rev @@ + Sql_ast.Visitor.fold_try_block Misc.cob_var_extractor_folder e [] in generate_start_end_sql prefix ( List.map (generate_set_sql_param prefix) cob_var_list diff --git a/src/lsp/sql_preproc/misc.ml b/src/lsp/sql_preproc/misc.ml index 37f35cfb2..795d1e27e 100644 --- a/src/lsp/sql_preproc/misc.ml +++ b/src/lsp/sql_preproc/misc.ml @@ -93,23 +93,13 @@ let resolve_copy ~config file = in iter_exts config.copy_exts - and extract_cob_var_name str = - let len = String.length str in - let rec aux i acc = - if i >= len then List.rev acc - else if str.[i] = ':' then - let start = i + 1 in - let rec find_end j = - if j >= len || str.[j] = ' ' || str.[j] = ',' || str.[j] = ')' || str.[j] = '(' then j - else find_end (j + 1) - in - let end_pos = find_end start in - let var_name = String.sub str start (end_pos - start) in - if List.mem var_name acc then aux end_pos acc - else aux end_pos (var_name :: acc) - else aux (i + 1) acc - in - aux 0 [] +let cob_var_extractor_folder = object + inherit [Sql_ast.cobol_var list] Sql_ast.Visitor.folder + method! fold_cobol_var cob_var acc = + if List.exists (fun c -> Sql_ast.compare_cobol_var cob_var c == 0) acc + then Cobol_common.Visitor.skip acc + else Cobol_common.Visitor.skip (cob_var::acc) +end let extract_filename path = let parts = Str.split (Str.regexp "/") path in diff --git a/src/lsp/sql_preproc/misc.mli b/src/lsp/sql_preproc/misc.mli index e0bb8941e..dcac9d334 100644 --- a/src/lsp/sql_preproc/misc.mli +++ b/src/lsp/sql_preproc/misc.mli @@ -22,8 +22,8 @@ val add_dot : with_dot:bool -> Buffer.t -> unit val resolve_copy : config:Types.config -> string -> string -val extract_cob_var_name : string -> string list - val extract_filename : string -> string val replace_colon_words : string -> string + +val cob_var_extractor_folder : Sql_ast.cobol_var list Sql_ast.Visitor.folder diff --git a/src/lsp/sql_preproc/parse.ml b/src/lsp/sql_preproc/parse.ml index 5be435569..a5259266f 100644 --- a/src/lsp/sql_preproc/parse.ml +++ b/src/lsp/sql_preproc/parse.ml @@ -65,6 +65,7 @@ let parse ~config ~filename ~contents = in sql_add_statement ~loc (DECLARATION { end_loc; declaration }); iter tokens + (*Exemple : 01 VCFLD SQL TYPE IS FLOAT(4,2).*) | (INTEGER importance, loc) :: (IDENT name, _) :: (IDENT "SQL", _) :: (IDENT "TYPE", _) :: (IDENT "IS", _) From b0b7364a081147434890492836380462228854ff Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 16 Oct 2024 16:25:10 +0200 Subject: [PATCH 29/37] feat: reactivate sql preproc, go to def/ref active in exec block --- .drom | 8 ++--- dune-project | 2 ++ opam/cobol_typeck.opam | 2 ++ opam/osx/cobol_typeck-osx.opam | 2 ++ opam/windows/cobol_typeck-windows.opam | 2 ++ src/lsp/cobol_lsp/lsp_lookup.ml | 39 +++++++++++++++++++++ src/lsp/cobol_typeck/dune | 2 +- src/lsp/cobol_typeck/package.toml | 28 ++++++++------- src/lsp/cobol_typeck/typeck_procedure.ml | 43 ++++++++++++++++++++++++ src/lsp/sql_parser/sql_parser.ml | 12 +++++-- src/lsp/sql_preproc/generate.ml | 1 - src/lsp/superbol_preprocs/main.ml | 4 +-- 12 files changed, 121 insertions(+), 24 deletions(-) diff --git a/.drom b/.drom index 3ed184bf4..22c1e4e7f 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -dd76e362dbef053fcde8cdf4d7f62239:. +6669845cf3ca47533736d5756c73dd85:. # end context for . # begin context for .github/workflows/workflow.yml @@ -75,7 +75,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project -c375da381bfae0c77c7af1cb51f96580:dune-project +7fce661d51287721f46c47607d6ed8f6:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -125,7 +125,7 @@ fd0946f7f9f5e0e3213b64f7ad42a6e4:opam/cobol_parser.opam # begin context for opam/cobol_typeck.opam # file opam/cobol_typeck.opam -13f2cab3e082a2e491f577df4e03ef8b:opam/cobol_typeck.opam +330a70555d064b59bcbd25ef6dabe2ef:opam/cobol_typeck.opam # end context for opam/cobol_typeck.opam # begin context for opam/cobol_unit.opam @@ -380,7 +380,7 @@ e31b22f1d241d75db90f170f9c6fd95d:src/lsp/cobol_preproc/dune # begin context for src/lsp/cobol_typeck/dune # file src/lsp/cobol_typeck/dune -ef30db283bff57bd7bfea9b29e9178fd:src/lsp/cobol_typeck/dune +11df07aa7e59dd5f6f690da14b82b8b5:src/lsp/cobol_typeck/dune # end context for src/lsp/cobol_typeck/dune # begin context for src/lsp/cobol_typeck/version.mlt diff --git a/dune-project b/dune-project index f811a7291..8eafe46fd 100644 --- a/dune-project +++ b/dune-project @@ -407,6 +407,8 @@ (description "SuperBOL Studio OSS is a new platform for COBOL") (depends (ocaml (>= 4.14.0)) + (superbol_preprocs (= version)) + (sql_ast (= version)) (cobol_unit (= version)) (cobol_ptree (= version)) (cobol_parser (= version)) diff --git a/opam/cobol_typeck.opam b/opam/cobol_typeck.opam index 780d608ef..be94efba9 100644 --- a/opam/cobol_typeck.opam +++ b/opam/cobol_typeck.opam @@ -47,6 +47,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "superbol_preprocs" {= version} + "sql_ast" {= version} "cobol_unit" {= version} "cobol_ptree" {= version} "cobol_parser" {= version} diff --git a/opam/osx/cobol_typeck-osx.opam b/opam/osx/cobol_typeck-osx.opam index b06df7478..6f252988e 100644 --- a/opam/osx/cobol_typeck-osx.opam +++ b/opam/osx/cobol_typeck-osx.opam @@ -49,6 +49,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "superbol_preprocs-osx" {= version} + "sql_ast-osx" {= version} "cobol_unit-osx" {= version} "cobol_ptree-osx" {= version} "cobol_parser-osx" {= version} diff --git a/opam/windows/cobol_typeck-windows.opam b/opam/windows/cobol_typeck-windows.opam index 943840030..75466993a 100644 --- a/opam/windows/cobol_typeck-windows.opam +++ b/opam/windows/cobol_typeck-windows.opam @@ -49,6 +49,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "superbol_preprocs-windows" {= version} + "sql_ast-windows" {= version} "cobol_unit-windows" {= version} "cobol_ptree-windows" {= version} "cobol_parser-windows" {= version} diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml index 2fc7a2d0c..0f6849702 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lsp_lookup.ml @@ -195,6 +195,45 @@ let element_at_position ~uri pos group : element_at_position = Visitor.skip_children @@ on_proc_name (qualname_at_pos ~filename qn pos) acc + method! fold_exec_block' exec_block acc = + let acc = match exec_block.payload with + | Superbol_preprocs.Generic.Generic_exec_block _ -> + acc + | Superbol_preprocs.Esql.Esql_exec_block esql -> + let cob_var_extractor_folder = object + inherit [Sql_ast.cobol_var list] Sql_ast.Visitor.folder + method! fold_cobol_var cob_var acc = + if List.exists (fun c -> Sql_ast.compare_cobol_var cob_var c == 0) acc + then Cobol_common.Visitor.skip acc + else Cobol_common.Visitor.skip (cob_var::acc) + end in + let cobol_vars = + Sql_ast.Visitor.fold_esql_instruction cob_var_extractor_folder + esql [] + in + let string_name_opt = List.filter_map begin function + | Sql_ast.CobVarNotNull cobol_var_id + | CobVarCasted (cobol_var_id, _) -> + if Lsp_position.is_in_srcloc ~filename pos ~@cobol_var_id + then Some cobol_var_id + else None + | CobVarNullIndicator (cobol_var_id, _) + when Lsp_position.is_in_srcloc ~filename pos ~@cobol_var_id -> + Some cobol_var_id + | CobVarNullIndicator (_, cobol_var_id) + when Lsp_position.is_in_srcloc ~filename pos ~@cobol_var_id -> + Some cobol_var_id + | CobVarNullIndicator _ -> None + end cobol_vars + in + let acc = match string_name_opt with + | [name] -> on_data_name (Name name) acc + | _ -> acc + in acc + | _ -> acc + in + Visitor.skip_children acc + end group init |> result (* --- *) diff --git a/src/lsp/cobol_typeck/dune b/src/lsp/cobol_typeck/dune index a08644027..dd4aef816 100644 --- a/src/lsp/cobol_typeck/dune +++ b/src/lsp/cobol_typeck/dune @@ -5,7 +5,7 @@ (public_name cobol_typeck) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries cobol_unit cobol_ptree cobol_parser cobol_data cobol_common ) + (libraries superbol_preprocs sql_ast cobol_unit cobol_ptree cobol_parser cobol_data cobol_common ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/cobol_typeck/package.toml b/src/lsp/cobol_typeck/package.toml index 454ef2fff..96de7606b 100644 --- a/src/lsp/cobol_typeck/package.toml +++ b/src/lsp/cobol_typeck/package.toml @@ -21,8 +21,8 @@ kind = "library" # 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" ] +# supported file generators are "ocamllex", "ocamlyacc" and "menhir" +# default is [ "ocamllex", "ocamlyacc" ] # generators = [ "ocamllex", "menhir" ] # menhir options for the package @@ -42,7 +42,7 @@ gen-version = "version.ml" # pack = "Mylib" # preprocessing options -# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))" +# 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 @@ -51,13 +51,15 @@ skip = ["index.mld"] # package library dependencies # [dependencies] # ez_file = ">=0.1 <1.3" -# base-unix = { libname = "unix", version = ">=base" } +# base-unix = { libname = "unix", version = ">=base" } [dependencies] cobol_ptree = "version" cobol_common = "version" cobol_data = "version" cobol_parser = "version" cobol_unit = "version" +superbol_preprocs = "version" +sql_ast = "version" # package tools dependencies [tools] @@ -65,14 +67,14 @@ ppx_deriving = ">=5.2.1" # 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" +# 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_typeck/typeck_procedure.ml b/src/lsp/cobol_typeck/typeck_procedure.ml index e201afc6d..05e6bada8 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.ml +++ b/src/lsp/cobol_typeck/typeck_procedure.ml @@ -249,6 +249,49 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure in Visitor.skip_children acc + method! fold_exec_block' exec_block acc = + let register_name name acc = + let qn = Cobol_ptree.Name name in + let loc = name.loc in + begin try + let bnd = Qualmap.find_binding qn data_definitions.data_items.named in + { acc with + refs = Typeck_outputs.register_data_qualref + ~loc bnd.full_qn acc.refs } + with + | Not_found -> + acc (* ignored for now, as we don't process all the DATA DIV. yet. *) + | Qualmap.Ambiguous (lazy matching_qualnames) -> + error acc @@ Ambiguous_data_name { given_qualname = qn &@ loc; + matching_qualnames } + end in + let acc = match exec_block.payload with + | Superbol_preprocs.Generic.Generic_exec_block _ -> + acc + | Superbol_preprocs.Esql.Esql_exec_block esql -> + let cob_var_extractor_folder = object + inherit [Sql_ast.cobol_var list] Sql_ast.Visitor.folder + method! fold_cobol_var cob_var acc = + if List.exists (fun c -> Sql_ast.compare_cobol_var cob_var c == 0) acc + then Cobol_common.Visitor.skip acc + else Cobol_common.Visitor.skip (cob_var::acc) + end in + let cobol_vars = + Sql_ast.Visitor.fold_esql_instruction cob_var_extractor_folder + esql [] + in + List.fold_left begin fun acc -> function + | Sql_ast.CobVarNotNull cobol_var_id + | CobVarCasted (cobol_var_id, _) -> + register_name cobol_var_id acc + | CobVarNullIndicator (cobol_var_id, cobol_var_id_2) -> + register_name cobol_var_id acc |> + register_name cobol_var_id_2 + end acc cobol_vars + | _ -> acc + in + Visitor.skip_children acc + end in Cobol_unit.Visitor.fold_procedure visitor procedure init |> references diff --git a/src/lsp/sql_parser/sql_parser.ml b/src/lsp/sql_parser/sql_parser.ml index 8702a6cab..2f73899e1 100644 --- a/src/lsp/sql_parser/sql_parser.ml +++ b/src/lsp/sql_parser/sql_parser.ml @@ -65,9 +65,15 @@ let parse text = ([], None) text |> fst |> List.rev in - let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in - (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) - ast + match tokens with + | Grammar.((EXECUTE, _, _) :: (SQL, _, _) :: (IGNORE, _, _) :: _) + | Grammar.((EXEC, _, _) :: (SQL, _, _) :: (IGNORE, _, _) :: _) -> + (* failsafe to avoid parsing potentially breaking SQL IGNORE sections *) + Sql_ast.Ignore [] + | _ -> + let ast = Grammar.MenhirInterpreter.loop (supplier tokens) init_checkpoint in + (* Format.fprintf Format.std_formatter "\n%a\n" Sql_ast.Printer.pp ast; *) + ast let parseString str = let ast = Grammar.main Lexer.token str in diff --git a/src/lsp/sql_preproc/generate.ml b/src/lsp/sql_preproc/generate.ml index 4e5c8ff29..e16ec5243 100644 --- a/src/lsp/sql_preproc/generate.ml +++ b/src/lsp/sql_preproc/generate.ml @@ -993,7 +993,6 @@ let generate ~filename ~contents ~cobol_unit sql_statements = :: (working_storage_section @ output cur_lines statements) end | EXEC_SQL_IGNORE { end_loc; begin_of_ignore_loc } -> - Printf.eprintf "%d,%d\n" begin_of_ignore_loc.line begin_of_ignore_loc.char; begin if i = begin_loc.line then [comment "ESQL IGNORED SECTION"] else [] end diff --git a/src/lsp/superbol_preprocs/main.ml b/src/lsp/superbol_preprocs/main.ml index f515090fc..088970a5f 100644 --- a/src/lsp/superbol_preprocs/main.ml +++ b/src/lsp/superbol_preprocs/main.ml @@ -18,8 +18,8 @@ let exec_scanners = exec_scanner_fallback = Generic.scanner; (* for now; TODO: Call.scanner? *) (* NB: Kept empty for now (the LSP does not yet benefit from this preprocessor) *) - exec_scanners = Cobol_preproc.Options.EXEC_MAP.empty; - (* exec_scanners = Cobol_preproc.Options.EXEC_MAP.singleton "SQL" Esql.scanner; *) + (* exec_scanners = Cobol_preproc.Options.EXEC_MAP.empty; *) + exec_scanners = Cobol_preproc.Options.EXEC_MAP.singleton "SQL" Esql.scanner; } let more scanners = From d9adafda278b568fd905ac311309dc69d4de41a8 Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 16 Oct 2024 16:27:33 +0200 Subject: [PATCH 30/37] test: autopromote --- test/output-tests/reparse.expected | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/output-tests/reparse.expected b/test/output-tests/reparse.expected index 898c08b44..436b24297 100644 --- a/test/output-tests/reparse.expected +++ b/test/output-tests/reparse.expected @@ -113,7 +113,7 @@ Re-parsing `test/testsuite/sql/sql_exec/sql_test04.cbl': Re-parsing `test/testsuite/sql/sql_exec/sql_test05.cbl': Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/sql_exec/sql_test06.cbl': - Parse: Failure. + Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/sql_exec/sql_test07.cbl': Parse: Failure. Re-parsing `test/testsuite/sql/sql_exec/sql_test08.cbl': @@ -169,7 +169,7 @@ Re-parsing `test/testsuite/sql/gixsql_test/TSQL009A.cbl': Re-parsing `test/testsuite/sql/gixsql_test/TSQL010A.cbl': Parse: OK. Reparse: Failure. Re-parsing `test/testsuite/sql/gixsql_test/TSQL011A.cbl': - Parse: Failure. + Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL012A.cbl': Parse: OK. Reparse: OK. Re-parsing `test/testsuite/sql/gixsql_test/TSQL013A.cbl': From 3c5fc3b5bae9d8a863e3e8a091af9a5c277fad47 Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 12:51:24 +0200 Subject: [PATCH 31/37] Add gixsql submodule --- .gitmodules | 3 +++ import/gixsql | 1 + 2 files changed, 4 insertions(+) create mode 160000 import/gixsql diff --git a/.gitmodules b/.gitmodules index ebaec40d4..e7556b1ae 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,3 +9,6 @@ path = import/superbol-vscode-debug url = https://github.com/OCamlPro/superbol-vscode-debug.git branch = superbol-vscode-debug +[submodule "import/gixsql"] + path = import/gixsql + url = git@github.com:OCamlPro/gixsql.git diff --git a/import/gixsql b/import/gixsql new file mode 160000 index 000000000..1bc323412 --- /dev/null +++ b/import/gixsql @@ -0,0 +1 @@ +Subproject commit 1bc323412b3a3d195b970343a91349e8ff9835bc From bcc49c08c923e01a979a65fe1ac3324f7ff6a66c Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 17:41:23 +0200 Subject: [PATCH 32/37] Add wrapper for the test script --- Makefile | 1 + import/gixsql | 2 +- scripts/test-gixsql.sh | 14 ++++++++++++++ 3 files changed, 16 insertions(+), 1 deletion(-) create mode 100755 scripts/test-gixsql.sh diff --git a/Makefile b/Makefile index 9deae20e8..4582e83b0 100644 --- a/Makefile +++ b/Makefile @@ -88,6 +88,7 @@ test: ./scripts/before.sh test ${DUNE} build ${DUNE_ARGS} ${DUNE_CROSS_ARGS} @runtest ${MAKE} test-syntax + ./scripts/test-gixsql.sh ./scripts/after.sh test clean: diff --git a/import/gixsql b/import/gixsql index 1bc323412..a8cc810b4 160000 --- a/import/gixsql +++ b/import/gixsql @@ -1 +1 @@ -Subproject commit 1bc323412b3a3d195b970343a91349e8ff9835bc +Subproject commit a8cc810b4735f18c874bd5815b8427d41db9b9a5 diff --git a/scripts/test-gixsql.sh b/scripts/test-gixsql.sh new file mode 100755 index 000000000..3364e2b2b --- /dev/null +++ b/scripts/test-gixsql.sh @@ -0,0 +1,14 @@ +#!/bin/sh +set -eu +trap "cd \"$PWD\"" EXIT + +if ! command -v nix 2>&1 >/dev/null +then + echo "GixSQL tests ignored. Install nix to run them." + exit 0 +fi + +cd "import/gixsql" + +# Run tests with the legacy preprocessor +LEGACY_PP="" nix develop --command ./run_test.sh From c89baa71a53d590312becbe1b49f04b51b724b39 Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 17:43:47 +0200 Subject: [PATCH 33/37] Add nix in the GitHub workflow --- .github/workflows/workflow.yml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 91e705cf2..3fd719e05 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -71,7 +71,7 @@ jobs: # if: steps.cache-opam.outputs.cache-hit == 'true' # Use fields.build-scripts to add more scripts to convert here - - run: dos2unix scripts/*.sh + - run: dos2unix scripts/*.sh if: matrix.os == 'windows-latest' # Use fields.github-workflow-before-build to add something here @@ -91,6 +91,12 @@ jobs: if: matrix.skip_test != 'true' run: make dev-deps + - name: install nix + if: matrix.skip_test != 'true' + uses: cachix/install-nix-action@v27 + with: + nix_path: nixpkgs=channel:nixos-unstable + - name: run test suite run: make test if: matrix.skip_test != 'true' From d613b9f1258be22ae63c16175fcf34d9fb86d3fa Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 17:59:13 +0200 Subject: [PATCH 34/37] Add the new preprocessor --- scripts/test-gixsql.sh | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/scripts/test-gixsql.sh b/scripts/test-gixsql.sh index 3364e2b2b..ea0b5e1cc 100755 --- a/scripts/test-gixsql.sh +++ b/scripts/test-gixsql.sh @@ -12,3 +12,7 @@ cd "import/gixsql" # Run tests with the legacy preprocessor LEGACY_PP="" nix develop --command ./run_test.sh + +# Run tests with the new preprocessor +SUPERBOL_BIN="_build/install/default/bin/superbol-free" \ + nix develop -- command ./run_test.sh From 72a4bff6d31a762789daee355897dac2e681b791 Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 18:01:27 +0200 Subject: [PATCH 35/37] Use a public address for gixsql submodule --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index e7556b1ae..f78a51de5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -11,4 +11,4 @@ branch = superbol-vscode-debug [submodule "import/gixsql"] path = import/gixsql - url = git@github.com:OCamlPro/gixsql.git + url = https://github.com/OCamlPro/gixsql.git From e141aac36084a9ebbb77cf2ff002fa7044a5a662 Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Thu, 17 Oct 2024 18:50:38 +0200 Subject: [PATCH 36/37] Use the Drom templates --- .drom | 4 ++-- .github/workflows/workflow.yml | 2 +- .github/workflows/workflow.yml.drom-tpl | 6 ++++++ Makefile.drom-tpl | 1 + import/gixsql | 2 +- scripts/test-gixsql.sh | 8 ++++---- 6 files changed, 15 insertions(+), 8 deletions(-) diff --git a/.drom b/.drom index 22c1e4e7f..a9666d6fc 100644 --- a/.drom +++ b/.drom @@ -10,7 +10,7 @@ version:0.9.0 # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -73b824a03b4a4f5c15db8791f70c6bc6:.github/workflows/workflow.yml +337022990706f74315eade01ae89fc73:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore @@ -25,7 +25,7 @@ version:0.9.0 # begin context for Makefile # file Makefile -0195ab922c6b2c04b5cc71036d59fe5e:Makefile +adcd250ca44ed88e912c8cebfaf88aab:Makefile # end context for Makefile # begin context for README.md diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 3fd719e05..bc58c3f8f 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -71,7 +71,7 @@ jobs: # if: steps.cache-opam.outputs.cache-hit == 'true' # Use fields.build-scripts to add more scripts to convert here - - run: dos2unix scripts/*.sh + - run: dos2unix scripts/*.sh if: matrix.os == 'windows-latest' # Use fields.github-workflow-before-build to add something here diff --git a/.github/workflows/workflow.yml.drom-tpl b/.github/workflows/workflow.yml.drom-tpl index 55cafceba..68b839911 100644 --- a/.github/workflows/workflow.yml.drom-tpl +++ b/.github/workflows/workflow.yml.drom-tpl @@ -84,6 +84,12 @@ jobs: # Use fields.github-workflow-after-build to add something here !(github-workflow-after-build) + - name: install nix + if: matrix.skip_test != 'true' + uses: cachix/install-nix-action@v27 + with: + nix_path: nixpkgs=channel:nixos-unstable + - name: run test suite run: make test if: matrix.skip_test != 'true' diff --git a/Makefile.drom-tpl b/Makefile.drom-tpl index d128ecb7d..ed8cb9a53 100644 --- a/Makefile.drom-tpl +++ b/Makefile.drom-tpl @@ -88,6 +88,7 @@ test: ./scripts/before.sh test ${DUNE} build ${DUNE_ARGS} ${DUNE_CROSS_ARGS} @runtest ${MAKE} test-syntax + ./scripts/test-gixsql.sh ./scripts/after.sh test clean: diff --git a/import/gixsql b/import/gixsql index a8cc810b4..3e6b3097c 160000 --- a/import/gixsql +++ b/import/gixsql @@ -1 +1 @@ -Subproject commit a8cc810b4735f18c874bd5815b8427d41db9b9a5 +Subproject commit 3e6b3097c0ab3b5260d2cf56da1fe5a376cc63f2 diff --git a/scripts/test-gixsql.sh b/scripts/test-gixsql.sh index ea0b5e1cc..9ef577097 100755 --- a/scripts/test-gixsql.sh +++ b/scripts/test-gixsql.sh @@ -1,6 +1,5 @@ #!/bin/sh set -eu -trap "cd \"$PWD\"" EXIT if ! command -v nix 2>&1 >/dev/null then @@ -11,8 +10,9 @@ fi cd "import/gixsql" # Run tests with the legacy preprocessor -LEGACY_PP="" nix develop --command ./run_test.sh +# LEGACY_PP="" nix develop --command ./run_test.sh # Run tests with the new preprocessor -SUPERBOL_BIN="_build/install/default/bin/superbol-free" \ - nix develop -- command ./run_test.sh +export TEST_VERBOSITY=1 +SUPERBOL_PP="/home/tiky/git/superbol-studio-oss/_build/install/default/bin/superbol-free" \ + nix develop --command ./run_test.sh From cb8866a3b5e7e8fd9915197ba65cf0da4c38fdbb Mon Sep 17 00:00:00 2001 From: Pierre Villemot Date: Fri, 18 Oct 2024 12:02:30 +0200 Subject: [PATCH 37/37] Absolute path to superbol-free in the runner --- .drom | 2 +- .github/workflows/workflow.yml | 2 ++ .github/workflows/workflow.yml.drom-tpl | 2 ++ scripts/test-gixsql.sh | 5 ++--- 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/.drom b/.drom index a9666d6fc..ca8db36f6 100644 --- a/.drom +++ b/.drom @@ -10,7 +10,7 @@ version:0.9.0 # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -337022990706f74315eade01ae89fc73:.github/workflows/workflow.yml +155c63a637995fa5bc8cf0cd89fcc6bb:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index bc58c3f8f..a0176d3dc 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -100,6 +100,8 @@ jobs: - name: run test suite run: make test if: matrix.skip_test != 'true' + env: + SUPERBOL_PP: "${{ github.workspace }}/_build/install/default/bin/superbol-free" - name: show test result on failure if: failure() diff --git a/.github/workflows/workflow.yml.drom-tpl b/.github/workflows/workflow.yml.drom-tpl index 68b839911..75bec4b5c 100644 --- a/.github/workflows/workflow.yml.drom-tpl +++ b/.github/workflows/workflow.yml.drom-tpl @@ -93,6 +93,8 @@ jobs: - name: run test suite run: make test if: matrix.skip_test != 'true' + env: + SUPERBOL_PP: "${{ github.workspace }}/_build/install/default/bin/superbol-free" - name: show test result on failure if: failure() diff --git a/scripts/test-gixsql.sh b/scripts/test-gixsql.sh index 9ef577097..575e1dab5 100755 --- a/scripts/test-gixsql.sh +++ b/scripts/test-gixsql.sh @@ -1,7 +1,7 @@ #!/bin/sh set -eu -if ! command -v nix 2>&1 >/dev/null +if ! command -v nix >/dev/null 2>&1 then echo "GixSQL tests ignored. Install nix to run them." exit 0 @@ -14,5 +14,4 @@ cd "import/gixsql" # Run tests with the new preprocessor export TEST_VERBOSITY=1 -SUPERBOL_PP="/home/tiky/git/superbol-studio-oss/_build/install/default/bin/superbol-free" \ - nix develop --command ./run_test.sh +nix develop --command ./run_test.sh