Add some basic support for more compiler directives in the pre-processor

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:"@[<v>" ~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
 
 

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

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_
 { () }

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)

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

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

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

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
 

test/cobol_preprocessing/compiler_directives.ml

@@ -19,32 +19,62 @@ 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
       $ SET SOURCEFORMAT "XOpen"
 / 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
+|}];;

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

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

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 = [] }

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:

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: