From 447f2809052165bc1e263f112d452ab7f319bfc5 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Tue, 17 Oct 2023 16:40:40 +0200 Subject: [PATCH 1/2] Do not ignore compiler directives when folding over source lines --- .drom | 4 +- src/lsp/cobol_common/diagnostics.ml | 4 + src/lsp/cobol_common/diagnostics.mli | 1 + src/lsp/cobol_config/cobol_config.ml | 2 + src/lsp/cobol_config/cobol_config.mli | 2 + src/lsp/cobol_indent/cobol_indent.ml | 11 +- src/lsp/cobol_indent/indenter.ml | 14 +- src/lsp/cobol_indent/indenter.mli | 3 +- src/lsp/cobol_lsp/lsp_request.ml | 6 +- src/lsp/cobol_lsp/lsp_semtoks.ml | 2 +- src/lsp/cobol_preproc/.gitattributes | 2 + src/lsp/cobol_preproc/compdir_grammar.mly | 78 ++++++++ src/lsp/cobol_preproc/compdir_keywords.ml | 20 ++ src/lsp/cobol_preproc/compdir_tree.ml | 19 ++ src/lsp/cobol_preproc/dune | 13 ++ src/lsp/cobol_preproc/grammar_common.mly | 11 +- src/lsp/cobol_preproc/package.toml | 13 ++ src/lsp/cobol_preproc/preproc_directives.ml | 5 +- src/lsp/cobol_preproc/preproc_engine.ml | 147 ++++++--------- src/lsp/cobol_preproc/preproc_engine.mli | 54 ++++-- src/lsp/cobol_preproc/preproc_grammar.mly | 33 +--- src/lsp/cobol_preproc/preproc_grammar_sig.ml | 4 - src/lsp/cobol_preproc/preproc_keywords.ml | 8 - src/lsp/cobol_preproc/preproc_tokens.mly | 9 +- src/lsp/cobol_preproc/preproc_trace.ml | 9 +- src/lsp/cobol_preproc/preproc_trace.mli | 8 +- src/lsp/cobol_preproc/preproc_utils.ml | 7 - src/lsp/cobol_preproc/preproc_utils.mli | 5 - src/lsp/cobol_preproc/src_lexer.mli | 9 + src/lsp/cobol_preproc/src_lexer.mll | 40 +++- src/lsp/cobol_preproc/src_reader.ml | 177 ++++++++++++++---- src/lsp/cobol_preproc/src_reader.mli | 26 ++- src/lsp/cobol_preproc/text_processor.ml | 1 - src/lsp/cobol_preproc/text_processor.mli | 2 - src/lsp/cobol_preproc/text_supplier.ml | 53 +++++- src/lsp/cobol_preproc/text_supplier.mli | 4 + .../superbol_free_lib/command_indent_range.ml | 4 +- src/lsp/superbol_free_lib/command_pp.ml | 1 + test/cobol_parsing/dune | 2 +- test/cobol_parsing/parser_testing.ml | 19 +- .../compiler_directives.ml | 4 +- test/cobol_preprocessing/dune | 15 ++ test/cobol_preprocessing/preproc_testing.ml | 54 ++++++ test/cobol_preprocessing/source_lines.ml | 153 +++++++++++++++ test/lsp/lsp_formatting.ml | 9 - test/output-tests/preproc.ml | 6 +- test/output-tests/syn_misc.expected | 40 ---- 47 files changed, 787 insertions(+), 326 deletions(-) create mode 100644 src/lsp/cobol_preproc/.gitattributes create mode 100644 src/lsp/cobol_preproc/compdir_grammar.mly create mode 100644 src/lsp/cobol_preproc/compdir_keywords.ml create mode 100644 src/lsp/cobol_preproc/compdir_tree.ml rename test/{cobol_parsing => cobol_preprocessing}/compiler_directives.ml (95%) create mode 100644 test/cobol_preprocessing/dune create mode 100644 test/cobol_preprocessing/preproc_testing.ml create mode 100644 test/cobol_preprocessing/source_lines.ml diff --git a/.drom b/.drom index a0c16bac8..1e9fca9fd 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -65727d1df3313fa04a075346c1986694:. +f593ca640b0428b52f00f9a54b784372:. # end context for . # begin context for .github/workflows/workflow.yml @@ -340,7 +340,7 @@ c830729656f586961a44188b55cb4ac6:src/lsp/cobol_data/dune # begin context for src/lsp/cobol_preproc/dune # file src/lsp/cobol_preproc/dune -801b4cd6ad70e6c633b48431afb67519:src/lsp/cobol_preproc/dune +72290e9f09cebbc9fdea47a9045c0330:src/lsp/cobol_preproc/dune # end context for src/lsp/cobol_preproc/dune # begin context for src/lsp/cobol_preproc/version.mlt diff --git a/src/lsp/cobol_common/diagnostics.ml b/src/lsp/cobol_common/diagnostics.ml index 7aa6f6c03..e6de4be27 100644 --- a/src/lsp/cobol_common/diagnostics.ml +++ b/src/lsp/cobol_common/diagnostics.ml @@ -211,6 +211,10 @@ let cons_option_result = function let forget_result { diags; _ } = diags let merge_results ~f r1 r2 = result (f r1.result r2.result) ~diags:(Set.union r1.diags r2.diags) +let show_n_forget ?(ppf = Fmt.stderr) { result; diags } = + Set.pp ppf diags; + result + let hint_result r = Cont.khint (with_diag r) let note_result r = Cont.knote (with_diag r) diff --git a/src/lsp/cobol_common/diagnostics.mli b/src/lsp/cobol_common/diagnostics.mli index 18eb970f4..8dd0404eb 100644 --- a/src/lsp/cobol_common/diagnostics.mli +++ b/src/lsp/cobol_common/diagnostics.mli @@ -115,6 +115,7 @@ val more_result: f:('a -> 'b with_diags) -> 'a with_diags -> 'b with_diags val cons_option_result: 'a option with_diags -> 'a list with_diags -> 'a list with_diags val forget_result: _ with_diags -> diagnostics val merge_results: f:('a -> 'b -> 'c) -> 'a with_diags -> 'b with_diags -> 'c with_diags +val show_n_forget: ?ppf:Format.formatter -> 'a with_diags -> 'a val hint_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func val note_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func diff --git a/src/lsp/cobol_config/cobol_config.ml b/src/lsp/cobol_config/cobol_config.ml index 483266124..b7bace9eb 100644 --- a/src/lsp/cobol_config/cobol_config.ml +++ b/src/lsp/cobol_config/cobol_config.ml @@ -283,3 +283,5 @@ let from_dialect (module Diags: DIAGS.STATEFUL) ~strict d = | Realia -> load_gnucobol_conf d ~strict "realia" | RM -> load_gnucobol_conf d ~strict "rm" | XOpen -> load_gnucobol_conf d ~strict "xopen" + +let dialect (module C: T) = C.dialect diff --git a/src/lsp/cobol_config/cobol_config.mli b/src/lsp/cobol_config/cobol_config.mli index 098d5592e..ebdc387ed 100644 --- a/src/lsp/cobol_config/cobol_config.mli +++ b/src/lsp/cobol_config/cobol_config.mli @@ -38,3 +38,5 @@ val from_dialect -> strict: bool -> Types.DIALECT.t -> (module T) + +val dialect: t -> dialect diff --git a/src/lsp/cobol_indent/cobol_indent.ml b/src/lsp/cobol_indent/cobol_indent.ml index 449ab69cb..ad15b12d0 100644 --- a/src/lsp/cobol_indent/cobol_indent.ml +++ b/src/lsp/cobol_indent/cobol_indent.ml @@ -11,20 +11,17 @@ (* *) (**************************************************************************) -(* If you delete or rename this file, you should add - 'src/cobol_indent/main.ml' to the 'skip' field in "drom.toml" *) - module Type = Indent_type (*return the result of indentation. use user-defined indent_config*) let indent_range' = Indenter.indent_range' (*indent the whole file and print*) -let indent_file ~source_format ~file ~indent_config = - indent_range' ~source_format ~range:None ~indent_config ~file +let indent_file ~dialect ~source_format ~file ~indent_config = + indent_range' ~dialect ~source_format ~range:None ~indent_config ~file |> Fmt.pr "%s" (*indent a range of file and print*) -let indent_range ~source_format ~file ~range ~indent_config = - indent_range' ~source_format ~range ~indent_config ~file +let indent_range ~dialect ~source_format ~file ~range ~indent_config = + indent_range' ~dialect ~source_format ~range ~indent_config ~file |> Fmt.pr "%s" diff --git a/src/lsp/cobol_indent/indenter.ml b/src/lsp/cobol_indent/indenter.ml index 7a7c3c103..f575214a0 100644 --- a/src/lsp/cobol_indent/indenter.ml +++ b/src/lsp/cobol_indent/indenter.ml @@ -62,7 +62,7 @@ let indenter ~source_format (str:string) (rdl:indent_record list) range = String.concat "\n" strl (*indent a range of file, with the default indent_config*) -let indent_range' ~source_format ~range ~file = +let indent_range' ~dialect ~source_format ~range ~file = let file_content = Ez_file.V1.EzFile.read_file file in (* Not satisfied with the `Cobol_preproc.fold_text_lines`, @@ -72,17 +72,19 @@ let indent_range' ~source_format ~range ~file = (* NB: not anymore. *) *) let state = - Cobol_preproc.fold_source_lines ~source_format + Cobol_preproc.fold_source_lines ~dialect ~source_format + ~skip_compiler_directives_text:false ~f:(fun _lnum line acc -> Indent_check.check_indentation line acc) (Filename file) { scope = BEGIN; context = []; acc = []; range } in - let ind_recds = state.acc in - indenter ~source_format file_content ind_recds state.range + (* NB: note here we ignore diagnostics *) + let ind_recds = state.result.acc in + indenter ~source_format file_content ind_recds state.result.range (*indent a range of file, with the user-defined indent_config*) -let indent_range' ~source_format ~indent_config ~range ~file = +let indent_range' ~dialect ~source_format ~indent_config ~range ~file = begin match indent_config with | Some indent_config -> Indent_config.set_config ~indent_config | None -> () end; - indent_range' ~source_format ~range ~file + indent_range' ~dialect ~source_format ~range ~file diff --git a/src/lsp/cobol_indent/indenter.mli b/src/lsp/cobol_indent/indenter.mli index 38d3993d7..c6f62793e 100644 --- a/src/lsp/cobol_indent/indenter.mli +++ b/src/lsp/cobol_indent/indenter.mli @@ -13,7 +13,8 @@ (*indent a range of file, with the user-defined or default indent_config*) val indent_range' - : source_format:Cobol_config.source_format_spec + : dialect: Cobol_config.dialect + -> source_format:Cobol_config.source_format_spec -> indent_config:string option -> range:Indent_type.range option -> file:string diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index ef1724105..fcf207b0b 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -177,6 +177,7 @@ let handle_range_formatting registry params = in let newText = Cobol_indent.indent_range' + ~dialect:(Cobol_config.dialect project.cobol_config) ~source_format:project.source_format ~indent_config:None ~file:(Lsp.Uri.to_path doc.uri) @@ -201,6 +202,7 @@ let handle_formatting registry params = try let newText = Cobol_indent.indent_range' + ~dialect:(Cobol_config.dialect project.cobol_config) ~source_format:project.source_format ~indent_config:None ~file:path @@ -233,7 +235,7 @@ let handle_hover registry (params: HoverParams.t) = let find_hovered_pplog_event pplog = List.find_opt begin function | Cobol_preproc.Trace.Replace _ - | LexDir _ -> + | CompilerDirective _ -> false | Replacement { matched_loc = loc; _ } | FileCopy { copyloc = loc; _ } -> @@ -265,7 +267,7 @@ let handle_hover registry (params: HoverParams.t) = Pretty.string_to (hover_markdown ~loc) "```%s\n%s\n```" mdlang text | Some FileCopy { status = MissingCopy _; _ } | Some Replace _ - | Some LexDir _ + | Some CompilerDirective _ | None -> None end diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 91f77eafb..cda010f92 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -570,7 +570,7 @@ let semtoks_of_preproc_statements ~filename ?range pplog = List.rev @@ List.fold_left begin fun acc -> function | Cobol_preproc.Trace.FileCopy { copyloc = loc; _ } | Cobol_preproc.Trace.Replace { replloc = loc } - | Cobol_preproc.Trace.LexDir { loc; _ } -> + | Cobol_preproc.Trace.CompilerDirective { loc; _ } -> acc_semtoks ~filename ?range TOKTYP.macro loc acc | Cobol_preproc.Trace.Replacement _ -> acc diff --git a/src/lsp/cobol_preproc/.gitattributes b/src/lsp/cobol_preproc/.gitattributes new file mode 100644 index 000000000..2ea8d75ec --- /dev/null +++ b/src/lsp/cobol_preproc/.gitattributes @@ -0,0 +1,2 @@ +preproc_keywords.ml linguist-generated +compdir_keywords.ml linguist-generated diff --git a/src/lsp/cobol_preproc/compdir_grammar.mly b/src/lsp/cobol_preproc/compdir_grammar.mly new file mode 100644 index 000000000..d3268bb21 --- /dev/null +++ b/src/lsp/cobol_preproc/compdir_grammar.mly @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* 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 Compdir_tree +%} + +%token EOL +%token TEXT_WORD +%token ALPHANUM +%token CDIR_SET [@keyword ">>SET", "$SET"] +%token CDIR_SOURCE [@keyword ">>SOURCE", "$SOURCE"] +%token FORMAT [@keyword] +%token FREE [@keyword] (* +COB2002 *) +%token IS [@keyword] +%token SOURCEFORMAT [@keyword] + +%token INVALID_ + +(* Entry points *) + +%start compiler_directive + +%start _unused_symbols (* <- used to supress some warnings *) + +(* -------------------------------------------------------------------------- *) + +%% + +(* --------------------- DEDICATED UTILITIES -------------------------------- *) + +let loc (X) == + | x = X; { x, $sloc } + +(* --- Entry points --------------------------------------------------------- *) + +let compiler_directive := + | ~ = compdir_phrase; EOL; < > + | ~ = compdir_microfocus_phrase; EOL; < > + +let compdir_phrase := + | ~ = compdir_source_format; < > + +let compdir_microfocus_phrase := + | ~ = compdir_microfocus_sourceformat; < > + +(* --- >>SOURCE | $ SET SOURCEFORMAT ---------------------------------------- *) + +let compdir_source_format := + | CDIR_SOURCE; FORMAT?; IS?; free = loc(FREE); + { Source_format_is_free (snd free) } + | CDIR_SOURCE; FORMAT?; IS?; i = text_word; + { Source_format_is i } + +let compdir_microfocus_sourceformat := + | CDIR_SET; SOURCEFORMAT; i = loc(ALPHANUM); (* elementary_string_literal? *) + { Set_sourceformat i } + +let text_word == (* text-word with position *) + | ~ = loc(TEXT_WORD); < > + +(* --- Misc ----------------------------------------------------------------- *) + +_unused_symbols: + | INVALID_ +{ () } + +%% diff --git a/src/lsp/cobol_preproc/compdir_keywords.ml b/src/lsp/cobol_preproc/compdir_keywords.ml new file mode 100644 index 000000000..144b1c317 --- /dev/null +++ b/src/lsp/cobol_preproc/compdir_keywords.ml @@ -0,0 +1,20 @@ +(* Caution: this file was automatically generated from compdir_grammar.cmly; do not edit *) +[@@@warning "-33"] (* <- do not warn on unused opens *) + +let keywords = Compdir_grammar.[ + "SOURCEFORMAT", SOURCEFORMAT; + "IS", IS; + "FREE", FREE; + "FORMAT", FORMAT; + ">>SOURCE", CDIR_SOURCE; + "$SOURCE", CDIR_SOURCE; + ">>SET", CDIR_SET; + "$SET", CDIR_SET; +] + +let puncts = Compdir_grammar.[ +] + +let silenced_keywords = Compdir_grammar.[ +] + diff --git a/src/lsp/cobol_preproc/compdir_tree.ml b/src/lsp/cobol_preproc/compdir_tree.ml new file mode 100644 index 000000000..4bbdbcd3a --- /dev/null +++ b/src/lsp/cobol_preproc/compdir_tree.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +open Cobol_common.Srcloc.TYPES + +type directive = + | Source_format_is_free of lexloc + | Source_format_is of (string * lexloc) + | Set_sourceformat of (string * lexloc) diff --git a/src/lsp/cobol_preproc/dune b/src/lsp/cobol_preproc/dune index 7052036d7..998b5f98d 100644 --- a/src/lsp/cobol_preproc/dune +++ b/src/lsp/cobol_preproc/dune @@ -24,6 +24,19 @@ (package cobol_preproc)) ; use field 'dune-trailer' to add more stuff here +(menhir (modules grammar_common compdir_grammar) + (merge_into compdir_grammar) + (flags --cmly --table)) + +(rule + (targets compdir_keywords.ml) + (enabled_if (<> %{profile} "release")) + (deps compdir_grammar.cmly) + (mode promote) + (action + (with-stdout-to %{targets} + (run %{exe:../cobol_parser/keywords/gen_keywords.exe} %{deps})))) + (menhir (modules preproc_tokens grammar_common preproc_grammar) (merge_into preproc_grammar) (flags --cmly --table diff --git a/src/lsp/cobol_preproc/grammar_common.mly b/src/lsp/cobol_preproc/grammar_common.mly index 6bca1937e..519aa7b89 100644 --- a/src/lsp/cobol_preproc/grammar_common.mly +++ b/src/lsp/cobol_preproc/grammar_common.mly @@ -1,13 +1,14 @@ %{ (**************************************************************************) (* *) -(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* SuperBOL OSS Studio *) (* *) -(* All rights reserved. *) -(* This file is distributed under the terms of the GNU Lesser General *) -(* Public License version 2.1, with the special exception on linking *) -(* described in the LICENSE.md file in the root directory. *) +(* 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. *) (* *) (**************************************************************************) diff --git a/src/lsp/cobol_preproc/package.toml b/src/lsp/cobol_preproc/package.toml index b841ab7cc..b419116a3 100644 --- a/src/lsp/cobol_preproc/package.toml +++ b/src/lsp/cobol_preproc/package.toml @@ -78,6 +78,19 @@ version = ">=1.2" [fields] dune-libraries = "str" dune-trailer = """ +(menhir (modules grammar_common compdir_grammar) + (merge_into compdir_grammar) + (flags --cmly --table)) + +(rule + (targets compdir_keywords.ml) + (enabled_if (<> %{profile} "release")) + (deps compdir_grammar.cmly) + (mode promote) + (action + (with-stdout-to %{targets} + (run %{exe:../cobol_parser/keywords/gen_keywords.exe} %{deps})))) + (menhir (modules preproc_tokens grammar_common preproc_grammar) (merge_into preproc_grammar) (flags --cmly --table diff --git a/src/lsp/cobol_preproc/preproc_directives.ml b/src/lsp/cobol_preproc/preproc_directives.ml index 9336bd0b0..208aafe7c 100644 --- a/src/lsp/cobol_preproc/preproc_directives.ml +++ b/src/lsp/cobol_preproc/preproc_directives.ml @@ -14,9 +14,8 @@ open Cobol_common.Srcloc.TYPES open Text.TYPES -type lexing_directive = - | LexDirSource: - 'k Src_format.source_format with_loc -> lexing_directive [@@unboxed] +type compiler_directive = + | CDirSource of Src_format.any with_loc [@@unboxed] type copy_statement = | CDirCopy of diff --git a/src/lsp/cobol_preproc/preproc_engine.ml b/src/lsp/cobol_preproc/preproc_engine.ml index adac77599..4745920ee 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/preproc_engine.ml @@ -53,6 +53,7 @@ and preprocessor_persist = overlay_manager: (module Src_overlay.MANAGER); replacing: Preproc_directives.replacing with_loc list list; copybooks: Cobol_common.Srcloc.copylocs; (* opened copybooks *) + dialect: Cobol_config.dialect; libpath: string list; verbose: bool; show_if_verbose: [`Txt | `Src] list; @@ -113,6 +114,7 @@ let preprocessor input = function overlay_manager = (module Om); replacing = []; copybooks = Cobol_common.Srcloc.no_copy; + dialect = Config.dialect; libpath; verbose; show_if_verbose = [`Src]; @@ -147,28 +149,12 @@ let apply_active_replacing_full { pplog; persist; _ } = match persist with | { replacing = r :: _; _ } -> Text_processor.apply_replacing OnFullText r pplog | _ -> fun text -> text, pplog -(** [lookup_compiler_directive chunk] searches for a compiler-directive - text-word (that starts with either `{v >> v}' or `{v $ v}') in the given - chunk of source text. - - Returns [Ok (prefix, cdir_text)] if a compiler directive is recognised, - where [cdir_text] is guaranteed to start with a compiler-directive word on a - line [l] and terminates at the end [l]. *) -(* Note: {!Text_processor.next_source_chunk} never outputs compiler-directive - text-words in positions other than the first two. Such a chunk also - terminates at the end of the source line as it cannot be continued (contrary - to normal source lines). *) -let lookup_compiler_directive: Text.text -> _ = function - | t :: _ as text when Text.cdirp t -> Ok ([ ], text) - | p :: (t :: _ as text) when Text.cdirp t -> Ok ([p], text) - | _ -> Error `NotCDir - (* --- *) (** [next_chunk lp] reads the next chunk from [lp], handling lexical and compiler directives along the way. It never returns an empty result: the output text always containts at least {!Eof}. *) -let rec next_chunk ({ reader; buff; _ } as lp) = +let rec next_chunk ({ reader; buff; persist = { dialect; _ }; _ } as lp) = match Src_reader.next_chunk reader with | reader, ([{ payload = Eof; _}] as eof) -> let text, pplog = apply_active_replacing_full lp (buff @ eof) in @@ -176,37 +162,23 @@ let rec next_chunk ({ reader; buff; _ } as lp) = | reader, text -> if show `Src lp then Pretty.error "Src: %a@." Text.pp_text text; - match lookup_compiler_directive text with - | Error `NotCDir -> + match Src_reader.try_compiler_directive ~dialect text with + | Ok None -> preprocess_line { lp with reader; buff = [] } (buff @ text) - | Ok ([], lexdir_text) -> - next_chunk @@ on_lexing_directive { lp with reader } lexdir_text - | Ok (text, lexdir_text) -> + | Ok Some ([], compdir, _) -> + next_chunk (apply_compiler_directive { lp with reader } compdir) + | Ok Some (text, compdir, _) -> let lp = { lp with reader; buff = [] } in - preprocess_line (on_lexing_directive lp lexdir_text) (buff @ text) - -and on_lexing_directive ({ persist = { pparser = (module Pp); - overlay_manager = om; _ }; - reader; _ } as lp) lexdir_text = - (* Here, [lexdir_text] is never empty as it's known to start with a compiler - directive marker `>>` (or `$` for MF-style directives), so we should always - have a loc: *) - let supplier = Text_supplier.pptoks_of_text_supplier om lexdir_text in - let loc = Option.get @@ Cobol_common.Srcloc.concat_locs lexdir_text in - let parser = Pp.Incremental.lexing_directive (position lp) in - match ~&(Pp.MenhirInterpreter.loop supplier parser) with - | { result = Some Preproc_directives.LexDirSource sf as lexdir; diags } -> - let pplog = Preproc_trace.new_lexdir ~loc ?lexdir lp.pplog in - let lp = add_diags lp diags in - let lp = with_pplog lp pplog in + preprocess_line (apply_compiler_directive lp compdir) (buff @ text) + | Error (text, e, _) -> + let diag = Src_reader.error_diagnostic e in + let lp = add_diag { lp with reader; buff = [] } diag in + preprocess_line lp (buff @ text) + +and apply_compiler_directive ({ reader; pplog; _ } as lp) = function + | { payload = Preproc_directives.CDirSource sf as compdir; loc } -> + let lp = with_pplog lp @@ Preproc_trace.new_compdir ~loc ~compdir pplog in with_reader lp (Src_reader.with_source_format sf reader) - | { result = None; diags } -> (* valid lexdir with erroneous semantics *) - let pplog = Preproc_trace.new_lexdir ~loc lp.pplog in - let lp = with_pplog lp pplog in - add_diags lp diags - | exception Pp.Error -> - DIAGS.Cont.kerror (add_diag lp) ~loc - "Malformed@ or@ unknown@ compiler@ directive" and preprocess_line lp srctext = match try_preproc lp srctext with @@ -423,47 +395,44 @@ let preprocessor ?(options = Preproc_options.default) input = {!preprocess_file}. *) let default_oppf = Fmt.stdout -let lex_file ~source_format ?(ppf = default_oppf) = - Cobol_common.do_unit begin fun (module DIAGS) input -> - let source_format = - DIAGS.grab_diags @@ decide_source_format input source_format in - Src_reader.print_lines ppf (make_reader ~source_format input) - end - -let lex_lib ~source_format ~libpath ?(ppf = default_oppf) = - Cobol_common.do_unit begin fun (module DIAGS) libname -> - match Cobol_common.Copybook.find_lib ~libpath libname with - | Ok filename -> - let source_format = - DIAGS.grab_diags @@ - decide_source_format (Filename filename) source_format in - Src_reader.print_lines ppf @@ - Src_reader.from_file ~source_format filename - | Error lnf -> - DIAGS.error "%a" Cobol_common.Copybook.pp_lookup_error lnf - end - -let fold_source_lines ~source_format ?epf ~f = - Cobol_common.do_any ?epf begin fun (module DIAGS) input -> - let source_format = - DIAGS.grab_diags @@ decide_source_format input source_format in - Src_reader.fold_lines (make_reader ~source_format input) ~f - end - -let pp_preprocessed ppf lp = - Pretty.print ppf "%a@." Text.pp_text (fst @@ full_text ~item:"file" lp) - -let preprocess_file ?options ?(ppf = default_oppf) = - Cobol_common.do_unit begin fun _init_diags filename -> - pp_preprocessed ppf @@ preprocessor ?options (Filename filename) - end - -let text_of_input ?options ?epf a = - Cobol_common.do_any begin fun _init_diags input -> - fst @@ - full_text ~item:"file" @@ - preprocessor ?options input - end ?epf a - -let text_of_file ?options ?epf filename = - text_of_input ?options ?epf (Filename filename) +let lex_file ~dialect ~source_format ?(ppf = default_oppf) input = + let { result = source_format; diags } = + decide_source_format input source_format in + DIAGS.result ~diags @@ + Src_reader.print_lines ~dialect ~skip_compiler_directives_text:true ppf @@ + make_reader ~source_format input + +let lex_lib ~dialect ~source_format ~libpath ?(ppf = default_oppf) libname = + match Cobol_common.Copybook.find_lib ~libpath libname with + | Ok filename -> + let { result = source_format; diags } = + decide_source_format (Filename filename) source_format in + DIAGS.result ~diags @@ + Src_reader.print_lines ~dialect ~skip_compiler_directives_text:true ppf @@ + Src_reader.from_file ~source_format filename + | Error lnf -> + DIAGS.error_result () "%a" Cobol_common.Copybook.pp_lookup_error lnf + +let fold_source_lines ~dialect ~source_format + ?skip_compiler_directives_text ?on_compiler_directive + ~f input acc = + let { result = source_format; diags } = + decide_source_format input source_format in + DIAGS.result ~diags @@ + Src_reader.fold_lines ~dialect ~f (make_reader ~source_format input) acc + ?skip_compiler_directives_text ?on_compiler_directive + +let text_of_input ?options input = + let text, pp = full_text ~item:"file" @@ preprocessor ?options input in + DIAGS.result text ~diags:(diags pp) + +let text_of_file ?options filename = + text_of_input ?options (Filename filename) + +let preprocess_input ?options ?(ppf = default_oppf) input = + text_of_input ?options input |> + DIAGS.map_result ~f:(Pretty.print ppf "%a@." Text.pp_text) + +let preprocess_file ?options ?(ppf = default_oppf) filename = + text_of_file ?options filename |> + DIAGS.map_result ~f:(Pretty.print ppf "%a@." Text.pp_text) diff --git a/src/lsp/cobol_preproc/preproc_engine.mli b/src/lsp/cobol_preproc/preproc_engine.mli index 0344b3ae4..c28f9cbb3 100644 --- a/src/lsp/cobol_preproc/preproc_engine.mli +++ b/src/lsp/cobol_preproc/preproc_engine.mli @@ -11,6 +11,8 @@ (* *) (**************************************************************************) +open Cobol_common.Srcloc.TYPES + type preprocessor type input = @@ -49,43 +51,65 @@ val decide_source_format -> Src_format.any Cobol_common.Diagnostics.with_diags val lex_file - : source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.dialect + -> source_format: Cobol_config.source_format_spec -> ?ppf:Format.formatter - -> ?epf:Format.formatter -> input - -> unit + -> unit Cobol_common.Diagnostics.with_diags val lex_lib - : source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.dialect + -> source_format: Cobol_config.source_format_spec -> libpath:string list -> ?ppf:Format.formatter - -> ?epf:Format.formatter -> [< `Alphanum | `Word ] * string - -> unit + -> unit Cobol_common.Diagnostics.with_diags + +(** [fold_source_lines ~dialect ~source_format ~skip_compiler_directives_text + ~on_compiler_directive ~f input acc] applies [f line_number line acc] for + each successive source line [line] of [input]. [line_number] gives the line + number for [line] (starting at [1]). [line] is given empty to [f] if it + corresponds to an empty line in the input, or was a line continuation in the + case of fixed-width reference format. + + When given, [on_compiler_directive] is called {e after} [f] has been fed + with the text of a compiler directive, with the same line number. + When set, [skip_compiler_directives_text] ([false] by default) prevents the + text of compiler directives from being fed to [f]. If given, + [on_compiler_directive] is called as if the text had been fed to [f]. + + Diagnostics resulting from lexing and parsing the input are attached to the + returned accumulated value. *) val fold_source_lines - : source_format: Cobol_config.source_format_spec - -> ?epf:Format.formatter + : dialect: Cobol_config.dialect + -> source_format: Cobol_config.source_format_spec + -> ?skip_compiler_directives_text: bool + -> ?on_compiler_directive + : (int -> Preproc_directives.compiler_directive with_loc -> 'a -> 'a) -> f:(int -> Text.text -> 'a -> 'a) -> input -> 'a - -> 'a + -> 'a Cobol_common.Diagnostics.with_diags + +val preprocess_input + : ?options: Preproc_options.preproc_options + -> ?ppf:Format.formatter + -> input + -> unit Cobol_common.Diagnostics.with_diags val preprocess_file : ?options: Preproc_options.preproc_options -> ?ppf:Format.formatter - -> ?epf:Format.formatter -> string - -> unit + -> unit Cobol_common.Diagnostics.with_diags val text_of_file : ?options: Preproc_options.preproc_options - -> ?epf:Format.formatter -> string - -> Text.text + -> Text.t Cobol_common.Diagnostics.with_diags val text_of_input : ?options: Preproc_options.preproc_options - -> ?epf:Format.formatter -> input - -> Text.text + -> Text.t Cobol_common.Diagnostics.with_diags diff --git a/src/lsp/cobol_preproc/preproc_grammar.mly b/src/lsp/cobol_preproc/preproc_grammar.mly index 961a574a4..98bbe9bbe 100644 --- a/src/lsp/cobol_preproc/preproc_grammar.mly +++ b/src/lsp/cobol_preproc/preproc_grammar.mly @@ -13,7 +13,6 @@ %parameter %parameter %{ - open CONFIG open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES module PP_UTILS = Preproc_utils.Make (CONFIG) @@ -23,9 +22,6 @@ (* Entry points *) -%start lexing_directive %start copy_statement @@ -44,33 +40,6 @@ let loc (X) == | x = X; { x &@ Overlay_manager.join_limits $sloc } -(* --- Entry points --------------------------------------------------------- *) - -let lexing_directive := - | ~ = lexdir_phrase; option("."); EOL; < > - | ~ = lexdir_microfocus_phrase; EOL; < > - -let lexdir_phrase := - | ~ = loc(lexdir_source_format); < > - -let lexdir_microfocus_phrase := - | ~ = loc(lexdir_microfocus_sourceformat); < > - -(* --- >>SOURCE | $ SET SOURCEFORMAT ---------------------------------------- *) - -let lexdir_source_format := - | CDIR_SOURCE; FORMAT?; IS?; _free = loc(FREE); - { let SF sf = Src_format.from_config Cobol_config.SFFree in - Cobol_common.Diagnostics.some_result @@ - Preproc_directives.LexDirSource (sf &@<- _free) } - | CDIR_SOURCE; FORMAT?; IS?; i = text_word; - { PP_UTILS.source_format_lexdir ~dialect i } - -let lexdir_microfocus_sourceformat := - | CDIR_SET; SOURCEFORMAT; i = loc(ALPHANUM); (* elementary_string_literal? *) - { PP_UTILS.source_format_lexdir ~dialect - (Cobol_common.Srcloc.locmap fst i) } - (* --- COPY ----------------------------------------------------------------- *) let copy_statement := ~ = loc (copy_statement_); EOL; < > @@ -158,7 +127,7 @@ let replace_statement_ := (* repl_to = loc(replacing_dst); *) (* { replacing' ?repl_dir repl_from repl_to } *) -let text_word := (* text-word with position *) +let text_word == (* text-word with position *) | ~ = loc(TEXT_WORD); < > let fileloc := diff --git a/src/lsp/cobol_preproc/preproc_grammar_sig.ml b/src/lsp/cobol_preproc/preproc_grammar_sig.ml index 3fd03b0b2..98b509b78 100644 --- a/src/lsp/cobol_preproc/preproc_grammar_sig.ml +++ b/src/lsp/cobol_preproc/preproc_grammar_sig.ml @@ -33,8 +33,6 @@ module type S = sig val replace_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Preproc_directives.replace_statement Cobol_common.Srcloc.with_loc) - val lexing_directive: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Preproc_directives.lexing_directive Cobol_common.Srcloc.with_loc) - val copy_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Preproc_directives.copy_statement Cobol_common.Srcloc.with_loc) val _unused_symbols: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (unit) @@ -54,8 +52,6 @@ module type S = sig val replace_statement: Lexing.position -> (Preproc_directives.replace_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint - val lexing_directive: Lexing.position -> (Preproc_directives.lexing_directive Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint - val copy_statement: Lexing.position -> (Preproc_directives.copy_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint val _unused_symbols: Lexing.position -> (unit) MenhirInterpreter.checkpoint diff --git a/src/lsp/cobol_preproc/preproc_keywords.ml b/src/lsp/cobol_preproc/preproc_keywords.ml index 2f8abc850..d34921bd5 100644 --- a/src/lsp/cobol_preproc/preproc_keywords.ml +++ b/src/lsp/cobol_preproc/preproc_keywords.ml @@ -4,7 +4,6 @@ let keywords = Preproc_tokens.[ "TRAILING", TRAILING; "SUPPRESS", SUPPRESS; - "SOURCEFORMAT", SOURCEFORMAT; "REPLACING", REPLACING; "REPLACE", REPLACE; "PRINTING", PRINTING; @@ -12,15 +11,8 @@ let keywords = Preproc_tokens.[ "OF", OF; "LEADING", LEADING; "LAST", LAST; - "IS", IS; "IN", IN; - "FREE", FREE; - "FORMAT", FORMAT; "COPY", COPY; - ">>SOURCE", CDIR_SOURCE; - "$SOURCE", CDIR_SOURCE; - ">>SET", CDIR_SET; - "$SET", CDIR_SET; "BY", BY; "ALSO", ALSO; ] diff --git a/src/lsp/cobol_preproc/preproc_tokens.mly b/src/lsp/cobol_preproc/preproc_tokens.mly index 5bfcf4acd..de0bc4832 100644 --- a/src/lsp/cobol_preproc/preproc_tokens.mly +++ b/src/lsp/cobol_preproc/preproc_tokens.mly @@ -13,8 +13,7 @@ %} %token EOL -%token TEXT_WORD (* Words before text manipulation stage. For - compiler_directive *) +%token TEXT_WORD (* Words before text manipulation stage *) %token ALPHANUM %token ALPHANUM_PREFIX %token NATLIT @@ -29,13 +28,8 @@ %token ALSO [@keyword] %token BY [@keyword] -%token CDIR_SET [@keyword ">>SET", "$SET"] -%token CDIR_SOURCE [@keyword ">>SOURCE", "$SOURCE"] %token COPY [@keyword] -%token FORMAT [@keyword] -%token FREE [@keyword] (* +COB2002 *) %token IN [@keyword] -%token IS [@keyword] %token LAST [@keyword] %token LEADING [@keyword] %token OF [@keyword] @@ -43,7 +37,6 @@ %token PRINTING [@keyword] %token REPLACE [@keyword] %token REPLACING [@keyword] -%token SOURCEFORMAT [@keyword] %token SUPPRESS [@keyword] (* +COB85 *) %token TRAILING [@keyword] diff --git a/src/lsp/cobol_preproc/preproc_trace.ml b/src/lsp/cobol_preproc/preproc_trace.ml index 89c5fd3ee..c4722d8cf 100644 --- a/src/lsp/cobol_preproc/preproc_trace.ml +++ b/src/lsp/cobol_preproc/preproc_trace.ml @@ -29,10 +29,9 @@ module TYPES = struct matched_loc: srcloc; replacement_text: Text.text; } - | LexDir of + | CompilerDirective of { - lexdir: Preproc_directives.lexing_directive option; (** invalid if - [None] *) + compdir: Preproc_directives.compiler_directive; loc: srcloc; } @@ -50,8 +49,8 @@ include TYPES let empty = [] let append = List.cons -let new_lexdir ~loc ?lexdir : log -> log = - List.cons @@ LexDir { lexdir; loc } +let new_compdir ~loc ~compdir : log -> log = + List.cons @@ CompilerDirective { compdir; loc } let copy_done ~loc ~filename : log -> log = List.cons @@ FileCopy { copyloc = loc; status = CopyDone filename } let cyclic_copy ~loc ~filename : log -> log = diff --git a/src/lsp/cobol_preproc/preproc_trace.mli b/src/lsp/cobol_preproc/preproc_trace.mli index c4583eac6..92816c69f 100644 --- a/src/lsp/cobol_preproc/preproc_trace.mli +++ b/src/lsp/cobol_preproc/preproc_trace.mli @@ -24,9 +24,9 @@ module TYPES: sig matched_loc: Cobol_common.srcloc; replacement_text: Text.text; } - | LexDir of + | CompilerDirective of { - lexdir: Preproc_directives.lexing_directive option; + compdir: Preproc_directives.compiler_directive; loc: Cobol_common.srcloc; } @@ -47,9 +47,9 @@ val empty: log val append : log_entry -> log -> log -val new_lexdir +val new_compdir : loc: Cobol_common.srcloc - -> ?lexdir: Preproc_directives.lexing_directive + -> compdir:Preproc_directives.compiler_directive -> log -> log val copy_done : loc: Cobol_common.srcloc diff --git a/src/lsp/cobol_preproc/preproc_utils.ml b/src/lsp/cobol_preproc/preproc_utils.ml index 1d0b3ac68..36e156b98 100644 --- a/src/lsp/cobol_preproc/preproc_utils.ml +++ b/src/lsp/cobol_preproc/preproc_utils.ml @@ -18,13 +18,6 @@ module DIAGS = Cobol_common.Diagnostics module Make (Config: Cobol_config.T) = struct - let source_format_lexdir ~dialect format = - match Src_format.decypher ~dialect ~&format with - | Ok (SF sf) -> - DIAGS.some_result @@ Preproc_directives.LexDirSource (sf &@<- format) - | Error (`SFUnknown f) -> - DIAGS.error_result None ~loc:~@format "Unknown@ source@ format@ `%s'" f - let safe_partial_replacing_when_src_literal ~loc = Config.safe_partial_replacing_when_src_literal#verify' ~loc:(Some loc) |> DIAGS.map_result ~f:(function Some s -> s = `Safe | None -> false) diff --git a/src/lsp/cobol_preproc/preproc_utils.mli b/src/lsp/cobol_preproc/preproc_utils.mli index dce429299..2ad9f7c30 100644 --- a/src/lsp/cobol_preproc/preproc_utils.mli +++ b/src/lsp/cobol_preproc/preproc_utils.mli @@ -16,11 +16,6 @@ open Cobol_common.Diagnostics.TYPES module Make (Config: Cobol_config.T) : sig - val source_format_lexdir - : dialect:Cobol_config.dialect - -> string with_loc - -> Preproc_directives.lexing_directive option with_diags - val replacing' : ?repl_dir:Preproc_directives.replacing_direction -> [< `Alphanum of Text.pseudotext diff --git a/src/lsp/cobol_preproc/src_lexer.mli b/src/lsp/cobol_preproc/src_lexer.mli index 5ae512ddb..d7d4e1514 100644 --- a/src/lsp/cobol_preproc/src_lexer.mli +++ b/src/lsp/cobol_preproc/src_lexer.mli @@ -17,6 +17,15 @@ val line: ('k Src_lexing.state as 's) -> Lexing.lexbuf -> 's * Text.text (* Second lexer *) +val keyword_of_cdtoken: (Compdir_grammar.token, string) Hashtbl.t + +type cdtoken_component = + | CDTok of Compdir_grammar.token + | CDEnd +val cdtoken: Lexing.lexbuf -> cdtoken_component + +(* Third lexer *) + val keyword_of_pptoken: (Preproc_tokens.token, string) Hashtbl.t type pptoken_component = diff --git a/src/lsp/cobol_preproc/src_lexer.mll b/src/lsp/cobol_preproc/src_lexer.mll index c3a33a306..7b6c3542a 100644 --- a/src/lsp/cobol_preproc/src_lexer.mll +++ b/src/lsp/cobol_preproc/src_lexer.mll @@ -12,9 +12,10 @@ (**************************************************************************) { - (* Two lexers: - * `line`: for lines of code before preprocessing - * `pptoken`: for simple tokens in the middle of preprocessing + (* Three lexers: + * `line`: for lines of source text before preprocessing + * `cdtoken`: for simple tokens used by compiler directives + * `pptoken`: for simple tokens used by text manipulation statements *) let pptoken_of_keyword = Hashtbl.create 15 @@ -25,6 +26,22 @@ Hashtbl.add pptoken_of_keyword kwd token; end Preproc_keywords.keywords + type pptoken_component = + | PPTok of Preproc_tokens.token + | PPEnd + + let cdtoken_of_keyword = Hashtbl.create 15 + let keyword_of_cdtoken = Hashtbl.create 15 + let __init_keywords = + List.iter begin fun (kwd, token) -> + Hashtbl.add keyword_of_cdtoken token kwd; + Hashtbl.add cdtoken_of_keyword kwd token; + end Compdir_keywords.keywords + + type cdtoken_component = + | CDTok of Compdir_grammar.token + | CDEnd + let update_loc lexbuf file line absolute chars = let open Lexing in let pos = lexbuf.lex_curr_p in @@ -38,10 +55,6 @@ pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars } - type pptoken_component = - | PPTok of Preproc_tokens.token - | PPEnd - } let newline = '\r'* '\n' @@ -532,6 +545,19 @@ and free_newline_or_eof state Src_lexing.unexpected Char state lexbuf ~k:free_gobble_line } +(* Text-word tokenizer (compiler directives) *) +and cdtoken = parse + + | blanks + { cdtoken lexbuf } + + | (nonblank+ as s) + { CDTok (try Hashtbl.find cdtoken_of_keyword s + with Not_found -> TEXT_WORD s) } + + | eof + { CDEnd } + (* Text-word tokenizer (text manipulation statements/replacing clauses) *) and pptoken = parse diff --git a/src/lsp/cobol_preproc/src_reader.ml b/src/lsp/cobol_preproc/src_reader.ml index d59961023..83e48b091 100644 --- a/src/lsp/cobol_preproc/src_reader.ml +++ b/src/lsp/cobol_preproc/src_reader.ml @@ -16,10 +16,24 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX open Text.TYPES +module DIAGS = Cobol_common.Diagnostics + type 'k reader = 'k Src_lexing.state * Lexing.lexbuf type 'k line = Line: 'k reader * text -> 'k line type t = Plx: 'k reader -> t [@@unboxed] +type error = + | Malformed_or_unknown_compiler_directive of srcloc + | Unknown_source_format of string * srcloc + +let error_diagnostic = function + | Malformed_or_unknown_compiler_directive loc -> + DIAGS.One.error ~loc "Malformed@ or@ unknown@ compiler@ directive" + | Unknown_source_format (f, loc) -> + DIAGS.One.error ~loc "Unknown@ source@ format@ `%s'" f + +(* --- *) + let diags (Plx (pl, _)) = Src_lexing.diagnostics pl let position (Plx (_, lexbuf)) = lexbuf.Lexing.lex_curr_p let comments (Plx (pl, _)) = Src_lexing.comments pl @@ -39,27 +53,127 @@ let next_chunk (Plx pl) = let Line (pl, text) = chunks_reader Src_lexer.line pl in Plx pl, text -let fold_chunks (Plx pl) f acc = - let rec aux pl acc = match chunks_reader Src_lexer.line pl with - | Line (_, [{ payload = Eof; _}]) -> acc - | Line (pl, text) -> aux pl (f text acc) - in - aux pl acc - (* let print_chunks ppf pl = *) (* fold_chunks pl (fun t () -> Pretty.print ppf "%a@\n" Text.pp_text t) () *) +(* Change of source format *) + +let with_source_format: Src_format.any with_loc -> t -> t = + fun { payload = SF format; loc } ((Plx (s, lexbuf)) as pl) -> + if Src_format.equal (Src_lexing.source_format s) format + then pl + else match Src_lexing.change_source_format s (format &@ loc) with + | Ok s -> Plx (s, lexbuf) + | Error s -> Plx (s, lexbuf) + (* --- *) -(** [fold_source_lines pl ~f acc] applies [f line_number line acc] for each - successive line [line] of the input lexed by [pl]. [line_number] gives the - line number for [line] (starting at [1]). [line] is given empty to [f] if - it corresponds to empty line in the input, or was a line continuation. *) -let fold_lines pl ~f acc = - let tok_lnum tok = +(** [lookup_compiler_directive chunk] searches for a compiler-directive + text-word (that starts with either `{v >> v}' or `{v $ v}') in the given + chunk of source text. + + Returns [Ok (prefix, cdir_text)] if a compiler directive is recognised, + where [cdir_text] is guaranteed to start with a compiler-directive word on a + line [l] and terminates at the end [l]. *) +(* Note: {!next_chunk} never outputs compiler-directive text-words in positions + other than the first two. Such a chunk also terminates at the end of the + source line as it cannot be continued (contrary to normal source lines). *) +let lookup_compiler_directive: Text.text -> _ = function + | t :: _ as text when Text.cdirp t -> Ok ([ ], text) + | p :: (t :: _ as text) when Text.cdirp t -> Ok ([p], text) + | _ -> Error `NotCDir + +let decode_compiler_directive ~dialect compdir_text = + (* Here, [compdir_text] is never empty as it's known to start with a compiler + directive marker `>>` (or `$` for MF-style directives), so we should always + have a loc: *) + let supplier = Text_supplier.cdtoks_of_text_supplier compdir_text in + let loc = Option.get @@ Cobol_common.Srcloc.concat_locs compdir_text in + let start_pos = Cobol_common.Srcloc.start_pos loc in + let parser = Compdir_grammar.Incremental.compiler_directive start_pos in + match Compdir_grammar.MenhirInterpreter.loop supplier parser with + | exception Compdir_grammar.Error -> + Error (Malformed_or_unknown_compiler_directive loc) + | Source_format_is_free lexloc -> + let sf = Src_format.from_config Cobol_config.SFFree in + let sf = sf &@ Cobol_common.Srcloc.raw lexloc in + Ok (Preproc_directives.CDirSource sf &@ loc) + | Source_format_is (format, lexloc) + | Set_sourceformat (format, lexloc) -> + let floc = Cobol_common.Srcloc.raw lexloc in + match Src_format.decypher ~dialect format with + | Ok sf -> + Ok (Preproc_directives.CDirSource (sf &@ floc) &@ loc) + | Error (`SFUnknown f) -> + Error (Unknown_source_format (f, floc)) + +let try_compiler_directive ~dialect text = + match lookup_compiler_directive text with + | Error `NotCDir -> + Ok None + | Ok (prefix, compdir_text) -> + match decode_compiler_directive ~dialect compdir_text with + | Error e -> + Error (prefix, e, compdir_text) + | Ok compdir -> + Ok (Some (prefix, compdir, compdir_text)) + +let fold_chunks + ~dialect + ?(skip_compiler_directives_text = false) + ?on_compiler_directive + ~f + pl acc = + let rec aux pl acc = match next_chunk pl with + | _pl, { payload = Eof; _} :: _ -> + acc + | pl, text -> + match try_compiler_directive ~dialect text with + | Ok None -> + aux pl (f text acc) + | Ok Some (prefix, ({ payload = CDirSource sf; _ } as compdir), text) -> + let acc = f prefix acc in + let acc = + if skip_compiler_directives_text + then acc + else f text acc + in + let acc = match on_compiler_directive with + | None -> acc + | Some f -> f compdir acc + in + aux (with_source_format sf pl) acc + | Error (prefix, _error, text) -> (* ignore? *) + let acc = f prefix acc in + if skip_compiler_directives_text + then aux pl acc + else aux pl (f text acc) + in + aux pl acc + +(* --- *) + +(** [fold_lines ~dialect ~skip_compiler_directives_text ~on_compiler_directive + ~f pl acc] applies [f line_number line acc] for each successive line [line] + of the input lexed by [pl]. [line_number] gives the line number for [line] + (starting at [1]). [line] is given empty to [f] if it corresponds to an + empty line in the input, or was a line continuation. + + When given, [on_compiler_directive] is called {e after} [f] has been fed + with the text of a compiler directive, with the same line number. + + When set, [skip_compiler_directives_text] ([false] by default) prevents the + text of compiler directives from being fed to [f]. If given, + [on_compiler_directive] is called as if the text had been fed to [f]. *) +let fold_lines + ~dialect + ?skip_compiler_directives_text + ?on_compiler_directive + ~f pl acc = + let loc_lnum { loc; _ } = (* On source text, which is NOT manipulated, we only have lexical locations, so using [start_pos] is enough. *) - (Cobol_common.Srcloc.start_pos ~@tok).pos_lnum + (Cobol_common.Srcloc.start_pos loc).pos_lnum in let spit_empty_lines ~until_lnum cur_lnum acc = let rec aux cur_lnum acc = @@ -72,7 +186,7 @@ let fold_lines pl ~f acc = let rec spit_chunk chunk (acc, cur_lnum, cur_prefix) = match Cobol_common.Basics.LIST.split_at_first ~prefix:`Same ~where:`Before - (fun tok -> tok_lnum tok > cur_lnum) chunk + (fun tok -> loc_lnum tok > cur_lnum) chunk with | Error () -> (* still on the same line *) (acc, cur_lnum, cur_prefix @ chunk) @@ -80,30 +194,29 @@ let fold_lines pl ~f acc = (acc, cur_lnum, cur_prefix @ prefix) | Ok (prefix, (tok :: _ as suffix)) -> (* terminating a line *) let acc = f cur_lnum (cur_prefix @ prefix) acc in - let new_lnum = tok_lnum tok in + let new_lnum = loc_lnum tok in let acc = spit_empty_lines ~until_lnum:new_lnum (succ cur_lnum) acc in spit_chunk suffix (acc, new_lnum, []) in - let acc, last_lnum, tail = fold_chunks pl spit_chunk (acc, 1, []) in + let spit_compdir f' cdir (acc, cur_lnum, prefix) = + let acc = if prefix <> [] then f cur_lnum prefix acc else acc in (* flush *) + let new_lnum = loc_lnum cdir in + let acc = spit_empty_lines ~until_lnum:new_lnum cur_lnum acc in + let acc = f' new_lnum cdir acc in (* call [f'] at end of corresp. line *) + acc, succ new_lnum, [] + in + let acc, last_lnum, tail = + fold_chunks ~dialect pl ~f:spit_chunk (acc, 1, []) + ?skip_compiler_directives_text + ?on_compiler_directive:(Option.map spit_compdir on_compiler_directive) + in match tail with (* fold on the last line upon exit... *) | [] | { payload = Eof; _ } :: _ -> acc (* ... if non-empty *) | _ -> f last_lnum tail acc -let print_lines ppf pl = - fold_lines pl ~f:(fun _ line () -> Pretty.print ppf "%a@\n" Text.pp_text line) () - -(* --- *) - -(* Change of source format *) - -let with_source_format - : 'k Src_format.source_format with_loc -> t -> t - = fun format ((Plx (s, lexbuf)) as pl) -> - if Src_format.equal (Src_lexing.source_format s) ~&format - then pl - else match Src_lexing.change_source_format s format with - | Ok s -> Plx (s, lexbuf) - | Error s -> Plx (s, lexbuf) +let print_lines ~dialect ?skip_compiler_directives_text ppf pl = + fold_lines ~dialect ?skip_compiler_directives_text pl () + ~f:(fun _ line () -> Pretty.print ppf "%a@\n" Text.pp_text line) (* --- *) diff --git a/src/lsp/cobol_preproc/src_reader.mli b/src/lsp/cobol_preproc/src_reader.mli index a0b7c431b..83e448619 100644 --- a/src/lsp/cobol_preproc/src_reader.mli +++ b/src/lsp/cobol_preproc/src_reader.mli @@ -17,6 +17,12 @@ open Cobol_common.Srcloc.TYPES type t +type error = + | Malformed_or_unknown_compiler_directive of srcloc + | Unknown_source_format of string * srcloc + +val error_diagnostic: error -> Cobol_common.Diagnostics.t + (** {1 Creation} *) val from_file @@ -35,14 +41,26 @@ val source_format: t -> Src_format.any val newline_cnums: t -> int list val next_chunk: t -> t * Text.t -val fold_chunks: t -> (Text.t -> 'a -> 'a) -> 'a -> 'a -val fold_lines: t -> f:(int -> Text.t -> 'a -> 'a) -> 'a -> 'a -val print_lines: Format.formatter -> t -> unit +val fold_lines + : dialect: Cobol_config.dialect + -> ?skip_compiler_directives_text: bool + -> ?on_compiler_directive + : (int -> Preproc_directives.compiler_directive with_loc -> 'a -> 'a) + -> f:(int -> Text.t -> 'a -> 'a) + -> t -> 'a -> 'a +val print_lines + : dialect: Cobol_config.dialect + -> ?skip_compiler_directives_text: bool + -> Format.formatter -> t -> unit +val try_compiler_directive + : dialect: Cobol_config.dialect -> Text.t + -> ((Text.t * Preproc_directives.compiler_directive with_loc * Text.t) option, + Text.t * error * Text.t) result (** {1 Change of source format} *) -val with_source_format: 'k Src_format.source_format with_loc -> t -> t +val with_source_format: Src_format.any with_loc -> t -> t (** {1 Resetting the input} *) diff --git a/src/lsp/cobol_preproc/text_processor.ml b/src/lsp/cobol_preproc/text_processor.ml index 484d14823..77c795294 100644 --- a/src/lsp/cobol_preproc/text_processor.ml +++ b/src/lsp/cobol_preproc/text_processor.ml @@ -399,7 +399,6 @@ let apply_replacing k repl log = module type ENTRY_POINTS = sig type 'x entry val replace_statement: replace_statement with_diags with_loc entry - val lexing_directive: lexing_directive option with_diags with_loc entry val copy_statement: copy_statement with_diags with_loc entry end diff --git a/src/lsp/cobol_preproc/text_processor.mli b/src/lsp/cobol_preproc/text_processor.mli index c5f4e4118..6b76befb7 100644 --- a/src/lsp/cobol_preproc/text_processor.mli +++ b/src/lsp/cobol_preproc/text_processor.mli @@ -46,8 +46,6 @@ module type ENTRY_POINTS = sig type 'x entry val replace_statement : Preproc_directives.replace_statement with_diags with_loc entry - val lexing_directive - : Preproc_directives.lexing_directive option with_diags with_loc entry val copy_statement : Preproc_directives.copy_statement with_diags with_loc entry end diff --git a/src/lsp/cobol_preproc/text_supplier.ml b/src/lsp/cobol_preproc/text_supplier.ml index 20f30bb76..e7ed56d80 100644 --- a/src/lsp/cobol_preproc/text_supplier.ml +++ b/src/lsp/cobol_preproc/text_supplier.ml @@ -14,6 +14,29 @@ open Cobol_common.Srcloc.INFIX open Text.TYPES +(** [cdtoks_of_chstr w] translates a COBOL character string [w] into + compiler directive tokens. Note numeric literals keep their representation as + text-words ({!TEXT_WORD}) in the result. *) +let cdtoks_of_chstr (chstr: text_word Cobol_common.Srcloc.with_loc) = + let open Compdir_grammar in + let ( ~@@ ) t = Cobol_common.Srcloc.as_lexloc ~@t in + match ~&chstr with + | CDirWord w + | TextWord w -> + List.rev @@ Cobol_common.Tokenizing.fold_tokens (w &@<- chstr) [] + ~tokenizer:(fun ~loc:_ -> Src_lexer.cdtoken) + ~until:(function CDEnd -> true | _ -> false) + ~f:begin fun t -> match ~&t with + | CDEnd -> Fun.id + | CDTok tok -> List.cons (tok, ~@@t) + end + | Alphanum { knd = Basic; str; qte = _; _ } -> + [ALPHANUM str, ~@@chstr] + | Eof -> + [EOL, ~@@chstr] + | _ -> + [INVALID_ ~&chstr, ~@@chstr] + (** [pptoks_of_chstr w] translates a COBOL character string [w] into pre-processor tokens. Note numeric literals keep their representation as text-words ({!TEXT_WORD}) in the result. *) @@ -50,28 +73,40 @@ type 'b supplier = unit -> 'b * Lexing.position * Lexing.position (** [ondemand_list_supplier ~pp ~eoi l] is a supplier that returns all tokens obtained after pre-processing of [l] by [pp], and then [eoi]. *) -let ondemand_list_supplier (module Om: Src_overlay.MANAGER) ~pp ~eoi l = - let y_l = ref [] and l = ref l and prev_limit = ref None in +let ondemand_list_supplier ~decompose ~endlimit ~pp ~eoi l = + let y_l = ref [] and l = ref l in let rec aux () = supply !y_l ~otherwise:begin fun () -> match !l with | x :: tl -> l := tl; supply (pp x) ~otherwise:aux | [] -> - let b = Option.value !prev_limit ~default:Om.dummy_limit in + let b = endlimit () in eoi, b, b end and supply ~otherwise = function | y :: y_tl -> y_l := y_tl; - let s, e = Om.limits ~@y in - Option.iter (fun e -> Om.link_limits e s) !prev_limit; - prev_limit := Some e; - ~&y, s, e + decompose y | [] -> otherwise () in aux -let pptoks_of_text_supplier om text = - ondemand_list_supplier ~eoi:Preproc_tokens.EOL ~pp:pptoks_of_chstr om text +let cdtoks_of_text_supplier text = + ondemand_list_supplier ~eoi:Compdir_grammar.EOL ~pp:cdtoks_of_chstr text + ~decompose:(fun (y, (s, e)) -> y, s, e) + ~endlimit:(fun () -> Lexing.dummy_pos) + +let pptoks_of_text_supplier (module Om: Src_overlay.MANAGER) text = + let prev_limit = ref None in + ondemand_list_supplier ~eoi:Preproc_tokens.EOL ~pp:pptoks_of_chstr text + ~decompose:begin fun y -> + let s, e = Om.limits ~@y in + Option.iter (fun e -> Om.link_limits e s) !prev_limit; + prev_limit := Some e; + ~&y, s, e + end + ~endlimit:begin fun () -> + Option.value !prev_limit ~default:Om.dummy_limit + end diff --git a/src/lsp/cobol_preproc/text_supplier.mli b/src/lsp/cobol_preproc/text_supplier.mli index 28240c1fd..f4449a418 100644 --- a/src/lsp/cobol_preproc/text_supplier.mli +++ b/src/lsp/cobol_preproc/text_supplier.mli @@ -15,6 +15,10 @@ type 'b supplier = unit -> 'b * Lexing.position * Lexing.position +val cdtoks_of_text_supplier + : Text.t + -> Compdir_grammar.token supplier + val pptoks_of_text_supplier : (module Src_overlay.MANAGER) -> Text.t diff --git a/src/lsp/superbol_free_lib/command_indent_range.ml b/src/lsp/superbol_free_lib/command_indent_range.ml index 1682c653e..7d3d86871 100644 --- a/src/lsp/superbol_free_lib/command_indent_range.ml +++ b/src/lsp/superbol_free_lib/command_indent_range.ml @@ -17,9 +17,11 @@ open Cobol_indent open Common_args -let action { preproc_options = { source_format; _ }; _ } ~file ~range +let action { preproc_options = { source_format; config; _ }; _ } ~file ~range ~indent_config = + let module Config = (val config) in indent_range ~source_format ~file ~range ~indent_config + ~dialect:Config.dialect let cmd = let file = ref "" in diff --git a/src/lsp/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index 4ec752fa7..2ea7d4d45 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -95,6 +95,7 @@ let cmd = else let text = let common = common_get () in + Cobol_common.Diagnostics.show_n_forget @@ Cobol_preproc.text_of_file file ~options:common.preproc_options in diff --git a/test/cobol_parsing/dune b/test/cobol_parsing/dune index 0699c110f..8a275f688 100644 --- a/test/cobol_parsing/dune +++ b/test/cobol_parsing/dune @@ -11,7 +11,7 @@ (library (name test_cobol_parser) - (modules compiler_directives cS_tokens decimal_point tokens) + (modules cS_tokens decimal_point tokens) (preprocess (pps ppx_expect)) (inline_tests diff --git a/test/cobol_parsing/parser_testing.ml b/test/cobol_parsing/parser_testing.ml index a9244a0f5..48c057d10 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -15,20 +15,17 @@ module DIAGS = Cobol_common.Diagnostics module StrMap = EzCompat.StringMap let preproc + ?(filename = "prog.cob") ?(source_format = Cobol_config.(SF SFFixed)) - prog + contents = - String { filename = "prog.cob"; contents = prog } |> + String { filename; contents } |> Cobol_preproc.preprocessor - ~options:Cobol_preproc.Options.{ - default with - libpath = []; - source_format - } + ~options:Cobol_preproc.Options.{ default with libpath = []; source_format } -let show_parsed_tokens ?(verbose = false) ?source_format prog = +let show_parsed_tokens ?(verbose = false) ?source_format ?filename contents = let DIAGS.{ result = WithArtifacts (_, { tokens; _ }); _ } = - preproc ?source_format prog |> + preproc ?source_format ?filename contents |> Cobol_parser.parse_with_artifacts ~options:Cobol_parser.Options.{ default with @@ -41,8 +38,8 @@ let show_parsed_tokens ?(verbose = false) ?source_format prog = (** Note: won't show detailed source locations as the openned file is not actually on disk (that may be fixed later with a custom internal file store). *) -let show_diagnostics ?(verbose = false) ?source_format prog = - preproc ?source_format prog |> +let show_diagnostics ?(verbose = false) ?source_format ?filename contents = + preproc ?source_format ?filename contents |> Cobol_parser.parse_simple ~options:Cobol_parser.Options.{ default with diff --git a/test/cobol_parsing/compiler_directives.ml b/test/cobol_preprocessing/compiler_directives.ml similarity index 95% rename from test/cobol_parsing/compiler_directives.ml rename to test/cobol_preprocessing/compiler_directives.ml index 830ab72f3..35385e2ac 100644 --- a/test/cobol_parsing/compiler_directives.ml +++ b/test/cobol_preprocessing/compiler_directives.ml @@ -12,7 +12,7 @@ (**************************************************************************) let%expect_test "fixed-format-cdirs" = - Parser_testing.show_diagnostics {| + Preproc_testing.show_diagnostics {| >>SET A >>SET B $ SET B @@ -29,7 +29,7 @@ let%expect_test "fixed-format-cdirs" = |}];; let%expect_test "hybrid-format-cdirs" = - Parser_testing.show_diagnostics {| + Preproc_testing.show_diagnostics {| >>SOURCE FORMAT IS FREE >>SOURCE FORMAT IS FIXED >> SET SOURCEFORMAT "COBOLX" diff --git a/test/cobol_preprocessing/dune b/test/cobol_preprocessing/dune new file mode 100644 index 000000000..46a80344d --- /dev/null +++ b/test/cobol_preprocessing/dune @@ -0,0 +1,15 @@ +(library + (name preproc_testing) + (modules Preproc_testing) + (libraries cobol_preproc) + ) + +(library + (name test_cobol_preproc) + (modules source_lines compiler_directives) + (preprocess + (pps ppx_expect)) + (inline_tests + (modes best)) ; add js for testing with nodejs + (libraries preproc_testing) + ) diff --git a/test/cobol_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml new file mode 100644 index 000000000..e5306a4cb --- /dev/null +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +open Cobol_common.Srcloc.INFIX +module DIAGS = Cobol_common.Diagnostics + +(** Note: won't show detailed source locations as the openned file is not + actually on disk (that may be fixed later with a custom internal file + store). *) +let show_diagnostics + ?(verbose = false) + ?(filename = "prog.cob") + ?(source_format = Cobol_config.(SF SFFixed)) + contents = + DIAGS.show_n_forget ~ppf:Fmt.stdout @@ + Cobol_preproc.preprocess_input + ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; + source_format } @@ + Cobol_preproc.String { filename; contents } + +let show_source_lines + ?(with_line_numbers = false) + ?(with_source_cdir_markers = false) + ?(with_compiler_directives_text = true) + ?(filename = "prog.cob") + ?(dialect = Cobol_config.DIALECT.Default) + ?(source_format = Cobol_config.(SF SFFixed)) + contents + = + DIAGS.show_n_forget ~ppf:Fmt.stdout @@ + Cobol_preproc.fold_source_lines ~dialect ~source_format + ~f:begin fun lnum line () -> + if with_line_numbers then Pretty.out "@\n%u: " lnum else Pretty.out "@\n"; + Pretty.out "%a" Cobol_preproc.Text.pp_text line; + end (String { filename; contents }) () + ~skip_compiler_directives_text:(not with_compiler_directives_text) + ?on_compiler_directive:begin + if not with_source_cdir_markers then None + else Option.some @@ fun lnum cdir () -> + if with_line_numbers then Pretty.out "@\n%u: " lnum; + match ~&cdir with + | Cobol_preproc.Directives.CDirSource _ -> + Pretty.out "|new source format|" + end diff --git a/test/cobol_preprocessing/source_lines.ml b/test/cobol_preprocessing/source_lines.ml new file mode 100644 index 000000000..b688fc4e8 --- /dev/null +++ b/test/cobol_preprocessing/source_lines.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +let%expect_test "fixed-format-cdirs" = + Preproc_testing.show_source_lines {| + >>SET A + >>SET B + $ SET B + |}; + [%expect {| + >>SET A + >>SET B + $SET B +|}];; + +let%expect_test "hybrid-format-cdirs" = + Preproc_testing.show_source_lines {| + >>SOURCE FORMAT IS FREE +>>SOURCE FORMAT IS FIXED + >> SET SOURCEFORMAT "COBOLX" +* comment line + *> floating comment +$ Source format free + *> another floating comment + >> SET SOURCEFORMAT "FIXED" + * fixed comment + $ SET SOURCEFORMAT "XOpen" +/ comment line +>>SET SOURCEFORMAT "CRT" +/ still comment line +$ SOURCE IS FREE + *> ok let's terminate here + . + |}; + [%expect {| + >>SOURCE FORMAT IS FREE + >>SOURCE FORMAT IS FIXED + >>SET SOURCEFORMAT "COBOLX" + + + $SOURCE FORMAT FREE + + >>SET SOURCEFORMAT "FIXED" + + $SET SOURCEFORMAT "XOpen" + + >>SET SOURCEFORMAT "CRT" + + $SOURCE IS FREE + + . +|}];; + +let%expect_test "hybrid-format-cdirs-with-cdir-markers" = + Preproc_testing.show_source_lines + ~with_source_cdir_markers:true + ~with_line_numbers:true {| + >>SOURCE FORMAT IS FREE +>>SOURCE FORMAT IS FIXED + >> SET SOURCEFORMAT "COBOLX" +* comment line + *> floating comment +$ Source format free + *> another floating comment + >> SET SOURCEFORMAT "FIXED" + * fixed comment + $ SET SOURCEFORMAT "XOpen" +/ comment line +>>SET SOURCEFORMAT "CRT" +/ still comment line +$ SOURCE IS FREE + *> ok let's terminate here + . + |}; + [%expect {| + 1: + 2: >>SOURCE FORMAT IS FREE + 2: |new source format| + 3: >>SOURCE FORMAT IS FIXED + 3: |new source format| + 4: >>SET SOURCEFORMAT "COBOLX" + 4: |new source format| + 5: + 6: + 7: $SOURCE FORMAT FREE + 7: |new source format| + 8: + 9: >>SET SOURCEFORMAT "FIXED" + 9: |new source format| + 10: + 11: $SET SOURCEFORMAT "XOpen" + 11: |new source format| + 12: + 13: >>SET SOURCEFORMAT "CRT" + 13: |new source format| + 14: + 15: $SOURCE IS FREE + 15: |new source format| + 16: + 17: . +|}];; + +let%expect_test "hybrid-format-cdirs-with-cdir-markers-bis" = + Preproc_testing.show_source_lines + ~with_source_cdir_markers:true + ~with_compiler_directives_text:false + ~with_line_numbers:true {| + >>SOURCE FORMAT IS FREE +>>SOURCE FORMAT IS FIXED + >> SET SOURCEFORMAT "COBOLX" +* comment line + *> floating comment +$ Source format free + *> another floating comment + >> SET SOURCEFORMAT "FIXED" + * fixed comment + $ SET SOURCEFORMAT "XOpen" +/ comment line +>>SET SOURCEFORMAT "CRT" +/ still comment line +$ SOURCE IS FREE + *> ok let's terminate here + . + |}; + [%expect {| + 1: + 2: |new source format| + 3: |new source format| + 4: |new source format| + 5: + 6: + 7: |new source format| + 8: + 9: |new source format| + 10: + 11: |new source format| + 12: + 13: |new source format| + 14: + 15: |new source format| + 16: + 17: . +|}];; diff --git a/test/lsp/lsp_formatting.ml b/test/lsp/lsp_formatting.ml index 3bdee36d2..b6f5428fc 100644 --- a/test/lsp/lsp_formatting.ml +++ b/test/lsp/lsp_formatting.ml @@ -38,7 +38,6 @@ let%expect_test "simple-formatting-request" = [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` PROGRAM-ID. HELLO. PROCEDURE DIVISION. para-1. @@ -74,7 +73,6 @@ let%expect_test "formatting-request-nested-if" = [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":14,"line":1},"start":{"character":8,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` para-1. IF X>9 THEN @@ -117,7 +115,6 @@ let%expect_test "formatting-request-data" = [%expect{| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":23,"line":1},"start":{"character":8,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` WORKING-STORAGE SECTION. 01 x. 05 y. @@ -191,7 +188,6 @@ let%expect_test "formatting-request-nested-program" = [%expect{| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` IDENTIFICATION DIVISION. PROGRAM-ID. X. PROCEDURE DIVISION. @@ -250,7 +246,6 @@ let%expect_test "formatting-request-alignment-argument" = [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":11,"line":1},"start":{"character":7,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` MOVE VAR-1 TO VAR-2 VAR-3 VAR-4 VAR-5. |}] @@ -283,7 +278,6 @@ let%expect_test "formatting-request-else-if" = [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":10,"line":1},"start":{"character":8,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` if x>1 move 1 to x else if x>2 @@ -411,7 +405,6 @@ let%expect_test "formatting-request-whole-program" = (Cobol_ptree__Data_sections_visitor.fold_data_clause): partial visitor implementation {"params":{"diagnostics":[{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` IDENTIFICATION DIVISION. PROGRAM-ID. MACESDS. ENVIRONMENT DIVISION. @@ -529,7 +522,6 @@ let%expect_test "formatting-request-on-exception" = [%expect{| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":11,"line":1},"start":{"character":7,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` CALL STH NOT ON EXCEPTION RAISE EXCEPTION exception-name-1 @@ -565,7 +557,6 @@ let%expect_test "formatting-request-perform" = [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":16,"line":1},"start":{"character":7,"line":1}},"severity":1},{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - >> Warning: Source format `auto` is not supported yet, using `fixed` PROCEDURE DIVISION. para-1. PERFORM 3 TIMES diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 35ecced05..224615012 100644 --- a/test/output-tests/preproc.ml +++ b/test/output-tests/preproc.ml @@ -16,12 +16,12 @@ open Ez_file open FileString.OP open Testsuite_utils -let preprocess_file ~source_format ~config = - Cobol_preproc.preprocess_file +let preprocess_file ~source_format ~config filename = + Cobol_common.Diagnostics.show_n_forget @@ + Cobol_preproc.preprocess_file filename ~options:Cobol_preproc.Options.{ source_format; config; verbose = false; libpath = [] } ~ppf:std_formatter - ~epf:std_formatter let () = (* Print one token per line so we can diff outputs more easily. *) diff --git a/test/output-tests/syn_misc.expected b/test/output-tests/syn_misc.expected index 1f855781d..ba86cd011 100644 --- a/test/output-tests/syn_misc.expected +++ b/test/output-tests/syn_misc.expected @@ -4063,16 +4063,6 @@ syn_misc.at-7842-empty0.cob:5.18-5.27: Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7861:0 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7885:0 -syn_misc.at-7885-prog.cob:4.27-4.29: - 1 - 2 CONTROL DIVISION. - 3 SUBSTITUTION SECTION. - 4 > REPLACE IISS BY IS ----- ^^ - 5 TERM BY TERMINAL - 6 "KO" BY "OK". ->> Error: Malformed REPLACE statement - syn_misc.at-7885-prog.cob:8.18-8.27: 5 TERM BY TERMINAL 6 "KO" BY "OK". @@ -4083,27 +4073,7 @@ syn_misc.at-7885-prog.cob:8.18-8.27: 10 . >> Error: Invalid syntax -syn_misc.at-7885-prog.cob:9.24-9.28: - 6 "KO" BY "OK". - 7 DEFAULT SECTION. - 8 ACCEPT ALTERNATE CONSOLE - 9 > DISPLAY IISS TERM ----- ^^^^ - 10 . - 11 IDENTIFICATION DIVISION. ->> Error: Invalid syntax - Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7918:0 -syn_misc.at-7918-prog.cob:5.26-5.28: - 2 CONTROL DIVISION. - 3 SUBSTITUTION SECTION. - 4 *> This REPLACE in Area A is ignored for now: - 5 > REPLACE IISS BY IS ----- ^^ - 6 TERM BY TERMINAL - 7 "KO" BY "OK". ->> Error: Malformed REPLACE statement - syn_misc.at-7918-prog.cob:9.17-9.26: 6 TERM BY TERMINAL 7 "KO" BY "OK". @@ -4114,16 +4084,6 @@ syn_misc.at-7918-prog.cob:9.17-9.26: 11 . >> Error: Invalid syntax -syn_misc.at-7918-prog.cob:10.23-10.27: - 7 "KO" BY "OK". - 8 DEFAULT SECTION. - 9 ACCEPT ALTERNATE CONSOLE - 10 > DISPLAY IISS TERM ----- ^^^^ - 11 . - 12 IDENTIFICATION DIVISION. ->> Error: Invalid syntax - Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:8018:0 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:8056:0 syn_misc.at-8056-prog.cob:2.7-2.11: From bc1e6495bdaac64f59ef9dd37bc9b5811c5f692e Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Wed, 18 Oct 2023 11:09:06 +0200 Subject: [PATCH 2/2] Add some basic support for more compiler directives in the pre-processor --- src/lsp/cobol_common/diagnostics.ml | 15 ++++++- src/lsp/cobol_common/diagnostics.mli | 2 +- src/lsp/cobol_preproc/compdir_grammar.mly | 25 ++++++----- src/lsp/cobol_preproc/compdir_tree.ml | 1 + src/lsp/cobol_preproc/preproc_directives.ml | 3 +- src/lsp/cobol_preproc/preproc_engine.ml | 10 +++-- src/lsp/cobol_preproc/src_lexer.mll | 27 ++++++++---- src/lsp/cobol_preproc/src_reader.ml | 27 +++++++----- .../compiler_directives.ml | 44 ++++++++++++++++--- test/cobol_preprocessing/preproc_testing.ml | 2 + test/cobol_preprocessing/source_lines.ml | 6 +-- test/output-tests/preproc.ml | 2 +- test/output-tests/run_file.expected | 4 +- test/output-tests/run_refmod.expected | 2 +- test/output-tests/run_subscripts.expected | 10 ++--- 15 files changed, 123 insertions(+), 57 deletions(-) diff --git a/src/lsp/cobol_common/diagnostics.ml b/src/lsp/cobol_common/diagnostics.ml index e6de4be27..5b692e94a 100644 --- a/src/lsp/cobol_common/diagnostics.ml +++ b/src/lsp/cobol_common/diagnostics.ml @@ -66,6 +66,14 @@ let is_error = function | { severity = Error; _ } -> true | _ -> false +let compare_severity a b = + if a = b then 0 else match a, b with + | Hint, _ -> -1 | _, Hint -> 1 + | Note, _ -> -1 | _, Note -> 1 + | Info, _ -> -1 | _, Info -> 1 + | Warn, _ -> -1 | _, Warn -> 1 + | Error, _ -> -1 + let pp_msg ppf diag = diag.message ppf let message diag = diag.message let severity diag = diag.severity @@ -126,6 +134,9 @@ module Set = struct let pp ppf diags = Pretty.list ~fopen:"@[" ~fclose:"@]@\n" ~fsep:"@\n" ~fempty:"" pp ppf (sort diags) + let pp_above ~level ppf diags = + pp ppf @@ + List.filter (fun { severity; _ } -> compare_severity level severity <= 0) diags let none: t = [] let one d = [d] let two d d' = [d; d'] @@ -211,8 +222,8 @@ let cons_option_result = function let forget_result { diags; _ } = diags let merge_results ~f r1 r2 = result (f r1.result r2.result) ~diags:(Set.union r1.diags r2.diags) -let show_n_forget ?(ppf = Fmt.stderr) { result; diags } = - Set.pp ppf diags; +let show_n_forget ?(min_level = Hint) ?(ppf = Fmt.stderr) { result; diags } = + Set.pp_above ~level:min_level ppf diags; result diff --git a/src/lsp/cobol_common/diagnostics.mli b/src/lsp/cobol_common/diagnostics.mli index 8dd0404eb..b66d2cfac 100644 --- a/src/lsp/cobol_common/diagnostics.mli +++ b/src/lsp/cobol_common/diagnostics.mli @@ -115,7 +115,7 @@ val more_result: f:('a -> 'b with_diags) -> 'a with_diags -> 'b with_diags val cons_option_result: 'a option with_diags -> 'a list with_diags -> 'a list with_diags val forget_result: _ with_diags -> diagnostics val merge_results: f:('a -> 'b -> 'c) -> 'a with_diags -> 'b with_diags -> 'c with_diags -val show_n_forget: ?ppf:Format.formatter -> 'a with_diags -> 'a +val show_n_forget: ?min_level:severity -> ?ppf:Format.formatter -> 'a with_diags -> 'a val hint_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func val note_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func diff --git a/src/lsp/cobol_preproc/compdir_grammar.mly b/src/lsp/cobol_preproc/compdir_grammar.mly index d3268bb21..1aa08f3a6 100644 --- a/src/lsp/cobol_preproc/compdir_grammar.mly +++ b/src/lsp/cobol_preproc/compdir_grammar.mly @@ -45,32 +45,33 @@ let loc (X) == (* --- Entry points --------------------------------------------------------- *) let compiler_directive := - | ~ = compdir_phrase; EOL; < > - | ~ = compdir_microfocus_phrase; EOL; < > - -let compdir_phrase := - | ~ = compdir_source_format; < > - -let compdir_microfocus_phrase := - | ~ = compdir_microfocus_sourceformat; < > + | ~ = source_format; EOL; < > + | ~ = set_sourceformat; EOL; < > + | ~ = set_generic; EOL; < > (* --- >>SOURCE | $ SET SOURCEFORMAT ---------------------------------------- *) -let compdir_source_format := +let source_format := | CDIR_SOURCE; FORMAT?; IS?; free = loc(FREE); { Source_format_is_free (snd free) } | CDIR_SOURCE; FORMAT?; IS?; i = text_word; { Source_format_is i } -let compdir_microfocus_sourceformat := +let set_sourceformat := | CDIR_SET; SOURCEFORMAT; i = loc(ALPHANUM); (* elementary_string_literal? *) { Set_sourceformat i } -let text_word == (* text-word with position *) - | ~ = loc(TEXT_WORD); < > +(* --- >>SET ... | $ SET ... ------------------------------------------------ *) + +let set_generic := + | CDIR_SET; w = text_word; + { Set w } (* --- Misc ----------------------------------------------------------------- *) +let text_word == (* text-word with position *) + | ~ = loc(TEXT_WORD); < > + _unused_symbols: | INVALID_ { () } diff --git a/src/lsp/cobol_preproc/compdir_tree.ml b/src/lsp/cobol_preproc/compdir_tree.ml index 4bbdbcd3a..6d3973c03 100644 --- a/src/lsp/cobol_preproc/compdir_tree.ml +++ b/src/lsp/cobol_preproc/compdir_tree.ml @@ -17,3 +17,4 @@ type directive = | Source_format_is_free of lexloc | Source_format_is of (string * lexloc) | Set_sourceformat of (string * lexloc) + | Set of (string * lexloc) diff --git a/src/lsp/cobol_preproc/preproc_directives.ml b/src/lsp/cobol_preproc/preproc_directives.ml index 208aafe7c..34a08b314 100644 --- a/src/lsp/cobol_preproc/preproc_directives.ml +++ b/src/lsp/cobol_preproc/preproc_directives.ml @@ -15,7 +15,8 @@ open Cobol_common.Srcloc.TYPES open Text.TYPES type compiler_directive = - | CDirSource of Src_format.any with_loc [@@unboxed] + | CDirSource of Src_format.any with_loc + | CDirSet of string with_loc type copy_statement = | CDirCopy of diff --git a/src/lsp/cobol_preproc/preproc_engine.ml b/src/lsp/cobol_preproc/preproc_engine.ml index 4745920ee..d23a730cf 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/preproc_engine.ml @@ -175,10 +175,14 @@ let rec next_chunk ({ reader; buff; persist = { dialect; _ }; _ } as lp) = let lp = add_diag { lp with reader; buff = [] } diag in preprocess_line lp (buff @ text) -and apply_compiler_directive ({ reader; pplog; _ } as lp) = function - | { payload = Preproc_directives.CDirSource sf as compdir; loc } -> - let lp = with_pplog lp @@ Preproc_trace.new_compdir ~loc ~compdir pplog in +and apply_compiler_directive + ({ reader; pplog; _ } as lp) { payload = compdir; loc } = + let lp = with_pplog lp @@ Preproc_trace.new_compdir ~loc ~compdir pplog in + match (compdir : Preproc_directives.compiler_directive) with + | CDirSource sf -> with_reader lp (Src_reader.with_source_format sf reader) + | CDirSet _ -> + DIAGS.Cont.kwarn (add_diag lp) ~loc "Ignored@ compiler@ directive" and preprocess_line lp srctext = match try_preproc lp srctext with diff --git a/src/lsp/cobol_preproc/src_lexer.mll b/src/lsp/cobol_preproc/src_lexer.mll index 7b6c3542a..a5b6abad4 100644 --- a/src/lsp/cobol_preproc/src_lexer.mll +++ b/src/lsp/cobol_preproc/src_lexer.mll @@ -123,9 +123,9 @@ let text_word = let cdir_char = (letter | digit | ':') (* colon for pseudo-words *) let cdir_word_suffix = - (cdir_char+ ((cdir_char | '_' | '-') cdir_char*)*) + (cdir_char ((cdir_char | '_' | '-') cdir_char*)*)? (* CHECKME: allow empty? *) let cdir_word = - (">>" blanks? cdir_word_suffix) + (">>" ' '? cdir_word_suffix) (* Fixed format *) @@ -141,7 +141,7 @@ rule fixed_line state } | sna ('$' as marker) (* compiler directive *) { - fixed_cdir_line (String.make 1 marker) state lexbuf + fixed_mf_cdir_line (String.make 1 marker) state lexbuf } | sna ('>' as marker) { @@ -210,7 +210,7 @@ and xopen_or_crt_or_acutrm_followup state = parse | ('$' as marker) { - fixed_cdir_line (String.make 1 marker) state lexbuf + fixed_mf_cdir_line (String.make 1 marker) state lexbuf } | cdir_word { @@ -234,9 +234,9 @@ and cobolx_line state (* COBOLX format (GCOS) *) { fixed_continue_line state lexbuf } - | ('$' | ">>" as marker) + | ('$' as marker) { - fixed_cdir_line marker state lexbuf + fixed_mf_cdir_line (String.make 1 marker) state lexbuf } | (['*' '/'] as marker) (* comment line *) { @@ -311,7 +311,18 @@ and fixed_nominal state { newline_or_eof state lexbuf } -and fixed_cdir_line marker state (* compiler directive *) +and fixed_cdir_line marker state (* `>>`-prefixed compiler directive *) + = parse + | ' '? cdir_word_suffix + { + Src_lexing.cdir_word ~ktkd:gobble_line ~knom:fixed_nominal + ~marker (Src_lexing.flush_continued state) lexbuf + } + | epsilon + { + newline_or_eof (Src_lexing.flush_continued state) lexbuf + } +and fixed_mf_cdir_line marker state (* Micro-focus compiler directive (`$`) *) = parse | blanks? cdir_word_suffix { @@ -440,7 +451,7 @@ and free_line state { free_line (Src_lexing.flush_continued ~force:true state) lexbuf } - | cdir_word + | (cdir_word | '$' blanks? cdir_word_suffix) { Src_lexing.cdir_word' ~k:free_nominal (Src_lexing.flush_continued ~force:true state) lexbuf diff --git a/src/lsp/cobol_preproc/src_reader.ml b/src/lsp/cobol_preproc/src_reader.ml index 83e48b091..00dc0ce6a 100644 --- a/src/lsp/cobol_preproc/src_reader.ml +++ b/src/lsp/cobol_preproc/src_reader.ml @@ -91,21 +91,23 @@ let decode_compiler_directive ~dialect compdir_text = let loc = Option.get @@ Cobol_common.Srcloc.concat_locs compdir_text in let start_pos = Cobol_common.Srcloc.start_pos loc in let parser = Compdir_grammar.Incremental.compiler_directive start_pos in + let raw_loc = Cobol_common.Srcloc.raw in + let open Preproc_directives in match Compdir_grammar.MenhirInterpreter.loop supplier parser with - | exception Compdir_grammar.Error -> - Error (Malformed_or_unknown_compiler_directive loc) | Source_format_is_free lexloc -> let sf = Src_format.from_config Cobol_config.SFFree in - let sf = sf &@ Cobol_common.Srcloc.raw lexloc in - Ok (Preproc_directives.CDirSource sf &@ loc) + Ok (CDirSource (sf &@ raw_loc lexloc) &@ loc) | Source_format_is (format, lexloc) | Set_sourceformat (format, lexloc) -> - let floc = Cobol_common.Srcloc.raw lexloc in - match Src_format.decypher ~dialect format with + (match Src_format.decypher ~dialect format with | Ok sf -> - Ok (Preproc_directives.CDirSource (sf &@ floc) &@ loc) + Ok (Preproc_directives.CDirSource (sf &@ raw_loc lexloc) &@ loc) | Error (`SFUnknown f) -> - Error (Unknown_source_format (f, floc)) + Error (Unknown_source_format (f, raw_loc lexloc))) + | Set (string, lexloc) -> + Ok (Preproc_directives.CDirSet (string &@ raw_loc lexloc) &@ loc) + | exception Compdir_grammar.Error -> + Error (Malformed_or_unknown_compiler_directive loc) let try_compiler_directive ~dialect text = match lookup_compiler_directive text with @@ -131,7 +133,7 @@ let fold_chunks match try_compiler_directive ~dialect text with | Ok None -> aux pl (f text acc) - | Ok Some (prefix, ({ payload = CDirSource sf; _ } as compdir), text) -> + | Ok Some (prefix, compdir, text) -> let acc = f prefix acc in let acc = if skip_compiler_directives_text @@ -142,12 +144,15 @@ let fold_chunks | None -> acc | Some f -> f compdir acc in - aux (with_source_format sf pl) acc - | Error (prefix, _error, text) -> (* ignore? *) + aux (apply_compdir compdir pl) acc + | Error (prefix, _error, text) -> (* ignore error? *) let acc = f prefix acc in if skip_compiler_directives_text then aux pl acc else aux pl (f text acc) + and apply_compdir { payload = compdir; _ } = match compdir with + | CDirSource sf -> with_source_format sf + | CDirSet _ -> Fun.id (* ignore *) in aux pl acc diff --git a/test/cobol_preprocessing/compiler_directives.ml b/test/cobol_preprocessing/compiler_directives.ml index 35385e2ac..d082486b2 100644 --- a/test/cobol_preprocessing/compiler_directives.ml +++ b/test/cobol_preprocessing/compiler_directives.ml @@ -19,23 +19,22 @@ let%expect_test "fixed-format-cdirs" = |}; [%expect {| prog.cob:2.7-2.14: - >> Error: Malformed or unknown compiler directive + >> Warning: Ignored compiler directive prog.cob:3.6-3.13: - >> Error: Malformed or unknown compiler directive + >> Warning: Ignored compiler directive prog.cob:4.6-4.13: - >> Error: Malformed or unknown compiler directive -|}];; + >> Warning: Ignored compiler directive |}];; let%expect_test "hybrid-format-cdirs" = Preproc_testing.show_diagnostics {| >>SOURCE FORMAT IS FREE >>SOURCE FORMAT IS FIXED - >> SET SOURCEFORMAT "COBOLX" + >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment -$ Source format free +$ Source format free *> another floating comment >> SET SOURCEFORMAT "FIXED" * fixed comment @@ -43,8 +42,39 @@ $ Source format free / comment line >>SET SOURCEFORMAT "CRT" / still comment line -$ SOURCE IS FREE +$ SOURCE IS FREE *> ok let's terminate here |}; [%expect {| |}];; + +let%expect_test "malformed-cdirs" = + (* TODO: what should we do with the lonesome `>>`? *) + Preproc_testing.show_diagnostics {| + >>foo + >> + >>*> empty one? + $*> another empty one? + $ SOURCE IS FREE +>> ? +$ + |}; + [%expect {| + prog.cob:2.6-2.11: + >> Error: Malformed or unknown compiler directive + + prog.cob:3.6-3.8: + >> Error: Malformed or unknown compiler directive + + prog.cob:4.6-4.8: + >> Error: Malformed or unknown compiler directive + + prog.cob:5.6-5.7: + >> Error: Malformed or unknown compiler directive + + prog.cob:7.0-7.4: + >> Error: Malformed or unknown compiler directive + + prog.cob:8.0-8.1: + >> Error: Malformed or unknown compiler directive +|}];; diff --git a/test/cobol_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml index e5306a4cb..9aa560612 100644 --- a/test/cobol_preprocessing/preproc_testing.ml +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -51,4 +51,6 @@ let show_source_lines match ~&cdir with | Cobol_preproc.Directives.CDirSource _ -> Pretty.out "|new source format|" + | _ -> (* ignore every other kind of directives *) + () end diff --git a/test/cobol_preprocessing/source_lines.ml b/test/cobol_preprocessing/source_lines.ml index b688fc4e8..e7d9893dd 100644 --- a/test/cobol_preprocessing/source_lines.ml +++ b/test/cobol_preprocessing/source_lines.ml @@ -27,7 +27,7 @@ let%expect_test "hybrid-format-cdirs" = Preproc_testing.show_source_lines {| >>SOURCE FORMAT IS FREE >>SOURCE FORMAT IS FIXED - >> SET SOURCEFORMAT "COBOLX" + >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment $ Source format free @@ -67,7 +67,7 @@ let%expect_test "hybrid-format-cdirs-with-cdir-markers" = ~with_line_numbers:true {| >>SOURCE FORMAT IS FREE >>SOURCE FORMAT IS FIXED - >> SET SOURCEFORMAT "COBOLX" + >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment $ Source format free @@ -117,7 +117,7 @@ let%expect_test "hybrid-format-cdirs-with-cdir-markers-bis" = ~with_line_numbers:true {| >>SOURCE FORMAT IS FREE >>SOURCE FORMAT IS FIXED - >> SET SOURCEFORMAT "COBOLX" + >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment $ Source format free diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 224615012..146487b7f 100644 --- a/test/output-tests/preproc.ml +++ b/test/output-tests/preproc.ml @@ -17,7 +17,7 @@ open FileString.OP open Testsuite_utils let preprocess_file ~source_format ~config filename = - Cobol_common.Diagnostics.show_n_forget @@ + Cobol_common.Diagnostics.show_n_forget ~min_level:Error @@ Cobol_preproc.preprocess_file filename ~options:Cobol_preproc.Options.{ source_format; config; verbose = false; libpath = [] } diff --git a/test/output-tests/run_file.expected b/test/output-tests/run_file.expected index 6e7119f24..c64612731 100644 --- a/test/output-tests/run_file.expected +++ b/test/output-tests/run_file.expected @@ -3261,7 +3261,7 @@ run_file.at-8591-prog.cob:9.6-9.17: ---- ^^^^^^^^^^^ 10 INPUT-OUTPUT SECTION. 11 FILE-CONTROL. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive run_file.at-8591-prog.cob:88.54: 85 05 FILLER PIC X(8) VALUE "PRE00000". @@ -5714,7 +5714,7 @@ run_file.at-10488-progs.cob:2.6-2.19: ---- ^^^^^^^^^^^^^ 3 ** CREATE KEY-DEF-AREA FROM ACB ARRAY 4 IDENTIFICATION DIVISION. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_file.at:10676:0 run_file.at-10676-prog.cob:86.12-86.24: diff --git a/test/output-tests/run_refmod.expected b/test/output-tests/run_refmod.expected index 448bc10d2..35b80d4f4 100644 --- a/test/output-tests/run_refmod.expected +++ b/test/output-tests/run_refmod.expected @@ -38,7 +38,7 @@ run_refmod.at-413-prog.cob:2.6-2.20: ---- ^^^^^^^^^^^^^^ 3 IDENTIFICATION DIVISION. 4 PROGRAM-ID. prog. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_refmod.at:435:0 run_refmod.at-435-prog1.cob:2.6-2.21: diff --git a/test/output-tests/run_subscripts.expected b/test/output-tests/run_subscripts.expected index b4d02823f..17e6fc3d0 100644 --- a/test/output-tests/run_subscripts.expected +++ b/test/output-tests/run_subscripts.expected @@ -17,7 +17,7 @@ run_subscripts.at-493-prog.cob:2.6-2.16: ---- ^^^^^^^^^^ 3 IDENTIFICATION DIVISION. 4 PROGRAM-ID. prog. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_subscripts.at:494:0 run_subscripts.at-494-progn.cob:2.6-2.18: @@ -26,7 +26,7 @@ run_subscripts.at-494-progn.cob:2.6-2.18: ---- ^^^^^^^^^^^^ 3 IDENTIFICATION DIVISION. 4 PROGRAM-ID. progn. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_subscripts.at:495:0 run_subscripts.at-495-progn2.cob:2.6-2.19: @@ -35,7 +35,7 @@ run_subscripts.at-495-progn2.cob:2.6-2.19: ---- ^^^^^^^^^^^^^ 3 IDENTIFICATION DIVISION. 4 PROGRAM-ID. progn2. ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_subscripts.at:532:0 run_subscripts.at-532-prog.cob:13.6-13.20: @@ -46,7 +46,7 @@ run_subscripts.at-532-prog.cob:13.6-13.20: ---- ^^^^^^^^^^^^^^ 14 DISPLAY y (idx) 15 *> Note: MF says "sets BOUND" ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive run_subscripts.at-532-prog.cob:16.6-16.18: 13 $SET NOSSRANGE @@ -56,6 +56,6 @@ run_subscripts.at-532-prog.cob:16.6-16.18: ---- ^^^^^^^^^^^^ 17 DISPLAY y (idx) 18 . ->> Error: Malformed or unknown compiler directive +>> Warning: Ignored compiler directive Considering: import/gnucobol/tests/testsuite.src/run_subscripts.at:581:0